



		    bft.pl1                         02/24/88  0851.3rew 02/24/88  0843.5      228429



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

/* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */

bft:
background_file_transfer:
     proc options (main);

/* PROGRAM FUNCTION

This is the routine that accepts command line arguments and then calls the
appropriate entrypoint in bft_.  This procedure checks the number of arguments
to the command and then if that is satisfactory then calls the appropriate
subroutine to check the arguments themselves.  This is done by checking the
first argument.  If it is valid, then a subroutine to handle that particular
command is called.
*/

/* NOTES
*/

/****^  HISTORY COMMENTS:
  1) change(86-06-06,Eichele), approve(87-07-15,MCR7580),
     audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075):
     Created.
  2) change(87-10-23,Flegel), approve(87-10-23,MCR7787),
     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
     Added multiple entry queues, control args, and queue display.
  3) change(87-12-12,Flegel), approve(87-12-12,MCR7819),
     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
     Added control arguments for a wider scope of request capabilities.
                                                   END HISTORY COMMENTS */

/* PARAMETERS */

/* MISC VARIABLES */
dcl key_procedure	       entry variable;	    /* Actual request handler */
dcl reason	       char (256) var;	    /* Error reason */
dcl code		       fixed bin (35);

/* GLOBAL */
dcl display_sw	       bit (1);		    /* List request */
dcl unload_sw	       bit (1);		    /* unload request */
dcl store_sw	       bit (1);		    /* store request */
dcl recover_sw	       bit (1);		    /* recover request */
dcl load_sw	       bit (1);		    /* load request */
dcl fetch_sw	       bit (1);		    /* fetch request */
dcl cancel_sw	       bit (1);		    /* cancel request */
dcl priority	       fixed bin;		    /* Queue number */
dcl long_sw	       bit (1);		    /* If queue display is long */
dcl main_arg_ptr	       ptr;		    /* Command arguments */
dcl arg_pos	       fixed bin;		    /* Argument being looked at */
dcl arg_count	       fixed bin;		    /* Number of arguments */
dcl arg_len	       fixed bin (21);	    /* Argument length */
dcl arg_ptr	       ptr;		    /* Argument */
dcl arg		       char (arg_len) based (arg_ptr);
dcl 01 modes	       like bft_queue_flags auto aligned; /* Transfer modes */

/* STRUCTURES */

/* SYSTEM CALLS */
dcl cu_$arg_list_ptr        entry (ptr);
dcl ioa_		       entry () options (variable);
dcl absolute_pathname_     entry (char (*), char (*), fixed bin (35));
dcl cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl cu_$arg_count	       entry (fixed bin, fixed bin (35));
dcl com_err_	       entry () options (variable);

/* SYSTEM CALL SUPPORT */
dcl error_table_$nodescr    fixed bin(35) ext static;
dcl error_table_$inconsistent fixed bin (35) ext static;
dcl error_table_$noarg     fixed bin (35) ext static;
dcl error_table_$bad_arg   fixed bin (35) ext static;
dcl error_table_$wrong_no_of_args fixed bin (35) ext static;

/* EXTERNAL CALLS */
dcl bft_$cancel	       entry (fixed bin, char (*), fixed bin (35));
dcl bft_queue_$display_element entry (ptr, bit (1), fixed bin, bit (1), bit (1));
dcl bft_queue_$initiate    entry (ptr, fixed bin (35));
dcl bft_$fetch	       entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35));
dcl bft_$load	       entry (fixed bin (35));
dcl bft_$recover_fetch     entry (fixed bin (35));
dcl bft_$recover_store     entry (fixed bin (35));
dcl bft_$store	       entry (char (*) var, char (*) var, bit (36) aligned, fixed bin, fixed bin (35));
dcl bft_$unload	       entry (fixed bin (35));

/* EXTERNAL CALL SUPPORT */
dcl bft_error_table_$invalid_file_type 	fixed bin(35) ext static;
dcl bft_error_table_$invalid_keyword fixed bin (35) ext static;
dcl bft_error_table_$invalid_priority fixed bin (35) ext static;
dcl bft_error_table_$bft_not_loaded fixed bin (35) ext static;
dcl ws_error_$invalid_capability_name fixed bin (35) ext static;

/* BUILTINS */
dcl null		       builtin;
dcl unspec	       builtin;
dcl substr	       builtin;
dcl rank		       builtin;
dcl addr		       builtin;
dcl rtrim		       builtin;

/* CONDITIONS */

/* CONSTANTS */
dcl NAME		       char (3) int static options (constant) init ("bft");
dcl USAGE_CANCEL	       char (128) var int static options (constant) init ("^3tUsage:  bft cancel request_identifier {request_identifier ...}");
dcl USAGE_UNLOAD	       char (128) var int static options (constant) init ("^3tUsage:  bft unload");
dcl USAGE_RECOVER	       char (128) var int static options (constant) init ("^3tUsage:  bft recover");
dcl USAGE_LOAD	       char (128) var int static options (constant) init ("^3tUsage:  bft load");
dcl USAGE_BFT	       char (128) var int static options (constant) init ("^3tUsage:  bft KEY {name1 {name2...name1N name2N}} {-control_args}");
dcl USAGE_KEYS	       char (128) var int static options (constant) init ("^6t(s)tore, (f)etch, (c)ancel, (ls) list, (l)oad, (u)nload, (r)ecover");

/**/

/* INITIALIZATION */

/* Set default transfer modes */

     priority = 3;				    /* Queue 3 */
     unspec (modes) = ""b;			    /* "0" are default values */
     long_sw = "0"b;			    /* Long queue display */

/* Set request type switches */

     cancel_sw = "0"b;
     fetch_sw = "0"b;
     load_sw = "0"b;
     recover_sw = "0"b;
     store_sw = "0"b;
     unload_sw = "0"b;
     display_sw = "0"b;

/* MAIN */

/* Get MAIN's arg_ptr */

     call cu_$arg_list_ptr (main_arg_ptr);
     if main_arg_ptr = null then do;
	call com_err_ (error_table_$nodescr, NAME,
	     "Getting argument pointer.");
	return;
     end;

/* How many args are there ? */

     call cu_$arg_count (arg_count, code);
     if code ^= 0 then do;
	call com_err_ (code, NAME, "Getting argument count.");
	return;
     end;

/* None, then this is a request for usage */

     if arg_count <= 0 then do;
	call com_err_ (error_table_$wrong_no_of_args, NAME);
	call ioa_ (USAGE_BFT);
	return;
     end;

/* Extract the keyword */

     arg_pos = 0;
     call get_arg ("0"b, code);
     if code ^= 0 then do;
	call com_err_ (code, NAME);
	call ioa_ (USAGE_BFT);
	return;
     end;

/* This argument MUST be a keyword, otherwise - what are we to do? */

     if (arg = "cancel" | arg = "c") then do;
	key_procedure = bft_cancel;
	cancel_sw = "1"b;
     end;
     else if (arg = "fetch" | arg = "f") then do;
	key_procedure = bft_fetch;
	fetch_sw = "1"b;
     end;
     else if (arg = "load" | arg = "l" | arg = "ld") then do;
	key_procedure = bft_load;
	load_sw = "1"b;
     end;
     else if (arg = "list" | arg = "ls") then do;
	key_procedure = bft_display;
	display_sw = "1"b;
     end;
     else if (arg = "recover" | arg = "r") then do;
	key_procedure = bft_recover;
	recover_sw = "1"b;
     end;
     else if (arg = "store" | arg = "s") then do;
	key_procedure = bft_store;
	store_sw = "1"b;
     end;
     else if (arg = "unload" | arg = "u" | arg = "uld") then do;
	key_procedure = bft_unload;
	unload_sw = "1"b;
     end;
     else do;
	call com_err_ (bft_error_table_$invalid_keyword, NAME, arg);
	call ioa_ (USAGE_KEYS);
	return;
     end;

/* Parse through control arguments */

     call parse_control_args (code, reason);
     if code ^= 0 then do;
	call com_err_ (code, NAME, reason);
	return;
     end;

/* We made it to here, so call the handler, skip the first "real" argument
   as it is the keyword */

     arg_pos = 0;
     call get_arg ("0"b, (0));
     call key_procedure ();

     return;

/**/

/* INTERNAL ENTRIES */

/**/

/* INTERNAL PROCEDURES */


/* *** Procedure: cancel - Internal proc for bft  *** */

bft_cancel:
     proc ();


/* PROCEDURE FUNCTION

Cancel an element from the queue, ONLY if it is not currenlty in transfer.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl request_type	       char (32) var;	    /* Cancellation request type */
dcl code		       fixed bin (35);	    /* Error code */
dcl passed	       fixed bin;		    /* Number of requests cancelled */

/* STRUCTURES */

/* INITIALIZATION */
     passed = 0;

/* MAIN */

/* Parse through each arg in the command line */

     do while (arg_pos < arg_count);
	call get_arg ("1"b, code);
	if code ^= 0 then do;
	     if passed = 0 then
		call com_err_ (code, NAME, arg);
	     else
		call com_err_ (code, NAME);
	     goto CANCEL_RETURN;
	end;

/* Determine which entry type we have, and cancel accordingly */

	if substr (arg, 1, 1) ^= "-" then
	     call bft_$cancel (BFT_PATH_ID, arg, code);
	else do;
	     request_type = arg;
	     call get_arg ("0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, NAME);
		return;
	     end;

	     if request_type = "-id" then
		call bft_$cancel (BFT_TIME_ID, arg, code);
	     else if request_type = "-entry" | request_type = "-et" then
		call bft_$cancel (BFT_ENTRY_ID, arg, code);
	end;

/* Is there an error ? */

	if code ^= 0 then do;
	     call com_err_ (code, NAME, "Cancelling ^a.", arg);
	     goto CANCEL_RETURN;
	end;

/* Increment the cancellation count */

	passed = passed + 1;
     end;

CANCEL_RETURN:

     if passed > 0 then
	call ioa_ ("^a: ^d request^[s^] submitted for cancellation.",
	     NAME, passed, (passed > 1));

     end bft_cancel;

/**/

/* *** Procedure: bft_display - Internal proc for bft  *** */

bft_display:
     proc ();


/* PROCEDURE FUNCTION

Display the current entries in the queues.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl running_count	       fixed bin;
dcl code		       fixed bin (35);
dcl running	       bit (1);		    /* Running element displayed */
dcl i		       fixed bin;
dcl empty_sw	       bit (1);		    /* Queues are empty? */
dcl slot		       fixed bin (35);	    /* Queue traversal index */
dcl count		       fixed bin (21);	    /* Elements in queue */

/* STRUCTURES */

/* INITIALIZATION */
     empty_sw = "1"b;

/* MAIN */

     call bft_queue_$initiate (queue_ptr, code);
     if code ^= 0 then do;
	call com_err_ (code, NAME, "Initiating queue.");
	return;
     end;

/* Display the store queue */

     running = "0"b;
     running_count = 1;
     do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;

/* Count how many requests are pending */

	count = 0;
	slot = queue.header.store_queue (i).first;
	do while (slot ^= 0);
	     count = count + 1;
	     slot = queue.array (slot).next;
	end;

/* Tell user how many requests in store queue */

	if count > 0 then do;
	     empty_sw = "1"b;		    /* To tell display_element to print a header */
	     call ioa_ ("^/BFT Store Queue ^d:^20t^d request^[s^].^/",
		i, running_count + count, (running_count + count > 1));
	     running_count = 0;

/* Display the running element */

	     if queue.header.storing.flags.initiated & ^running then do;
		call bft_queue_$display_element (addr (queue.header.storing),
		     long_sw, BFT_MULTICS_to_PC, "1"b, "1"b);
		if long_sw then
		     call ioa_ ();
		empty_sw = "0"b;
		running = "1"b;
	     end;

/* Display the remainder of the queue */

	     slot = queue.header.store_queue (i).first;
	     do while (slot ^= 0);
		call bft_queue_$display_element (addr (queue.array (slot)),
		     long_sw, BFT_MULTICS_to_PC, "0"b, empty_sw);
		empty_sw = "0"b;
		slot = queue.array (slot).next;
		if long_sw & slot ^= 0 then
		     call ioa_ ();
	     end;
	end;
     end;

/* Display the running element if there are no pending elements */

     if queue.header.storing.flags.initiated & ^running then do;
	call ioa_ ("^/BFT Store Queue:^/");
	call bft_queue_$display_element (addr (queue.header.storing),
	     long_sw, BFT_MULTICS_to_PC, "1"b, "1"b);
	empty_sw = "0"b;
	running = "1"b;
     end;

/* Display the fetch queue */

     running = "0"b;
     running_count = 1;
     do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;
	count = 0;
	slot = queue.header.fetch_queue (i).first;
	do while (slot ^= 0);
	     count = count + 1;
	     slot = queue.array (slot).next;
	end;

	if count > 0 then do;
	     empty_sw = "1"b;		    /* To tell display_element to print a header */
	     call ioa_ ("^/BFT Fetch Queue ^d:^20t^d request^[s^].^/",
		i, running_count + count, (running_count + count > 1));
	     running_count = 0;

	     if queue.header.fetching.flags.initiated & ^running then do;
		call bft_queue_$display_element (addr (queue.header.fetching),
		     long_sw, BFT_PC_to_MULTICS, "1"b, "1"b);
		if long_sw then
		     call ioa_ ();
		empty_sw = "0"b;
		running = "1"b;
	     end;

	     slot = queue.header.fetch_queue (i).first;
	     do while (slot ^= 0);
		call bft_queue_$display_element (addr (queue.array (slot)),
		     long_sw, BFT_PC_to_MULTICS, "0"b, empty_sw);
		empty_sw = "0"b;
		slot = queue.array (slot).next;
		if long_sw & slot ^= 0 then
		     call ioa_ ();
	     end;
	end;
     end;
     if queue.header.fetching.flags.initiated & ^running then do;
	call ioa_ ("^/BFT Fetch Queue:^/");
	call bft_queue_$display_element (addr (queue.header.fetching),
	     long_sw, BFT_PC_to_MULTICS, "1"b, "1"b);
	empty_sw = "0"b;
	running = "1"b;
     end;

/* If there were no transfers, say so */

     if empty_sw then
	call ioa_ ("There are no requests in any BFT queue.");
     else
	call ioa_ ();

     end bft_display;

/**/

/* *** Procedure: bft_fetch - Internal proc for bft *** */

bft_fetch:
     proc ();

/* PROCEDURE FUNCTION

This routine is called if the first argument specified a fetch.  If two
filenames are given, both are accepted.  If only one is given, then the
destination will default to being the same as the supplied source name.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */
dcl passed	       fixed bin;		    /* Requests submitted */
dcl temp_file	       char (168);
dcl mu_path	       char (168);
dcl pc_path	       char (66);

/* STRUCTURES */

/* INITIALIZATION */
     passed = 0;

/* MAIN */

/* Repeat until there are no more requests in the command line */

     do while (arg_pos < arg_count);

/* Get the pc_path */

	call get_arg ("0"b, code);
	if code ^= 0 then do;
	     if passed = 0 then
		call com_err_ (code, NAME, arg);

	     goto FETCH_RETURN;
	end;

	pc_path = arg;
	mu_path = "===";

/* Look for the Multics path, if it is not specified, default to pc_path */

	call get_arg ("0"b, code);
	if code ^= 0 & code ^= error_table_$noarg then do;
	     call com_err_ (code, NAME, arg);
	     goto FETCH_RETURN;
	end;
	else if code = 0 then
	     mu_path = arg;

/* Obtain the full pathname of the specified destination */

	temp_file = mu_path;
	call absolute_pathname_ (temp_file, mu_path, code);
	if code ^= 0 then do;
	     call com_err_ (code, NAME, "Expanding Multics pathname.");
	     goto FETCH_RETURN;
	end;

/* Call the bft_$fetch entrypoint with the valid parms */

	call bft_$fetch (rtrim (pc_path), rtrim (mu_path), unspec (modes),
	     priority, code);
	if code ^= 0 then do;
	     if code = ws_error_$invalid_capability_name then
		code = bft_error_table_$bft_not_loaded;
	     call com_err_ (code, NAME, "Issuing fetch request.");

	     goto FETCH_RETURN;
	end;

/* Increment the cancellation count */

	passed = passed + 1;
     end;

FETCH_RETURN:

     if passed > 0 then
	call ioa_ ("^a: ^d request^[s^] submitted for fetching.", NAME,
	     passed, (passed > 1));

     end bft_fetch;

/**/

/* *** Procedure: bft_load - Internal proc for bft *** */

bft_load:
     proc ();

/* PROCEDURE FUNCTION                                                             

This calls the proper entrypoint to get BFT loaded into the CAT.  No arguments
are required.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Print a usage message if there is an invalid number  of args */

     if arg_count ^= 1 then do;
	call com_err_ (error_table_$wrong_no_of_args, NAME);
	call ioa_ (USAGE_LOAD);
	return;
     end;

/* Make call to proper entrypoint */

     call bft_$load (code);
     if (code ^= 0) then do;
	if code = ws_error_$invalid_capability_name then
	     code = bft_error_table_$bft_not_loaded;
	call com_err_ (code, NAME, "While attempting to load BFT.");
	return;
     end;

     end bft_load;

/**/

/* *** Procedure: bft_recover - Internal proc for bft *** */

bft_recover:
     proc ();

/* PROCEDURE FUNCTION                                                    

This is the routine called if the argument was fetch_recover.  The purpose of
this routine is to transmit the portion of a file that was previously
interrupted.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Print a usage message if there is an invalid number  of args */

     if arg_count ^= 1 then do;
	call com_err_ (error_table_$wrong_no_of_args, NAME);
	call ioa_ (USAGE_RECOVER);
	return;
     end;

/* Recover fetch operations */

     call bft_$recover_fetch (code);
     if (code ^= 0) then do;
	if code = ws_error_$invalid_capability_name then
	     code = bft_error_table_$bft_not_loaded;
	call com_err_ (code, NAME, "Attempting to recover fetch.");
     end;

/* Recover store operations */

     call bft_$recover_store (code);
     if (code ^= 0) then do;
	if code = ws_error_$invalid_capability_name then
	     code = bft_error_table_$bft_not_loaded;
	call com_err_ (code, NAME, "Attempting to recover store.");
     end;

     end bft_recover;

/**/

/* *** Procedure: bft_store - Internal proc for bft *** */

bft_store:
     proc ();

/* PROCEDURE FUNCTION                                                            

This routine is identical in function to the bft_fetch, except for the fact
that it calls bft_$store.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */
dcl passed	       fixed bin;		    /* Previous request submitted */
dcl pc_path	       char (66);
dcl mu_path	       char (168);

/* STRUCTURES */

/* INITIALIZATION */
     passed = 0;

/* MAIN */

/* Repeat until there are no more requests in the command line */

     do while (arg_pos < arg_count);

/* Get the mu_path */

	call get_arg ("0"b, code);
	if code ^= 0 then do;
	     if passed = 0 then
		call com_err_ (code, NAME, arg);

	     goto STORE_RETURN;
	end;

	mu_path = arg;
	pc_path = "===";

/* Look for the PC path, if not specified then assume mu_patjh */

	call get_arg ("0"b, code);
	if code ^= 0 & code ^= error_table_$noarg then do;
	     call com_err_ (code, NAME, arg);
	     goto STORE_RETURN;
	end;
	else if code = 0 then
	     pc_path = arg;

/* Call the bft_$store entrypoint with the valid parms */

	call bft_$store (rtrim (mu_path), rtrim (pc_path), unspec (modes),
	     priority, code);
	if code ^= 0 then do;
	     if code = ws_error_$invalid_capability_name then
		code = bft_error_table_$bft_not_loaded;
	     call com_err_ (code, NAME, "Issuing store request.");
	     goto STORE_RETURN;
	end;

	passed = passed + 1;
     end;

STORE_RETURN:

     if passed > 0 then
	call ioa_ ("^a: ^d request^[s^] submitted for storing.", NAME,
	     passed, (passed > 1));

     end bft_store;

/**/

/* *** Procedure: bft_unload - Internal proc for bft *** */

bft_unload:
     proc ();

/* PROCEDURE FUNCTION                                                           

If the first argument was unload then this is the routine that is called.  This
calls the necessary enttrypoint to have BFT deleted from the CAT.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Print a usage message if there is an invalid number  of args */

     if arg_count ^= 1 then do;
	call com_err_ (error_table_$wrong_no_of_args, NAME);
	call ioa_ (USAGE_UNLOAD);
	return;
     end;

/* Call the proper entrypoint with the valid parameters */

     call bft_$unload (code);
     if (code ^= 0) then do;
	if code = ws_error_$invalid_capability_name then
	     code = bft_error_table_$bft_not_loaded;
	call com_err_ (code, NAME, "While attempting to unload BFT.");
	return;
     end;

     end bft_unload;

/**/

/* *** Procedure: get_arg - Internal proc for bft  *** */

get_arg:
     proc (p_special, p_code);


/* PROCEDURE FUNCTION

Extract the next real argument from the argument list.
If the p_special parameter is True, then accept the "-control_arg STR" as a
"non-control" argument.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_special	       bit(1) parameter;	    /* Accept "-ca STR " */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */
     p_code = 0;

/* Skip all control_args until a NON-control_arg is found */

     do while ("1"b);
	arg_pos = arg_pos + 1;

	if arg_pos > arg_count then do;
	     p_code = error_table_$noarg;
	     return;
	end;

	call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
	if p_code ^= 0 then
	     return;

	if substr (arg, 1, 1) = "-" then do;
	     if arg = "-entry" | arg = "-et"	    /* These are special */
		| arg = "-id"
	     then do;
		if p_special then		    /* Caller wants this */
		     return;
		else			    /* Skip the param */
		     arg_pos = arg_pos + 1;
	     end;
	     else if arg = "-queue" | arg = "-q"    /* Skip the param */
		| arg = "-file_type" | arg = "-ft"
	     then
		arg_pos = arg_pos + 1;
	     else				    /* No params */
		;
	end;
	else
	     return;
     end;

     end get_arg;

/**/

/* *** Procedure: parse_control_args - Internal proc for bft  *** */

parse_control_args:
     proc (p_code, p_reason);


/* PROCEDURE FUNCTION

Skip through the command line arguments and extract control arguments.

Control arguments extracted are:

	-brief,		-bf
	-notify,		-nt
	-no_notify,	-nnt
	-file_type TYPE,	-ft TYPE
	-queue N,		-q N

Control arguments "skipped" (as they are really a "single" argument):

	-entry NAME,	-et NAME
	-id ID
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_reason	       char (*) var parameter;    /* Error reason */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl temp_queue	       fixed bin;		    /* local queue value */

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;
     p_reason = "";

/* MAIN */

     do arg_pos = 1 to arg_count;
	call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
	if p_code ^= 0 then
	     return;

	if arg = "-file_type" | arg = "-ft" then do;
	     if ^(store_sw | fetch_sw) then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     arg_pos = arg_pos + 1;
	     call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
	     if p_code ^= 0 then
		return;

	     if arg = "binary" then
		modes.binary_sw = "1"b;
	     else if arg = "ascii" then
		modes.binary_sw = "0"b;
	     else do;
		p_reason = arg;
		p_code = bft_error_table_$invalid_file_type;
		return;
	     end;
	end;

	else if arg = "-long" | arg = "-lg" then do;
	     if ^display_sw then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     long_sw = "1"b;
	end;

	else if arg = "-brief" | arg = "-bf" then do;
	     if ^display_sw then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     long_sw = "0"b;
	end;

	else if arg = "-id" then do;
	     if ^cancel_sw then do;
		p_code = error_table_$inconsistent;
		return;
	     end;
	end;

	else if arg = "-entry" | arg = "-et" then do;
	     if  ^cancel_sw then do;
		p_code = error_table_$inconsistent;
		return;
	     end;
	end;

	else if arg = "-notify" | arg = "-nt" then do;
	     if ^(fetch_sw | store_sw) then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     modes.notify_sw = "1"b;
	end;

	else if arg = "-no_notify" | arg = "-nnt" then do;
	     if ^(fetch_sw | store_sw) then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     modes.notify_sw = "0"b;
	end;

	else if arg = "-queue" | arg = "-q" then do;
	     if ^(store_sw | fetch_sw) then do;
		p_code = error_table_$inconsistent;
		return;
	     end;

	     arg_pos = arg_pos + 1;
	     call cu_$arg_ptr_rel (arg_pos, arg_ptr, arg_len, p_code, main_arg_ptr);
	     if p_code ^= 0 then
		return;

	     if arg_len ^= 1 then do;
		p_reason = arg;
		p_code = bft_error_table_$invalid_priority;
		return;
	     end;

	     temp_queue = rank (substr (arg, 1, 1)) - rank ("0");
	     if temp_queue < BFT_MIN_PRIORITY
		| temp_queue > BFT_MAX_PRIORITY
	     then do;
		p_reason = arg;
		p_code = bft_error_table_$invalid_priority;
		return;
	     end;

	     priority = temp_queue;
	end;

	else if substr (arg, 1, 1) = "-" then do;
	     p_code = error_table_$bad_arg;
	     reason = arg;
	     return;
	end;
     end;

     end parse_control_args;

/**/

/* INCLUDE FILES */
%include bft_queue;
%include bft_values;

     end bft;




		    bft_.pl1                        02/24/88  0851.3rew 02/24/88  0843.5      115308



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

bft_:
     proc ();

/* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */

/* PROGRAM FUNCTION

This is the file that holds all of the Multics entrypoints.  These entrypoints
do nothing more than place the supplied arguments into a structure of the type
defined in bft_values.incl.pl1.  This is done so that only a pointer must be
passed between the two programs (this one and the bft_main_.pl1 program, which
holds all of the code for the minor capabilities).  This will only work because
these calls are guaranteed to be local (ie.  on Multics).  Once all of the
necessary information is written into the structure, the pointer to the
structure is converted to char and then passed to the minor capability as a
character string, and it us decoded back to a pointer there.  On return , each
entrypoint reassigns the passed error code to its parameter error_code so the
calling routine may use the information.
*/

/* NOTES
*/

/****^  HISTORY COMMENTS:
  1) change(86-07-22,Eichele), approve(87-07-15,MCR7580),
     audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075):
     Created.
  2) change(87-10-23,Flegel), approve(87-10-23,MCR7787),
     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
     Changed to work with multiple entries for queueing as well as adding a few
     new control arguments.
                                                   END HISTORY COMMENTS */

/* PARAMETERS */
dcl p_id_sw	       fixed bin parameter;	    /* Request ID type */
dcl p_id		       char (*) parameter;	    /* Request ID */
dcl p_priority	       fixed bin parameter;	    /* Transfer priority */
dcl p_flags	       bit (36) aligned parameter;  /* Transfer flags */
dcl p_arg_len	       fixed bin parameter;
dcl p_arg_ptr	       ptr parameter;
dcl p_data_block_ptr       ptr parameter;
dcl p_destination_filename char (*) var parameter;
dcl p_major_sender	       fixed bin parameter;
dcl p_mcb_ptr	       ptr parameter;
dcl p_minor_cap_no	       fixed bin parameter;
dcl p_source_filename      char (*) var parameter;
dcl p_code	       fixed bin (35) parameter;

/* MISC VARIABLES */
dcl dir_name	       char (168);		    /* Pathname */
dcl message	       char (256);
dcl bft_major	       fixed bin;
dcl bft_mcb	       ptr;
dcl bft_struct_ptr	       ptr;
dcl code		       fixed bin (35);
dcl command_id	       fixed bin;
dcl major_num	       fixed bin;

/* STRUCTURES */
dcl 01 bft_struct	       like bft_values_struct based (bft_struct_ptr);

/* SYSTEM CALLS */
dcl absolute_pathname_      entry (char(*), char(*), fixed bin(35));

/* SYSTEM CALL SUPPORT */

/* EXTERNAL CALLS */

/* EXTERNAL CALL SUPPORT */
dcl bft_error_table_$invalid_request_type  fixed bin(35) ext static;
dcl bft_error_table_$unexpected_minor_capability fixed bin (35) ext static;

/* BUILTINS */
dcl byte		       builtin;
dcl null		       builtin;
dcl addr		       builtin;
dcl length	       builtin;
dcl rtrim		       builtin;

/* CONDITIONS */
dcl cleanup	       condition;

/* CONSTANTS */

/**/

/* INITIALIZATION */

/* MAIN */

     return;

/**/

/* INTERNAL ENTRIES */


/* *** Entry: cancel - Internal entry for bft_  *** */

cancel:
     entry (p_id_sw, p_id, p_code);


/* ENTRY FUNCTION

Remove the specified request from the bft queues.
*/

/* NOTES
*/

     p_code = 0;

/* Fill out the message: ID_SW;ID; */

     
     if p_id_sw = BFT_TIME_ID | p_id_sw = BFT_PATH_ID | p_id_sw = BFT_ENTRY_ID then
	message = byte (p_id_sw) || DELIM_CHAR;
     else do;
	p_code = bft_error_table_$invalid_request_type;
	return;
     end;

     if p_id_sw = BFT_PATH_ID then do;
	call absolute_pathname_ (p_id, dir_name, p_code);
	if p_code ^= 0 then
	     return;
	message = rtrim (message) || rtrim (dir_name) || DELIM_CHAR;
     end;
     else
	message = rtrim (message) || rtrim (p_id) || DELIM_CHAR;

/* Execute bft_minor_$add_to_fetch_queue */

     bft_major = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, bft_major,
	p_code);
     if p_code ^= 0 then
	return;

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code);
     if p_code ^= 0 then
	return;

     call ws_$execute_capability (bft_major, bft_minor_$cancel_request,
	addr (message), length (rtrim (message)), bft_mcb, p_code);
     call ws_$destroy_instance (bft_mcb, (0));

     return;

/**/

/* *** Entry: process_event - Internal entry fo bft_ *** */

process_event:
     entry (p_minor_cap_no, p_major_sender, p_arg_ptr, p_arg_len, p_mcb_ptr,
	p_data_block_ptr);

/* ENTRY FUNCTION

This is the point where MOWSE will begin necessary execution.  There are no
minor capabilities defined other than those required by MOWSE.
*/

/* NOTES
*/

     bft_mcb = p_mcb_ptr;
     if (p_minor_cap_no > MAXIMUM_SYSTEM_MINOR) | (p_minor_cap_no < MINIMUM_SYSTEM_MINOR) then do;
	code = bft_error_table_$unexpected_minor_capability;
	return;
     end;

     if p_minor_cap_no ^= EXECUTE_COMMAND_REPLY then
	call minor_error (p_minor_cap_no);

     major_num = 0;
     code = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, code);
     if code ^= 0 then
	call ws_$put_background_message (bft_mcb, 0, "bft_ ", "Error in loading BFT.");

     code = 0;
     call ws_$destroy_instance (bft_mcb, code);
     if code ^= 0 then do;
	call ws_$put_background_message (bft_mcb, 0, "bft_ ",
	     "BFT_ failed to properly destroy itself.");
	return;
     end;

     return;

/**/

/* *** Entry: fetch - Internal entry for bft_ *** */

fetch:
     entry (p_source_filename, p_destination_filename, p_flags, p_priority,
	p_code);

/* ENTRY FUNCTION

This entrypoint assembles the arguments and makes the proper call to 
bft_minor_$add_to_fetch_queue.
*/

/* NOTES
*/

     call add_to_queue (p_destination_filename, p_source_filename, p_flags,
	p_priority, bft_minor_$add_to_fetch_queue, p_code);

     return;

/**/

/* *** Entry: load - Internal entry for bft_ *** */

load:
     entry (p_code);

/* ENTRY FUNCTION

This entrypoint assembles the arguments and makes the proper call to bft_minor_
(main entrypoint).
*/

/* NOTES
*/

/* Allocate a structure where the arguments will be placed */

     on cleanup call clean_up ();

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code);
     if p_code ^= 0 then
	return;

     call ws_$execute_command ("bft_main_", LOCAL_SYSTEM, command_id,
	bft_mcb, p_code);

     call ws_$destroy_instance (bft_mcb, (0));

     return;

/**/

/* *** Entry: recover_fetch - Internal entry for bft_ *** */

recover_fetch:
     entry (p_code);

/* ENTRY FUNCTION
                                                   
This entrypoint assembles the arguments and makes the proper call to
bft_minor_$recover_fetch
*/

/* NOTES
*/

/* Locate the bft_main_ capability */

     bft_major = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, bft_major,
	p_code);
     if p_code ^= 0 then
	return;

/* Execute bft_minor_$recover_fetch */

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code);
     if p_code ^= 0 then
	return;

     call ws_$execute_capability (bft_major, bft_minor_$recover_fetch,
	null, (0), bft_mcb, p_code);

     call ws_$destroy_instance (bft_mcb, (0));

     return;

/**/

/* *** Entry: recover_store - Internal entry for bft_ *** */

recover_store:
     entry (p_code);

/* ENTRY FUNCTION

This entrypoint assembles the arguments and makes the proper call to
bft_minor_$recover_store.
*/

/* NOTES
*/

/* Find the bft_main_ capability */

     major_num = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM,
	major_num, p_code);
     if p_code ^= 0 then
	return;

/* Execute bft_minor_$recover_store */

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code);
     if p_code ^= 0 then
	return;

     call ws_$execute_capability (major_num, bft_minor_$recover_store,
	null, (0), bft_mcb, p_code);

     call ws_$destroy_instance (bft_mcb, (0));

     return;

/**/

/* *** Entry: store - Internal entry for bft_ *** */

store:
     entry (p_source_filename, p_destination_filename, p_flags, p_priority,
	p_code);

/* ENTRY FUNCTION

This entrypoint assembles the arguments and makes the proper call to
bft_minor_$add_to_store_queue.
*/

/* NOTES
*/

     call add_to_queue (p_source_filename, p_destination_filename, p_flags,
	p_priority, bft_minor_$add_to_store_queue, p_code);

     return;

/**/

/* *** Entry: unload - Internal entry for bft_ *** */

unload:
     entry (p_code);

/* ENTRY FUNCTION

This entrypoint assembles the arguments and makes the proper call to
TERMINATE_APPLICATION.
*/

/* NOTES
*/

/* Allocate the structure where the arguments will be placed */

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, bft_mcb, p_code);
     if p_code ^= 0 then
	return;

     major_num = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, p_code);
     if p_code ^= 0 then
	return;

     bft_major = major_num;
     call ws_$execute_capability (bft_major, bft_minor_$bft_shut_down,
	null, 0, bft_mcb, p_code);
     call ws_$destroy_instance (bft_mcb, (0));

     return;

/**/

/* INTERNAL PROCEDURES */


/* *** Procedure: add_to_queue - Internal proc for bft_  *** */

add_to_queue:
     proc (p_multics_path, p_pc_path, p_flags, p_priority, p_minor, p_code);


/* PROCEDURE FUNCTION

This procedure assembles the arguments for adding an element to either
the store or fetch queue.
*/

/* NOTES
*/


/* PARAMETERS */
dcl p_priority	       fixed bin parameter;	    /* Transfer priority */
dcl p_flags	       bit (36) aligned parameter;  /* Transfer modes */
dcl p_minor	       fixed bin parameter;	    /* Store or Fetch */
dcl p_pc_path	       char (*) var parameter;
dcl p_multics_path	       char (*) var parameter;
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl flags_over	       char (4) aligned based (addr (p_flags));  /* Character overlay of flags */
dcl mcb_ptr	       ptr;		    /* MOWSE control block */
dcl major_num	       fixed bin;		    /* Capability number */
dcl message	       char (256);		    /* Message to be sent */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     p_code = 0;

/* Fill out the message: MULTICS_SOURCE;PC_SOURCE;FLAGS;PRIORITY; */

     message = rtrim (p_multics_path) || DELIM_CHAR;
     message = rtrim (message) || p_pc_path || DELIM_CHAR;
     message = rtrim (message) || flags_over || DELIM_CHAR;
     message = rtrim (message) || byte (p_priority);

     major_num = 0;
     call ws_$find_capability_number ("bft_main_", LOCAL_SYSTEM, major_num, p_code);
     if p_code ^= 0 then
	return;

/* Execute bft_minor_$add_to_fetch_queue */

     call ws_$create_instance ("bft_", "process_event", BFT_INBUFFER_SIZE,
	BFT_OUTBUFFER_SIZE, null, mcb_ptr, p_code);
     if p_code ^= 0 then
	return;

     call ws_$execute_capability (major_num, p_minor, addr (message),
	length (rtrim (message)), mcb_ptr, p_code);
     call ws_$destroy_instance (mcb_ptr, (0));

end add_to_queue;

/**/

/* *** Procedure: minor_error - Internal proc for bft_ *** */

minor_error:
     proc (p_minor_number);

/* PROCEDURE FUNCTION

This is called when one of the predefined minor capabilities is called that is
not expected.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_minor_number	       fixed bin parameter;

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call ws_$put_background_message (bft_mcb, 0, "BFT_ ",
	"Unexpected minor capability has been called.");

     end minor_error;

/**/

/* *** Procedure: clean_up - Internal proc for bft_ *** */

clean_up:
     proc ();

/* PROCEDURE FUNCTION

This cleanup handler frees up the space allocated in the system_free_area.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if bft_struct_ptr ^= null then do;
	free bft_struct_ptr -> bft_struct;
	bft_struct_ptr = null;
     end;

     end clean_up;

/**/

/* INCLUDE FILES */
%include bft;
%include bft_values;
%include mowse_lib_dcls;
%include mowse;

     end bft_;




		    bft_error_table_.alm            02/24/88  0851.3rew 02/24/88  0846.4       18450



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

" HISTORY COMMENTS:
"  1) change(87-07-15,Flegel), approve(87-07-15,MCR7580),
"     audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075):
"     Created.
"  2) change(87-10-06,Flegel), approve(87-10-23,MCR7787),
"     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
"     Added codes: no_queue, invalid_priority, invalid_queue,
"       invalid_file_type, invalid_keyword.
"     Deleted codes: LS_set, LF_set, RS_set, RF_set, store_queue_full,
"       status_discrepancy.
"                                                      END HISTORY COMMENTS

include	et_macros

et	bft_error_table_

ec	bft_not_loaded,bftnotld,
	(The major capablility BFT has not been loaded.)

ec	fetch_in_progress,fetchprg,
	(Fetch cannot be initiated due to a current transfer in progress.)

ec	fetch_queue_full,fetchful,
	(There is already an entry in the BFT Fetch queue.)

ec	illegal_minor_capability,ilmincap,
	(An illegal minor capability was called.)

ec	invalid_direction,badirect,
	(Transfer direction is invalid.)

ec	invalid_file_type,badfile,
	(Transfer file type is invalid.)

ec	invalid_keyword,badkey,
	(Keyword is invalid.)

ec	invalid_priority,badprior,
	(Priority level is invalid.)

ec	invalid_queue,badq,
	(Pointer to BFT queue is invalid.)

ec	invalid_request_type,badrqst,
	(Request type is invalid.)

ec	no_entries,noentry,
	(No more entries in queue.)

ec	no_queue,noqueue,
	(BFT queue has been deleted.)

ec	store_in_progress,storeprg,
	(Store cannot be initiated due to a current transfer in progress.)

ec	unexpected_minor_capability,mnrntexp,
	(An unexpected minor capability number was recieved.)

end




		    bft_main_.pl1                   02/24/88  0851.3rew 02/24/88  0843.6      638523



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

bft_main_:
     proc () options (main);

/* PROGRAM FUNCTION

This program is the Multics side of the MOWSE application BFT.  This program in
conjunction with the PC portion, allows a user to transfer files to and from
Multics through commands entered on either the PC or at Multics command level.
Because this code is designed to run in the "background", all messages are
printed out via the MOWSE put_background_message facility, and MUST be used in
conjunction with MOWSE and the terminal emulator.  For a description of
commands see bft.info.
*/

/* NOTES
*/

/****^  HISTORY COMMENTS:
  1) change(86-07-22,Eichele), approve(87-06-30,MCR7580),
     audit(87-07-30,RBarstad), install(87-08-07,MR12.1-1075):
     Created.
  2) change(87-10-23,Flegel), approve(87-10-23,MCR7787),
     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
     Converted to use new queueing strategy which handles multiple entries.
                                                   END HISTORY COMMENTS */

/* PARAMETERS */
dcl p_minor_cap	       fixed bin parameter;	    /* Minor function number */
dcl p_major_sender	       fixed bin parameter;	    /* Source of message */
dcl p_arg_ptr	       ptr parameter;	    /* Pointer to message */
dcl p_arg_len	       fixed bin parameter;	    /* Length of message */
dcl p_mcb_ptr	       ptr parameter;	    /* MOWSE control block */
dcl p_data_block_ptr       ptr parameter;	    /* Data kept around */

/* MISC VARIABLES */
dcl command_id	       fixed bin;		    /* ID of execute command */
dcl my_major	       fixed bin;		    /* Capability number of bft_main_ */
dcl major_num	       fixed bin;		    /* Capability number */
dcl mcb_ptr	       ptr;		    /* MOWSE control block */
dcl code		       fixed bin (35);	    /* Error code */

/* STRUCTURES */

/* SYSTEM CALLS */
dcl get_equal_name_	        entry (char(*), char(*), char(32), fixed bin(35));
dcl hcs_$star_	        entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl absolute_pathname_      entry (char(*), char(*), fixed bin(35));
dcl iox_$get_chars	       	entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl iox_$position	        entry (ptr, fixed bin, fixed bin(21), fixed bin(35));
dcl convert_status_code_    entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl iox_$put_chars	       	entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl iox_$open	        entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl iox_$attach_name        entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl expand_pathname_        entry (char(*), char(*), char(*), fixed bin(35));
dcl clock_	        entry() returns(fixed bin(71));
dcl iox_$destroy_iocb       entry (ptr, fixed bin(35));
dcl iox_$detach_iocb        entry (ptr, fixed bin(35));
dcl iox_$close	        entry (ptr, fixed bin(35));
dcl iox_$find_iocb	       	entry (char(*), ptr, fixed bin(35));
dcl com_err_	        entry() options(variable);
dcl get_system_free_area_   entry() returns(ptr);

/* SYSTEM CALL SUPPORT */
dcl error_table_$bad_conversion  fixed bin(35) ext static;
dcl error_table_$short_record  fixed bin(35) ext static;
dcl error_table_$end_of_info 	fixed bin(35) ext static;

/* EXTERNAL CALLS */
dcl bft_queue_$cancel       entry (ptr, char(*), fixed bin, fixed bin(35));
dcl bft_queue_$remove       entry (ptr, fixed bin, fixed bin(35));
dcl ws_$disconnect_response  entry (fixed bin, fixed bin, ptr, fixed bin(35));
dcl ws_$connect_response    entry (fixed bin, fixed bin, ptr, fixed bin(35));
dcl ws_$execute_capability  entry (fixed bin, fixed bin, ptr, fixed bin, ptr, fixed bin(35));
dcl bft_queue_$add	       	entry (ptr, ptr, fixed bin, fixed bin, fixed bin(35));
dcl ws_$disconnect_request  entry (fixed bin, ptr, fixed bin(35));
dcl ws_$execute_command     entry (char(*), fixed bin, fixed bin, ptr, fixed bin(35));
dcl ws_$destroy_instance    entry (ptr, fixed bin(35));
dcl ws_$put_background_message  entry() options(variable);
dcl ws_$find_capability_number  entry (char(*), fixed bin, fixed bin, fixed bin(35));
dcl ws_$create_instance     entry (char(*), char(*), fixed bin, fixed bin, ptr, ptr, fixed bin(35));
dcl bft_queue_$initiate     entry (ptr, fixed bin(35));

/* EXTERNAL CALL SUPPORT */
dcl bft_error_table_$store_in_progress 	fixed bin(35) ext static;
dcl bft_error_table_$no_entries  fixed bin(35) ext static;
dcl bft_error_table_$fetch_in_progress 	fixed bin(35) ext static;
dcl bft_error_table_$illegal_minor_capability  fixed bin(35) ext static;
dcl ws_error_$invalid_minor_capability 	fixed bin(35) ext static;
dcl ws_error_$invalid_capability_name  fixed bin(35) ext static;

/* BUILTINS */
dcl sum		       builtin;
dcl search	       builtin;
dcl rtrim		       builtin;
dcl rank		       builtin;
dcl byte		       builtin;
dcl addr		       builtin;
dcl reverse	       builtin;
dcl convert	       builtin;
dcl ltrim		       builtin;
dcl length	       builtin;
dcl substr	       builtin;
dcl index		       builtin;
dcl unspec	       builtin;
dcl null		       builtin;

/* CONDITIONS */
dcl cleanup	       condition;

/* CONSTANTS */
dcl NAME		       char (9) int static options (constant) init ("bft_main_");
dcl fixedbin21	       fixed bin (21) based;
dcl fixedbin17	       fixed bin (17) based;
dcl char128var	       char (128) var based;

/**/

/* INITIALIZATION */

     code = 0;
     queue_ptr = null;
     data_block_ptr = null;

/* MAIN */

/* The first section of code is executed when the bft load command is used.  It
initializes the necessary variables and notifies MOWSE that it is to be
registered as a major cability.  */

/* Initialize the necessary structures and queues */

     call initialize_bft (code);
     if code ^= 0 then do;
	call com_err_ (code, NAME, "Initializing.");
	return;
     end;

/* : Register as a MOWSE major capability */

     call ws_$create_instance (NAME, "main_entry",
	data_block.inbuff_len, data_block.outbuff_len, data_block_ptr,
	mcb_ptr, code);
     if code ^= 0 then do;
	call com_err_ (code, NAME, "Creating MOWSE instance.");
	return;
     end;

/* Check to see if this is more than the first instance of BFT that MOWSE knows
   about.  Multiple instances of BFT are not allowed */

     major_num = 0;
     call ws_$find_capability_number (NAME, LOCAL_SYSTEM, major_num, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Failed to locate one instance of BFT");
	call bft_shut_down ();
	return;
     end;

/* If there exists more than one instance of BFT then delete the current one */

     my_major = major_num;
     call ws_$find_capability_number (NAME, LOCAL_SYSTEM, my_major, code);
     if code = 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft", "Already loaded.");
	call ws_$destroy_instance (mcb_ptr, code);
	call cleanup_data_block ();
	return;
     end;

/* Check to see if the PC BFT is loaded */

     major_num = find_pc_bft (mcb_ptr, "0"b);
     if major_num ^= 0 then
	return;

/* Load PC BFT by executing the proper command */

     else do;
	call ws_$execute_command ("bft_load", REMOTE_SYSTEM, command_id,
	     mcb_ptr, code);
	if code ^= 0 then do;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
		"Excuting ""PC:bft_load"" command.");
	     call bft_shut_down ();
	     return;
	end;
     end;

     return;

/**/

/* INTERNAL ENTRIES */


/* *** Entry: main_entry - Internal entry for bft_main_  *** */

main_entry:
     entry (p_minor_cap, p_major_sender, p_arg_ptr, p_arg_len, p_mcb_ptr, p_data_block_ptr);


/* ENTRY FUNCTION

This is the entry point where all other major capabilities access BFT via
MOWSE.  The minor capability number determines which of the procedures is
called.
*/

/* NOTES
*/

/* Set up addressing */

     data_block_ptr = p_data_block_ptr;
     queue_ptr = data_block.queue_ptr;
     mcb_ptr = p_mcb_ptr;

/* If we are shutting down, ignore most messages */

     if data_block.flags.shut_down_sw
	& p_minor_cap ^= TERMINATE_APPLICATION
	& p_minor_cap ^= RESPONSE_DISCONNECT
	& p_minor_cap ^= bft_minor_$bft_shut_down
     then
	return;

/* Verify that the minor capability number is acceptable */

     if ((p_minor_cap < 32 | p_minor_cap > 50) & (p_minor_cap < 64 | p_minor_cap > 81))
	| p_minor_cap = 79 | p_minor_cap = 80

     then do;
	call ws_$put_background_message (mcb_ptr,
	     ws_error_$invalid_minor_capability, "bft", "  ^d.", p_minor_cap);
	call bft_shut_down ();
	return;
     end;

/* Handle the minor capability */

     goto case (p_minor_cap);

case (32):
     call execute_command_reply ();
     return;

case (36):
     call no_handler ("execute_capability_reply", "1"b);
     return;

case (37):
     call no_handler ("suspend_application", "0"b);
     return;

case (38):
     call no_handler ("resume_application", "0"b);
     return;

case (39):
     call terminate_application ();
     return;

case (40):
     call no_handler ("reset_application", "0"b);
     return;

case (41):
     call no_handler ("reset_reply", "0"b);
     return;

case (42):
     call no_handler ("wake_up", "0"b);
     return;

case (43):
     call no_handler ("status", "0"b);
     return;

case (44):
     call no_handler ("buffer_overflow", "1"b);
     return;

case (45):
     call no_handler ("fail_capability", "1"b);
     return;

case (46):
     call no_handler ("query_reply", "0"b);
     return;

case (47):
     call no_handler ("response_connect", "0"b);
     return;

case (48):
     call response_disconnect ();
     return;

case (49):
     call request_connect (p_major_sender);
     return;

case (50):
     call request_disconnect (p_major_sender);
     return;

case (64):
     call add_to_fetch_queue (p_arg_ptr, p_arg_len, p_major_sender);
     return;

case (65):
     call add_to_store_queue (p_arg_ptr, p_arg_len, p_major_sender);
     return;

case (66):				    /* CHECK_FILE_LENGTH */
     return;

case (67):
     call initiate_fetch ();
     return;

case (68):
     call bft_shut_down ();
     return;

case (69):
     call position_file_pointer (p_arg_ptr, p_arg_len);
     return;

case (70):
     call receive_data (p_arg_ptr, p_arg_len);
     return;

case (71):
     call receive_eof ();
     return;

case (72):
     call recover_fetch ();
     return;

case (73):
     call recover_store ();
     return;

case (74):
     call read_error (p_arg_ptr, p_arg_len);
     return;

case (75):
     call initiate_store ();
     return;

case (76):
     call write_error (p_arg_ptr, p_arg_len);
     return;

case (77):
     call send_data ();
     return;

case (78):
     call cancel (p_arg_ptr, p_arg_len);
     return;

case (79):				    /* unused */
     return;

case (80):				    /* EXPAND_PC_PATH */
     return;

case (81):
     call full_pc_path (p_mcb_ptr, p_arg_ptr, p_arg_len);
     return;

/**/

/* INTERNAL PROCEDURES */


/* *** Procedure: add_to_fetch_queue - Internal proc for bft_main_  *** */

add_to_fetch_queue:
     proc (p_arg_ptr, p_arg_len, p_major_sender);


/* PROCEDURE FUNCTION

Add the request to the fetch (PC->Multics) queue.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Length of message */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);
dcl p_major_sender	       fixed bin parameter;	    /* Source of message */

/* MISC VARIABLES */
dcl priority	       fixed bin;		    /* Transfer priority */
dcl flags		       bit(36) aligned;	    /* Transfer modes */
dcl pc_path	       char (66);		    /* PC path */
dcl mu_path	       char (168);		    /* Multics path */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call extract_requests (p_arg_data, mu_path, pc_path, flags, priority);

     call add_to_queue (mu_path, pc_path, flags, priority, p_major_sender, BFT_PC_to_MULTICS);

end add_to_fetch_queue;

/**/

/* *** Procedure: add_to_queue - Internal proc for bft_main_  *** */

add_to_queue:
     proc (p_mu_path, p_pc_path, p_flags, p_priority, p_sender, p_direction);


/* PROCEDURE FUNCTION

This minor capability is responsible for adding elements to the fetch or store
queue (PC to Multics transfers).  If the request initiated from the local
system (Multics), then EXPAND_PC_PATH is called on the PC:BFT to expand the
provided PC pathname to an absolute value.  Which then returns control to
FULL_PC_PATH on MU:BFT continuing the addition of the transfer request to the
queue.  Otherwise, it is assumed that the remote (PC) sent the full path and
the request is entered into the queue.

If no fetch is in progress, then a fetch is initiated.
*/

/* NOTES

The message data is assumed to be correct:

   MU_PATH;PC_PATH;FLAGS;PRIORITY;
*/

/* PARAMETERS */
dcl p_mu_path	       char (*) parameter;	    /* Multics path */
dcl p_pc_path	       char (*) parameter;	    /* PC path */
dcl p_priority	       fixed bin parameter;	    /* Priority of request */
dcl p_flags	       bit(36) aligned parameter; /* Transfer modes */
dcl p_direction	       fixed bin parameter;	    /* Direction (store / fetch) */
dcl p_sender	       fixed bin parameter;	    /* Sender of message */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl pending_ptr	       ptr;		    /* Pending structure */
dcl system_free_area       area based (data_block.system_free_area_ptr);

/* STRUCTURES */
dcl 01 element	       like queue_element automatic;

/* INITIALIZATION */
     unspec (element) = ""b;

/* MAIN */
     element.multics_path = p_mu_path;
     element.pc_path = p_pc_path;
     unspec (element.flags) = p_flags;

/* If the source of the request was from Multics system, then we need to
   expand the PC path to its fullest */

     if get_system_id (p_sender) = LOCAL_SYSTEM | p_direction = BFT_PC_to_MULTICS then do;
	pending_ptr = null;
	on cleanup call cleanup_pending (pending_ptr);
	allocate pending set (pending_ptr) in (system_free_area);
	pending_ptr -> pending.next = null;

/* Insert the request into the "to-be-completed" list */

	pending_ptr -> pending.multics_path = rtrim (element.multics_path);
	pending_ptr -> pending.pc_path = rtrim (element.pc_path);
	pending_ptr -> pending.flags = unspec (element.flags);
	pending_ptr -> pending.switches.processing_sw = "0"b;
	pending_ptr -> pending.switches.first_sw = "1"b;
	pending_ptr -> pending.switches.pad = ""b;
	pending_ptr -> pending.priority = p_priority;
	pending_ptr -> pending.id = 0;
	call insert_pending (p_direction, pending_ptr);

	revert cleanup;

	call get_pc_path ();
     end;

/* Otherwise, add the request to the appropriate queue */

     else do;
	element.time_id = clock_ ();
         	call bft_queue_$add (queue_ptr, addr (element), p_priority,
	     p_direction, code);
	if code ^= 0 then do;
	     call ws_$put_background_message (p_mcb_ptr, code, "bft",
		"Adding element to ^[store^;fetch^] queue ^d.",
		(p_direction = BFT_MULTICS_to_PC), p_priority);
	     return;
	end;
     end;

/* Let's start something going if it isn't already */

     if p_direction = BFT_PC_to_MULTICS then
	call initiate_fetch ();
     else
	call initiate_store ();

end add_to_queue;

/**/

/* *** Procedure: add_to_store_queue - Internal proc for bft_main_  *** */

add_to_store_queue:
     proc (p_arg_ptr, p_arg_len, p_major_sender);


/* PROCEDURE FUNCTION

Add the element to the store queue, if it needs starname expansion for the
Multics Path, go ahead and do it.  But for every request, there is a high
chance that each one must go to the PC for PC expansion to an absolute path of
the destination.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Length of message */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);
dcl p_major_sender	       fixed bin parameter;	    /* Sender of request */

/* MISC VARIABLES */
dcl pc_entry_name	       char (11);		    /* Entry component */
dcl pc_dir_name	       char (66);		    /* Directory component */
dcl pc_equal1	       char (32);		    /* For expanding equalnames */
dcl pc_equal	       char (66);		    /* Equal name for PC entry */
dcl path_name	       char (168);		    /* Full path of request */
dcl entry_name	       char (32);
dcl code		       fixed bin (35);
dcl dir_name	       char (168);
dcl priority	       fixed bin;		    /* Priority of request */
dcl flags		       bit(36) aligned;	    /* Transfer modes */
dcl pc_path	       char (66);
dcl mu_path	       char (168);
dcl i		       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */
     call extract_requests (p_arg_data, mu_path, pc_path, flags, priority);

     call expand_pathname_ (mu_path, dir_name, entry_name, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Expanding ^a for storing.", mu_path);
	return;
     end;

     on cleanup begin;
	free star_names_ptr -> star_names;
	free star_entry_ptr -> star_entries;
     end;

     call hcs_$star_ (dir_name, entry_name, star_ALL_ENTRIES,
	data_block.system_free_area_ptr, star_entry_count, star_entry_ptr,
	star_names_ptr, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Matching starnames for ^a.", mu_path);
	return;
     end;

     do i = 1 to star_entry_count;
	pc_equal = pc_path;
	if star_entries (i).type = star_LINK
	     | star_entries (i).type = star_SEGMENT
	then do;
	     if index (pc_path, "=") ^= 0 then do;
		call expand_pc_pathname (pc_path, pc_dir_name, pc_entry_name, code);
		if code ^= 0 then do;
		     call ws_$put_background_message (mcb_ptr, code, "bft",
			"Expanding ^a for equal name.", pc_path);
		     return;
		end;

		call get_equal_name_ (star_names (i), pc_entry_name, pc_equal1,
		     code);
		if code ^= 0 then do;
		     call ws_$put_background_message (mcb_ptr, code, "bft",
			"Getting equal name for ^a.", star_names (i));
		     return;
		end;

		pc_equal = "";
		if length (rtrim (pc_dir_name)) > 0 then
		     pc_equal = rtrim (pc_dir_name) || "\";
		pc_equal = rtrim (pc_equal) || rtrim (pc_equal1);
	     end;

	     path_name = rtrim (dir_name) || ">" || rtrim (star_names (i));
	     call add_to_queue (path_name, pc_equal, flags, priority,
		p_major_sender, BFT_MULTICS_to_PC);
	end;
     end;

     free star_names_ptr -> star_names;
     free star_entry_ptr -> star_entries;
end add_to_store_queue;

/**/

/* *** Procedure: add_token - Internal proc for bft_main_  *** */

add_token:
     proc (p_message, p_message_len, p_token);


/* PROCEDURE FUNCTION

Add the token to the message.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_message	       char (*) parameter;	    /* Message being created */
dcl p_message_len	       fixed bin parameter;	    /* Current length of message */
dcl p_token	       char (*) parameter;	    /* Token to add */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     substr (p_message, p_message_len + 1) = p_token;
     p_message_len = p_message_len + length (p_token);

     substr (p_message, p_message_len + 1) = DELIM_CHAR;
     p_message_len = p_message_len + length (DELIM_CHAR);

end add_token;

/**/

/* *** Procedure: bft_shut_down - Internal proc for bft_main_  *** */

bft_shut_down:
     proc ();

/* PROCEDURE FUNCTION

This routine is called when BFT is to be shut down.  A message to this effect
ist printed, and then the disconnect request minor is called on the remote
machine.  When the disconnect_reply is called, this side of bft will shut down.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);	    /* Error code */
dcl major_num	       fixed bin;		    /* Capability number */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     data_block.flags.shut_down_sw = "1"b;

/* Close and detach all opened IOCBs */

     call cleanup_iocb_switches ();

/* Release all of the pending transfers waiting for pc_path expansion */

     call cleanup_pending_chain ();

/* Generate the shutdown message */

     call ws_$put_background_message (mcb_ptr, 0, "bft",
	"BFT is shutting down and removing itself from MOWSE.");

     major_num = 0;
     call ws_$find_capability_number ("BFT", REMOTE_SYSTEM, major_num, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Finding PC counterpart in bft_shut_down.");
	return;
     end;

     call ws_$disconnect_request (major_num, mcb_ptr, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Requesting disconnect in bft_shut_down.");
	return;
     end;

end bft_shut_down;

/**/

/* *** Procedure: cancel - Internal proc for bft_main_  *** */

cancel:
     proc (p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

This minor capability cancels the specified request from the queue.  The
provided request_id is either a path (PC or Multics) or an ID of an entry
in the queue.
*/

/* NOTES

The message data is assumed tro be correct:

	ID_SW;REQUEST_ID;
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Message length */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);

/* MISC VARIABLES */
dcl id_type	       fixed bin;		    /* Type of request_id */
dcl request_id	       char (168);		    /* Actual request id */
dcl token		       char (p_arg_len) var;
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */
     code = 0;

/* MAIN */

/* Strip the request type */

     call strip_token (p_arg_data, token);
     id_type = rank (substr (token, 1, 1));
     if ^(id_type = BFT_PATH_ID | id_type = BFT_TIME_ID | id_type = BFT_ENTRY_ID) then do;
	call ws_$put_background_message (mcb_ptr, error_table_$bad_conversion,
	     "bft", "Extracting request_id type.");
	return;
     end;

/* Strip the request id */

     call strip_token (p_arg_data, token);
     request_id = ltrim (token);

/* Cancel the request */

     call bft_queue_$cancel (queue_ptr, request_id, id_type, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Cancelling ^a.", request_id);
	return;
     end;

end cancel;

/**/

/* *** Procedure: chars_to_bits - Internal proc for bft_main_  *** */

chars_to_bits:
     proc (p_precision, p_string) returns (bit(*));


/* PROCEDURE FUNCTION

Convert a character string to a continuous bit representation.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_precision	       fixed bin parameter;	    /* Number of bits to extract */
dcl p_string	       char (*) parameter;	    /* Chars to convert */

/* MISC VARIABLES */
dcl i		       fixed bin;
dcl ret_string	       bit(p_precision);	    /* Return bit string */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     ret_string = ""b;
     do i = 1 to length (p_string);
	substr (ret_string, p_precision - (i*8))
	     = unspec (substr (p_string, i, 1));
     end;

     return (ret_string);

end chars_to_bits;

/**/

/* *** Procedure: cleanup_data_block - Internal proc for bft_main_  *** */

cleanup_data_block:
     proc ();


/* PROCEDURE FUNCTION

Free the data block structure back to the system.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if data_block_ptr ^= null then do;
	free data_block_ptr -> data_block;
	data_block_ptr = null;
     end;

end cleanup_data_block;

/**/

/* *** Procedure: cleanup_pending_chain - Internal proc for bft_main_  *** */

cleanup_pending_chain:
     proc ();


/* PROCEDURE FUNCTION

Release all of the elements in the chain of pending requests.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl temp_ptr	       ptr;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Release all of the pending transfers waiting for pc_path expansion */

     do while (data_block.fetch_pending ^= null);
	temp_ptr = data_block.fetch_pending -> pending.next;
	call cleanup_pending (data_block.fetch_pending);
	data_block.fetch_pending = temp_ptr;
     end;
     do while (data_block.store_pending ^= null);
	temp_ptr = data_block.store_pending -> pending.next;
	call cleanup_pending (data_block.store_pending);
	data_block.store_pending = temp_ptr;
     end;

end cleanup_pending_chain;

/**/

/* *** Procedure: expand_pc_pathname - Internal proc for bft_main_  *** */

expand_pc_pathname:
     proc (p_source, p_dir_name, p_entry_name, p_code);


/* PROCEDURE FUNCTION

Parse apart the PC pathname into its directory and entry components.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_code	       fixed bin (35) parameter;
dcl p_source	       char (*) parameter;	    /* Path to expand */
dcl p_dir_name	       char (*) parameter;	    /* Directory component */
dcl p_entry_name	       char (*) parameter;	    /* Entry component */

/* MISC VARIABLES */
dcl done		       bit(1);		    /* Loop control */
dcl i		       fixed bin;
dcl indx		       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

     indx = 1;
     p_dir_name = "";
     p_entry_name = "";
     done = "0"b;
     do while (^done & indx < length (rtrim (p_source)));
	i = index (substr (p_source, indx), "\");
	if i > 0 then
	     indx = indx + i;
	else
	     done = "1"b;
     end;

     if indx > 1 then
	p_dir_name = substr (p_source, 1, indx - 2);
     p_entry_name = substr (rtrim (p_source), indx);

end expand_pc_pathname;

/**/

/* *** Procedure: extract_requests - Internal proc for bft_main_  *** */

extract_requests:
     proc (p_message, p_mu_path, p_pc_path, p_flags, p_priority);


/* PROCEDURE FUNCTION

Extract requests from the message.  This is a STORE or FETCH request
message with the format:

     MU_PATH;PC_PATH;FLAGS;PRIORITY;
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_message	       char (*) parameter;	    /* Message to extract from */
dcl p_priority	       fixed bin parameter;
dcl p_flags	       bit(36) aligned parameter;
dcl p_pc_path	       char (*) parameter;
dcl p_mu_path	       char (*) parameter;

/* MISC VARIABLES */
dcl i		       fixed bin;
dcl ch_flags	       char (4);		    /* Character representation of flags */
dcl code		       fixed bin (35);
dcl dir_name	       char (168);		    /* Directory of path */
dcl token		       char (length (p_message)) var;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Get the Multics path, PC path, and flags, in THAT order from the message */

     call strip_token (p_message, token);
     dir_name = ltrim (substr (token, 1, length (token)));
     call absolute_pathname_ (dir_name, p_mu_path, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Expanding ^a.", rtrim (p_mu_path));
	return;
     end;

     call strip_token (p_message, token);
     p_pc_path =  ltrim (substr (token, 1, length (token)));

     call strip_token (p_message, token);
     ch_flags = substr (token, 1, length (token));
     p_flags = ""b;
     do i = 1 to 4;
	substr (p_flags, (8*(i-1))+1, 8)
	     = substr (unspec (substr (ch_flags, i, 1)), 2, 8);
     end;
     substr (unspec (p_flags), 5, 32) = p_flags;

     call strip_token (p_message, token);
     p_priority = rank (substr (token, 1, 1));

end extract_requests;

/**/

/* *** Procedure: find_pending - Internal proc for bft_main_  *** */

find_pending:
     proc (p_pending_ptr, p_start_ptr, p_request_id, p_remove);


/* PROCEDURE FUNCTION

Lovcate the element corresponding to the request ID.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_remove	       bit(1) parameter;	    /* Remove the element? */
dcl p_request_id	       fixed bin parameter;	    /* ID of element to be matched */
dcl p_start_ptr	       ptr parameter;	    /* Start of list */
dcl p_pending_ptr	       ptr parameter;	    /* Found element */

/* MISC VARIABLES */
dcl prev_ptr	       ptr;		    /* Previous element pointer */
dcl search_ptr	       ptr;		    /* Pointer to look with */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     p_pending_ptr = null;
     search_ptr = p_start_ptr;
     prev_ptr = null;

     if p_start_ptr = null then
	return;

     do while (search_ptr -> pending.id ^= p_request_id);
	prev_ptr = search_ptr;
	search_ptr = prev_ptr -> pending.next;
	if search_ptr = null then
	     return;
     end;

     if search_ptr = null then do;
	p_pending_ptr = null;
	return;
     end;

     p_pending_ptr = search_ptr;

     if ^p_remove then
	return;

     if prev_ptr = null then
	p_start_ptr = search_ptr -> pending.next;
     else
	prev_ptr -> pending.next = search_ptr -> pending.next;
     p_pending_ptr -> pending.next = null;

end find_pending;

/**/

/* *** Procedure: full_pc_path - Internal proc for bft_main_  *** */

full_pc_path:
     proc (p_mcb_ptr, p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

The PC has expanded a path to its full name, the ID of the request is matched
with a pending request and extracted to be inserted into the queue.
*/

/* NOTES

The argument data is:

	PC_PATH;MAJOR_ID;DIRECTION
*/

/* PARAMETERS */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);
dcl p_mcb_ptr	       ptr parameter;	    /* MOWSE control block */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Length of message */

/* MISC VARIABLES */
dcl equalname	       char (32);		    /* Equalname created */
dcl mu_entryname	       char (32);		    /* Multics entry component */
dcl mu_dirname	       char (168);		    /* Multics directory component */
dcl pc_entryname	       char (12);		    /* PC entry componenet */
dcl pc_dirname	       char (66);		    /* PC directory componenet */
dcl remove_sw	       bit(1);		    /* If removal required */
dcl code		       fixed bin (35);
dcl pending_ptr	       ptr;		    /* Matching element */
dcl direction	       fixed bin;		    /* Direction of transfer */
dcl major		       fixed bin;		    /* Major request id */
dcl major_id_over	       fixed bin (17) unal based (addr (major_bit_id));
dcl major_bit_id	       bit(18) unal;
dcl token		       char (p_arg_len) var;

/* STRUCTURES */
dcl 01 element	       like queue_element auto;

/* INITIALIZATION */

/* MAIN */

     call strip_token (p_arg_data, token);
     element.pc_path = token;

     call strip_token (p_arg_data, token);
     major_bit_id = ""b;
     substr (major_bit_id, 1, 9 * length (token))
	= reverse (chars_to_bits (9 * length (token), substr (token, 1)));
     major_bit_id
	= reverse (major_bit_id);
     major = major_id_over;

     call strip_token (p_arg_data, token);
     direction = rank (substr (token, 1, 1));

/* If the returned path length is 0, no match so remove the element */

     remove_sw = (length (rtrim (element.pc_path)) = 0);

/* Locate the matching element */

     if direction = BFT_PC_to_MULTICS then
	call find_pending (pending_ptr, data_block.fetch_pending, major, remove_sw);
     else
	call find_pending (pending_ptr, data_block.store_pending, major, remove_sw);
     if pending_ptr = null then
	return;

/* If this was a first request response, and there is no match, then error */

     if pending_ptr -> pending.switches.first_sw & remove_sw
	& search (pending_ptr -> pending.pc_path, "?*") > 0
     then
	call ws_$put_background_message (mcb_ptr, 0, "bft",
	     "No PC match for ^a.", pending_ptr -> pending.pc_path);

/* Fill out the queue element and add it to the appropriate queue */

     if ^remove_sw then do;
	pending_ptr -> pending.switches.processing_sw = "0"b;
	pending_ptr ->pending.switches.first_sw = "0"b;

	if index (pending_ptr -> pending.multics_path, "=") > 0 then do;
	     call expand_pc_pathname (element.pc_path, pc_dirname,
		pc_entryname, code);
	     call expand_pathname_ (pending_ptr -> pending.multics_path,
		mu_dirname, mu_entryname, code);
	     if code ^= 0 then do;
		call ws_$put_background_message (mcb_ptr, code, "bft",
		     "Expanding ^a to add to queue.",
		     pending_ptr -> pending.multics_path);
		return;
	     end;

	     call get_equal_name_ (pc_entryname, mu_entryname, equalname, code);
	     if code ^= 0 then do;
		call ws_$put_background_message (mcb_ptr, code, "bft",
		     "Getting equalname ^a to add to queue.",pc_entryname);
		return;
	     end;

	     element.multics_path = rtrim (mu_dirname) || ">" || equalname;
	end;
	else
	     element.multics_path = pending_ptr -> pending.multics_path;

	element.next = 0;
	element.time_id = clock_ ();
	unspec (element.flags) = pending_ptr -> pending.flags;

	call bft_queue_$add (queue_ptr, addr (element),
	     pending_ptr -> pending.priority, direction, code);
	if code ^= 0 then do;
	     call ws_$put_background_message (p_mcb_ptr, code, "bft",
		"Adding element to ^[store^;fetch^] queue ^d.",
		(direction = BFT_MULTICS_to_PC), pending_ptr -> pending.priority);
	     return;
	end;
     end;
     else
	call cleanup_pending (pending_ptr);

/* Lets get another name expanded, if necessary */

     call get_pc_path ();

/* Lets try for a transfer */

     if ^remove_sw then do;
	if direction = BFT_PC_to_MULTICS then
	     call initiate_fetch ();
	else
	     call initiate_store ();
     end;

end full_pc_path;

/**/

/* *** Procedure: bits_to_chars - Internal proc for bft_main_  *** */

bits_to_chars:
     proc (p_n_bytes, p_bits) returns (char (*));


/* PROCEDURE FUNCTION

Convert a continuous bit string to series of characters where 8 bits
are stuffed into each character.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_n_bytes	       fixed bin parameter;	    /* Number of bytes in number */
dcl p_bits	       bit (*);		    /* Conversion number */

/* MISC VARIABLES */
dcl out_string	       char (p_n_bytes);	    /* Output string */
dcl i		       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     unspec (out_string) = ""b;
     do i = 1 to p_n_bytes;
	substr (unspec (substr (out_string, i, 1)), 2, 8)
	     = reverse (substr (reverse (p_bits), (8*(i-1))+1, 8));
     end;

     return (reverse (out_string));

end bits_to_chars;

/**/

/* *** Procedure: cleanup_iocb_switches - Internal proc for bft_main_  *** */

cleanup_iocb_switches:
     proc ();


/* PROCEDURE FUNCTION

Close and detach all opend bft switches.  This must be done by name.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl iocb_ptr	       ptr;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call iox_$find_iocb ("bft_send", iocb_ptr, code);
     if code = 0 then
	call close_data_file (iocb_ptr);

     call iox_$find_iocb ("bft_receive", iocb_ptr, code);
     if code = 0 then
	call close_data_file (iocb_ptr);

end cleanup_iocb_switches;

/**/

/* *** Procedure: cleanup_pending - Internal proc for bft_main_  *** */

cleanup_pending:
     proc (p_pending_ptr);


/* PROCEDURE FUNCTION

Release the structure pointed at by the pointer.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_pending_ptr	       ptr parameter;	    /* The structure to be cleaned */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if p_pending_ptr ^= null then do;
	free p_pending_ptr -> pending;
	p_pending_ptr = null;
     end;

end cleanup_pending;

/**/

/* *** Procedure: close_data_file - Internal proc for bft_main_  *** */

close_data_file:
     proc (p_iocb_ptr);


/* PROCEDURE FUNCTION

Close the file specified by the iocb.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_iocb_ptr	       ptr parameter;	    /* IOCB to close */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call iox_$close (p_iocb_ptr, (0));
     call iox_$detach_iocb (p_iocb_ptr, (0));
     call iox_$destroy_iocb (p_iocb_ptr, (0));

     p_iocb_ptr = null;

end close_data_file;

/**/

/* *** Procedure: execute_command_reply - Internal proc for bft_main_  *** */

execute_command_reply:
     proc ();


/* PROCEDURE FUNCTION

This is called by MOWSE as a reply to the excecute command call in the loading
section (main) of this program.  There is no code here because it is only used
when MOWSE makes this reply.  BFT does not require any information or perform
any function upon receipt of this call.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

end execute_command_reply;

/**/

/* *** Procedure: execute_pc_bft - Internal proc for bft_main_  *** */

execute_pc_bft:
     proc (p_arg_ptr, p_arg_len, p_minor, p_mcb_ptr, p_code);


/* PROCEDURE FUNCTION

Execute PC counterpart of BFT.
*/

/* NOTES

If an error occured, then here is where the shutdown is generated and
the offending error code is passed back up.  The code should merely be used
to indicate some error occurred, nothing should be done with it.
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Length of message */
dcl p_minor	       fixed bin parameter;	    /* Minor to execute */
dcl p_mcb_ptr	       ptr parameter;	    /* MOWSE control block */
dcl p_code	       fixed bin (35) parameter;

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if data_block.pc_bft_num = 0 then
	if find_pc_bft (p_mcb_ptr, "1"b) = 0 then
	     return;

     call ws_$execute_capability (data_block.pc_bft_num, p_minor, p_arg_ptr,
	p_arg_len, p_mcb_ptr, p_code);
     if p_code ^= 0 then do;
	call ws_$put_background_message (p_mcb_ptr, p_code, "bft",
	     "Executing PC:BFT, minor ^d.", p_minor);
	call bft_shut_down ();
     end;

end execute_pc_bft;

/**/

/* *** Procedure: find_pc_bft - Internal proc for bft_main_  *** */

find_pc_bft:
     proc (p_mcb_ptr, p_shut_down_sw) returns (fixed bin);


/* PROCEDURE FUNCTION

Locate the PC counterpart of bft.  If found, return the major number and
insert it into the data_block.  If not found, thenn shut_down (if asked for).
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_shut_down_sw	       bit(1) parameter;	    /* Shut down if true */
dcl p_mcb_ptr	       ptr parameter;	    /* MOWSE control block */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl major_num	       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     major_num = 0;
     call ws_$find_capability_number ("BFT", REMOTE_SYSTEM, major_num, code);

     if code ^= 0 & code ^= ws_error_$invalid_capability_name then do;
	call ws_$put_background_message (p_mcb_ptr, code, "bft", "Locating PC:BFT.");
	if p_shut_down_sw then
	     call bft_shut_down ();
	return (0);
     end;

     data_block.pc_bft_num = major_num;

     return (major_num);

end find_pc_bft;

/**/

/* *** Procedure: get_pc_path - Internal proc for bft_main_  *** */

get_pc_path:
     proc ();


/* PROCEDURE FUNCTION

If the top element in the pending list is NOT being processed for a PC path,
then submit the request for an expansion on that PC pathname.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl direction	       fixed bin;		    /* Direction of transfer request */
dcl id_token	       char (2);		    /* Char conversion if ID */
dcl pending_ptr	       ptr;		    /* Pointer to element to be processed */
dcl message	       char (128);		    /* Message to transmit */
dcl message_len	       fixed bin;		    /* Length of transmitted message */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* If the top request is in process, return */

     if data_block.store_pending ^= null then do;
	if data_block.store_pending -> pending.switches.processing_sw then
	     return;
     end;
     else if data_block.fetch_pending ^= null then do;
	if data_block.fetch_pending -> pending.switches.processing_sw then
	     return;
     end;
     else
	return;

/* Lets give STORE expansion priority, there will probably be fewer */

     pending_ptr = data_block.store_pending;
     direction = BFT_MULTICS_to_PC;
     if pending_ptr = null then do;
	pending_ptr = data_block.fetch_pending;
	direction = BFT_PC_to_MULTICS;
     end;
     pending_ptr -> pending.switches.processing_sw = "1"b;

/* Send out the message */

     message_len = 0;
     if pending_ptr -> pending.switches.first_sw then do;
	call add_token (message, message_len, BFT_FIRST);
	call add_token (message, message_len,
	     rtrim (pending_ptr -> pending.pc_path));
     end;
     else do;
	call add_token (message, message_len, BFT_NEXT);
	call add_token (message, message_len, "");
     end;

     id_token = bits_to_chars (2, unspec (pending_ptr -> pending.id));
     if substr (id_token, 1, 1) = "" then
	call add_token (message, message_len, substr (id_token, 2, 1));
     else
	call add_token (message, message_len, id_token);

     call add_token (message, message_len, byte (direction));

     call execute_pc_bft (addr (message), message_len,
	bft_minor_$expand_pc_path, mcb_ptr, (0));

end get_pc_path;

/**/

/* *** Procedure: get_system_id - Internal proc for bft_main_  *** */

get_system_id:
     proc (p_major) returns (fixed bin);


/* PROCEDURE FUNCTION

Extract the system ID from the capability number.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_major	       fixed bin parameter;	    /* Capability number to extract from */

/* MISC VARIABLES */

/* STRUCTURES */
dcl 01 major_overlay       unaligned based (addr (p_major)),
       02 pad	       bit (18),
       02 system	       fixed bin (8),
       02 index	       fixed bin (8);

/* INITIALIZATION */

/* MAIN */

     return (major_overlay.system);

end get_system_id;

/**/

/* *** Procedure: initialize_bft - Internal proc for bft_main_  *** */

initialize_bft:
     proc (p_code);


/* PROCEDURE FUNCTION

This sets all of the variables that BFT needs to access when it is called up.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl system_free_area       area based (system_free_area_ptr);
dcl system_free_area_ptr   ptr;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

     system_free_area_ptr = get_system_free_area_ ();
     allocate data_block in (system_free_area) set (data_block_ptr);
     unspec (data_block) = ""b;

     data_block.version = BFT_DATA_BLOCK_VERSION_1;
     data_block.pc_bft_num = 0;
     data_block.inbuff_len = BFT_INBUFF_LENGTH;
     data_block.outbuff_len = BFT_OUTBUFF_LENGTH;
     data_block.receive_iocb_ptr = null;
     data_block.send_iocb_ptr = null;
     data_block.system_free_area_ptr = system_free_area_ptr;
     data_block.fetch_pending = null;
     data_block.store_pending = null;
     data_block.flags.shut_down_sw = "0"b;

     call bft_queue_$initiate (queue_ptr, p_code);
     if p_code ^= 0 then 
	return;
     data_block.queue_ptr = queue_ptr;

end initialize_bft;

/**/

/* *** Procedure: initiate_fetch - Internal proc for bft_main_  *** */

initiate_fetch:
     proc ();


/* PROCEDURE FUNCTION

This procedure / minor capability, examines the PC_to_MULTICS (fetch) queue
and determines if it is possible to begin transfer of another file.  Conditions
are acceptable only when a PC_to_MULTICS (fetch) is not currently in progress
and there exists an element in the PC_to_MULTICS (fetch) queue.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl message_len	       fixed bin;		    /* Length of message */
dcl message	       char (128);		    /* Message sent out */
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Extract the next element from the fetch queue, repeat until we got one */

     do while ("1"b);
	call bft_queue_$remove (queue_ptr, BFT_PC_to_MULTICS, code);
	if code = bft_error_table_$fetch_in_progress | code = bft_error_table_$no_entries then
	     return;
	else if code ^= 0 then do;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
		"Getting next entry from fetch queue.");
	     call bft_shut_down ();
	     return;
	end;

/* Open the destination (Multics) file */

	call open_receive_data_file (rtrim (queue.header.fetching.multics_path),
	     "0"b, code);
	if code ^= 0 then do;
	     queue.header.fetching.flags.initiated = "0"b;
	     queue.header.fetch_file_pos = 0;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
		"Opening ^a.", rtrim (queue.header.fetching.multics_path));
	end;
	else do;
	     message_len = 0;
	     call add_token (message, message_len,
		rtrim (queue.header.fetching.pc_path));
	     call add_token (message, message_len,
		bits_to_chars (4, unspec (queue.header.fetching.flags)));
	     call execute_pc_bft (addr (message), message_len,
		bft_minor_$initiate_fetch, mcb_ptr, code);
	     if code ^= 0 then
		return;
	end;
     end;

end initiate_fetch;

/**/

/* *** Procedure: initiate_store - Internal proc for bft_main_  *** */

initiate_store:
     proc ();


/* PROCEDURE FUNCTION

This procedure / minor capability, examines the MULTICS_to_PC (store) queue
and determines if it is possible to begin transfer of another file.  Conditions
are acceptable only when a MULTICS_to_PC (store) is not currently in progress
and there exists an element in the MULTICS_to_PC (store) queue.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl message	       char (256);
dcl message_len	       fixed bin;		    /* Length of message to send */
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Extract the next element from the store queue, repeat until we got one */

     do while  ("1"b);
	call bft_queue_$remove (queue_ptr, BFT_MULTICS_to_PC, code);
	if code = bft_error_table_$store_in_progress | code = bft_error_table_$no_entries then
	     return;
	else if code ^= 0 then do;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
		"Getting next entry from store queue.");
	     call bft_shut_down ();
	     return;
	end;

/* Open the source (Multics) file */

	call open_send_data_file (rtrim (queue.header.storing.multics_path),
	     code);
	if code ^= 0 then do;
	     queue.header.storing.flags.initiated = "0"b;
	     queue.header.store_file_pos = 0;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
	          "Opening ^a.", rtrim (queue.header.storing.multics_path));
	end;
	else do;
	     message_len = 0;
	     call add_token (message, message_len,
		rtrim (queue.header.storing.pc_path));
	     call add_token (message, message_len,
		bits_to_chars (4, unspec (queue.header.storing.flags)));
	     call execute_pc_bft (addr (message), message_len,
		bft_minor_$initiate_store, mcb_ptr, code);
	     if code ^= 0 then
		return;
	end;
     end;

end initiate_store;

/**/

/* *** Procedure: insert_pending - Internal proc for bft_main_  *** */

insert_pending:
     proc (p_direction, p_pending_ptr);


/* PROCEDURE FUNCTION

Insert the pending request into the appropriate chain.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_direction	       fixed bin parameter;	    /* Which direction */
dcl p_pending_ptr	       ptr parameter;	    /* Structure to insert */

/* MISC VARIABLES */
dcl start_ptr	       ptr;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if p_direction = BFT_PC_to_MULTICS then do;
	if data_block.fetch_pending = null then do;
	     data_block.fetch_pending = p_pending_ptr;
	     p_pending_ptr -> pending.id = 1;
	     return;
	end;
	else
	     start_ptr = data_block.fetch_pending;
     end;
     else do;
	if data_block.store_pending = null then do;
	     data_block.store_pending = p_pending_ptr;
	     p_pending_ptr -> pending.id = 1;
	     return;
	end;
	else
	     start_ptr = data_block.store_pending;
     end;

/* Traverse the list */

     do while (start_ptr -> pending.next ^= null);
	start_ptr = start_ptr -> pending.next;
     end;
     start_ptr -> pending.next = p_pending_ptr;

     p_pending_ptr -> pending.id = start_ptr -> pending.id + 1;

end insert_pending;

/**/

/* *** Procedure: no_handler - Internal proc for bft_main_  *** */

no_handler:
     proc (p_message, p_shut_down_sw);


/* PROCEDURE FUNCTION

This procedure displays an error message indicating that the called minor
capability is NOT supported.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_shut_down_sw	       bit(1) parameter;	    /* If shut down is required */
dcl p_message	       char (*) parameter;	    /* Message to accompany error. */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call ws_$put_background_message (mcb_ptr,
	bft_error_table_$illegal_minor_capability, "bft", p_message);
     if p_shut_down_sw then
	call bft_shut_down ();

end no_handler;

/**/

/* *** Procedure: open_receive_data_file - Internal proc for bft_main_  *** */

open_receive_data_file:
     proc (p_path, p_append_sw, p_code);


/* PROCEDURE FUNCTION

Open the receive data file for writing.  If the p_append flag is true, then the
file is being recovered and we need to open it and set the file position to the
character specified in the value segment.  Otherwise the file will be destroyed
if it already exists.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_path	       char (*) parameter;	    /* Path to open */
dcl p_append_sw	       bit(1) parameter;	    /* Open for append */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl iocb_ptr	       ptr;		    /* IOCB being opened */
dcl open_descrip	       char (256);		    /* Opening modes */

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

/* If the file is already open, then close it */

     if data_block.receive_iocb_ptr ^= null then
	call close_data_file (data_block.receive_iocb_ptr);

/* Close and detach the bft_receive IOCB if it exists */

     call iox_$find_iocb ("bft_receive", iocb_ptr, p_code);
     if p_code = 0 then
	call close_data_file (iocb_ptr);

/* Open the file and attach the iocb pointer */

     open_descrip = "vfile_ " || rtrim (p_path);
     if p_append_sw then
	open_descrip = rtrim (open_descrip) || " -append";

     call iox_$attach_name ("bft_receive", iocb_ptr, open_descrip, null, p_code);
     if p_code ^= 0 then
	return;

     call iox_$open (iocb_ptr, Stream_input_output, ("0"b), p_code);
     if p_code ^= 0 then
	return;

/* Return with the new IOCB and set the data_block value to it */

     data_block.receive_iocb_ptr = iocb_ptr;

end open_receive_data_file;

/**/

/* *** Procedure: open_send_data_file - Internal proc for bft_main_  *** */

open_send_data_file:
     proc (p_path, p_code);


/* PROCEDURE FUNCTION

Open the specified file for sending data.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_path	       char (*) parameter;	    /* Path to open */
dcl p_code	       fixed bin (35) parameter;

/* MISC VARIABLES */
dcl open_descrip	       char (256);		    /* Opening modes */
dcl iocb_ptr	       ptr;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

/* If we have already opened the send file, then close it */

     if data_block.send_iocb_ptr ^= null then
	call close_data_file (data_block.send_iocb_ptr);

/* Close and detach the bft_send IOCB if it exists */

     call iox_$find_iocb ("bft_send", iocb_ptr, p_code);
     if p_code = 0 then
	call close_data_file (iocb_ptr);

/* Lets get ahold of it and store it in the data block */

     open_descrip = "vfile_ " || rtrim (p_path);
     call iox_$attach_name ("bft_send", iocb_ptr, open_descrip, null, p_code);
     if p_code ^= 0 then
	return;

     call iox_$open (iocb_ptr, Stream_input, ("0"b), p_code);
     if p_code ^= 0 then
	return;

/* Return with the new IOCB and set the data_block value to it */

     data_block.send_iocb_ptr = iocb_ptr;

end open_send_data_file;

/**/

/* *** Procedure: position_file_pointer - Internal proc for bft_main_  *** */

position_file_pointer:
     proc (p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

This minor capability is called during the recovery process to set the output
file pointer to correspond with the size of the file that has already been
received by the remote (during a store).  This value is passed via the argument
list from CHECK_FILE_LENGTH.  If all goes well, the transfer is continued from
the position specified.
*/

/* NOTES

The argument data is:

	FILE_LENGTH
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Message length */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);

/* MISC VARIABLES */
dcl mode		       fixed bin;		    /* Positioning mode */
dcl byte_count	       fixed bin (21);	    /* File position */
dcl token		       char (p_arg_len) var;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Get the file position from the argument list */

     call strip_token (p_arg_data, token);
     byte_count = convert (byte_count, token);

/* Open the file that was in transfer */

     call open_send_data_file (rtrim (queue.header.storing.multics_path), code);
     if code ^= 0 then do;
	queue.header.storing.flags.initiated = "0"b;
	queue.header.store_file_pos = 0;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Opening ^a for positioning.",
	     rtrim (queue.header.storing.multics_path));
	call initiate_store ();
	return;
     end;

/* Position in the file to the appropriate byte / line position */

     queue.header.store_file_pos = byte_count;
     if queue.header.storing.flags.binary_sw then
	mode = 2;
     else
	mode = 0;

     call iox_$position (data_block.send_iocb_ptr, -1, 0, code);
     call iox_$position (data_block.send_iocb_ptr, mode,
	queue.header.store_file_pos, code);
     if code ^= 0 then do;
	queue.header.storing.flags.initiated = "0"b;
	queue.header.store_file_pos = 0;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Positioning file ^a.",
	     rtrim (queue.header.storing.multics_path));
	call initiate_store ();
	return;
     end;

/* Begin the transfer from the new file position */

     call send_data ();

end position_file_pointer;

/**/

/* *** Procedure: read_error - Internal proc for bft_main_  *** */

read_error:
     proc (p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

This procedure is called by the remote machine to signal an error occurred
while the remote machine was sending a file.  The proper cleanup is done and
the queues are checked to see if there are any pending requests.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Message length */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);

/* MISC VARIABLES */
dcl error_string	       char (128) var;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Extract the error message from the argument string */

     call strip_token (p_arg_data, error_string);
     call ws_$put_background_message (mcb_ptr, 0, "bft", error_string);

/* Remove the current fetch from the queue */

     queue.header.fetching.flags.initiated = "0"b;
     queue.header.fetch_file_pos = 0;
     call close_data_file (data_block.receive_iocb_ptr);

/* Try for another request from the fetch queue */

     call initiate_fetch ();

end read_error;

/**/

/* *** Procedure: receive_data - Internal proc for bft_main_  *** */

receive_data:
     proc (p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

This is the minor capability responsible for writing the data it receives as an
argument to the destination file.  The name of the is kept in the value
segment.  The file is opened , and the data is written out.  Then SEND_DATA is
called on the remote machine to send the next piece of the file.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Message length */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);

/* MISC VARIABLES */
dcl mu_entryname	       char (32);
dcl mu_dirname	       char (168);
dcl line_len	       fixed bin;
dcl line_start	       fixed bin;		    /* Position of <LF> in data */
dcl message	       char (128);		    /* Message to send */
dcl long_info	       char (100) aligned;	    /* Long error */
dcl short_info	       char (8) aligned;	    /* Short error */
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Verify that this transfer has NOT been cancelled midestream */

     if ^queue.header.fetching.flags.initiated then do;
	queue.header.fetch_file_pos = 0;
	call close_data_file (data_block.receive_iocb_ptr);

	call expand_pathname_ (rtrim (queue.header.fetching.multics_path),
	     mu_dirname, mu_entryname, code);
	message = "Fetch request " || rtrim (mu_entryname);
	message = rtrim (message)  || " cancelled in progress.";
	call execute_pc_bft (addr (message), length (rtrim (message)),
	     bft_minor_$write_error, mcb_ptr, (0));
	return;
     end;

/* Write the bytes that were passed into the file */

     call iox_$put_chars (data_block.receive_iocb_ptr, p_arg_ptr,
	convert (fixedbin21, p_arg_len), code);
     if code ^= 0 then do;
	queue.header.fetching.flags.initiated = "0"b;
	queue.header.fetch_file_pos = 0;
	call close_data_file (data_block.receive_iocb_ptr);

	call convert_status_code_ (code, short_info, long_info);
	message = rtrim (long_info) || ".  Receiving data.";
	call execute_pc_bft (addr (message), length (rtrim (message)),
	     bft_minor_$write_error, mcb_ptr, (0));
	return;
     end;

/* Increment the count of received chars/lines */

     if queue.header.fetching.flags.binary_sw then
	queue.header.fetch_file_pos
	     = queue.header.fetch_file_pos + convert (fixedbin21, p_arg_len);
     else do;
	line_len = index (substr (p_arg_data, 1), byte (10));
	line_start = line_len;
	do while (line_len > 0);
	     queue.header.fetch_file_pos = queue.header.fetch_file_pos + 1;
	     line_len = index (substr (p_arg_data, line_start + 1), byte (10));
	     line_start = line_start + line_len;
	end;
     end;

/* Prod PC:BFT for another chunk */

     call execute_pc_bft (null, 0, bft_minor_$send_data, mcb_ptr, code);
     if code ^= 0 then
	return;

end receive_data;

/**/

/* *** Procedure: receive_eof - Internal proc for bft_main_  *** */

receive_eof:
     proc ();


/* PROCEDURE FUNCTION

This routine performs the proper cleanup after the local machine receives an
end of file.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Clear the flags indicating that a fetch was in progress */

     queue.header.fetching.flags.initiated = "0"b;
     queue.header.fetch_file_pos = 0;

/* Close the IOCB and notify completion */

     call close_data_file (data_block.receive_iocb_ptr);
     if queue.header.fetching.flags.notify_sw then
	call ws_$put_background_message (mcb_ptr, 0, "bft",
	     "Completed transfer of ^a to Multics.",
	     rtrim (queue.header.fetching.multics_path));

/* Try for another fetch */

     call initiate_fetch ();

end receive_eof;

/**/

/* *** Procedure: recover_fetch - Internal proc for bft_main_  *** */

recover_fetch:
     proc ();


/* PROCEDURE FUNCTION

The fetch (PC_to_MULTICS) queue is examined for an interrupted request.  If one
exists, then it is resumed by calling POSITION_FILE_POINTER on PC:BFT to set
the continuation mark of the fetch.  If there is no interrupted reqest, then
the rest of the queue is attempted to be started through initiateing a store.
*/

/* NOTES

No arguments are required as it is automatic.
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl message	       char (128);
dcl message_len	       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* If there is no current request (ie. interrupted) then initiate a new fetch */

     if ^queue.header.fetching.initiated then do;
	call initiate_fetch ();
	return;
     end;

/* Open the file */

     call open_receive_data_file (rtrim (queue.header.fetching.multics_path),
	"1"b, code);
     if code ^= 0 then do;
	queue.header.fetching.flags.initiated = "0"b;
	queue.header.fetch_file_pos = 0;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Opening ^a.", rtrim (queue.header.fetching.multics_path));
	call initiate_fetch ();
	return;
     end;

/* If the file_type is "ascii", then position to the next char after last LF */

     if ^queue.header.fetching.flags.binary_sw then do;
	call iox_$position (data_block.receive_iocb_ptr, -1, 0, code);
	call iox_$position (data_block.receive_iocb_ptr, 0,
	     queue.header.fetch_file_pos, code);
	if code ^= 0 then do;
	     queue.header.fetching.flags.initiated = "0"b;
	     queue.header.fetch_file_pos = 0;
	     call ws_$put_background_message (mcb_ptr, code, "bft",
		"Line positioning ^a.",
		rtrim (queue.header.fetching.multics_path));
	     call initiate_fetch ();
	     return;
	end;
     end;

/* Position the source file_pointer on the remote */

     message_len = 0;
     call add_token (message, message_len, rtrim (queue.header.fetching.pc_path));
     call add_token (message, message_len, convert (char128var, queue.header.fetch_file_pos));
     call add_token (message, message_len,
	bits_to_chars (4, unspec (queue.header.fetching.flags)));
     call execute_pc_bft (addr (message), message_len,
	bft_minor_$position_file_pointer, mcb_ptr, code);
     if code ^= 0 then
	return;

end recover_fetch;

/**/

/* *** Procedure: recover_store - Internal proc for bft_main_  *** */

recover_store:
     proc ();


/* PROCEDURE FUNCTION

The store (MULTICS_to_PC) queue is examined for an interrupted request.  If
one exists, then it is resumed by calling CHECK_FILE_LENGTH on PC:BFT to see
where it is to continue from.  If there is no interrupted reqest, then the
rest of the queue is attempted to be started through initiateing a store.
*/

/* NOTES

No arguments are required as all is automatic.
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl message_len	       fixed bin;		    /* Length of message */
dcl message	       char (128);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* If there is no current request (ie. interrupted) then initiate a new store */

     if ^queue.header.storing.initiated then do;
	call initiate_store ();
	return;
     end;

/* Otherwise, get the interrupted request back on track */

     message_len = 0;
     call add_token (message, message_len, rtrim (queue.header.storing.pc_path));
     call add_token (message, message_len,
	bits_to_chars (4, unspec (queue.header.storing.flags)));
     call execute_pc_bft (addr (message), message_len,
	bft_minor_$check_file_length, mcb_ptr, code);
     if code ^= 0 then
	return;

end recover_store;

/**/

/* *** Procedure: request_connect - Internal proc for bft_main_  *** */

request_connect:
     proc (p_sender);


/* PROCEDURE FUNCTION

An application is requesting connection to bft_main_, this is not to be
allowed so bft will respond with a REJECT code.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_sender	       fixed bin parameter;	    /* Sender of request */

/* MISC VARIABLES */
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call ws_$connect_response (REJECT, p_sender, mcb_ptr, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Responding to connect_request from ^d.", p_sender);
	return;
     end;

end request_connect;

/**/

/* *** Procedure: request_disconnect - Internal proc for bft_main_  *** */

request_disconnect:
     proc (p_sender);


/* PROCEDURE FUNCTION

This minor capability is not to be called under normal circumstances.  It will
return and error and terminate BFT if it is called.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_sender	       fixed bin parameter;	    /* Capability disconnecting */

/* MISC VARIABLES */
dcl code		       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call cleanup_iocb_switches ();

     call cleanup_pending_chain ();

     call ws_$disconnect_response (ACCEPT, p_sender, mcb_ptr, code);
     if code ^= 0 then do;
	call ws_$put_background_message (mcb_ptr, code, "bft",
	     "Disconnecting from ^d.", p_sender);
	return;
     end;

     call ws_$destroy_instance (mcb_ptr, (0));
     call cleanup_data_block ();

end request_disconnect;

/**/

/* *** Procedure: response_disconnect - Internal proc for bft_main_  *** */

response_disconnect:
     proc ();


/* PROCEDURE FUNCTION

This minor capability is not to be called under normal circumstances.  It will
return and error and terminate BFT if it is called.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     data_block.flags.shut_down_sw = "1"b;

     call cleanup_iocb_switches ();

     call ws_$destroy_instance (mcb_ptr, (0));

     call cleanup_data_block ();

end response_disconnect;

/**/

/* *** Procedure: send_data - Internal proc for bft_main_  *** */

send_data:
     proc ();


/* PROCEDURE FUNCTION

This minor capability reads from the file that is specified in the value
segment from the byte position that is also stored in the value segment.  It
updates the byte count, and then sends the data that it if any, to RECEIVE_DATA
on the remote machine.  If it reads the end of file, then it calls RECEIVE_EOF
on the remote machine.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */
dcl mu_entryname	       char (32);
dcl mu_dirname	       char (168);
dcl line_start	       fixed bin (21);	    /* Start position in search for LFs */
dcl line_len	       fixed bin (21);	    /* Determines lengths of lines */
dcl bytes_read	       fixed bin (21);	    /* Characters from file */
dcl inbuffer	       char (120) aligned;
dcl message	       char (128);		    /* Message */
dcl long_info	       char (100) aligned;
dcl code		       fixed bin (35);
dcl short_info	       char (8) aligned;

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Verify that this transfer has NOT been cancelled midestream */

     if ^queue.header.storing.flags.initiated then do;
	queue.header.store_file_pos = 0;
	call close_data_file (data_block.send_iocb_ptr);

	call expand_pathname_ (rtrim (queue.header.storing.multics_path),
	     mu_dirname, mu_entryname, code);
	message = "Store request " || rtrim (mu_entryname);
	message = rtrim (message)  || " cancelled in progress.";
	call execute_pc_bft (addr (message), length (rtrim (message)),
	     bft_minor_$read_error, mcb_ptr, (0));
	return;
     end;

/* Read up to the maximum number of bytes from the file*/

     call iox_$get_chars (data_block.send_iocb_ptr, addr (inbuffer),
	BFT_BLOCK_SIZE, bytes_read, code);

/* If it is the end of file, then call RECEIVE_EOF on the remote machine */

     if code = error_table_$end_of_info then do;
	call close_data_file (data_block.send_iocb_ptr);

	call execute_pc_bft (null, 0, bft_minor_$receive_eof, mcb_ptr, code);
	if code ^= 0 then
	     return;

	queue.header.storing.flags.initiated = "0"b;
	queue.header.store_file_pos = 0;

	call initiate_store ();
	return;
     end;

/* If some unknown error occurred then generate a read_error */

     if code ^= 0 & code ^= error_table_$short_record then do;
	queue.header.storing.flags.initiated = "0"b;
	queue.header.store_file_pos = 0;
	call close_data_file (data_block.send_iocb_ptr);

	call convert_status_code_ (code, short_info, long_info);
	message = rtrim (long_info) || "  Sending data.";
	call execute_pc_bft (addr (message), length (rtrim (message)),
	     bft_minor_$read_error, mcb_ptr, (0));
	return;
     end;

/* Update the byte / line count */

     if queue.header.storing.flags.binary_sw then
	queue.header.store_file_pos
	     = queue.header.store_file_pos + bytes_read;
     else do;
	line_len = index (substr (inbuffer, 1, bytes_read), byte (10));
	line_start = line_len + 1;
	do while (line_len > 0 & line_start <= bytes_read);
	     queue.header.store_file_pos = queue.header.store_file_pos + 1;
	     line_len = index (substr (inbuffer, line_start,
		bytes_read - line_start), byte (10));
	     line_start = line_start + line_len;
	end;
     end;

/* Put the data read into the arg_list and call RECEIVE_DATA on the remote  system*/

     call execute_pc_bft (addr (inbuffer), convert (fixedbin17, bytes_read),
	bft_minor_$receive_data, mcb_ptr, code);
     if code ^= 0 then
	return;

end send_data;

/**/

/* *** Procedure: strip_token - Internal proc for bft_main_  *** */

strip_token:
     proc (p_arg_data, p_token);


/* PROCEDURE FUNCTION

This is a utility routine designed to remove the first token in in a list that
is separated by a delimiter.  It returns the token, and the remainder of the
list with up to and including the first delimiter stripped off.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_data	       char (*) parameter;	    /* Data to extract from */
dcl p_token	       char (*) var parameter;    /* Token extracted */

/* MISC VARIABLES */
dcl delim_position	       fixed bin;		    /* length of token */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     delim_position = index (p_arg_data, DELIM_CHAR);
     if delim_position = 0 then
	delim_position = length (p_arg_data);

     p_token = substr (p_arg_data, 1, delim_position - 1);
     p_arg_data = substr (p_arg_data, delim_position + 1);

end strip_token;

/**/

/* *** Procedure: terminate_application - Internal proc for bft_main_  *** */

terminate_application:
     proc ();


/* PROCEDURE FUNCTION

Terminate BFT - ie. shutdown immediately.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     call bft_shut_down ();

end terminate_application;

/**/

/* *** Procedure: write_error - Internal proc for bft_main_  *** */

write_error:
     proc (p_arg_ptr, p_arg_len);


/* PROCEDURE FUNCTION

This procedure is called by the remote machine to signal an error occurred
while the remote machine was receiving a file.  The proper cleanup is done and
the queues are checked to see if there are any pending requests.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_arg_ptr	       ptr parameter;	    /* Message */
dcl p_arg_len	       fixed bin parameter;	    /* Message length */
dcl p_arg_data	       char (p_arg_len) based (p_arg_ptr);

/* MISC VARIABLES */
dcl error_string	       char (128) var;	    /* Error message sentr */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

/* Extract the error message from the arg_list */

     call strip_token (p_arg_data, error_string);
     call ws_$put_background_message (mcb_ptr, 0, "bft", error_string);

/* Remove the current store from the queue */

     queue.header.storing.flags.initiated = "0"b;
     queue.header.store_file_pos = 0;
     call close_data_file (data_block.send_iocb_ptr);

/* Try for another request from the store queue */

     call initiate_store ();

end write_error;

/**/

/* INCLUDE FILES */
%include star_structures;
%include access_mode_values;
%include iox_modes;
%include mowse;
%include bft_queue;
%include bft_values;

end;




		    bft_queue_.pl1                  02/24/88  0851.8rew 02/24/88  0845.0      257418



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

bft_queue_:
     proc (p_q_ptr, p_code);

/* format: style4,indattr,ifthen,^indcomtxt,thendo,^indproc,^indblkcom,^indprocbody,initcol1,declareind8,dclind4,struclvlind3,comcol55 */

/* PROGRAM FUNCTION

This is a collection of entrypoints which service the queues associated with
bft.  Entrypoints contained are:

   add
   initialize
   remove
   terminate

Calling bft_queue_ will return a pointer to the current queue.
*/


/* NOTES
*/

/****^  HISTORY COMMENTS:
  1) change(87-10-06,Flegel), approve(87-10-23,MCR7787),
     audit(88-01-27,RWaters), install(88-02-24,MR12.2-1028):
     Created.
                                                   END HISTORY COMMENTS */

/* PARAMETERS */
dcl p_header	       bit(1) parameter;	    /* Display header required */
dcl p_long_sw	       bit(1) parameter;	    /* Long display requested */
dcl p_state	       bit(1) parameter;	    /* Transfer activity state */
dcl p_id_sw	       fixed bin parameter;	    /* 0 = path, 1 = ID */
dcl p_id		       char (*) parameter;	    /* Entry ID */
dcl p_direction	       fixed bin parameter;	    /* Transfer direction */
dcl p_priority	       fixed bin parameter;	    /* Element priority level */
dcl p_e_ptr	       ptr parameter;	    /* Queue element pointer */
dcl p_q_ptr	       ptr parameter;	    /* Pointer to bft queues */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl time_string	       char (20) var;
dcl formatted_time	       char (250);
dcl time_stamp	       fixed bin (71);
dcl lock_sw	       bit(1);		    /* If the lock has been set */
dcl match_q	       fixed bin;
dcl first_slot	       fixed bin (35);
dcl match_prev_slot	       fixed bin (35);
dcl match_slot	       fixed bin (35);
dcl match_found	       (2) bit (1);
dcl prev_slot	       fixed bin (35);
dcl i		       fixed bin;
dcl mask		       bit (36) aligned;
dcl slot		       fixed bin (35);	    /* Array position of queue element */
dcl new_queue	       bit (1);		    /* Just created */

/* STRUCTURES */

/* SYSTEM CALLS */
dcl date_time_	        entry (fixed bin(71), char(*));
dcl request_id_	        entry (fixed bin(71)) returns(char(19));
dcl ioa_		       	entry() options(variable);
dcl match_request_id_      entry (fixed bin (71), char (*)) returns (bit (1) aligned);
dcl hcs_$reset_ips_mask    entry (bit (36) aligned, bit (36) aligned);
dcl hcs_$set_ips_mask      entry (bit (36) aligned, bit (36) aligned);
dcl set_lock_$unlock       entry (bit (36) aligned, fixed bin (35));
dcl set_lock_$lock	       entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl hcs_$truncate_seg      entry (ptr, fixed bin (19), fixed bin (35));
dcl initiate_file_	       entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl hcs_$make_seg	       entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl user_info_	       entry (char (*), char (*), char (*));
dcl user_info_$homedir     entry (char (*));

/* SYSTEM CALL SUPPORT */
dcl error_table_$noentry   fixed bin (35) ext static;
dcl error_table_$request_id_ambiguous fixed bin (35) ext static;
dcl error_table_$bad_conversion fixed bin (35) ext static;
dcl error_table_$noalloc   fixed bin (35) ext static;
dcl sys_info$max_seg_size  fixed bin (35) ext static;

/* EXTERNAL CALLS */

/* EXTERNAL CALL SUPPORT */
dcl bft_error_table_$store_in_progress 	fixed bin(35) ext static;
dcl bft_error_table_$fetch_in_progress 	fixed bin(35) ext static;
dcl bft_error_table_$invalid_direction fixed bin (35) ext static;
dcl bft_error_table_$no_entries fixed bin (35) ext static;
dcl bft_error_table_$invalid_queue fixed bin (35) ext static;
dcl bft_error_table_$invalid_priority fixed bin (35) ext static;
dcl bft_error_table_$no_queue fixed bin (35) ext static;

/* BUILTINS */
dcl reverse	       builtin;
dcl substr	       builtin;
dcl verify	       builtin;
dcl index		       builtin;
dcl unspec	       builtin;
dcl size		       builtin;
dcl addr		       builtin;
dcl null		       builtin;
dcl rtrim		       builtin;

/* CONDITIONS */
dcl cleanup	       condition;

/* CONSTANTS */

/**/

/* INITIALIZATION */

	p_q_ptr = null;
	lock_sw = "0"b;
	call initialize_entry ();
	on cleanup call set_lock_$unlock (queue.header.lockword, (0));

/* MAIN */

	p_q_ptr = null;
	new_queue = find_bft_queue ("0"b, p_code);
	if new_queue then
	     p_code = bft_error_table_$no_queue;

	p_q_ptr = queue_ptr;

	goto BFT_QUEUE_RETURN;

/**/

/* INTERNAL ENTRIES */


/* *** Entry: add - Internal entry for bft_queue_  *** */

add:
     entry (p_q_ptr, p_e_ptr, p_priority, p_direction, p_code);


/* ENTRY FUNCTION

Add the provided element to the bft queue.
*/

/* NOTES
*/

     lock_sw = "1"b;
     call initialize_entry ();
     on cleanup call set_lock_$unlock (queue.header.lockword, (0));

/* If element pointer is null, then ignore */

     if p_e_ptr = null then
	goto BFT_QUEUE_RETURN;

/* If queue pointer is null, then error */

     if queue_ptr = null then do;
	p_code = bft_error_table_$invalid_queue;
	goto BFT_QUEUE_RETURN;
     end;

/* If priority level is invalid, then error */

     if p_priority < BFT_MIN_PRIORITY | p_priority > BFT_MAX_PRIORITY then do;
	p_code = bft_error_table_$invalid_priority;
	goto BFT_QUEUE_RETURN;
     end;

/* If direction is invalid, then error */

     if p_direction ^= BFT_PC_to_MULTICS & p_direction ^= BFT_MULTICS_to_PC then do;
	p_code = bft_error_table_$invalid_direction;
	goto BFT_QUEUE_RETURN;
     end;

/* Find queue slot */

     call find_new_slot (slot, p_code);
     if p_code ^= 0 then
	goto BFT_QUEUE_RETURN;

/* Copy the element structure into the queue element */

     queue.array (slot) = p_e_ptr -> queue_element;
     queue.array (slot).flags.allocated = "1"b;
     queue.array (slot).next = 0;

/* Chain the new element into the appropriate queue */

     call hcs_$set_ips_mask (""b, mask);
     if p_direction = BFT_PC_to_MULTICS then do;
	if queue.header.fetch_queue (p_priority).last = 0 then
	     queue.header.fetch_queue (p_priority).first = slot;
	else
	     queue.array (queue.header.fetch_queue (p_priority).last).next = slot;
	queue.header.fetch_queue (p_priority).last = slot;
     end;
     else do;
	if queue.header.store_queue (p_priority).last = 0 then
	     queue.header.store_queue (p_priority).first = slot;
	else
	     queue.array (queue.header.store_queue (p_priority).last).next = slot;
	queue.header.store_queue (p_priority).last = slot;
     end;
     call hcs_$reset_ips_mask (mask, mask);

     goto BFT_QUEUE_RETURN;

/**/

/* *** Entry: cancel - Internal entry for bft_queue_  *** */

cancel:
     entry (p_q_ptr, p_id, p_id_sw, p_code);


/* ENTRY FUNCTION

Remove the specified entry from the transfer queue.  BFT will then not find the
entry and will not transfer the entry.  Entries which are currently in
transfer, ie.  the fetching or storing field of the queue header are initiated
and meet the cancellation specs, will merely have their "initiated" bit field
turned off.  It will then be up to the caller to check this bit field.

ID's are either:

	PATHNAME - absolute or relative, star NOT allowed
	ENTRY    - entryname of request.
	ID       - time stamp ID tagged to the entry.
*/

/* NOTES
*/

     p_code = 0;

     lock_sw = "1"b;
     call initialize_entry ();
     on cleanup call set_lock_$unlock (queue.header.lockword, (0));

     match_slot = 0;
     match_prev_slot = 0;

/* Verify the ID specifier */

     if p_id_sw = BFT_TIME_ID then do;
	if verify (rtrim (p_id), "+-.0123456789") ^= 0 then do;
	     p_code = error_table_$bad_conversion;
	     goto BFT_QUEUE_RETURN;
	end;
     end;

/* Check the "running" elements, these have priority */

     if queue.header.storing.flags.initiated then do;
	if match_request_type (addr (queue.header.storing), p_id, p_id_sw) then do;
	     queue.header.storing.flags.initiated = "0"b;
	     return;
	end;
     end;
     if queue.header.fetching.flags.initiated then do;
	if match_request_type (addr (queue.header.fetching), p_id, p_id_sw) then do;
	     queue.header.fetching.flags.initiated = "0"b;
	     return;
	end;
     end;

/* Hunt down the entry */

     match_found (*) = "0"b;

     do i = BFT_MIN_PRIORITY to BFT_MAX_PRIORITY;
	first_slot = queue.header.store_queue (i).first;
	do while (match_entry (first_slot, prev_slot, slot, rtrim (p_id), p_id_sw));
	     if ^match_found (1) & ^match_found (2) then do;
		match_found (1) = "1"b;
		match_slot = slot;
		match_prev_slot = prev_slot;
		match_q = i;
		first_slot = queue.array (slot).next;
	     end;
	     else do;
		p_code = error_table_$request_id_ambiguous;
		goto BFT_QUEUE_RETURN;
	     end;
	end;

	first_slot = queue.header.fetch_queue (i).first;
	do while (match_entry (first_slot, prev_slot, slot, rtrim (p_id), p_id_sw));
	     if ^match_found (1) & ^match_found (2) then do;
		match_found (2) = "1"b;
		match_slot = slot;
		match_prev_slot = prev_slot;
		match_q = i;
		first_slot = queue.array (slot).next;
	     end;
	     else do;
		p_code = error_table_$request_id_ambiguous;
		goto BFT_QUEUE_RETURN;
	     end;
	end;
     end;

/* If there was a single match, remove the entry */

     if match_found (1) then
	call remove_entry (queue.header.store_queue (match_q).first, queue.header.store_queue (match_q).last, match_prev_slot, match_slot);

     else if match_found (2) then
	call remove_entry (queue.header.fetch_queue (match_q).first, queue.header.fetch_queue (match_q).last, match_prev_slot, match_slot);

     else do;
	p_code = error_table_$noentry;
	goto BFT_QUEUE_RETURN;
     end;

     goto BFT_QUEUE_RETURN;

/**/

/* *** Entry: display_element - Internal entry for bft_queue_  *** */

display_element:
     entry (p_e_ptr, p_long_sw, p_direction, p_state, p_header);


/* ENTRY FUNCTION

Display a queue element.
*/

/* NOTES
*/

     time_stamp = p_e_ptr -> queue_element.time_id;

     if ^p_long_sw then do;
	if p_header then
	     call ioa_ ("Multics Path^30tDirection^40tPC Path^55tID");
	call ioa_ ("^a^33t^[->^;<-^]^[*^]^40t^a^55t^a^[ (running)^]",
	     strip_path (p_e_ptr -> queue_element.multics_path, ">"),
	     (p_direction = BFT_MULTICS_to_PC),
	     p_e_ptr -> queue_element.flags.binary_sw,
	     strip_path (p_e_ptr -> queue_element.pc_path, "\"),
	     substr (request_id_ (time_stamp), 7, 8),
	     p_state);
     end;
     else do;
	time_string = request_id_ (time_stamp);
	call date_time_ (time_stamp, formatted_time);
	call ioa_ (
	     "Source:^21t^[^a^s^;^s^a^]^/Destination:^21t^[^a^s^;^s^a^]"
	     || "^/Request ID:^21t^a^/Time queued:^21t^a"
	     || "^/State:^21t^[running^;unprocessed^]^/Notify:^21t^[yes^;no^]"
	     || "^/File type:^21t^[binary^;ascii^]",
	     (p_direction = BFT_PC_to_MULTICS),
	     p_e_ptr -> queue_element.pc_path,
	     p_e_ptr -> queue_element.multics_path,
	     (p_direction = BFT_PC_to_MULTICS),
	     p_e_ptr -> queue_element.multics_path,
	     p_e_ptr -> queue_element.pc_path,
	     time_string, rtrim (formatted_time),
	     p_state, p_e_ptr -> queue_element.flags.notify_sw,
	     p_e_ptr -> queue_element.flags.binary_sw);
     end;

     return;

/**/

/* *** Entry: initiate - Internal entry for bft_queue_  *** */

initiate:
     entry (p_q_ptr, p_code);


/* ENTRY FUNCTION

This entry will initiate the bft queue segment.  If the segment does not
already exist it will be created and formatted.
*/

/* NOTES
*/

     p_q_ptr = null;
     lock_sw = "0"b;
     call initialize_entry ();
     on cleanup call set_lock_$unlock (queue.header.lockword, (0));

/* Find the queue segment */

     new_queue = find_bft_queue ("1"b, p_code);
     if p_code ^= 0 then
	goto BFT_QUEUE_RETURN;

/* Initialize the header field */

     if new_queue then
	call initialize_queue_header ();

     p_q_ptr = queue_ptr;

     goto BFT_QUEUE_RETURN;

/**/

/* *** Entry: remove - Internal entry for bft_queue_  *** */

remove:
     entry (p_q_ptr, p_direction, p_code);


/* ENTRY FUNCTION

Move the next element from the specified queue (PC -> Multics or
Multics -> PC) to the appropriate "in progress" element in the header.  The
highest priority (1,2,3,4) is removed from the queue.
*/

/* NOTES
*/

     lock_sw = "1"b;
     call initialize_entry ();
     on cleanup call set_lock_$unlock (queue.header.lockword, (0));

/* If the queue ptr is null, then error */

     if queue_ptr = null then do;
	p_code = bft_error_table_$invalid_queue;
	goto BFT_QUEUE_RETURN;
     end;

/* If the transfer in the specified direction is not complete, then error
 * Might as well verify the direction at the same time
 */
     if p_direction = BFT_PC_to_MULTICS then do;
	if queue.header.fetching.flags.initiated then do;
	     p_code = bft_error_table_$fetch_in_progress;
	     goto BFT_QUEUE_RETURN;
	end;
     end;
     else if p_direction = BFT_MULTICS_to_PC then do;
	if queue.header.storing.flags.initiated then do;
	     p_code = bft_error_table_$store_in_progress;
	     goto BFT_QUEUE_RETURN;
	end;
     end;
     else do;
	p_code = bft_error_table_$invalid_direction;
	goto BFT_QUEUE_RETURN;
     end;
		
/* Find the next element slot */

     call find_old_slot (p_direction, slot, p_code);
     if p_code ^= 0 | slot = 0 then do;
	if p_code = 0 then
	     p_code = bft_error_table_$no_entries;
	goto BFT_QUEUE_RETURN;
     end;

/* Move the element out the callers structure */

     queue.array (slot).flags.initiated = "1"b;
     if p_direction = BFT_PC_to_MULTICS then do;
	queue.header.fetch_file_pos = 0;
	queue.header.fetching = queue.array (slot);
     end;
     else do;
	queue.header.store_file_pos = 0;
	queue.header.storing = queue.array (slot);
     end;

     call free_old_slot (slot, p_code);
     if p_code ^= 0 then
	goto BFT_QUEUE_RETURN;

     goto BFT_QUEUE_RETURN;

/**/

/* GLOBAL LABEL ENTRY */

/* *** Label: BFT_QUEUE_RETURN - Internal label for bft_queue_ *** */

/* LABEL FUNCTION

This label is to be used to return from the bft_queue_ entry points to the
caller of that entry.  It serves to unlock the lockword that exists within
the queue segment.
*/

BFT_QUEUE_RETURN:

     if lock_sw then
	call set_lock_$unlock (queue.header.lockword, (0));

     return;

/**/

/* INTERNAL PROCEDURES */


/* *** Procedure: allocate_slot - Internal proc for bft_queue_  *** */

allocate_slot:
     proc (p_code);


/* PROCEDURE FUNCTION

Allocate another element slot at the end of the segment.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl mask		       bit(36) aligned;
dcl new_slot	       fixed bin (35);

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

     if size (queue) + size (queue_element) > sys_info$max_seg_size then do;
	p_code = error_table_$noalloc;
	return;
     end;

/* Increase the queue size */

     new_slot = queue.header.segment_size + 1;
     call initialize_element (addr (queue.array (new_slot)));

     call hcs_$set_ips_mask (""b, mask);
     queue.array (new_slot).next = queue.header.free_list;
     queue.header.free_list = new_slot;
     queue.header.segment_size = new_slot;
     call hcs_$reset_ips_mask (mask, mask);

     end allocate_slot;

/**/

/* *** Procedure: find_bft_queue - Internal proc for bft_queue_  *** */

find_bft_queue:
     proc (p_create_sw, p_code) returns (bit (1));


/* PROCEDURE FUNCTION

Get a pointer to the bft queue segment.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_create_sw	       bit (1) parameter;	    /* True if to be created */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl code		       fixed bin (35);
dcl name		       char (168);		    /* Queue segment name */
dcl home_path	       char (64);		    /* Home directory */
dcl account_id	       char (32);
dcl project_id	       char (9);
dcl person_id	       char (22);

/* STRUCTURES */

/* INITIALIZATION */

     p_code = 0;

/* MAIN */

     call user_info_$homedir (home_path);
     call user_info_ (person_id, project_id, account_id);
     name = rtrim (person_id) || ".bft";

/* If the segment is to be created, create it if it doesn't exist. */

     if p_create_sw then do;
	call hcs_$make_seg (home_path, name, "", RW_ACCESS_BIN, queue_ptr,
	     code);
	return ((code = 0));
     end;

/* Else do not attempt to create the queue, just look for it */

     else do;
	call initiate_file_ (home_path, name, unspec (RW_ACCESS_BIN),
	     queue_ptr, (0), code);
	return ((code ^= 0));
     end;

     end find_bft_queue;

/**/

/* *** Procedure: find_old_slot - Internal proc for bft_queue_  *** */

find_old_slot:
     proc (p_direction, p_slot, p_code);


/* PROCEDURE FUNCTION

Find the next element of highest priority in the specified direction.
*/

/* NOTES

The entry is removed from the specified queue but is not released to the free
list.
*/

/* PARAMETERS */
dcl p_direction	       fixed bin parameter;	    /* Direction of element */
dcl p_slot	       fixed bin (35) parameter;  /* Found slot */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl mask		       bit(36) aligned;
dcl i		       fixed bin;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;
     p_slot = 0;

/* MAIN */

     do i = 1 to 4;
	if p_direction = BFT_PC_to_MULTICS then do;
	     if queue.header.fetch_queue (i).first ^= 0 then do;
		call hcs_$set_ips_mask (""b, mask);
		p_slot = queue.header.fetch_queue (i).first;
		queue.header.fetch_queue (i).first = queue.array (p_slot).next;
		if queue.header.fetch_queue (i).first = 0 then
		     queue.header.fetch_queue (i).last = 0;
		call hcs_$reset_ips_mask (mask, mask);

		return;
	     end;
	end;
	else do;
	     if queue.header.store_queue (i).first ^= 0 then do;
		call hcs_$set_ips_mask (""b, mask);
		p_slot = queue.header.store_queue (i).first;
		queue.header.store_queue (i).first = queue.array (p_slot).next;
		if queue.header.store_queue (i).first = 0 then
		     queue.header.store_queue (i).last = 0;
		call hcs_$reset_ips_mask (mask, mask);

		return;
	     end;
	end;
     end;

/* Element was not found, so it's an error */

     p_code = bft_error_table_$no_entries;

     end find_old_slot;

/**/

/* *** Procedure: find_new_slot - Internal proc for bft_queue_  *** */

find_new_slot:
     proc (p_slot, p_code);


/* PROCEDURE FUNCTION

Find an empty position in the queue element array 
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_slot	       fixed bin (35) parameter;  /* Found slot in array */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl mask		       bit(36) aligned;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;
     p_slot = 0;

/* MAIN */

     if queue.header.free_list = 0 then do;
	call allocate_slot (p_code);
	if p_code ^= 0 then
	     return;
     end;

     call hcs_$set_ips_mask (""b, mask);
     p_slot = queue.header.free_list;
     queue.header.free_list = queue.array (queue.header.free_list).next;
     queue.array (p_slot).next = 0;
     call hcs_$reset_ips_mask (mask, mask);

     end find_new_slot;

/**/

/* *** Procedure: free_old_slot - Internal proc for bft_queue_  *** */

free_old_slot:
     proc (p_slot, p_code);


/* PROCEDURE FUNCTION

Place the specified slot into the free list.  Check if a page of the queue
segment can be released.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_slot	       fixed bin (35) parameter;  /* Slot to be freed */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl mask		       bit(36) aligned;

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

/* Add the element to the free list */

     call initialize_element (addr (queue.array (p_slot)));
     call hcs_$set_ips_mask (""b, mask);
     queue.array (p_slot).next = queue.header.free_list;
     queue.header.free_list = p_slot;
     call hcs_$reset_ips_mask (mask, mask);

/* If the element is the last element in the segment, shrink the segment */

     if p_slot = queue.header.segment_size then do;
	call free_seg (p_code);
	if p_code ^= 0 then
	     return;
     end;

     end free_old_slot;

/**/

/* *** Procedure: free_seg - Internal proc for bft_queue_  *** */

free_seg:
     proc (p_code);


/* PROCEDURE FUNCTION

Reduce the segment size of the queue, truncate the segment to the nearest page.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_code	       fixed bin (35) parameter;  /* Error code */

/* MISC VARIABLES */
dcl mask		       bit(36) aligned;
dcl word_count	       fixed bin (19);	    /* New segment length */
dcl previous_slot	       fixed bin (35);	    /* Slot before current search */
dcl free_slot	       fixed bin (35);	    /* Slot to free */
dcl slot		       fixed bin (35);	    /* Index slot */
dcl last_alloc	       fixed bin (35);	    /* Last allocated element */
dcl total_free	       fixed bin (35);	    /* Elements to free */

/* STRUCTURES */

/* INITIALIZATION */
     p_code = 0;

/* MAIN */

/* Find last NON-allocated element */

     total_free = 0;
     last_alloc = queue.header.segment_size;
     do while (^queue.array (last_alloc).flags.allocated & last_alloc > 0);
	total_free = total_free + 1;
	last_alloc = last_alloc - 1;
     end;

/* Remove the slots to be released from the free list */

     previous_slot = 0;
     slot = queue.header.free_list;
     do while (slot ^= 0);
	if slot > last_alloc then do;
	     call hcs_$set_ips_mask (""b, mask);
	     free_slot = slot;
	     if previous_slot = 0 then do;	    /* First in list */
		slot = queue.array (free_slot).next;
		queue.header.free_list = slot;
	     end;
	     else do;			    /* Middle of list */
		queue.array (previous_slot).next = queue.array (free_slot).next;
		previous_slot = slot;
		slot = queue.array (slot).next;
	     end;
	     call hcs_$reset_ips_mask (mask, mask);

	     call initialize_element (addr (queue.array (free_slot)));
	end;
	else do;
	     previous_slot = slot;
	     slot = queue.array (slot).next;
	end;

	queue.header.segment_size = last_alloc;
	word_count = size (queue_header) + (last_alloc * size (queue_element));
	call hcs_$truncate_seg (queue_ptr, word_count, p_code);
	if p_code ^= 0 then
	     return;
     end;

     end free_seg;

/**/

/* *** Procedure: initialize_element - Internal proc for bft_queue_  *** */

initialize_element:
     proc (p_e_ptr);


/* PROCEDURE FUNCTION

Initialize the element structure.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_e_ptr	       ptr parameter;	    /* Element to be initialized */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     p_e_ptr -> queue_element.next = 0;
     p_e_ptr -> queue_element.multics_path = "";
     p_e_ptr -> queue_element.pc_path = "";
     p_e_ptr -> queue_element.time_id = 0;
     p_e_ptr -> queue_element.flags.allocated = "0"b;
     p_e_ptr -> queue_element.flags.binary_sw = "0"b;
     p_e_ptr -> queue_element.flags.pad = ""b;
     p_e_ptr -> queue_element.flags.mbz = ""b;

     end initialize_element;

/**/

/* *** Procedure: initialize_entry - Internal proc for bft_queue_  *** */

initialize_entry:
     proc ();


/* PROCEDURE FUNCTION

Initialize entrypoint variables.
*/

/* MAIN */

     p_code = 0;
     queue_ptr = p_q_ptr;

/* Lock out other accesses to the queue segment */

     if lock_sw then
	call set_lock_$lock (queue.header.lockword, BFT_QUEUE_WAIT_TIME, p_code);

     end initialize_entry;

/**/

/* *** Procedure: initialize_queue_header - Internal proc for bft_queue_  *** */

initialize_queue_header:
     proc ();


/* PROCEDURE FUNCTION

Initialize the fields of the queue header to casue the queue to have 0
elements.
*/

/* NOTES
*/

/* PARAMETERS */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     queue.header.version = "VERSION1";
     queue.header.lockword = ""b;
     queue.header.store_queue (*).last = 0;
     queue.header.store_queue (*).first = 0;
     queue.header.store_queue (*).flags.pad = "0"b;
     queue.header.fetch_queue (*).last = 0;
     queue.header.fetch_queue (*).first = 0;
     queue.header.fetch_queue (*).flags.pad = "0"b;
     queue.header.storing.flags.initiated = "0"b;
     queue.header.store_file_pos = 0;
     queue.header.fetching.flags.initiated = "0"b;
     queue.header.fetch_file_pos = 0;
     queue.header.free_list = 0;
     queue.header.segment_size = 0;

     end initialize_queue_header;

/**/

/* *** Procedure: match_entry - Internal proc for bft_queue_  *** */

match_entry:
     proc (p_start_slot, p_prev_slot, p_slot, p_id, p_id_sw) returns (bit (1));


/* PROCEDURE FUNCTION

Find a match in the chain specified by start_slot.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_id_sw	       fixed bin parameter;	    /* A time ID */
dcl p_id		       char (*) parameter;	    /* Match ID */
dcl p_start_slot	       fixed bin (35) parameter;  /* Start of queue list */
dcl p_prev_slot	       fixed bin (35) parameter;  /* Previous slot to matched entry */
dcl p_slot	       fixed bin (35) parameter;  /* Slot matched */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */
     p_prev_slot = 0;
     p_slot = p_start_slot;
     do while (p_slot ^= 0);
	if match_request_type (addr (queue.array (p_slot)), p_id, p_id_sw) then
	     return ("1"b);

	p_prev_slot = p_slot;
	p_slot = queue.array (p_prev_slot).next;
     end;

     return ("0"b);

     end match_entry;

/**/

/* *** Procedure: match_request_type - Internal proc for bft_queue_  *** */

match_request_type:
     proc (p_e_ptr, p_id, p_id_sw) returns (bit(1));


/* PROCEDURE FUNCTION

Verify the element passed against the ID and ID type provided.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_e_ptr	       ptr parameter;	    /* Element to match */
dcl p_id		       char (*) parameter;	    /* Match ID */
dcl p_id_sw	       fixed bin parameter;	    /* Type of id */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if p_id_sw = BFT_TIME_ID then do;
	if match_request_id_ (p_e_ptr -> queue_element.time_id, p_id) then
	     return ("1"b);
     end;

     else if p_id_sw = BFT_PATH_ID then do;
	if rtrim (p_id) = rtrim (p_e_ptr -> queue_element.multics_path)
	     | rtrim (p_id) = rtrim (p_e_ptr -> queue_element.pc_path)
	then
	     return ("1"b);
     end;

     else do;
	if rtrim (p_id) = strip_path (rtrim (p_e_ptr -> queue_element.multics_path), ">") then
	     return ("1"b);

	if rtrim (p_id) = strip_path (rtrim (p_e_ptr -> queue_element.pc_path), "\") then
	     return ("1"b);
     end;

     return ("0"b);

end match_request_type;

/**/

/* *** Procedure: remove_entry - Internal proc for bft_queue_  *** */

remove_entry:
     proc (p_start_slot, p_last_slot, p_prev_slot, p_slot);


/* PROCEDURE FUNCTION

Remove slot from the queue.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_last_slot	       fixed bin (35) parameter;  /* Last entry in list */
dcl p_start_slot	       fixed bin (35) parameter;  /* Start of list */
dcl p_prev_slot	       fixed bin (35) parameter;  /* Predecessor to slot */
dcl p_slot	       fixed bin (35) parameter;  /* Slot to be removed */

/* MISC VARIABLES */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     if queue.array (p_slot).next = 0 then
	p_last_slot = p_prev_slot;

     if p_prev_slot = 0 then
	p_start_slot = queue.array (p_slot).next;
     else
	queue.array (p_prev_slot).next = queue.array (p_slot).next;

     call free_old_slot (p_slot, (0));

     end remove_entry;

/**/

/* *** Procedure: strip_path - Internal proc for bft_queue_  *** */

strip_path:
     proc (p_path, p_separator) returns (char (*));


/* PROCEDURE FUNCTION

Strip of the entryname from the given path, given the directory spearator.
*/

/* NOTES
*/

/* PARAMETERS */
dcl p_path	       char (*) parameter;	    /* Path to be stripped */
dcl p_separator	       char (1) parameter;	    /* Directory separator */

/* MISC VARIABLES */
dcl indx		       fixed bin (21);	    /* Revers entry index */

/* STRUCTURES */

/* INITIALIZATION */

/* MAIN */

     indx = index (reverse (rtrim (p_path)), p_separator) - 1;
     if indx < 0 then
	return (p_path);

     return (reverse (substr (reverse (rtrim (p_path)), 1, indx)));

end strip_path;

/**/

/* INCLUDE FILES */
%include bft_values;
%include access_mode_values;
%include bft_queue;

     end;





		    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
