



		    gcos_big_tape_blocks_.pl1       12/11/84  1355.9rew 12/10/84  1041.6       13842



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

/* Subroutine that reports whether the caller can use "big"
   tape blocks.

   Author: Dave Ward	04/22/81
*/
	call use_big_tape_blocks_ (code);
	if code = 0 then return ("0"b);
	if code = error_table_$big_ws_req then do;	/* Does not have access. */
	     call com_err_ (
		code
		, "gcos_big_tape_blocks_"
		, "^/Caller can not use big tape blocks."
		||"^/Contact personnel from SysMaint."
		||"^/Need read and ^[execute^;write^] on ^a>^a,"
		||"^/or read and ^[execute^;write^] on ^a>^a."
		, nex (1), dir (1), ent (1)
		, nex (2), dir (2), ent (2)
		);
	     return ("1"b);
	end;
	call com_err_ (
	     code
	     , "gcos_big_tape_blocks_"
	     , "^/UNEXPECTED ERROR, could not get mode for caller, contact SysMaint."
	     );
	return ("1"b);
%page;
/*   Variables for gcos_big_tape_blocks_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  error_table_$big_ws_req  fixed bin(35) ext static;
dcl  ioa_                     entry() options(variable);
dcl  use_big_tape_blocks_     entry (fixed bin(35));
%page;
%include use_big_tape_blocks;
     end gcos_big_tape_blocks_;




		    gcos_fms.pl1                    12/11/84  1355.9rew 12/10/84  1021.5      167283



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_fms: gfms: proc;

/* Display information, excluding data files, from a
   gcos user or master save tape.

   Author: Dave Ward	09/30/80
   Change: Dave Ward	10/04/80	arguments.
   Change: Dave Ward	10/15/80	-den, -gf, -tr, -tll.
   Change: Dave Ward	10/19/80	-file, -no_file and -input_file
   Change: Dave Ward	10/27/80	added -scan_ss option.
   Change: Dave Ward	11/25/80	revised control arguments.
   Change: Dave Ward	01/27/81	provide gfms_return condition.
   Change: Dave Ward	02/02/81	print_calling_sequence_
   Change: Dave Ward	04/22/81	print big tape blocks not available.
   Change: Scott C. Akers	02/08/82	Add -spn, -drm, -rest control_args.
				Convert all names to gfms_<name>.
   Change: Ron Barstad  83-04-05  Make usage message standard, dcl builtins, delete unused dcls
   Change: Ron Barstad  83-06-03  Add -den spec to attach description
   Change: Ron Barstad  84-11-16  Forced tape reel number to upper case
*/
	call cu_$af_return_arg (			/* Obtain reference to caller's input arguments. */
	     na					/* (output) number of arguments. */
	     , rsp				/* (output) pointer to return argument. */
	     , rsl				/* (output) length of return argument. */
	     , code				/* (output) status. */
	     );
	if code = 0 then do;			/* 1) Called as an active function. */
	     get_arg = cu_$af_arg_ptr;		/* Use active function argument getter. */
	     put_err = active_fnc_err_;
	end;
	else
	rsp = addr (rsx);				/* Default return string. */
	rsl = 5;					/* Default length. */
	if code = error_table_$not_act_fnc then do;	/* 2) Not called as active function. */
	     get_arg = cu_$arg_ptr;			/* Use "normal" argument getter. */
	     put_err = com_err_;
	end;
	else do;
	     call com_err_ (			/* 3) Could not obtain args. */
		code
		, "gcos_fms"
		, "^/Could not obtain argument information. Quitting."
		);
	     return;
	end;

	if gcos_big_tape_blocks_ () then do;
	     rs = "false";
	     return;
	end;

	if na<1 then do;
wrong_number_args: ;
	     call put_err (				/* Wrong number arguments. */
		error_table_$noarg
		, "gcos_fms ("||version||")"
		, "^/Usage:^-gfms REEL_NUMBER {-CONTROL_ARGS}"
		);

/* DON'T Print in error output cryptic form of calling sequence. (following is kept as a comment
	     call gfms_calling_sequence_ (
		"arg:"
		, "  -den n|Tape density is n (default dynamic)."
		, "  -dump|Exhaustive display of tape info."
		, "  -file name...|Accept only files named (default is all files)."
		, "  -if file|File names in segment (with suffix .gfms)."
		||" One name per line, may be prefixed with ^ for not."
		, "  -no_ga|Do not supply gtss file attributes (default is to supply)."
		, "  -no_tll|Don't print total llinks (default is to print)."
		, "  -no_unload|Do not unload files (default is to unload)."
		, "  -not_file name...|Accept no file named."
		, "  -prfn|Print sorted list of file names (default is not)."
		, "  -scan_ss|Only print substructure records (default is not)."
		, "  -tk n|Tape is n track (default is 9)."
		, "  -restore UMC_NAME|Restore only UMC specified."
		, "  -rest UMC_NAME|Same as -restore."
		, "  -smc_pathname path|Specify where to do the restore. (Default is working_dir.)"
		, "  -spn path|Same as -smc_pathname."
		, "  -directory_mapping DRM_RULE|Specify whether to place files in working_dir,"
		||" >udd>UMC_NAME, or SMC pathname. (Default is ""wd"")"
		, "  -drm DRM_RULE|Same as -directory_mapping."
		); 
*/
	     return;
	end;

	call init_routine;

/* Obtain temp segments for description tree, file names lists. */

	call get_temp_segments_ (
	     "gfms"
	     , tsp
	     , code
	     );
	if code ^= 0 then do;
	     call put_err (
		code
		, "gfms"
		, "Obtaining 3 temp segments."
		);
	     return;
	end;

/* Process caller's arguments. */
	do i = 1 to na;
	     call get_arg (i, ap, al, code);		/* Obtain the next argument (arg). */
	     if code ^= 0 then do;
		call put_err (
		     code
		     , "gfms"
		     , "Argument ^i."
		     , i
		     );
		goto error_exit;
	     end;

	     if al<1 then do;			/* Argument is zero length string. */
		call put_err (
		     error_table_$smallarg
		     , "gfms"
		     , "Argument ^i zero length. Quitting."
		     , i
		     );
		goto error_exit;
	     end;

	     if substr (arg, 1, 1) = "-" then do;	/* Control argument. */
		if last_was_file & (file_name_count = 0) then do;
		     call put_err (
			0
			, "gfms"
			, "File name control argument not followed by file name."
			);
		     goto error_exit;
		end;
		last_was_file = "0"b;
		file_name_count = -1;

		l = hbound (control_arg, 1);
		do f = 1 to l;			/* Search for control arg name. */
		     if substr (arg, 2) = control_arg (f).name then do;
			last_was_file = "0"b;
			goto carg (control_arg (f).val);
		     end;
		end;
		call put_err (			/* Unknown control arg. */
		     error_table_$badopt
		     , "gfms"
		     , "Arg ^i ""^a"". Quitting."
		     , i
		     , arg
		     );
		goto error_exit;
	     end;

	     if file_name_count >= 0 then do;
		file_name_count = file_name_count+1;
		if gfms_file_name_ (not_file, arg) then arg_err = "1"b;
		goto next_arg;
	     end;

	     if need_input_file then do;
		need_input_file = "0"b;
		if gfms_input_file_list_ (arg) then arg_err = "1"b;
		goto next_arg;
	     end;

	     if need_track then do;
		need_track = "0"b;
		if arg = "7" then tape_track = "7";
		else
		if arg = "9" then tape_track = "9";
		else do;
		     call put_err (
			0
			, "gfms"
			, "Only 7 or 9 track provided for. Quitting."
			);
		     goto error_exit;
		end;
		goto next_arg;
	     end;

	     if need_density then do;
		need_density = "0"b;
		do k = lbound (tape_densities, 1) to hbound (tape_densities, 1);
		     if arg = tape_densities (k) then do;
			ftd, ltd = k;		/* Use density table entry k. */
			den_arg = arg;
			goto next_arg;
		     end;
		end;
		call put_err (
		     error_table_$bad_density
		     , "gfms"
		     , "Only densities ^a provided for. Quitting."
		     , string (tape_densities)
		     );
		goto error_exit;
	     end;

	     if   need_umc_name
	     then do;
		need_umc_name = "0"b;
		gfms_ext$umc_name = arg;
		goto next_arg;
		end;

	     if   need_mapping_rule
	     then do;
		need_mapping_rule = "0"b;
		if   arg = "wd"
		   | arg = "smc"
		   | arg = "umc"
		then do;
		     gfms_ext$mapping_rule = arg;

		     if   arg = "smc"
		        & ^got_smc_path
		     then need_smc_path = "1"b;

		     if   arg = "umc"
		     then gfms_ext$working_dir = ">udd";

		     if   arg = "wd"
		     then gfms_ext$working_dir = rtrim (get_wdir_ ());

		     goto next_arg;
		     end;

		else do;

		     call put_err  (error_table_$badopt,
				"gfms",
				"^/Mapping Rules are:^-WD^-SMC^-UMC");

		     goto error_exit;
		     end;
		end;

	     if   need_smc_path
	     then do;
		need_smc_path = "0"b;
		call expand_pathname_ ((arg), dname, ename, code);

		if   code = 0
		then do;
		     gfms_ext$working_dir = rtrim (dname) || ">" || ename;
		     goto next_arg;
		     end;
		else do;
		     call put_err  (code, "gfms",
				"^/Illegal SMC pathname: ^/^a", arg);
		     goto error_exit;
		     end;
		end;

/* Tape reel number. */
	     reel_number = translate(arg,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz");
	     goto next_arg;
%page;
carg (01):     ;

/* density */
	     need_density = "1"b;
	     goto next_arg;

carg (02):     ;

/* "dump" */
	     dump = "1"b;				/* Do dump tape information. */
	     gfms_ext$print_routines.ioa = ioa_;
	     gfms_ext$print_routines.ioa_nnl = ioa_$nnl;
	     goto next_arg;

carg (03):     ;

/* "file" */
	     file_name_count = 0;			/* 0 => obtain names. */
	     not_file = "0"b;
	     last_was_file = "1"b;
	     goto next_arg;

carg (04):     ;

/* "input_file" */
	     need_input_file = "1"b;
	     goto next_arg;

carg (05):     ;

/* not gtss file attributes. */
	     gf = "0"b;
	     goto next_arg;

carg (06):     ;

/* no total llinks. */
	     tll = "0"b;
	     goto next_arg;

carg (07):     ;

/* "no_unload" */
	     unload = "0"b;
	     goto next_arg;

carg (08):     ;

/* not_file. */
	     file_name_count = 0;			/* 0 => obtain names. */
	     not_file = "1"b;
	     last_was_file = "1"b;
	     goto next_arg;

carg (09):     ;

/* "pr_file_names" */
	     prfn = "1"b;
	     goto next_arg;

carg (10):     ;
	     scan_ss = "1"b;
	     goto next_arg;

carg (11):     ;

/* track n */
	     need_track = "1"b;
	     goto next_arg;

carg (12):     ;

/* smc smc_path */
	     need_smc_path = "1"b;
	     goto next_arg;

carg (13):     ;

/* drm mapping_rule */
	     need_mapping_rule = "1"b;
	     goto next_arg;

carg (14):     ;

/* restore umc*/
	     need_umc_name = "1"b;
	     goto next_arg;

not_provided:  ;
	     call ioa_ ("Control arg ""^a"" ^i not yet provided."
		, control_arg (f).name
		, i
		);
	     goto next_arg;

next_arg:	     ;
	end;

	if (number_names>0) & dump then
	     call gfms_dump_do_files_;

	if   leftovers ()				/* If any args are left hanging */
	  | arg_err
	then do;
error_exit:    ;
	     call release_temp_segs;
	     rs = "false";
	     return;
	     end;
%page;
/* Store the attach description. */
	attach_description =
	     "tape_nstd_ "				/* name of I/O module. */
	     ||rtrim(reel_number)
	     ||" -bk 15624"			/* => up to 3906 words (file content records largest). */
	     ||" -tk "||tape_track
	     ;
	if den_arg ^= ""
	     then attach_description = rtrim(attach_description)||" -den "||rtrim(den_arg);


/* Establish "on" conditions. */
	on cond (gfms_fail) begin;
	     call put_err (
		0
		, "gfms"
		, "FAILED."
		);
	     call clean_up;
	     goto exit;
	end;

	on cond (cleanup) call clean_up;

	on cond (gfms_return) goto exit;

/* Process the tape. */
	string (tape_reel_information) = "";
	call gfms_header_label_ ();			/* display tape label. */
	call gfms_serial_number_record_ ();		/* display tape serial number record. */
	call gfms_task_block_record_ (master_save);	/* display tape block record (tbr). */
	if master_save then
	     call gfms_smc_records_ ();
	call gfms_substructure_records_ ();
	call gfms_file_content_records_ ();

/* Close and detach the tape. */
	call clean_up;

exit:	;
	return;
%page;
clean_up:	proc;
	     call release_temp_segs;

/* Perform close and detach (cleanup condition)
   activities.
*/
	     if gfms_close_ () then return;
	     call gfms_detach_;
	     return;
	end clean_up;
%page;
init_routine: proc;

/* Performs all the initialization. */


/* Set default options. */
	arg_err = "0"b;				/* No argument errors yet. */
	tape_track = "9";
	close, detach = "0"b;			/* Don't close or detach. */
	gf = "1"b;				/* provide gtss file attributes. */
	tll = "1"b;				/* print file total llinks. */
	dump = "0"b;				/* Do not dump tape information. */
	prfn = "0"b;				/* Don't print file names. */
	unload = "1"b;				/* Do unload files. */
	ftd = lbound (tape_densities, 1);
	ltd = hbound (tape_densities, 1);		/* upper bound of tape densities table. */
	two_words = "0"b;
	nlp = addr (two_words);
	gfms_ext$print_routines.ioa = null_proc;
	gfms_ext$print_routines.ioa_nnl = null_proc;
	gfms_ext$working_dir = rtrim (get_wdir_ ());
	gfms_ext$mapping_rule = "wd";
	gfms_ext$umc_name = "";

	last_was_file
	     , got_smc_path
	     , need_density
	     , need_input_file
	     , need_mapping_rule
	     , need_smc_path
	     , need_track
	     , need_umc_name
	     , scan_ss
	     = "0"b;
	file_name_count = -1;			/* -1 => no file name needed. */
	reel_number = "";
	den_arg = "";

	return;

end init_routine;
%page;
leftovers: proc () returns (bit(1));

	if reel_number = ""
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "Tape reel number has not been supplied."
		);
	     return ("1"b);
	     end;

	if need_input_file
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "-input_file control argument not followed by input file name."
		);
	     return ("1"b);
	     end;

	if need_density
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "-density control argument not followed by density value."
		);
	     return ("1"b);
	     end;

	if need_track
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "-track control argument not followed by track value."
		);
	     return ("1"b);
	     end;

	if file_name_count = 0
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "-file control argument not followed by file names."
		);
	     return ("1"b);
	     end;

	if need_mapping_rule
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "Mapping rule not given."
		|| "^/Mapping Rules are:^-WD^-SMC^-UMC"
		);
	     return ("1"b);
	     end;

	if need_umc_name
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "UMC name not given."
		);
	     return ("1"b);
	     end;

	if need_smc_path
	then do;
	     call put_err (
		error_table_$noarg
		, "gfms"
		, "SMC pathname not given."
		);
	     return ("1"b);
	     end;

	return ("0"b);				/* All is well so far. */

end leftovers;
%page;
release_temp_segs: proc;

/* Release temp segment for description tree. */
	     call release_temp_segments_ (
		"gfms"
		, tsp
		, code
		);
	     if code ^= 0 then
		call put_err (
		code
		, "gfms"
		, "Releasing 3 temp segments."
		);
	     return;
	end release_temp_segs;

null_proc: proc;return;end;				/* Procedure that does nothing. */


%page;
/*   Variables for gcos_fms:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  active_fnc_err_          entry() options(variable);
dcl  addr                     builtin;
dcl  al                       fixed bin;
dcl  ap                       ptr;
dcl  arg                      char(al)unal based(ap);
dcl  arg_err                  bit(1);
dcl  cleanup                  condition ext;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  cu_$af_arg_ptr           entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$af_return_arg        entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$arg_ptr              entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  den_arg                  char (8);
dcl  dname		char (168);
dcl  ename		char (32);
dcl  error_table_$badopt      fixed bin(35) ext static;
dcl  error_table_$bad_density fixed bin(35) ext static;
dcl  error_table_$noarg       fixed bin(35) ext static;
dcl  error_table_$not_act_fnc fixed bin(35) ext static;
dcl  error_table_$smallarg    fixed bin(35) ext static;
dcl  expand_pathname_	entry (char(*), char(*), char(*), fixed bin(35));
dcl  f                        fixed bin;
dcl  file_name_count          fixed bin;
dcl  gcos_big_tape_blocks_    entry() returns(bit(1));
dcl  get_arg                  entry(fixed bin,ptr,fixed bin,fixed bin(35)) variable auto;
dcl  get_temp_segments_       entry (char(*), (*)ptr, fixed bin(35));
dcl  gfms_close_              entry() returns(bit(1));
dcl  gfms_detach_             entry options(variable);
dcl  gfms_dump_do_files_      entry;
dcl  gfms_fail                condition ext;
dcl  gfms_file_content_records_ entry();
dcl  gfms_file_name_          entry (bit(1), char(*)) returns(bit(1));
dcl  gfms_header_label_       entry();
dcl  gfms_input_file_list_    entry (char(*)) returns(bit(1));
dcl  gfms_return              condition ext;
dcl  gfms_serial_number_record_ entry();
dcl  gfms_smc_records_        entry();
dcl  gfms_substructure_records_ entry();
dcl  gfms_task_block_record_  entry(bit(1));
dcl  got_smc_path		bit(1);
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  k                        fixed bin;
dcl  l                        fixed bin;
dcl  last_was_file            bit(1);
dcl  lbound                   builtin;
dcl  master_save              bit(1);
dcl  na                       fixed bin;
dcl  need_density             bit(1);
dcl  need_input_file          bit(1);
dcl  need_mapping_rule	bit(1);
dcl  need_smc_path		bit(1);
dcl  need_track               bit(1);
dcl  need_umc_name		bit(1);
dcl  not_file                 bit(1);
dcl  put_err                  entry variable options(variable);
dcl  reel_number              char(7);
dcl  release_temp_segments_   entry (char(*), (*)ptr, fixed bin(35));
dcl  rs                       char(rsl)var based(rsp);
dcl  rsl                      fixed bin(21);
dcl  rsp                      ptr;
dcl  rsx                      char(5)var;
dcl  rtrim                    builtin;
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  tape_track               char(1);
dcl  tsp                      (3)aligned ptr based(addr(gfms_ext$temp_segs));
dcl  two_words                bit(72)aligned;
dcl  get_wdir_                entry() returns(char(168));
%page;
dcl 1 control_arg	(23) static int options(constant)
,     3 name	char(20)init(
 /* 01 01 */ "den"
,/* 02 01 */ "density"
,/* 03 02 */ "dump"
,/* 04 03 */ "file"
,/* 05 04 */ "if"
,/* 06 04 */ "input_file"
,/* 07 05 */ "no_ga"
,/* 08 05 */ "no_gtss_attributes"
,/* 09 06 */ "no_tll"
,/* 10 06 */ "no_total_llinks"
,/* 11 07 */ "no_unload"
,/* 12 08 */ "not_file"
,/* 13 09 */ "prfn"
,/* 14 09 */ "print_file_names"
,/* 15 10 */ "scan_ss"
,/* 16 11 */ "tk"
,/* 17 11 */ "track"
,/* 18 12 */ "spn"
,/* 19 12 */ "smc_pathname"
,/* 20 13 */ "drm"
,/* 21 13 */ "directory_mapping"
,/* 22 14 */ "rest"
,/* 23 14 */ "restore"
		)
,     3 val	fixed bin init(
 /* 01 */ 01 /* "den"	*/
,/* 02 */ 01 /* "density"	*/
,/* 03 */ 02 /* "dump"	*/
,/* 04 */ 03 /* "file"	*/
,/* 05 */ 04 /* "if"	*/
,/* 06 */ 04 /* "input_file"	*/
,/* 07 */ 05 /* "no_ga"	*/
,/* 08 */ 05 /* "no_gtss_attributes"	*/
,/* 09 */ 06 /* "no_tll"	*/
,/* 10 */ 06 /* "no_total_llinks"	*/
,/* 11 */ 07 /* "no_unload"	*/
,/* 12 */ 08 /* "not_file"	*/
,/* 13 */ 09 /* "prfn"	*/
,/* 14 */ 09 /* "print_file_names"	*/
,/* 15 */ 10 /* "scan_ss"	*/
,/* 16 */ 11 /* "tk"	*/
,/* 17 */ 11 /* "track"	*/
,/* 18 */ 12 /* "spn"	*/
,/* 19 */ 12 /* "smc_pathname"*/
,/* 20 */ 13 /* "drm"*/
,/* 21 */ 13 /* "directory_mapping"*/
,/* 22 */ 14 /* "rest"*/
,/* 23 */ 14 /* "restore"*/

			)
;
%page;
%include gfms_version;
%page;
%include gfms_tape_densities;
%page;
%include gfms_ext;
%page;
%include gfms_do_files;
     end gcos_fms;




		    gfms_ascii_.pl1                 12/11/84  1355.9rew 12/10/84  1041.7       13014



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_ascii_: proc (bs)returns (char (*));

/* Convert BCD character in input bit string "bs"
   to ascii characters and return.

   Author: Dave Ward	09/30/80
  Modified:  Ron Barstad  83-03-10  Changed call to gtss_bcd_ascii_ to gfms_bcd_ascii_ which had already been installed
                                    Corrected precision of number of char to convert
*/
dcl  bs                       bit(*)parm;
	nc = divide (length (bs), 6, 24);
	substr (r, 1, nc) = " ";
	call gfms_bcd_ascii_ (			/* upper case bcd to ascii. */
	     addr (bs)				/* Location of bcd characters. */
	     , nc					/* Number ofcharacters. */
	     , addr (r)				/* location of ascii characters output. */
	     );
	return (rtrim (substr (r, 1, nc)));

dcl  addr                     builtin;
dcl  divide                   builtin;
dcl  gfms_bcd_ascii_          entry(ptr,fixed bin(24),ptr);
dcl  length                   builtin;
dcl  nc                       fixed bin(24);
dcl  r                        char(400)aligned;
dcl  rtrim                    builtin;
dcl  substr                   builtin;
%page;
%include gfms_ext;
     end gfms_ascii_;




		    gfms_ascii_bcd_.alm             12/11/84  1355.9rew 12/10/84  1041.7       13257



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"	ASCII to BCD conversion routine.
"
"	dcl	gfms_ascii_bcd_ entry(ptr,FB,ptr);
"	Parm 1:	Pointer to (input) ascii string.
"	Parm 2:	Length of (input) string.
"	Parm 3:	Pointer to (output) bcd string.
"		(caller must assure output string long enough).
"
"	Author:	Dave Ward		08/03/81
"			(from gfms_ascii_bcd_)
"
	name	gfms_ascii_bcd_
	entry	gfms_ascii_bcd_

gfms_ascii_bcd_:
	eppbp	ap|2,*		bp -> input data
	eppbp	bp|0,*
	lda	ap|4,*		a = length
	eppbb	ap|6,*		bb -> output buffer
	eppbb	bb|0,*

	mvt	(pr,rl),(pr,rl)
	desc9a	bp|0,al
	desc6a	bb|0,al
	arg	table

	short_return


table:	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020077076013
	oct	053074032057
	oct	035055054060
	oct	073052033061
	oct	000001002003
	oct	004005006007
	oct	010011015056
	oct	036075016017
	oct	014021022023
	oct	024025026027
	oct	030031041042
	oct	043044045046
	oct	047050051062
	oct	063064065066
	oct	067070071012
	oct	037034040072
	oct	057021022023
	oct	024025026027
	oct	030031041042
	oct	043044045046
	oct	047050051062
	oct	063064065066
	oct	067070071012
	oct	040034020020

	end




		    gfms_bcd_ascii_.alm             12/11/84  1355.9rew 12/10/84  1041.7       11475



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"	bcd to ascii (upper case)
"
"	dcl gfms_bcd_ascii_ entry(ptr,fixed bin(24),ptr);
"	Arguments:
"		1. Pointer to input bcd characters (6 bit).
"		2. Number of characters.
"		3. Pointer to ascii output string.
"
"	Author:	Dave Ward		08/03/81
"		From Mike Jordan's gdb_bcd_ascii_.alm
"
	name	gfms_bcd_ascii_
	entry	gfms_bcd_ascii_
gfms_bcd_ascii_:
	eppbp	ap|2,*		bp->input data
	eppbp	bp|0,*
	lda	ap|4,*		get char count
	eppap	ap|6,*		ap->output buffer
	eppap	ap|0,*
	mvt	(pr,rl),(pr,rl)
	desc6a	bp|0,al
	desc9a	ap|0,al
	arg	upper
	short_return

	entry	lc
lc:
	eppbp	ap|2,*		bp->input data
	eppbp	bp|0,*
	lda	ap|4,*		get char count
	eppap	ap|6,*		ap->output buffer
	eppap	ap|0,*
	mvt	(pr,rl),(pr,rl)
	desc6a	bp|0,al
	desc9a	ap|0,al
	arg	lower
	short_return

upper:	aci	|0123456789[#@:>?|
	aci	| ABCDEFGHI&.](<\|
	aci	|^JKLMNOPQR-$*);'|
	aci	|+/STUVWXYZ_,%="!|

lower:	aci	|0123456789[#@:>?|
	aci	| abcdefghi&.](<\|
	aci	|^jklmnopqr-$*);'|
	aci	|+/stuvwxyz_,%="!|
	end




		    gfms_calling_sequence_.pl1      12/11/84  1355.9rew 12/10/84  1041.7       52767



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

/* Print the input arguments (strings) on error_output
   stream with the following considerations:
   strings containing "|" are justified
   and information after the "|" are folded under this
   character, e.g.,
   abc | stuff xxx
   d   | more stuff

   Author: Dave Ward	02/02/81
   Change: Dave Ward	02/03/81 fold lines not containing |.
   Change: Scott C. Akers	02/08/82 Change name from print_calling_sequence_ to
			gfms_calling_sequence_ for binding into bound_gfms.
*/
	ll = get_line_length_$stream ("error_output", code);
	call cu_$arg_count (na);
	mm = 0;					/* Set initial max m. */

/* Obtain parameter information. */
	do i = 1 to na while (i <= hbound (a, 1));
	     call cu_$arg_ptr (i, p (i), l (i), code);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gfms_calling_sequence_"
		     , "Arg ^i"
		     , i
		     );
		return;
	     end;

/* Measure for | location. */
	     m (i) = index (argi, "|");
	     mm = max (mm, m (i));
	end;

/* Print the strings. */
	do i = 1 to (i-1);
	     if (m (i) = 0) | (mm > (ll-5)) then do;	/* Either no |, or | too far to the right (a Reagen bar). */
		if length (argi) <= ll then		/* Not more than ll characters to print. */
		     call out (argi);
		else				/* More than ll characters to print. */
		call fold (argi);
	     end;
	     else do;				/* String contains |. */
		call out (substr (argi, 1, m (i)-1));
		if m (i)<mm then
		     call out (substr ((100)" ", 1, mm-m (i)));
		call out (" |");
		if l (i)>m (i) then			/* There are characters after the |. */
		     call pr_rest (after_bar);
	     end;
	     call out (NL);
	end;
fail:	;
	return;
%page;
fold:	proc (s);

/* Output ll characters, break on space, fold remainder.
*/
dcl  s                        char(*)parm;
	     if length (s) <= ll then do;
		call out (s);
		return;
	     end;
	     k = index (reverse (substr (s, 1, ll)), " ");
	     if k>0 then do;
		l = length (rtrim (substr (s, 1, ll-k)));
		if l>0 then do;
		     call out (substr (s, 1, l));
		     call out (NL);
		end;
		l = ll - (k-1) + 1;			/* Location 1st character of remainder. */
		if (length (s)-l+1)>ll then
		     call fold (substr (s, l));
		else do;				/* Right justify final piece. */
		     call out (substr ((100)" ", 1, ll- (length (s)-l+1)));
		     call out (substr (s, l));
		end;
		return;
	     end;

/* No blanks in string. */
	     call out (substr (s, 1, ll));
	     call out (NL);
	     call fold (substr (s, ll+1));
	     return;
dcl  k                        fixed bin;
dcl  l                        fixed bin;
	end fold;
%page;
out:	proc (s);

/* Print string "s". */
dcl  s                        char(*)parm;
	     call iox_$put_chars (
		iox_$error_output
		, addr (s)
		, length (s)
		, code
		);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gfms_calling_sequence_"
		     , "String ""^a"""
		     , s
		     );
		goto fail;
	     end;
	     return;
	end out;
%page;
pr_rest:	proc (s);

/* Print the string "s" as the rest of the string
   after |.
*/
dcl  s                        char(*)parm;
	     call out (" ");
	     l = ll-mm-2;				/* Print characters available. */
	     pl = length (s);
	     if pl <= l then do;			/* Not more than ll characters to print. */
		call out (s);
		return;
	     end;

/* More than ll characters,
   print up to ll characters on this line
   and fold the remainder.
*/
	     k = index (reverse (substr (s, 1, l)), " ");
	     if k = 0 then do;			/* No space found. */
		call out (substr (s, 1, l));
		fc = l+1;
		ln = pl-l;
		if ln<1 then return;
	     end;
	     else do;				/* Print up to space. */
		call out (rtrim (substr (s, 1, l- (k-1))));
		fc = l-k+2;
		ln = pl-fc+1;
		if ln<1 then return;
	     end;
	     call out (NL);
	     call out (substr ((100)" ", 1, mm-1));
	     call out (" |");
	     call pr_rest (substr (s, fc, ln));
	     return;
dcl  fc                       fixed bin;
dcl  k                        fixed bin;
dcl  l                        fixed bin;
dcl  ln                       fixed bin;
dcl  pl                       fixed bin;
	end pr_rest;
%page;
/*   Variables for gfms_calling_sequence_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  after_bar                char(l(i)-m(i))unal based(addr(ari(m(i)+1)))	/* i-th argument, characters after |. */;
dcl  argi                     char(l(i))unal based(p(i))	/* i-th argument, character string. */;
dcl  ari                      (l(i))char(1)unal based(p(i))	/* i-th argument, array of characters. */;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  cu_$arg_count            entry (fixed bin);
dcl  cu_$arg_ptr              entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  get_line_length_$stream  entry (char(*), fixed bin(35)) returns(fixed bin);
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  index                    builtin;
dcl  iox_$error_output        ptr ext static;
dcl  iox_$put_chars           entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  ll                       fixed bin;
dcl  max                      builtin;
dcl  min                      builtin;
dcl  mm                       fixed bin;
dcl  na                       fixed bin;
dcl  reverse                  builtin;
dcl  substr                   builtin;

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

dcl 1 a	(1000)aligned
,     2 p ptr
,     2 l fixed bin(21)
,     2 m fixed bin
;
     end gfms_calling_sequence_;




		    gfms_close_.pl1                 12/11/84  1355.9rew 12/10/84  1041.8        9558



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

/* Close I/O switch "gfms_input",
   return "1" and report if failure.

   Author: Dave Ward	10/18/80
*/
	if ^close then return ("0"b);
	call iox_$close (
	     cbp					/* (input) pointer to switch's control block. */
	     , code				/* (output) I/O system status code. */
	     );
	if code = 0 then return ("0"b);		/* Successful. */
	call com_err_ (
	     code
	     , "gfms"
	     , "closing (^p) description^/^a"
	     , cbp
	     , attach_description
	     );
	return ("1"b);				/* Failed. */

dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  iox_$close               entry (ptr, fixed bin(35));
%page;
%include gfms_ext;
     end gfms_close_;




		    gfms_date_.pl1                  12/11/84  1355.9rew 12/10/84  1041.8       10944



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_date_: proc (bcd_date)returns (char (8));

/* Return date MM/DD/YY from input of 6 bcd
   characters (36 bits) MMDDYY.

   Author: Dave Ward	10/04/80
   Change: Dave Ward	02/04/81 recoded using r array.
*/
dcl  bcd_date                 bit(36)aligned parm;
	r (1) = a (c (1)); r (2) = a (c (2));		/* Month MM. */
	r (3) = "/";
	r (4) = a (c (3)); r (5) = a (c (4));		/* Day DD. */
	r (6) = "/";
	r (7) = a (c (5)); r (8) = a (c (6));		/* Year YY. */
	return (string (r));
%page;
/*   Variables for gfms_date_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  c                        (6)fixed bin(6)unsigned unal based(addr(bcd_date));
dcl  r                        (8)char(1);

dcl  a                        (0:63)char(1)static int options(constant)init(
			"0"
,			"1"
,			"2"
,			"3"
,			"4"
,			"5"
,			"6"
,			"7"
,			"8"
,			"9"
,			(54)(1)"#"
);
%page;
%include gfms_ext;
     end gfms_date_;




		    gfms_detach_.pl1                12/11/84  1355.9rew 12/10/84  1041.8        8658



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

/* Detach the I/O switch "gfms_input" located by cbp.

   Author: Dave Ward	10/18/80
*/
	if ^detach then return;
	call iox_$detach_iocb (
	     cbp					/* (input) pointer to switch's control block. */
	     , code				/* (output) I/O system status code. */
	     );
	if code ^= 0 then
	     call com_err_ (
	     code
	     , "gfms"
	     , "detaching description^/^a"
	     , attach_description
	     );
	return;

dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  iox_$detach_iocb         entry (ptr, fixed bin(35));
%page;
%include gfms_ext;
     end gfms_detach_;




		    gfms_dump_description_tree_.pl1 12/11/84  1355.9rew 12/10/84  1041.8       30150



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

/* Dump description tree.

   Author: Dave Ward	10/23/80
*/
	call ioa_ ("^|DUMP OF cat/desc:");

/* Dump cat. */
	call ioa_ ("^16xprntsc chldlk chldcs name");
	do i = 1 to n_cat;
	     call ioa_ (
		"^6i. ^[catalog^;^3xfile^]^3( ^6i^) ^a"
		, i
		, cat (i).is_cat
		, cat (i).parent_sector
		, cat (i).child_link
		, cat (i).child_sector
		, cat (i).ascii_name
		);
	end;

/* DUMP description. */
	call ioa_ ("^11xlink sector maxsiz mode name");
	do i = 1 to n_desc;
	     call ioa_$nnl (
		"^6i. ^3( ^6i^) ^4b ^a"
		, i
		, description (i).link
		, description (i).sector
		, description (i).attributes.max_size_llinks
		, description (i).attributes.mode
		, gfms_ascii_ ((description (i).name))
		);
	     if description (i).attributes.user_info.present then
		call ioa_$nnl (" ^12.3b", "0"b||attributes (i).value);
	     call ioa_$nnl ("^/");
	end;

/* Check hash chains consume all entries. */
	string (cu) = "0"b;
	call tc (cat_child, cu, "1"b);
	call tc (file_child, cu, "1"b);
	if ^string (cu) ^= "0"b then do;		/* cat entries unaccounted for. */
	     do i = 1 to hbound (cu, 1);
		if cu (i) = "0"b then
		     call ioa_ (
		     "cat^3i NOT USED ^a"
		     , i
		     , cat (i).ascii_name
		     );
	     end;
	end;

	string (du) = "0"b;
	call tc (desc, du, "0"b);
	if ^string (du) ^= "0"b then do;		/* cat entries unaccounted for. */
	     do i = 1 to hbound (du, 1);
		if du (i) = "0"b then
		     call ioa_ (
		     "cat^3i NOT USED ^a"
		     , i
		     , cat (i).ascii_name
		     );
	     end;
	end;
fail:	;
	return;
tc:	proc (l, u, c);

/* Trace chains from start list "l", marking "u" for
   all entries found. "c" is "1"b of this is for cat, versus
   for description.
*/
dcl  c                        bit(1) parm;
dcl  l                        (0:1020)fixed bin(18)unsigned parm;
dcl  u                        (*)bit(1)unal parm;
	     do i = 0 to 1020;
		if l (i)>0 then do;
		     k = l (i);
		     do while (k>0);
			if k>hbound (u, 1) then do;
			     call com_err_ (
				0
				, "gfms_dump_description_tree_"
				, "BUG: link ^i > number entries ^[cat^;desc^] ^i"
				, k
				, c
				, hbound (u, 1)
				);
			     goto fail;
			end;
			u (k) = "1"b;		/* Mark used. */
			if c then k = cat (k).child_link;
			else k = description (k).link;
		     end;
		end;
	     end;
	     return;

dcl  i                        fixed bin;
dcl  k                        fixed bin;
	end tc;
%page;
/*   Variables for gfms_dump_description_tree_:		*/
/*   IDENTIFIER		ATTRIBUTES		*/
dcl  com_err_ entry() options(variable);
dcl  cu                       (n_cat)bit(1)unal based(addr(u));
dcl  du                       (n_desc)bit(1)unal based(addr(u));
dcl  gfms_ascii_              entry (bit(*)) returns(char(*));
dcl  i                        fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  u                        bit(36000)aligned;
%page;
%include gfms_description_tree;
%include gfms_ext;
     end;




		    gfms_dump_do_files_.pl1         12/11/84  1355.9rew 12/10/84  1041.8       11277



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

/* Dump the file name list.

   Author: Dave Ward	10/19/80
   Change: Dave Ward	10/30/80 new do files structure.
*/
	call ioa ("DUMP OF FILE NAMES:");
	t = 0;					/* Total count. */
	do sp = addr (file_start), addr (cat_start);
	     do k = lbound (start, 1) to hbound (start, 1);
		j = start (k);
		if j>0 then do;
		     n = 0;
		     do while (j>0);
			t = t+1;
			n = n+1;
			call ioa (
			     "^4i. ^4i ^4i ^[no ^;   ^]^a"
			     , t
			     , k
			     , n
			     , not (j)
			     , name (j)
			     );
			j = link (j);
		     end;
		end;
	     end;
	end;
	return;

dcl  j                        fixed bin;
dcl  k                        fixed bin;
dcl  n                        fixed bin;
dcl  sp                       ptr;
dcl  start                    (0:1020)fixed bin based(sp);
dcl  t                        fixed bin;
%include gfms_do_files;
%include gfms_ext;
     end gfms_dump_do_files_;




		    gfms_dump_rec_.pl1              12/11/84  1355.9rew 12/10/84  1041.8       31194



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_dump_rec_: proc (p, n);

/* Display catalog record BCD and octal.

   Author: Dave Ward	11/05/80
   Change: Dave Ward	11/06/80 number of words parameter.
   Change: Dave Ward	11/25/80 notify zero words requested.
*/
dcl  n                        fixed bin parm;
dcl  p                        ptr parm;
	if n<1 then do;
	     call ioa_$ioa_switch_nnl (
		iox_$error_output
		, "ZERO WORDS READ. NO DUMP."
		);
	     return;
	end;
	f = n-1;					/* upper bound 0,1,...,n-1. */
	call ioa_$ioa_switch_nnl (iox_$error_output, "^5x");
	do i = 0 to 7;				/* Print header. */
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^13x^i", i);
	end;
	call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
	do i = 0 by 8 to f;
	     if i>0 then
		if last_line = current_line then do;
		     if first then do;
			first = "0"b;
			call ioa_$ioa_switch_nnl (iox_$error_output, "^6x^12(=^)");
			call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
		     end;
		     goto next_line;
		end;
	     first = "1"b;
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^4i.", i);
	     do j = i to (i+8-1) while (j <= f);	/* Print bcd. */
		call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^13a", bcd (w (j)));
	     end;
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^/^5x");
	     do j = i to (i+8-1) while (j <= f);	/* Print octal. */
		call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^6.3b'^6.3b", wl (j), wr (j));
	     end;
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
next_line:     ;
	end;
	return;
%page;
bcd:	proc (w)returns (char (13));

/* Convert 6 bcd characters to ascii, convert blanks to
   underlines (bcd has no underline character, so this
   distinguishes bcd blanks). Return the 6 characters as a 2
   strings of 6 characters each, space in middle, each input
   character preceeded by a space.
*/
dcl  w                        bit(36)aligned parm;
	     string (s) = gfms_ascii_ ((w));		/* Convert bcd to ascii. */
	     string (s) = translate (string (s), "_", " "); /* Convert spaces to underlines. */
	     string (r) = " ";			/* Blank the result. */
	     do i = 0 to 5;
		if i<3 then k = 1;
		else k = 2;
		r ((i*2)+k) = s (i);		/* Distribute to every other character of the output. */
	     end;
	     return (string (r));

dcl  i                        fixed bin;
dcl  k                        fixed bin;
dcl  r                        (0:12)char(1)unal;
dcl  s                        (0:5)char(1)unal;
	end bcd;
%page;
/*   Variables for gfms_dump_rec_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  current_line             bit(8*36)aligned based(addr(w(i)));
dcl  f                        fixed bin;
dcl  first                    bit(1);
dcl  gfms_ascii_              entry (bit(*)) returns(char(*));
dcl  i                        fixed bin;
dcl  ioa_$ioa_switch_nnl      entry() options(variable);
dcl  iox_$error_output        ptr ext static;
dcl  j                        fixed bin;
dcl  last_line                bit(8*36)aligned based(addr(w(i-8)));
dcl  w                        (0:f)bit(36)aligned based(p);

dcl 1 w2			(0:f)aligned based(p)
,     2 wl		bit(18)unal
,     2 wr		bit(18)unal
;
     end gfms_dump_rec_;




		    gfms_end_of_input_.pl1          12/11/84  1355.9rew 12/10/84  1041.8       28836



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_end_of_input_: proc (bp, bl, nb)returns (bit (1));

/* End of information reached attempting to read a record.
   Determine if tape is multi-reel, in which case, proceed
   to the next reel, fill the remainder of the record (based
   on "bp" of length "bl" bytes of which "nb" have been input)
   and return "0"b. If trailing label indicates EOF (end of file)
   then return "1"b, there is no more input.

   Author: Dave Ward	10/18/80
*/
dcl  bl                       fixed bin(21) parm	/* Length of buffer (bytes). */;
dcl  bp                       ptr parm	/* Pointer to input buffer. */;
dcl  nb                       fixed bin(21) parm	/* Number of bytes no in buffer. */;
	if gfms_trailer_label_ () then return ("1"b);	/* Multireel tape concluded. */

/* Continue file from next tape reel. */

	call gfms_header_label_;			/* Process label from next reel. */

/* Obtain the next FILE CONTENT record from tape.
*/
	call iox_$read_record (
	     cbp					/* (input) pointer to control block. */
	     , addr (rec_space)			/* (input) record buffer. */
	     , size (rec_space)*4			/* (input) buffer length in bytes. */
	     , nbr				/* (output) number of bytes read. */
	     , code				/* (output) I/O system status. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms_file_content_records_"
		, "Attempting to read EOI record."
		||"^/Tape status ^4.3b"
		||"^/buffer length ^i (bytes)."
		||"^/bytes read ^i."
		||"^/attach description ""^a"""
		, gfms_tape_status_ (cbp)
		, size (rec_space)*4
		, nbr
		, attach_description
		);
fail:	     ;
	     signal cond (gfms_fail);
	end;

	if (nb + nbr) > bl then do;			/* Exceeded bytes in buffer. */
	     call com_err_ (
		0
		, "gfms_end_of_input_"
		, "Record split over reels exceeds buffer bytes ^i"
		||"^/^i bytes read from last reel, ^i bytes from current reel."
		, bl
		, nb
		, nbr
		);
	     signal cond (gfms_fail);
	end;

	buffer.new = substr (rec_space, 1, nbr);
	nb = nb+nbr;				/* Reset to total bytes now in buffer. */
	return ("0"b);
%page;
/*   Variables for gfms_end_of_input_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  divide                   builtin;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  gfms_fail                condition ext;
dcl  gfms_header_label_       entry;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  gfms_trailer_label_      entry() returns(bit(1));
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  nbr                      fixed bin(21);
dcl  rec_space                char(15624)aligned /* 15624 = 3906 words (file content data records). */;

dcl 1 buffer	aligned based(bp)
,     3 old	char(nb)unal
,     3 new	char(nbr)unal
;
%page;
%include gfms_ext;
     end gfms_end_of_input_;




		    gfms_ext.cds                    12/11/84  1355.9r w 12/10/84  1041.9       27099



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gfms_ext:proc;

/* Generate object for "gfms_ext" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gfms_ext)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gfms_ext);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gfms_ext);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gfms_ext";

	cds_args_ptr -> cds_args.seg_name = "gfms_ext";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gfms_ext");
	   else 
	      call com_err_( 0,"gfms_ext","Object for gfms_ext created [^i words].",size(gfms_ext));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gfms_ext.incl.pl1 **/

dcl 1 gfms_ext aligned,

      2 print_routines	aligned like gfms_ext$print_routines,

      2 temp_segs		aligned like gfms_ext$temp_segs,

      2 tape_file		aligned like gfms_ext$tape_file,

      2 options		aligned like gfms_ext$options,

      2 working_dir		char (168) var,	

      2 mapping_rule	char(3),

      2 umc_name		char(12);
%page;
%include gfms_ext;
%page;
%include cds_args;
end;




		    gfms_file_content_records_.pl1  12/11/84  1355.9rew 12/10/84  1022.3      318816



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

/* Display FILE CONTENT records information.

   Author: Dave Ward	10/03/80
   Change: Dave Ward	10/08/80	isolate printing names.
   Change: Dave Ward	10/10/80	create and move date to file.
   Change: Dave Ward	10/13/80	lower case names, handle record_quota_overflow
   Change: Dave Ward	10/15/80	total records, record entry.
   Change: Dave Ward	10/16/80	corrected totaling records.
   Change: Dave Ward	10/17/80	provide gtss file attributes.
   Change: Dave Ward	10/29/80	adjusted to new tree description.
   Change: Dave Ward	10/30/80	adjusted to new file name list.
   Change: Dave Ward	11/12/80	creation date from content record.
   Change: Dave Ward	11/25/80	bug in selective unloading.
   Change: Scott C. Akers	02/08/82	Get working directory from gfms_ext$working_dir.
				Don't blow up on bad file, just skip it.
				Selective unloading by UMC, use UMC
				to specify pathname if "-drm umc" applies.
   Change: Ron Barstad        11/24/82  Fix bug on restoring MSFs--cl was not being set to 0 on new seg
   Change: Ron Barstad        12/23/82  Fix bug on return from quota overflow fix command level
   Change: Ron Barstad        11/21/84  Added rtrims to formation of msf paths

*/

	call ioa ("^|FILE CONTENT RECORDS INFORMATION:");
	first_warning = "1"b;
	rqo_in_progress = "0"b;			/* Whether processing record quota overflow (0 => not). */
	fcbp = null ();				/* MSF fcb pointer. */
	wd = gfms_ext$working_dir;			/* Obtain caller's working directory. */
	i = 0;					/* Total file count. */
	bf = "";					/* Bad file string. */
	file_name_list.next_entry = 1;		/* Next available start entry. */
	file_name_list.nn = 0;			/* Number of file names. */
	file_name_list.total_llinks = 0;		/* Total number llinks in all files. */
	if unload then				/* Unloading, provide for record quota overflow. */
	     on condition (record_quota_overflow)
	     call process_rqo (			/* Procedure to call if quota exceeded. */
	     "Creating file:"
	     ||"^/"||rtrim(wd)||rtrim(sub_dir)||">"||rtrim (file_entry)
	     );
LOOP_1:	do while (get_rec () = GOT_RECORD);		/* Obtain next file content record. */
	     if file_continued = "0"b then
GROUP_1:		do;				/* Start f next file. */
		i = i+1;				/* Count of files. */
		t = file_size;			/* Total file llinks. */
		a = file_llinks_in_record;		/* Accumulated file llinks (1st record). */
		call block_info;
		call display_header (bf);
		call define_file (			/* Establish Multics file in which to unload. */
		     file_name2			/* (input) file name. */
		     , file_desc_sect_num		/* (input) sector number of file description record. */
		     , t				/* (input) total length of file llinks. */
		     , bf				/* (input) string of codes why file bad. */
		     , cfd			/* (output) gcos catalog/file description. */
		     , sub_dir			/* (output) multics directory path. */
		     , gcos_file_name		/* (output) GCOS file name (upper case). */
		     , file_entry			/* (output) multics file entry name (lower case). */
		     , fne_ptr			/* (output) pointer to file name entry. */
		     , have_file			/* (output) "1"b file definition successful. */
		     );
		unloading_file = "0"b;		/* Assume we are not to unload file. */
		if have_file then
		     if unload then
			if do_file (cfd, gcos_file_name) then
GROUP_2:			     do;
			     call create_file (
				wd
				, sub_dir
				, file_entry
				, fcbp
				, c (0)
				, have_file
				);
			     if have_file then do;
				if gf then	/* Provide gtss file attributes. */
				     call gfms_gtss_attributes_ (
				     rtrim(wd)||sub_dir	/* (input) directory. */
				     , file_entry	/* (input) file name. */
				     , fne_ptr	/* (input) pointer to file name entry. */
				     , fcr.file_creation_date /* (input) creation date BCD. */
				     );
				cn = 0;		/* Current component number. */
				cp = c (0);	/* Pointer to the Multics file (segment). */
				cl, nll = a;	/* Number of llinks to move
						   (will not exceed 1st segment <= 3840 words). */
				unspec (cp -> move_llinks) = unspec (addr (fcr.words66_nw) -> move_llinks);
				unloading_file = "1"b; /* File is being unloaded. */
			     end;
			end GROUP_2;

LOOP_2:		do while (t>a);			/* total llinks > accumulated llinks. */
		     i = i+1;
		     if get_rec () = END_OF_FILE then do;
			call com_err_ (
			     0
			     , "gfms_file_content_records_"
			     , "end of input during continuation record in file ^a"
			     , cfd
			     );
			signal condition (gfms_fail);
		     end;
		     if file_continued = "0"b then do;	/* This should be a continued record. */
			call com_err_ (
			     0
			     , "gfms_file_content_records_"
			     , "File ^a file size ^i accumulated ^i uncontinued record."
			     , cfd
			     , t
			     , a
			     );
		     end;
		     call block_info;
		     call display_header (bf);
		     if unloading_file then
			call unload_record;
		     a = a + file_llinks_in_record;	/* Number of accumulated llinks moved. */
		end LOOP_2;

/* "close" the file. */
		if unloading_file then do;
		     call msf_manager_$adjust (
			fcbp
			, cn
			, cl*320*36
			, "1"b			/* Set the bit count. */
			||"1"b			/* truncate the final component. */
			||"1"b			/* terminate the component. */
			, code
			);
		     if code ^= 0 then do;
			call com_err_ (
			     code
			     , "gfms_file_content_records_"
			     , "Unable to adjust at component ^i:"
			     ||"^/""^a"""
			     , cn
			     , rtrim(wd)||rtrim(sub_dir)||">"||file_entry
			     );
		     end;
		     call msf_manager_$close (fcbp);
		end;

		if t ^= a then do;			/* Accumulated records not equal to total. */
		     call com_err_ (
			0
			, "gfms_file_content_records_"
			, "File ^a size ^i accumulated ^i."
			, cfd
			, t
			, a
			);
		end;

	     end GROUP_1;
	     else do;				/* Continued record after file completed. */
		call com_err_ (
		     0
		     , "gfms_file_content_records_"
		     , "Continued record after file ^a completed."
		     , cfd
		     );
	     end;
	end LOOP_1;

	if prfn | tll then call gfms_print_names_ (nn);
	return;
%page;
bcd:	proc (w)returns (char (13));

/* Convert 6 bcd characters to ascii, convert blanks to
   underlines (bcd has no underline character, so this
   distinguishes bcd blanks). Return the 6 characters as a 2
   strings of 6 characters each, space in middle, each input
   character preceeded by a space.
*/
dcl  w                        bit(36)aligned parm;
	     string (s) = gfms_ascii_ ((w));		/* Convert bcd to ascii. */
	     string (s) = translate (string (s), "_", " "); /* Convert spaces to underlines. */
	     string (r) = " ";			/* Blank the result. */
	     do i = 0 to 5;
		if i<3 then k = 1;
		else k = 2;
		r ((i*2)+k) = s (i);		/* Distribute to every other character of the output. */
	     end;
	     return (string (r));

dcl  i                        fixed bin;
dcl  k                        fixed bin;
dcl  r                        (0:12)char(1)unal;
dcl  s                        (0:5)char(1)unal;
	end bcd;
%page;
block_info: proc;

/* Display and verify block information
   from file content record.
*/
	     call ioa (
		"^6i. (block^6i)  size^6i  record-size^6i"
		, i
		, block_serial_number
		, block_size
		, record_size
		);

	     if no_files_in_record ^= 1 then do;
		call ioa ("number of files in record not 1 (^i)", no_files_in_record);
		do i = 0 to 65 by 4;
		     call ioa_nnl ("^12x^2i. ", i);
		     do j = i to (i+3) while (j <= 65);
			call ioa_nnl (" ^12.3b", w (j));
		     end;
		     call ioa_nnl ("^/");
		end;
	     end;
	     return;
	end block_info;
%page;
create_directory: proc (wd, dr);

/* Create subdirectories specified by "dr"
   under directory specified by "wd"
*/
dcl  dr                       char(168)var parm;
dcl  wd                       char(168)var parm;
	     n = 1;
	     on condition (record_quota_overflow)
		call process_rqo (
		"Creating directory:"
		||"^/"||rtrim(wd)||">"||rtrim(dr)||">"||ent
		);
	     do while (n <= length (dr));
		k = index (substr (dr, n), ">");
		if k = 0 then k = length (dr)-n+2;
		if n> 1 then wdir = rtrim(wd)||">"||substr (dr, 1, n-2);
		else wdir = wd;
		ent = substr (dr, n, k-1);
		call hcs_$append_branchx (
		     wdir				/* (input) pathname of containing directory. */
		     , ent			/* (input) name of subdirectory. */
		     , 01011b			/* (input) status, modify and append access for *.*.*. */
		     , rings			/* (input) ring brackets. */
		     , "*.*.*"			/* (input) person project for access. */
		     , 1				/* (input) directory being created. */
		     , 0				/* (input) copy switch not on. */
		     , 0				/* (input) no bit count. */
		     , code			/* (output) storage system status. */
		     );
		if code ^= 0 then
		     if code ^= error_table_$namedup then do;
			call com_err_ (
			     code
			     , "gfms"
			     , "Directory: ^a>^a (retryable)"
			     , wdir
			     , ent
			     );
			signal condition (gfms_fail);
		     end;
		n = n+k;
	     end;
	     revert condition (record_quota_overflow);
	     return;

dcl  ent                      char(32);
dcl  k                        fixed bin;
dcl  n                        fixed bin;
dcl  wdir                     char(168);
	end create_directory;
%page;
create_file: proc (wd, dir, ent, fcbp, p1, fc);

/* Create MSF file wd>dir>ent.
   Set fcbp to MSF file control block (fcb).
   Set pointer p1 to 1st component.
   Set fc "1"b if successful.
*/
dcl  dir                      char(168)var parm;
dcl  ent                      char(32)parm;
dcl  fc                       bit(1)parm;
dcl  fcbp                     ptr parm;
dcl  p1                       ptr parm;
dcl  wd                       char(168)var parm;
	     number_of_attempts = 0;
try2:	     ;
	     call msf_manager_$open (
		rtrim(wd)||dir
		, ent
		, fcbp
		, code
		);
	     if code ^= 0 then
		if code ^= error_table_$noentry then do;
		     if code = error_table_$no_dir then do;
			number_of_attempts = number_of_attempts+1;
			if number_of_attempts = 1 then do;
			     if length (dir)>1 then
				call create_directory (wd, substr (dir, 2));
			     goto try2;
			end;
		     end;
		     call com_err_ (
			code
			, "gfms_file_content_records_"
			, "Attempting to create:"
			||"^/""^a"""
			, rtrim(wd)||rtrim(dir)||">"||ent
			);
		     fc = "0"b;			/* Could not create the file. */
		     return;
		end;

	     call msf_manager_$get_ptr (		/* Obtain pointer to 1st component. */
		fcbp
		, 0				/* 1st component number. */
		, "1"b				/* (input) => create file if non-existent. */
		, p1				/* (output) pointer to component 0. */
		, bc				/* (output) bit count. */
		, code
		);
	     if code ^= 0 then do;
		if code ^= error_table_$namedup then
		     if code ^= error_table_$segknown then do;
			call com_err_ (
			     code
			     , "gfms_file_content_records_"
			     , "Unable to obtain pointer to 1st component of:"
			     ||"^/""^a"""
			     , rtrim(wd)||rtrim(dir)||">"||ent
			     );
			fc = "0"b;		/* Could not create the file. */
			return;
		     end;
		call msf_manager_$adjust (		/* Truncate existing file. */
		     fcbp				/* (input) pointer to file control block. */
		     , 0				/* (input) MSF component. */
		     , 0				/* (input) bit count. */
		     , "0"b			/* (3 bits input) do not set bit count. */
		     ||"1"b			/* truncate the component. */
		     ||"0"b			/* do not terminate the component. */
		     , code			/* (output) status code. */
		     );
		if code ^= 0 then
		     call com_err_ (
		     code
		     , "gfms"
		     , "Unable to truncate existing file ^a^a>^a"
		     , wd
		     , dir
		     , ent
		     );
	     end;

	     fc = "1"b;
	     return;

dcl  number_of_attempts       fixed bin;
	end create_file;
%page;
define_file: proc (n, s, l, bfc, cfn, dir, fn, ent, fep, defined);

/* Look up sector number "s" in the description tree
   and display the catalog description found.
   "n" is the BCD name of the file in the header information.
   "l" is the total length of the file in llinks (=> 320 words @).
   "bfc" is the bad file code string.
   "cfn" is to be output the catalog/file name obtained.
   "dir" is the Multics (sub) directory pathname.
   "fn" is GCOS file name (upper case).
   "ent" is the Multics file entry name (fn lower case).
   "fep" is output set to file name entry.
   "defined" is "1"b if file defined, else "0"b.
*/
dcl  bfc                      char(20)var parm;
dcl  cfn                      char(200)var parm;
dcl  defined                  bit(1)parm;
dcl  dir                      char(168)var parm;
dcl  ent                      char(32)parm;
dcl  fep                      ptr parm;
dcl  fn                       char(12)var parm;
dcl  l                        fixed bin parm;
dcl  n                        bit(72)aligned parm;
dcl  s                        fixed bin(18)unsigned unal parm;
	     defined = "1"b;			/* Assume file will be defined. */
	     cfn					/* GCOS catalog file description. */
		, dir = "";			/* Multics directory pathname. */
	     fn = rtrim (gfms_ascii_ ((n)));		/* GCOS file name (i.e., upper case).. */
	     ent = translate (fn, lower, upper);	/* Multics entry name (lower case). */

/* Locate description record. */
	     d = start_list.desc (mod (s, hbound (start_list.desc, 1)+1));
	     do while (d>0);
		if description (d).sector = s then goto found_desc;
		d = description (d).link;
	     end;
	     call com_err_ (			/* Unable to find desc. */
		0
		, "gfms_file_content_records_"
		, "Can not find description for sector ^6i (^6.3b oct) ""^a"""
		, s
		, unspec (s)
		, fn
		);
fail:	     ;
	     defined = "0"b;			/* File not defined. */
	     goto finish_define_file;

found_desc:    ;

/* Locate file entry of catalog. */
	     f = start_list.file_child (mod (s, hbound (start_list.file_child, 1)+1));
	     do while (f>0);
		if cat (f).child_sector = s then goto found_file;
		f = cat (f).child_link;
	     end;
	     call com_err_ (			/* Unable to find file catalog. */
		0
		, "gfms_file_content_records_"
		, "Can not find sector ^6i (^6.3b oct) ""^a"" file in catalog."
		, s
		, unspec (s)
		, fn
		);
	     goto fail;

found_file:    ;

	     if (n ^= description (d).name) | (n ^= cat (f).name) then
		call com_err_ (			/* Names not consistant. */
		0
		, "gfms_file_content_records_"
		, "Names from content, description and catalog not consistant:"
		||"^/""^a"", ""^a"" and ""^a"""
		||"^/ Using first name."
		, gfms_ascii_ ((n))
		, gfms_ascii_ ((description (d).name))
		, gfms_ascii_ ((cat (f).name))
		);

/* Search the tree (backwards) to determine the
   GCOS catalog/file description and correspondingly
   the Multics pathname.
*/
next_level_up_tree: ;
	     cs = cat (f).parent_sector;		/* Catalog sector of my parent. */
	     f = start_list.cat_child (mod (cs, hbound (start_list.cat_child, 1)+1));
	     do while (f>0);
		if cat (f).child_sector = cs then do;	/* Found my parent. */
		     if length (cfn) = 0 then cfn, dir = cat (f).ascii_name;
		     else do;
			cfn = cat (f).ascii_name||"/"||cfn;
			dir = cat (f).ascii_name||">"||dir;
		     end;
		     goto next_level_up_tree;
		end;
		f = cat (f).child_link;
	     end;

/* Unable to find previous parent.
   => There is no parent, i.e., catalog/file description
   terminated.
*/

/* Collect file information. */
	     fep, fnep = addr (file_name_list.start_entry (file_name_list.next_entry));
	     file_name_entry.char_length.defl = length (bfc);
	     file_name_entry.char_length.naml = length (fn);
	     file_name_entry.char_length.catl = length (cfn);
	     if (file_name_list.next_entry + size (file_name_entry)) > hbound (file_name_list.start_entry, 1) then do;
		if first_warning then
		     call com_err_ (
		     error_table_$too_many_names
		     , "gfms_file_content_records_"
		     , "Only space for first ^i file names. Continuing."
		     , file_name_list.nn
		     );
		first_warning = "0"b;
	     end;
	     else do;				/* Store the next file name entry. */
		nn = nn+1;
		file_name_entry.llinks = l;
		file_name_entry.defective = bfc;
		file_name_entry.name = fn;
		file_name_entry.catalog = cfn;
		unspec (file_name_entry.attr) = unspec (description (d).attributes);
		file_name_list.next_entry =
		     file_name_list.next_entry + size (file_name_entry); /* Locate next available entry. */
	     end;
	     total_llinks = total_llinks + l;		/* Total llinks for all files. */
finish_define_file: ;
	     cfn = cfn||"/"||fn;			/* Complete catalog file description. */
	     if length (dir)>0 then
		dir = ">"|| translate (dir, lower, upper);
	     return;

dcl  cs                       fixed bin(18)unsigned;
dcl  d                        fixed bin;
dcl  f                        fixed bin;
	end define_file;
%page;
display_header: proc (bfc);

/* Display file content header. */
dcl  bfc                      char(20)var parm	/* bad file code. */;
	     call ioa_nnl ("^11x");
	     call ioa_nnl (" file_name2 ^12a", gfms_ascii_ ((file_name2)));
	     call ioa_nnl (" user_name ^12a", gfms_ascii_ ((user_name)));
	     call ioa_nnl (" file_size ^6i llinks", file_size);
	     call ioa_nnl (" file_continued ^1b", file_continued);
	     call ioa_nnl (" file_llinks_in_record ^6i", file_llinks_in_record);
	     call ioa_nnl ("^/^11x");
	     call ioa_nnl (" record_code ^a", record_code_type ());
	     call ioa_nnl (" file_desc_sect_num ^6i", file_desc_sect_num);
	     call ioa_nnl ("^/^11x");
	     if abort_locked ^= "0"b then do;
		bfc = bfc||" AL";
		call ioa_nnl (" abort_locked ^1b", abort_locked);
	     end;
	     if defective_space ^= "0"b then do;
		bfc = bfc||" DS";
		call ioa_nnl (" defective_space ^1b", defective_space);
	     end;
	     if saved_while_write_busy ^= "0"b then do;
		bfc = bfc||" WB";
		call ioa_nnl (" saved_while_write_busy ^1b", saved_while_write_busy);
	     end;
	     if file_creation_date ^= "0"b then
		call ioa_nnl (" file_creation_date ^12a", gfms_date_ (file_creation_date));
	     if defective_llinks ^= "0"b then do;
		bfc = bfc||" DL";
		call ioa_nnl (" defective_llinks ^4.3b", defective_llinks);
	     end;
	     if part_of_file ^= "0"b then do;
		bfc = bfc||" PF";
		call ioa_nnl (" part_of_file ^1b", part_of_file);
	     end;
	     call ioa_nnl ("^/");
	     return;
	end display_header;
%page;
do_file:	proc (c, f)returns (bit (1));

/* Return "1"b if caller designated that
   catalog file description "c" or file "f" is to
   be unloaded.
*/
dcl  c                        char(200)var parm;
dcl  f                        char(12)var parm;
	     if file_names.number_names < 1 then return ("1"b); /* => do all. */
	     k = file_start (gfms_hash_ ((f), hbound (file_start, 1)+1));
	     do while (k>0);			/* Examine if file name specified. */
		if file_name (k).name = f then do;
		     if file_name (k).not then return ("0"b); /* Do not unload file f. */
		     return ("1"b);			/* Do unload file f. */
		end;
		k = file_name (k).link;
	     end;
	     k = cat_start (gfms_hash_ ((c), hbound (cat_start, 1)+1));
	     do while (k>0);			/* Examine if file name specified. */
		if file_name (k).name = c then do;
		     if file_name (k).not then return ("0"b); /* Do not unload file f. */
		     return ("1"b);			/* Do unload file f. */
		end;
		k = file_name (k).link;
	     end;
	     return ("0"b);				/* Neither specified. Don't unload. */

dcl  gfms_hash_               entry (char(*), fixed bin) returns(fixed bin);
dcl  k                        fixed bin;

%include gfms_do_files;
	end do_file;
%page;
dump_rec:	proc (p, l);

/* Display record BCD and octal.
*/
dcl  l                        fixed bin parm;
dcl  p                        ptr parm;
	     n = l-1;				/* Number counting from 0 of l words. */
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^5x");
	     do i = 0 to 7;				/* Print header. */
		call ioa_$ioa_switch_nnl (iox_$error_output, "^13x^i", i);
	     end;
	     call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
	     do i = 0 by 8 to n;
		if i>0 then
		     if last_line = current_line then do;
			if first then do;
			     first = "0"b;
			     call ioa_$ioa_switch_nnl (iox_$error_output, "^6x^12(=^)");
			     call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
			end;
			goto next_line;
		     end;
		first = "1"b;
		call ioa_$ioa_switch_nnl (iox_$error_output, "^4i.", i);
		do j = i to (i+8-1) while (j <= n);	/* Print bcd. */
		     call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^13a", bcd (w (j)));
		end;
		call ioa_$ioa_switch_nnl (iox_$error_output, "^/^5x");
		do j = i to (i+8-1) while (j <= n);	/* Print octal. */
		     call ioa_$ioa_switch_nnl (iox_$error_output, "^1x^6.3b'^6.3b", wl (j), wr (j));
		end;
		call ioa_$ioa_switch_nnl (iox_$error_output, "^/");
next_line:	;
	     end;
	     return;

dcl  current_line             bit(min(8,l-i)*36)aligned based(addr(w(i)));
dcl  first                    bit(1);
dcl  i                        fixed bin;
dcl  ioa_$ioa_switch_nnl      entry() options(variable);
dcl  iox_$error_output        ptr ext static;
dcl  j                        fixed bin;
dcl  last_line                bit(min(8,l-i)*36)aligned based(addr(w(i-8)));
dcl  n                        fixed bin;
dcl  w                        (0:n)bit(36)aligned based(p);

dcl 1 w2			(0:n)aligned based(p)
,     2 wl		bit(18)unal
,     2 wr		bit(18)unal
;
	end dump_rec;
%page;
get_rec:	proc returns (fixed bin);

/* Obtain the next FILE CONTENT record from tape.
   Returns END_OF_FILE when no more input.
   Returns GOT_RECORD when a good record is read.
   Returns SKIP_FILE when a sick record is read.

   If we're restoring a specific UMC, then get_rec "eats" all records
   which don't belong to the user name specified, and only returns
   when one of the foregoing conditions is satisfied.

*/
more:	     ;
	     call iox_$read_record (
		cbp				/* (input) pointer to control block. */
		, addr (fcr_space)			/* (input) record buffer. */
		, size (fcr_space)*4		/* (input) buffer length in bytes. */
		, nbr				/* (output) number of bytes read. */
		, code				/* (output) I/O system status. */
		);
	     if code ^= 0 then
		if code = error_table_$end_of_info then
		     if gfms_end_of_input_ (
		     addr (fcr_space)		/* (input) pointer to input buffer. */
		     , size (fcr_space)*4		/* (input) length of buffer (bytes). */
		     , nbr			/* (input/output) current number bytes in buffer. */
		     ) then return (END_OF_FILE);	/* No more tape input. */
		     else goto cont;		/* Next reel in process. */
		else
		if code ^= error_table_$long_record then do;
		     call com_err_ (
			code
			, "gfms_file_content_records_"
			, "Attempting to read file content record."
			||"^/Tape status ^4.3b"
			||"^/buffer length ^i (bytes)."
			||"^/bytes read ^i."
			||"^/attach description ""^a"""
			, gfms_tape_status_ (cbp)
			, size (fcr_space)*4
			, nbr
			, attach_description
			);
fail:		     ;
		     signal condition (gfms_fail);
		end;

cont:	     ;
	     lc_uname = translate (gfms_ascii_ ((user_name)), lower, upper);
	     if   gfms_ext$umc_name ^= ""		/* Skip this record if it's
						   not related to the specified UMC. */
	        & lc_uname ^= gfms_ext$umc_name
	     then goto more;

	     if   gfms_ext$mapping_rule = "umc"		/* Gotta put the stuff in the
						   right place. */
	     then wd =   rtrim (gfms_ext$working_dir)
		    || ">"
		    || rtrim (lc_uname)
		    || ">"
		    || rtrim (lc_uname);

	     if mod (nbr, 4) ^= 0 then		/* Make sure length in words is consistent. */
		call com_err_ (
		0
		, "gfms_file_content_records_"
		, "Bytes read (^i) not word modulo, will truncate to word and continue."
		, nbr
		);
	     nwr = divide (nbr, 4, 17);		/* Number of words read. */
	     if nwr = 66 then
		if block_size = 65 then
		     if record_size = 64 then
			if no_files_in_record = 1 then
			     if file_llinks_in_record = 0 then do; /* Empty content record. */
				call com_err_ (
				     0
				     , "gfms_file_content_records_"
				     , "Empty content record (file ^i) for ""^a"""
				     , i
				     , gfms_ascii_ ((file_name2))
				     );
				i = i+1;		/* Count file. */
				goto more;
			     end;
	     nw = nwr-1;				/* upper bound of fcr structure. */
	     if nw < lbound (words66_nw, 1) then do;
		call com_err_ (
		     0
		     , "gfms_file_content_records_"
		     , "Faulty file content record."
		     ||"^/file ^i, ^i bytes read."
		     ||"^2/File contents will be inconsistent."
		     , i
		     , nbr
		     );
		call dump_rec (addr (fcr_space), nwr);
		return (SKIP_FILE);			/* Skip this file. */
	     end;
	     return (GOT_RECORD);
end get_rec;
%page;
process_rqo: proc (m);

/* Process record quota overflow (message m).
*/
dcl  m                        char(*)parm;
	     call user_info_$process_type (t);
	     if t ^= 1 then do;			/* Not interactive caller. */
		call com_err_ (
		     0
		     , "gfms"
		     , "Record quota overflow. "||m
		     );
		signal condition (gfms_fail);
	     end;
	     if rqo_in_progress then do;
		call com_err_ (
		     0
		     , "gfms"
		     , "Successive record quota overflow."
		     ||"^/Can not continue."
		     );
		signal condition (gfms_fail);
	     end;
	     rqo_in_progress = "1"b;
	     version = query_info_version_4;
	     yes_or_no_sw = "1"b;			/* Accept only yes or no. */
	     suppress_name_sw = "1"b;			/* Include name. */
	     suppress_spacing = "1"b;
	     cp_escape_control = "00"b;		/* Obey default. */
	     status_code = error_table_$rqover;		/* record quota overflow. */
	     query_code = 0;
	     question_iocbp, answer_iocbp = null ();
	     repeat_time = 0;			/* Don't repeat question. */
	     call command_query_ (
		addr (query_info)
		, ans
		, "gfms"
		, "Record quota overflow. "||m
		||"^/Do you want to correct? "
		);
	     if ans = "no" then signal condition (gfms_fail);
	     on condition (program_interrupt) rqo_in_progress = "0"b;
	     call ioa_ ("You're at command level. Correct and ""pi""");
	     call cu_$cl ();
	     if ^rqo_in_progress then return;
	     call com_err_ (
		0
		, "gfms_file_content_records_"
		, "Record quota overflow. Cannot continue."
		);

	     signal condition (gfms_fail);
dcl  ans                      char(3)var;
dcl  command_query_           entry() options(variable);
dcl  cu_$cl                   entry();
dcl  program_interrupt        condition ext;
dcl  t                        fixed bin;
dcl  user_info_$process_type  entry (fixed bin);
	end process_rqo;
%page;
record_code_type: proc returns (char (*));

/* Evaluate record code. */
	     if record_code = 0 then return ("NORMAL");
	     if record_code = 1 then return ("DELAYED FILE, CONTENT FOLLOWS HEADER");
	     if record_code = 2 then return ("DELAYED FILE, CONTENT LATER");
	     if record_code = 4 then return ("NO CONTENT SAVED");
	     return ("UNKNOW RECORD CODE "||ltrim (char (record_code)));
	end record_code_type;
%page;
unload_record: proc;

/* Unload the current data record into the Multics file. */
	     l = file_llinks_in_record;		/* Expected number of llinks to move. */
	     if (cl + l) > llinks_per_segment then do;	/* About to span a Multics segment. */
		pl, nll = llinks_per_segment - cl;	/* Fill out the segment. */
		l = l - pl;			/* Reduce llinks in record by amount moved. */
		unspec (addrel (cp, 320*cl) -> move_llinks) = /* Move initial part of record. */
		     unspec (addr (fcr.words66_nw) -> move_llinks);

/* Move to next MFS component. */
		cn = cn+1;
		if cn > hbound (c, 1) then do;	/* Exceeded MSF number of components. */
		     call com_err_ (
			code
			, "gfms_file_content_records_"
			, "Exceeded ^i maximum number allowed MSF components:"
			||"^/""^a"""
			, hbound (c, 1)
			, rtrim(wd)||rtrim(sub_dir)||">"||file_entry
			);
		     signal condition (gfms_fail);		/* FOR NOW. */
		end;

		call msf_manager_$get_ptr (		/* Obtain the next MSF component (segment). */
		     fcbp
		     , cn				/* Component number. */
		     , "1"b			/* (input) => create file if non-existent. */
		     , c (cn)
		     , bc				/* (output) bit count. */
		     , code
		     );
		if code ^= 0 then
		     if code ^= error_table_$segknown then do;
			call com_err_ (
			     code
			     , "gfms_file_content_records_"
			     , "Unable to obtain pointer to component ^i of:"
			     ||"^/""^a"""
			     , cn
			     , rtrim(wd)||rtrim(sub_dir)||">"||file_entry
			     );
			signal condition (gfms_fail);
		     end;
		cp = c (cn); cl = 0;		/* Reset to next component segment. */
	     end;
	     else pl = 0;				/* Start of data record to be moved. */
	     nll = l;				/* Number llinks to move. */
	     unspec (addrel (cp, 320*cl) -> move_llinks) = /* Move final part of record. */
		unspec (addrel (addr (fcr.words66_nw), 320*pl) -> move_llinks);
	     cl = cl + nll;				/* Curren length. */
	     return;
	end unload_record;
%page;
/*  Variables for gfms_file_content_records_:			*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  a                        fixed bin;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  bc                       fixed bin(24);
dcl  bf                       char(20)var;
dcl  c                        (0:499)ptr;
dcl  cat_ptr                  ptr init(null());
dcl  cfd                      char(200)var;
dcl  char                     builtin;
dcl  cl                       fixed bin(24); /* current length in llinks of seg */
dcl  cn                       fixed bin;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  cp                       ptr;
dcl  divide                   builtin;
dcl  END_OF_FILE		fixed bin internal static options (constant) init (3);
dcl  error_table_$end_of_info fixed bin(35) ext static;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  error_table_$namedup     fixed bin(35) ext static;
dcl  error_table_$noentry     fixed bin(35) ext static;
dcl  error_table_$no_dir      fixed bin(35) ext static;
dcl  error_table_$rqover      fixed bin(35) ext static;
dcl  error_table_$segknown    fixed bin(35) ext static;
dcl  error_table_$too_many_names fixed bin(35) ext static;
dcl  fcbp                     ptr;
dcl  fcr_space                (3906)bit(36)aligned;
dcl  file_entry               char(32);
dcl  first_warning            bit(1);
dcl  fne_ptr                  ptr init(null());
dcl  gcos_file_name           char(12)var;
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_date_               entry (bit(36) aligned) returns(char(8));
dcl  gfms_end_of_input_       entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1));
dcl  gfms_fail                condition ext;
dcl  gfms_gtss_attributes_    entry (char(186), char(32), ptr, bit(36) aligned);
dcl  gfms_print_names_        entry(fixed bin);
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  GOT_RECORD		fixed bin internal static options (constant) init (2);
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  index                    builtin;
dcl  ioa_                     entry() options(variable);
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  j                        fixed bin;
dcl  l                        fixed bin;
dcl  lbound                   builtin;
dcl  lc_uname		char (12);
dcl  length                   builtin;
dcl  llinks_per_segment       fixed bin static int options(constant)init(816);
dcl  lower                    char(26)static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  ltrim                    builtin;
dcl  min                      builtin;
dcl  mod                      builtin;
dcl  move_llinks              (nll) bit(36*320)aligned based;
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$open        entry (char(*), char(*), ptr, fixed bin(35));
dcl  nbr                      fixed bin(21);
dcl  nll                      fixed bin;
dcl  null                     builtin;
dcl  nw                       fixed bin;
dcl  nwr                      fixed bin;
dcl  pl                       fixed bin;
dcl  record_quota_overflow    condition ext;
dcl  rings                    (3)fixed bin(3)static int options(constant)init(4,4,4);
dcl  rqo_in_progress          bit(1);
dcl  rtrim                    builtin;
dcl  SKIP_FILE		fixed bin internal static options (constant) init (1);
dcl  size                     builtin;
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  sub_dir                  char(168)var;
dcl  t                        fixed bin;
dcl  translate                builtin;
dcl  unloading_file           bit(1);
dcl  unspec                   builtin;
dcl  upper                    char(26)static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  w                        (0:65)bit(36)aligned based(addr(fcr_space));
dcl  wd                       char(168)var;

dcl  hcs_$append_branchx      entry (
			char(*)
,			char(*)
,			fixed bin(5)
,			(3) fixed bin(3)
,			char(*)
,			fixed bin(1)
,			fixed bin(1)
,			fixed bin(24)
,			fixed bin(35)
			);
%page;
/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-27 FILE CONTENT RECORDS (<=3906 words)
*/
dcl 1 fcr			aligned based(addr(fcr_space))
,     3 word0
,       4 block_serial_number	fixed bin(18)unsigned unal
,       4 block_size	fixed bin(18)unsigned unal
,     3 word1
,       4 record_size	fixed bin(18)unsigned unal
,       4 b18_35		bit(18)unal
,     3 content_header
,       4 word2
,         5 record_code	fixed bin(4)unsigned unal
,         5 no_files_in_record fixed bin(4)unsigned unal /* always 1. */
,         5 serial_no_records_in_file fixed bin(4)unsigned unal
,         5 SMC_section_no	fixed bin(6)unsigned unal
,         5 RFG1		bit(18)unal /* RFG => reserved For GCOS. */
,       4 words3_4
,         5 user_name	bit(72)
,       4 word5
,         5 file_desc_sect_num fixed bin(18)unsigned unal
,         5 RFG6		bit(1)unal
,         5 abort_locked	bit(1)unal
,         5 RFG7		bit(7)unal
,         5 defective_space	bit(1)unal
,         5 RFG8		bit(7)unal
,         5 saved_while_write_busy bit(1)unal
,       4 word6
,         5 file_creation_date bit(36)
,       4 word7
,         5 time_at_create	bit(24)unal
,         5 prior_creation	bit(12)unal
,       4 word8
,         5 file_continued	bit(1)unal
,         5 file_llinks_in_record fixed bin(4)unsigned unal
,         5 RFG2		bit(1)unal
,         5 defective_llinks	bit(12)unal
,         5 RFG3		bit(18)unal
,       4 word9
,         5 part_of_file	bit(1)unal
,         5 RFG4		bit(11)unal
,         5 file_size	fixed bin(24)unsigned unal
,       4 words10_11
,         5 file_name	bit(72)
,       4 words12_13
,         5 file_name2	bit(72)
,       4 words14_64
,         5 RFG5		(14:64)bit(36)
,       4 word65
,         5 checksum	bit(36)
,     3 words66_nw		(66:nw)bit(36)
;
%page;
%include gfms_description_tree;
%page;
%include gfms_ext;
%page;
%include gfms_file_name_list;
%page;
%include query_info;
     end gfms_file_content_records_;




		    gfms_file_name_.pl1             12/11/84  1355.9rew 12/10/84  1041.9       17784



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_file_name_: proc (nf, fn)returns (bit (1));

/* Hash file name "fn" as selected or not
   selected (nf="0"b or nt="1"b).
   Return "1"b if failure.

   Author: Dave Ward	10/19/80
   Change: Dave Ward	10/30/80 provide catalog (/) and file name.
*/
dcl  fn                       char(*)parm;
dcl  nf                       bit(1)parm;
	if number_names >= hbound (file_name, 1) then do;
	     if number_names = hbound (file_name, 1) then
		call com_err_ (
		0
		, "gfms_file_name_"
		, "Exhausted ^i entries available in file name list."
		, hbound (file_name, 1)
		);
	     number_names = number_names+1;
	     return ("1"b);				/* Failure. */
	end;
	if index (fn, "/")>0 then sp = addr (cat_start);
	else sp = addr (file_start);
	uc_fn = translate (
	     fn
	     , "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
	     , "abcdefghijklmnopqrstuvwxyz"
	     );
	k = gfms_hash_ ((uc_fn), hbound (start, 1)+1);
	number_names = number_names+1;
	file_name (number_names).not = nf;
	file_name (number_names).link = start (k);
	start (k) = number_names;
	file_name (number_names).name = uc_fn;
	return ("0"b);				/* Success. */
%page;
/*   Variables for gfms_file_name_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  com_err_                 entry() options(variable);
dcl  gfms_hash_               entry (char(*), fixed bin) returns(fixed bin);
dcl  index                    builtin;
dcl  k                        fixed bin;
dcl  sp                       ptr;
dcl  start                    (0:1020)fixed bin based(sp);
dcl  translate                builtin;
dcl  uc_fn                    char(168)var;
%page;
%include gfms_do_files;
%page;
%include gfms_ext;
     end gfms_file_name_;




		    gfms_gtss_attributes_.pl1       12/11/84  1355.9rew 12/10/84  1041.9       23229



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_gtss_attributes_: proc (dir, ent, fep, date);

/* Provide gtss attributes on file dir>ent

   Author: Dave Ward	10/17/80
   Change: Dave Ward	10/30/80 fep parameter, new file name list.
   Change: Dave Ward	11/12/80 change date to a parameter.
   Change: Dave Ward	11/21/80 corrected setting mode random.
*/
dcl  date                     bit(36)aligned parm;
dcl  dir                      char(168)parm;
dcl  ent                      char(32)parm;
dcl  fep                      ptr parm;
	fnep = fep;
	gtss_file_values.version = 1;
	gtss_file_values.dname = dir;
	gtss_file_values.ename = " ";
	gtss_file_values.new_ename = ent;
	gtss_file_values.change_name = "0"b;		/* Do not change name of file. */
	gtss_file_values.set_switch.mode_random
	     , gtss_file_values.set_switch.maxll
	     , gtss_file_values.set_switch.curll
	     , gtss_file_values.set_switch.busy
	     , gtss_file_values.set_switch.attr
	     , gtss_file_values.set_switch.null_file
	     , gtss_file_values.set_switch.number_allocations
	     , gtss_file_values.set_switch.creation_date
	     = "1"b;

	gtss_file_values.data_flags.mode_random = ((file_name_entry.attr.mode & "0100"b) ^= "0"b);
	gtss_file_values.data_fields.maxll = file_name_entry.attr.max_size_llinks;
	gtss_file_values.data_fields.curll = file_name_entry.llinks;
	gtss_file_values.data_flags.busy = "0"b;
	gtss_file_values.attributes.attr = file_name_entry.user_info.value;
	gtss_file_values.data_flags.null_file = "0"b;
	gtss_file_values.data_fields.number_allocations = 0;
	gtss_file_values.creation_date = gfms_ascii_ ((date));

	call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	if code ^= 0 then
	     call com_err_ (
	     code
	     , "gfms_gtss_attributes_"
	     , "For ^a>^a."
	     , dir
	     , ent
	     );
	return;
%page;
/*   Variables for gfms_gtss_attributes_	*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  gtss_attributes_mgr_$set entry (ptr, fixed bin(35));
dcl  gfms_ascii_              entry (bit(*)) returns(char(*));
%page;
%include gfms_file_name_list;
%page;
%include gtss_file_values;
%page;
%include gfms_description_tree;
%page;
%include gfms_ext;
     end gfms_gtss_attributes_;




		    gfms_hash_.pl1                  12/11/84  1355.9rew 12/10/84  1041.9       10980



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_hash_: proc (s, m) returns (fixed bin);

/*
   Return "v" mod "m", where "v" is the binary
   value obtained by catenating the length, first
   character, middle character, and last (right)
   character of "s" (as binary values, 9 bits @).

   Author: Dave Ward	05/28/80 (from HASH.pl1)
*/
dcl  m                        fixed bin parm;
dcl  s                        char (*) parm;
	l = length (s);
	unspec (bv) =
	     substr (unspec (l), 28, 9)
	     || unspec (substr (s, 1, 1))
	     || unspec (substr (s, divide ((l+1), 2, 35, 0), 1))
	     || unspec (substr (s, l, 1));
	return ((mod (bv, m)));

dcl  bv                       fixed bin (35);
dcl  divide                   builtin;
dcl  l                        fixed bin (35);
dcl  mod                      builtin;
dcl  substr                   builtin;
dcl  unspec                   builtin;
%page;
%include gfms_ext;
     end gfms_hash_ ;




		    gfms_hash_cat_.pl1              12/11/84  1355.9rew 12/10/84  1041.9       24930



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_hash_cat_: proc (b_name, a_name, ic, ps, cs);

/* Store the catalog entry in the description tree.
   Entry is a catalog (ic="1"b) or a file (ic="0"b).
   Sector number of parent is "ps" and of child is "cs".
   The name of the entry is BCD "b_name" and equivently
   ASCII "a_name".

   Author: Dave Ward	11/08/80
*/
dcl b_name bit(72)aligned parm;
dcl a_name char(12)var parm;
dcl ic bit(1)parm;
dcl ps fixed bin(18)unsigned unal parm;
dcl cs fixed bin(18)unsigned parm;

/* Record entry name in cat array. */
	n_cat = n_cat+1;
	if n_cat > hbound (cat, 1) then do;
	     call com_err_ (
		0
		, "gfms_hash_cat_"
		, "Exhausted ^i entries of cat table."
		, hbound (cat, 1)
		);
	     signal cond (gfms_fail);
	end;
	cat (n_cat).name = b_name;			/* entry name BCD. */
	cat (n_cat).ascii_name = a_name;		/* entry name ASCII. */
	cat (n_cat).is_cat = ic;			/* catalog ("1"b) or file ("0"b) entry. */
	cat (n_cat).parent_sector = ps;		/* sector of my parent. */
	cat (n_cat).child_sector = cs;		/* sector of my child (subcatalog or file description). */

/* Hash child sector number into one of two lists
   according to whether this is a catalog entry or
   a file entry.
*/
	if ic then				/* entry is a catalog. */
	     slp = addr (start_list.cat_child);
	else					/* entry is a file. */
	slp = addr (start_list.file_child);
	k = mod (cs, hbound (slp -> start_list, 1)+1);
	j = slp -> start_list (k);
	do while (j>0);				/* Assure name not currently hashed. */
	     if cat (j).child_sector = cs then do;
		call com_err_ (
		     0
		     , "gfms_hash_cat_"
		     , "BUG, multiple occurance of ""^a"" (sector ^6i ^6.3b oct)"
		     , a_name
		     , cs
		     , unspec (cs)
		     );
		return;
	     end;
	     j = cat (j).child_link;
	end;

/* New name to enter in the hashed list. */
	cat (n_cat).child_link = slp -> start_list (k);	/* Link new name to previous hash entry. */
	slp -> start_list (k) = n_cat;		/* Link this name as the first in hash list. */
	return;
%page;
/*   Variables for gfms_hash_cat_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl gfms_fail condition ext;
dcl  com_err_ entry() options(variable);
dcl mod builtin;
dcl hbound builtin;
dcl addr builtin;
dcl  j                        fixed bin;
dcl  k                        fixed bin;
dcl  slp                      ptr;
dcl  start_list               (0:1020)fixed bin(18)unsigned based;
%page;
%include gfms_description_tree;
%page;
%include gfms_ext;
     end gfms_hash_cat_;




		    gfms_header_label_.pl1          12/11/84  1355.9rew 12/10/84  1022.4       88551



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

/* Process the tape header label.

   Author: Dave Ward	10/17/80
   Change: Dave Ward	01/27/81 signal gfms_return if attach fails.
   Change: Dave Ward	02/23/82 completed tape density algorithm (modeled after read_tape_and_query)
   Change: Ron Barstad        84-11-21 fixed subsequent tape density checking and reel sequence check
*/
	close, detach = "0"b;			/* Assume failure. */
	call attach;
	detach = "1"b;				/* detach allowed, attach completed. */
	call open;
	close = "1"b;				/* close allowed, open completed. */
	call get_density ();
	call iox_$read_record (
	     cbp					/* (input) pointer to control block. */
	     , addr (tape_label)			/* (input) record buffer. */
	     , size (tape_label)*4			/* (input) buffer length in bytes. */
	     , nbr				/* (output) number of bytes read. */
	     , code				/* (output) I/O system status. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms_header_label_"
		, "Attempting to read tape header label file."
		||"^/Tape status ^4.3b"
		||"^/buffer length ^i (bytes)."
		||"^/bytes read ^i."
		||"^/attach description ""^a"""
		, gfms_tape_status_ (cbp)
		, size (tape_label)*4
		, nbr
		, attach_description
		);
fail:	     ;
	     call gfms_dump_rec_ (
		addr (tape_label)
		, divide (nbr+3, 4, 17)
		);
	     signal cond (gfms_fail);
	end;

	if label_identifier ^= GE__600_BTL_ then do;
	     call com_err_ (
		0
		, "gfms_header_label_"
		, "Label identifier ""^12a"" not ""GE  600 BTL """
		, gfms_ascii_ ((label_identifier))
		);
	     goto fail;
	end;

	prn = gfms_ascii_ ((prverr));			/* Previous reel number in error. */
	reel_serial = gfms_ascii_ ((reel_serial_number));
	file_serial = gfms_ascii_ ((file_serial_number));
	reel_sequence = gfms_ascii_ ((reel_sequence_number));

	if file_serial_num = " " then do;		/* Initialize saved label information. */
	     reel_serial_num = reel_serial;
	     file_serial_num = file_serial;
	     reel_sequence_num = (6)"0";
	end;
	call validate_label;

	call ioa ("^|HEADER LABEL INFORMATION:");
	call ioa ("label_identifier^6(.^) ""GE  600 BTL """);
	call ioa ("installation_id^7(.^) ^a", gfms_ascii_ ((installation_id)));
	call ioa ("reel_serial_number^4(.^) ^a", reel_serial);
	call ioa ("file_serial_number^4(.^) ^a", file_serial);
	call ioa ("reel_sequence_number^2(.^) ^a", reel_sequence);
	string (yyddd) = gfms_ascii_ ((creation_date));
	call ioa ("creation_date^9(.^)  year "||year||"  day-of-year "||day_of_year);
	call ioa ("retention_days^8(.^) ^a", gfms_ascii_ ((retention_days)));
	call ioa ("file_name^13(.^) ^a", gfms_ascii_ ((file_name)));
	call ioa ("user_info^13(.^) ^a", gfms_ascii_ ((user_info)));
	call ioa ("prverr^16(.^) ^a", prn);

/* Position to the file after the label file. */
	call iox_$control (
	     cbp					/* (input) pointer to I/O switch. */
	     , "forward_file"			/* (input) control order. */
	     , null ()				/* (input) NOT USED FOR THIS ORDER. */
	     , code				/* (output) I/O status code. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms"
		, "positioning to file after header label. description^/^c"
		, attach_description
		);
	     goto fail;
	end;
	return;
%page;
attach:	proc;

/* Attach I/O switch "gfms_input" to I/O module tape_nstd_.
*/
	     call iox_$attach_name (
		"gfms_input"			/* (input) I/O switch name. */
		, cbp				/* (output) pointer to switch's control block. */
		, attach_description		/* (input) attach description. */
		, null ()				/* (input) usual search rules to find tape_nstd_. */
		, code				/* (output) I/O system status code. */
		);
	     if code = 0 then return;
	     call com_err_ (
		code
		, "gfms"
		, "attaching with description^/^a"
		, attach_description
		);
	     signal cond (gfms_return);

dcl  code                     fixed bin(35);
dcl  iox_$attach_name         entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl  null                     builtin;
	end attach;
%page;
get_density: proc;

/* Determine the density of the input tape
   by successively trying tape densities until
   successful.
   If failure report, close and detach.
*/
	     ad = "";
	     do i = ftd to ltd;
		ad = ad||tape_densities (i);
		call iox_$control (
		     cbp				/* (input) pointer to I/O switch. */
		     , "d"||tape_densities (i)	/* (input) set tape density control order. */
		     , null ()			/* (input) NOT USED FOR THIS ORDER. */
		     , code			/* (output) I/O status code. */
		     );
		if code = 0 then do;		/* Able to open at density d(i). */
		     call iox_$read_record (		/* Attempt to read at the density set. */
			cbp			/* (input) pointer to control block. */
			, addr (tape_label)		/* (input) record buffer. */
			, size (tape_label)*4	/* (input) buffer length in bytes. */
			, nbr			/* (output) number of bytes read. */
			, code			/* (output) I/O system status. */
			);
		     call iox_$control (		/* Rewind the tape. */
			cbp
			, "rewind"
			, null ()
			, (0)			/* Status code. Ignored. */
			);
		     if code = 0 then		/* Able to read at the density. */
			return;			/* Success. */
		end;
	     end;
	     call com_err_ (
		code
		, "gfms"
		, "unable to set any density (^a) description^/^a"
		, ad
		, attach_description
		);
	     call gfms_close_;
	     call gfms_detach_;
	     goto fail;

dcl  ad                       char(25)var;
dcl  code                     fixed bin(35);
dcl  i                        fixed bin;
dcl  iox_$control             entry (ptr, char(*), ptr, fixed bin(35));

%include gfms_tape_densities;
	end get_density;
%page;
open:	proc;

/* Open I/O switch.
*/
	     call iox_$open (
		cbp				/* (input) pointer to control block. */
		, 4				/* (input) sequential input. */
		, "0"b				/* (input) UNUSED. */
		, code
		);
	     if code = 0 then return;
	     call com_err_ (
		code
		, "gfms"
		, "sequential input opening for attach description^/^a"
		, attach_description
		);
	     call gfms_detach_;
	     goto fail;

dcl  code                     fixed bin(35);
dcl  iox_$open                entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
	end open;
%page;
validate_label: proc;

/* Validate that label is consistant with previous label. */
	     if file_serial ^= file_serial_num then do;
		call com_err_ (
		     0
		     , "gfms_header_label_"
		     , "Current reel ^a, sequence number ^a, in file ^a"
		     ||"^/Expecting file ^a(reel ^a, sequence ^a)."
		     , file_serial
		     , reel_sequence
		     , reel_serial
		     , file_serial_num
		     , reel_serial_num
		     , reel_sequence_num
		     );
		goto fail;
	     end;
	     if verify (ltrim (reel_sequence), "0123456789")>0 then do;
		call com_err_ (
		     0
		     , "gfms_header_label_"
		     , "Reel sequence number ""^a"" not all numeric."
		     , reel_sequence
		     );
		goto fail;
	     end;
	     if prn = " " then			/* preceding EOR label not erroneous. */
		if fixed (substr(reel_sequence,2), 17) ^= (fixed (substr(reel_sequence_num,2), 17)+1) then do;
		     call com_err_ (
			0
			, "gfms_header_label_"
			, "Reel ^a (file ^a) out of sequence."
			||"^/last sequence ^a, current sequence ^a."
			, reel_serial
			, file_serial
			, reel_sequence_num
			, reel_sequence
			);
		     goto fail;
		end;
		else
		if reel_serial ^= reel_serial_num then do;
		     call com_err_ (
			0
			, "gfms_header_label_"
			, "File ^a sequence number ^a reel serial ^a, expected reel serial ^a."
			, file_serial
			, reel_sequence
			, reel_serial
			, reel_serial_num
			);
		     call command_query_$yes_no (yes, 0, "gcos_fms",
			"Do you want to ignore the reel serial mismatch and process the mounted tape next?",
			"Ignore?");
		     if ^yes then goto fail;
		end;
	     return;
	end validate_label;
%page;
/*   Variables for gfms_header_label_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  command_query_$yes_no    entry() options(variable);
dcl  divide                   builtin;
dcl  file_serial              char(6);
dcl  GE__600_BTL_             bit(72)static int options(constant)init("272520200600002022634320"b3);
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_close_              entry;
dcl  gfms_detach_             entry;
dcl  gfms_dump_rec_           entry (ptr, fixed bin);
dcl  gfms_fail                condition ext;
dcl  gfms_return              condition ext;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  ioa_                     entry() options(variable);
dcl  iox_$control             entry (ptr, char(*), ptr, fixed bin(35));
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  nbr                      fixed bin(21);
dcl  prn                      char(6);
dcl  reel_sequence            char(6);
dcl  reel_serial              char(6);
dcl  size                     builtin;
dcl  yes                      bit(1);

/* See DD07 (April 1974) FILE AND RECORD CONTROL
   Page 11-2 standard label format.
*/
dcl 1 tape_label		aligned
,     3 label_identifier	bit(72)
,     3 installation_id	bit(36)
,     3 reel_serial_number	bit(36)
,     3 file_serial_number	bit(36)
,     3 reel_sequence_number	bit(36)
,     3 creation_date	bit(36)
,     3 retention_days	bit(36)
,     3 file_name		bit(72)
,     3 user_info		bit(108)
,     3 prverr		bit(36)
;

dcl 1 yyddd		aligned
,     3 blank		char(1)unal
,     3 year		char(2)unal
,     3 day_of_year		char(3)unal
;
%page;
%include gfms_ext;
     end gfms_header_label_;




		    gfms_input_file_list_.pl1       12/11/84  1355.9rew 12/10/84  1041.9       29205



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_input_file_list_: proc (fn)returns (bit (1));

/* Obtain list of names from input file "fn[.gfms]".
   File contains list of gcos catalog/file
   descriptions optionally preceeded by "^" (not)
   character indicating file is not o be selected.
   Return "1"b if failure occurs.

   Author: Dave Ward	10/19/80
*/
dcl  fn                       char(*)parm;
	call expand_pathname_$add_suffix (
	     fn					/* (input) pathanme. */
	     , "gfms"				/* (input) suffix name. */
	     , dir				/* (output) directory. */
	     , ent				/* (output) entry name. */
	     , code				/* (output) eror code. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms_input_file_list_"
		, "Could not expand ""^a"""
		, fn
		);
	     return ("1"b);				/* Failed. */
	end;

	call hcs_$initiate_count (			/* Obtain input file. */
	     dir					/* (input) directory name. */
	     , ent				/* (input) entry name. */
	     , ""					/* (input) null reference name. */
	     , bc					/* (output) file's bit count. */
	     , 1					/* (input) not a copy. */
	     , fp					/* (output) pointer to input file. */
	     , code				/* (output) status code. */
	     );
	if fp = null () then do;
	     call com_err_ (
		code
		, "gfms_input_file_list_"
		, "Input file ""^a>^a"""
		, dir
		, ent
		);
	     return ("1"b);				/* Failed. */
	end;

/* Process names from input file. */
	il = divide (bc+8, 9, 24);
	nc = 1;
dcl f bit(1)init("0"b);
	do while (nc <= il);
	     k = index (substr (is, nc), NL);
	     if k = 0 then nc = il-nc+2;
	     if k>1 then do;			/* Non-null line. */
		n = "0"b;				/* => no "^". */
		if k>2 then do;
		     if substr (is, nc, 1) = "^" then do;
			n = "1"b;			/* => "^"file. */
			nc = nc+1;
			k = k-1;
		     end;
		end;
		if gfms_file_name_ (n, substr (is, nc, k-1)) then f = "1"b;
	     end;
	     nc = nc+k;
	end;
	return (f);
%page;
/*   Variables for gfms_input_file_list_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  bc                       fixed bin(24);
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  dir                      char(168);
dcl  ent                      char(32);
dcl  expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  fp                       ptr;
dcl  gfms_file_name_          entry (bit(1), char(*)) returns(bit(1));
dcl  hcs_$initiate_count      entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35));
dcl  il                       fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  is                       char(il)aligned based(fp);
dcl  k                        fixed bin;
dcl  n                        bit(1);
dcl  nc                       fixed bin(24);

dcl  NL                       char(1)static int options(constant)init("
");
%page;
%include gfms_do_files;
%page;
%include gfms_ext;
     end gfms_input_file_list_;




		    gfms_print_names_.pl1           12/11/84  1355.9rew 12/10/84  1022.4       79965



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_print_names_: proc (n);

/* Sort and print file names (n names)

   Author: Dave Ward	10/10/80
   Change: Dave Ward	10/15/80 totals.
   Change: Dave Ward	10/16/80 separate file name and catalog.
   Change: Dave Ward	10/30/80 reel, date time header.
   Change: Dave Ward	11/11/80 bug in sort comparison routine.
   Change: Dave Ward	11/18/80 periods in attributes and defect display.
*/
dcl  n                        fixed bin parm;
	j = 1;					/* Index to first start entry. */
	do i = 1 to n;				/* Prepare index to file name entries. */
	     fnep = addr (start_entry (j));		/* Locate next file name entry. */
	     sa (i) = j;				/* j => index to entry. */
	     j = j + size (file_name_entry);
	end;
	if prfn then do;
	     call SORT ((n), sa, cmp);

/* Print in sorted order. */
	     if dump then call ioa_$nnl ("^|");		/* New page if dumping or printing tree. */
	     call date_time_ (clock_ (), dt);
	     call ioa_ (
		"gcos_fms  (version ^a)"
		||"^/tape reel ^a  ^a"
		, version
		, file_serial_num
		, dt
		);
	     call ioa_ (
		"^/"				/* Skip line after header. */
		|| "^23tS sequential file"
		||"^/^23tR random"
		||"^/^23tA ascii"
		||"^/^23tI I-D-S"
		||"^/"
		||"              maximum v|     user        defect       file" /* 1st header line. */
		||"^/"				/* Skip a line. */
		||"      llinks   llinks mode  information code         name         catalog" /* 2nd header line. */
		);
	     print_name, last_name = " ";
	     do i = 1 to n;
		fnep = addr (start_entry (sa (i)));	/* Located next file name entry in sorted order. */
		if file_name_entry.name = last_name then print_name = " ";
		else print_name, last_name = file_name_entry.name;
		l = length (file_name_entry.defective);
		call ioa_ (
		     "^4i."			/* name count. */
		     ||"^7i"			/* current size. */
		     ||"^[ no limit^s^;^9i^]"		/* max size. */
		     ||"^1x^4a"			/* mode */
		     ||"^1x^[^12.3b^;^6( .^)^s^]"	/* user info. */
		     ||"^1x^[^va^;.^s^s^]^va"		/* defective. */
		     ||"^1x^12a"			/* file name. */
		     ||"^1x^a"			/* catalog */
		     , i
		     , file_name_entry.llinks
		     , file_name_entry.attr.max_size_llinks = 0, file_name_entry.attr.max_size_llinks
		     , md (file_name_entry.attr.mode)
		     , file_name_entry.attr.present, file_name_entry.attr.value
		     , l>0, l, file_name_entry.defective, 12-max (1, l), substr ((6)" .", 1, 12-max (1, l))
		     , print_name
		     , file_name_entry.catalog
		     );
	     end;
	     if tll then
		call ioa_ (
		"TOTAL^7i"
		, total_llinks
		);
	end;
	else
	if tll then
	     call ioa_ (
	     "^6i llinks ^6i files."
	     , total_llinks
	     , n
	     );
	return;
%page;
cmp:	proc (i1, i2)returns (fixed bin);

/* Compare 2 file name entries to determine sorted order. */
dcl  i1                       fixed bin parm;
dcl  i2                       fixed bin parm;
	     p1 = addr (start_entry (i1));
	     p2 = addr (start_entry (i2));
	     if f1.name < f2.name then return (0);
	     if f1.name > f2.name then return (1);
	     if f1.catalog < f2.catalog then return (0);
	     if f1.catalog > f2.catalog then return (1);
	     if f1.llinks < f2.llinks then return (0);
	     if f1.llinks > f2.llinks then return (1);
	     return (0);
dcl  p1                       ptr;
dcl  p2                       ptr;

dcl 1 f1			aligned based(p1)
,     3 llinks		fixed bin(24)	/* llinks in file. */
,     3 attr		like description_tree.attributes
,     3 char_length				/* Lengths of variable. */
,       4 defl		fixed bin
,       4 naml		fixed bin
,       4 catl		fixed bin
,     3 defective		char(f1.char_length.defl)unal
,     3 name		char(f1.char_length.naml)unal
,     3 catalog		char(f1.char_length.catl)unal
;

dcl 1 f2			aligned based(p2)
,     3 llinks		fixed bin(24)	/* llinks in file. */
,     3 attr		like description_tree.attributes
,     3 char_length				/* Lengths of variable. */
,       4 defl		fixed bin
,       4 naml		fixed bin
,       4 catl		fixed bin
,     3 defective		char(f2.char_length.defl)unal
,     3 name		char(f2.char_length.naml)unal
,     3 catalog		char(f2.char_length.catl)unal
;
	end cmp;
%page;
md:	proc (m)returns (char (4));

/* Evaluate mode m. */
dcl  m                        bit(4)unal parm;
	     r = " ";
	     if m & "1000"b then substr (r, 1, 1) = "S";	/* Sequential. */
	     if m & "0100"b then substr (r, 2, 1) = "R";	/* Random. */
	     if m & "0010"b then substr (r, 3, 1) = "A";	/* ASCII. */
	     if m & "0001"b then substr (r, 4, 1) = "I";	/* IDS. */
	     return (r);

dcl  r                        char(4);
	end md;
%page;
SORT:	proc (len, lst, cmp);

/*
   _l_s_t, of length _l_e_n, is the ordering of the
   data to be sorted. Using the comparison procedure
   _c_m_p, return _l_s_t ordered according to the comparisons.

   _c_m_p has two input parameters. These are two entries from
   the _l_s_t that point to the next two data elements to
   be sorted. If the data element pointed to by the first parameter
   is "next" then _c_m_p returns a zero, 0, else returns a one, 1.

   Author: Dave Ward	06/16/80
*/
dcl  cmp                      entry(fixed bin,fixed bin) returns(fixed bin) parameter;
dcl  len                      fixed bin parameter;
dcl  lst                      (*) fixed bin parameter;

/*
   calculate the lengths of
   lists and their start pointers
   in a linear set.
*/
	     if len<2 then return;
	     t = 0;
	     l = len;
	     do n = 1 by 1 while (l>1);
		s (n) = t;			/* start of the next list. */
		if mod (l, 2) = 1 then l = l+1;	/* make the length even. */
		t = t+l;				/* accumulate the lengths. */
		l = l/2;				/* next list is 1/2 the length of the present list. */
	     end;
	     n = n-1;

	     begin;				/* Local block. */
/* pointers to input list. */
		do i = 1 to len;
		     m (i) = i;
		end;

/* fill in all lists. */
		do i = 2 to n;
		     lft = s (i-1);
		     rit = s (i) ;
		     do j = 1 by 2 to (rit - lft);
			x = lft+j;
			v1 = m (x);
			v2 = m (x+1);
			if v2>0 then
			     if cmp (lst (v1), lst (v2)) = 1 then v1 = v2;
			rit = rit+1;
			m (rit) = v1;
		     end;
		end;


/* calculate the list of pointers in o */
		y = s (n)+1;
		do i = 1 to len;
		     v1 = m (y);
		     v2 = m (y+1);
		     if (v1 = 0) & (v2 = 0) then i = len; /* End "i" loop. */
		     else do;
			if v1 = 0 then v1 = v2;
			else if v2>0 then
			     if cmp (lst (v1), lst (v2)) = 1 then v1 = v2;
			o (i) = lst (v1);		/* next output value. */
			m (v1) = 0;		/* delete the last winner. */
			do j = 2 to n;		/* get the next winner. */
			     lft = s (j-1);
			     if mod (v1, 2) = 1 then v2 = v1+1; else v2 = v1-1;
			     x = (v1+1)/2;
			     v1 = m (v1+lft);
			     v2 = m (v2+lft);
			     if v1 = 0 then v1 = v2;
			     else if v2>0 then
				if cmp (lst (v1), lst (v2)) = 1 then v1 = v2;
			     m (x+s (j)) = v1;
			     v1 = x;
			end;
		     end;
		end;
		i = i-1;
		len = i;				/* output the length of the output list. */
		do i = 1 to i;			/* copy over the output list. */
		     lst (i) = o (i);
		end;
						/* Declarations for local block. */
dcl  m                        (t) fixed bin init((t)0);
dcl  o                        (len) fixed bin;
	     end;					/* Local block. */

						/* Global declarations. */
dcl  i                        fixed bin;
dcl  j                        fixed bin;
dcl  l                        fixed bin;
dcl  lft                      fixed bin;
dcl  mod                      builtin;
dcl  n                        fixed bin;
dcl  rit                      fixed bin;
dcl  s                        (36)fixed bin	/* Indices to "bottoms" of lists. */;
dcl  t                        fixed bin;
dcl  v1                       fixed bin;
dcl  v2                       fixed bin;
dcl  x                        fixed bin;
dcl  y                        fixed bin;
	end SORT;
%page;
/*   Variables for gfms_print_names_:	*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  clock_                   entry() returns(fixed bin(71));
dcl  date_time_               entry (fixed bin(71), char(*));
dcl  dt                       char(24);
dcl  i                        fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  j                        fixed bin;
dcl  l                        fixed bin;
dcl  last_name                char(12);
dcl  print_name               char(12);
dcl  sa                       (n)fixed bin;
%page;
%include gfms_file_name_list;
%page;
%include gfms_ext;
%page;
%include gfms_description_tree;
%page;
%include gfms_version;
     end gfms_print_names_;




		    gfms_serial_number_record_.pl1  12/11/84  1355.9rew 12/10/84  1041.9       30078



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

/* Display tape serial number record information.

   Author: Dave Ward	10/01/80
*/
	call iox_$read_record (
	     cbp					/* (input) pointer to control block. */
	     , addr (tsnr)				/* (input) record buffer. */
	     , size (tsnr)*4			/* (input) buffer length in bytes. */
	     , nbr				/* (output) number of bytes read. */
	     , code				/* (output) I/O system status. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms_serial_number_record_"
		, "Attempting to read tape serial number record."
		||"^/Tape status ^4.3b"
		||"^/buffer length ^i (bytes)."
		||"^/bytes read ^i."
		||"^/attach description ""^a"""
		, gfms_tape_status_ (cbp)
		, size (tsnr)*4
		, nbr
		, attach_description
		);
fail:	     ;
	     signal cond (gfms_fail);
	end;

	call ioa ("^|TAPE SERIAL NUMBER RECORD INFORMATION (block 1):");
	if word0.b00_17 = 1				/* Must be block 1 of record. */
	& word0.b18_35 = 65
	& word1.b00_17 = 64
	& word1.b18_35 = "000017"b3 then do;		/* Expected constants. */
	     call ioa ("serial number of copy this volume ^a", gfms_ascii_ ((word2)));
	     call ioa ("serial number of latest journal tape ^a", gfms_ascii_ ((word2)));
	end;
	else do;					/* Constant(s) improper. */
	     call com_err_ (
		0
		, "gfms_serial_number_record_"
		, "serial number record constants not as expected."
		);
	     call gfms_dump_rec_ (
		addr (tsnr)
		, divide (nbr+3, 4, 17)
		);
	     goto fail;
	end;
	return;
%page;
/*  Variables for gfms_serial_number_record_:			*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_dump_rec_           entry (ptr, fixed bin);
dcl  gfms_fail                condition ext;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  j                        fixed bin;
dcl  nbr                      fixed bin(21);
dcl  size                     builtin;
dcl  word                     (0:size(tsnr)-1)bit(36)aligned based(addr(tsnr));

/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-24 TAPE SERIAL NUMBER RECORD (66 words)
*/
dcl 1 tsnr		aligned
,     3 word0		/* File and Record Control BCW. */
,       4 b00_17		fixed bin(18)unsigned unal
,       4 b18_35		fixed bin(18)unsigned unal
,     3 word1		/* File and Record Control RCW. */
,       4 b00_17		fixed bin(18)unsigned unal
,       4 b18_35		bit(18)unal
,     3 word2		bit(36) /* tape serial number of copy of vol. */
,     3 word3		bit(36) /* tape serial number of latest journal tape. */
,     3 words4_65		(4:65)bit(36) /* Reserved for GCOS. */
;
%page;
%include gfms_ext;
     end gfms_serial_number_record_;




		    gfms_smc_records_.pl1           12/11/84  1355.9rew 12/10/84  1042.0       75564



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

/* Display SMC records information.

   Author: Dave Ward	10/02/80
   Change: Dave Ward	10/20/80 verify EOF record.
   Change: Dave Ward	11/05/80 add type 6 cat info to tree.
   Change: Dave Ward	11/08/80 hash catalog.
   Change: Ron Barstad        11/24/82 fix bug preventing unload of master save
	                             --must ignore type "77"b3  records
*/

	call ioa ("^|SMC RECORDS INFORMATION:");
	tc = 0;					/* Total count of catalog records. */
	do i = 1 by 1 while (get_rec ());
	     call ioa (
		"^6i. (block^6i)  size^6i  record-size^6i"
		, i
		, block_serial_number
		, block_size
		, record_size
		);

/* Display smc records. */
	     rl = nw-1;				/* Remaining length (words) for catalog records. */
	     if mod (rl, size (gfms_catrec_6)) ^= 0 then do;
		call com_err_ (
		     0
		     , "gfms_smc_records_"
		     , "Not modulo (^i) number of words for catalog records (^i)"
		     , size (gfms_catrec_6)
		     , rl
		     );
fail:		;
		signal cond (gfms_fail);
	     end;

/* Set pointer to initial catalog record. */
	     cat_ptr = addr (type6_records);

	     do while (rl>0);
		tc = tc+1;			/* Catalog record count. */
		call ioa ("^8x[^6i] type 6 catalog.", tc);
		if gfms_catrec_6.type = "77"b3 then goto cont;
		if gfms_catrec_6.type ^= "06"b3 then do;
		     call com_err_ (
			0
			, "gfms_smc_records_"
			, "SMC NOT TYPE 6 RECORD"
			);
		     call gfms_dump_rec_ (cat_ptr, 64);
		     goto fail;
		end;

		do j = 1 to hbound (smc_entry, 1);	/* Process type 6 catalog smc entries. */
		     if (smc_name (j) = "0"b) | (smc_name (j) = (12)"20"b3) then goto cont;
		     call cat_6_entry (
			j
			, gfms_catrec_6.dupl_sector_no
			, addr (gfms_catrec_6.smc_entry (j))
			);
		end;
cont:		;
		if j = 1 then call ioa ("^17xNO ENTRIES.");

		rl = rl - size (gfms_catrec_6);
		if rl > 0 then
		     cat_ptr = addrel (cat_ptr, size (gfms_catrec_6));
	     end;
	end;
	return;
%page;
cat_6_entry: proc (j, ps, smcep);

/* Provide tree description information from type 6 catalog
   smc entry. "j" is index to entry. "ps" is parent sector,
   "smcep" locates smc entry.
*/
dcl  j                        fixed bin parm;
dcl  ps                       fixed bin(18)unsigned unal parm;
dcl  smcep                    ptr parm;
	     n = rtrim (gfms_ascii_ ((smce.smc_name)));
	     call ioa (
		"^17x^1i. ^12a ^[^^on-device^; on-device^] cat-0-sector ^6i"
		||"^/^20xparent ^6i cat-llinks ^6i allowed ^2.3b llinks-in-use ^6i max-llinks ^[unlimited^s^;^6i^]"
/* line 1 values. */
		, j
		, n
		, smce.umc_on_device
		, smce.umc_llink*5			/* sector of child (type 0 catalog). */
/* line 2 values. */
		, ps				/* sector or parent. */
		, smce.catalog_llinks
		, string (smce.smc_perms)
		, smce.llinks_in_use
		, smce.llinks_allowed = 0
		, smce.llinks_allowed
		);

	     call gfms_hash_cat_ (
		smce.smc_name			/* (input) name BCD. */
		, n				/* (input) name ASCII. */
		, "1"b				/* (input) entry is catalog. */
		, ps				/* (input) sector of parent. */
		, smce.umc_llink*5			/* (input) sector of child. */
		);
	     return;

dcl  n                        char(12)var;
dcl 1 smce aligned based(smcep) like gfms_catrec_6.smc_entry;
	end cat_6_entry;
%page;
get_rec:	proc returns (bit (1));

/* Obtain the next SMC record from tape.
   Return "0"b when record read is the EOF record
   (position past the EOF record).
   Return "1"b when SMC record read.
*/
	     call iox_$read_record (
		cbp				/* (input) pointer to control block. */
		, addr (smc_space)			/* (input) record buffer. */
		, size (smc_space)*4		/* (input) buffer length in bytes. */
		, nbr				/* (output) number of bytes read. */
		, code				/* (output) I/O system status. */
		);
	     if code ^= 0 then
		if code = error_table_$end_of_info then
		     if gfms_end_of_input_ (
		     addr (smc_space)		/* (input) pointer to input buffer. */
		     , size (smc_space)*4		/* (input) length of buffer (bytes). */
		     , nbr			/* (input/output) current number bytes in buffer. */
		     ) then do;			/* No more tape input. */
			call com_err_ (
			     0
			     , "gfms_substructure_records_"
			     , "End of tape input reached in SMC records."
			     );
			signal cond (gfms_fail);
		     end;
		     else goto cont;		/* Next reel in process. */
		else
		if code ^= error_table_$long_record then do;
		     call com_err_ (
			code
			, "gfms_smc_records_"
			, "Attempting to read smc record."
			||"^/Tape status ^4.3b"
			||"^/buffer length ^i (bytes)."
			||"^/bytes read ^i."
			||"^/attach description ""^a"""
			, gfms_tape_status_ (cbp)
			, size (smc_space)*4
			, nbr
			, attach_description
			);
fail:		     ;
		     signal cond (gfms_fail);
		end;

/* Assure length in words is conistent. */
cont:	     ;
	     if mod (nbr, 4) ^= 0 then
		call com_err_ (
		0
		, "gfms_smc_records_"
		, "Bytes read (^i) not word modulo, will truncate to word and continue."
		, nbr
		);
	     nwr = divide (nbr, 4, 17);		/* Number of words read. */
	     nw = nwr-1;				/* upper bound of smc structure. */
	     if nw < 2 then do;
		call com_err_ (
		     0
		     , "gfms_smc_records_"
		     , "Record ^i bytes long (<2 words)"
		     , nbr
		     );
		goto fail;
	     end;

/* Determine if EOF record reached. */
	     if smc.eof_mark = "170017"b3 then do;
		p = addr (smc_space);
		if p -> k65 ^= 65
		| p -> k64 ^= 64
		| p -> EOF_number ^= 1 then
		     call com_err_ (
		     0
		     , "gfms_smc_records_"
		     , "Faulty EOF record. Continuing."
		     ||"^/1st 4 words:^4( ^12.3b^)"
		     , unspec (p -> EOF_record.word0)
		     , unspec (p -> EOF_record.word1)
		     , unspec (p -> EOF_record.word2)
		     , unspec (p -> EOF_record.word3)
		     );
		call ioa (
		     "^6i. (block^6i) EOF record."
		     , i
		     , p -> EOF_record.bsn
		     );
		return ("0"b);
	     end;
	     return ("1"b);

dcl  p                        ptr;
%include gfms_EOF_record;
	end get_rec;
%page;
/*  Variables for gfms_smc_records_:			*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  cat_ptr                  ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  divide                   builtin;
dcl  error_table_$end_of_info fixed bin(35) ext static;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_dump_rec_           entry (ptr,fixed bin);
dcl  gfms_end_of_input_       entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1));
dcl  gfms_fail                condition ext;
dcl  gfms_hash_cat_           entry (bit(72) aligned, char(12) var, bit(1), uns fixed bin(18) unal, uns fixed bin(18));
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  j                        fixed bin;
dcl  mod                      builtin;
dcl  nbr                      fixed bin(21);
dcl  null                     builtin;
dcl  nw                       fixed bin;
dcl  nwr                      fixed bin;
dcl  rl                       fixed bin;
dcl  rtrim                    builtin;
dcl  size                     builtin;
dcl  smc_space                (3842)bit(36)aligned;
dcl  string                   builtin;
dcl  tc                       fixed bin;
dcl  unspec                   builtin;
dcl  w                        (0:63)bit(36)aligned based(cat_ptr);
%page;
/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-25 SMC RECORDS (<=3842 words)
*/
dcl 1 smc			aligned based(addr(smc_space))
,     3 word0
,       4 block_serial_number	fixed bin(18)unsigned unal
,       4 block_size	fixed bin(18)unsigned unal
,     3 word1
,       4 record_size	fixed bin(18)unsigned unal
,       4 eof_mark		bit(18)unal
,     3 words2_3841
,       4 type6_records	(2:nw)bit(36)
;
%page;
%include gfms_catrec_6;
%page;
%include gfms_ext;
     end gfms_smc_records_;




		    gfms_substructure_records_.pl1  09/20/89  1352.4rew 09/20/89  1351.1      204039



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-05-11,RBarstad), approve(89-09-19,MCR8117),
     audit(89-06-26,Parisek), install(89-09-20,MR12.3-1069):
     Allowed for catalog descriptors (type 1) to be out of sequence.
     This is possible from a fragmented file system.
                                                   END HISTORY COMMENTS */


gfms_substructure_records_: proc ();

/* Display SUBSTRUCTURE records information.

   Author: Dave Ward	10/28/80
   Change: Dave Ward	11/07/80 print parent sector of type 0 cat.
   Change: Dave Ward	11/11/80 carry parent sector from 0 to 1 cat records.
   Change: Dave Ward	01/28/81 allow unfound parent sector.
   Change: Ron Barstad        12/23/82  Fixed several bugs:
                                         1. skipping catalog entries after first null entry
                                        2. treating empty(type 63) catalog records as error-
                                           this prevented processing of dontdo and doonlys and single cat or file saves

*/

	call ioa ("^|SUBSTRUCTURE RECORDS INFORMATION:");
	bc					/* Count of blocks. */
	     , e					/* Count of total empty catalog records. */
	     , tc					/* Total count of catalog records. */
	     , rl					/* => require a new input record (see scan). */
	     = 0;
	unspec (parent_list) = "0"b;
	call scan;
	if scan_ss then do;
	     call gfms_dump_description_tree_;
	     signal cond (gfms_fail);
	end;
	return;
%page;
cat_0_1_entry: proc (ps, cel, ep);

/* Store the catalog entries (files or subcatalogs)
   in the description tree. Link entries back to
   the parent catalog (at tree cat entry "fcl").
*/
dcl  cel                      fixed bin parm;
dcl  ep                       ptr parm;
dcl  ps                       fixed bin(18)unsigned unal parm;
	     if ps = 0 then return;                       /* there is no parent */
	     cep = ep;				/* Pointer to initial name entry in catalog. */
	     do i = 1 to cel;
		if (ce.name = "0"b) | (ce.name = (12)"20"b3) then goto cont; /* skip on null or blank entry name. */

		n = rtrim (gfms_ascii_ ((ce.name)));	/* n => name of this entry. */
		ic = ce.entry_is_catalog;		/* Entry is a subcatalog. */
		cs = ce.description_sector_org;	/* Sector where my child is found. */
		call ioa (
		     "^12x^2i. ^12a ^[^^on-device^; on-device^] ^[catalog^;   file^] ^6i"
		     , i
		     , n
		     , ce.not_on_this_device
		     , ic
		     , cs
		     );

		call gfms_hash_cat_ (
		     ce.name			/* entry name BCD. */
		     , n				/* entry name ASCII. */
		     , ic				/* "1"b=> catalog, "0"b=> file. */
		     , ps				/* sector number of parent. */
		     , cs				/* sector number of child. */
		     );
cont:		;
		if i < cel then			/* Position to the next name entry. */
		     cep = addrel (cep, size (ce));
	     end;
	     return;
dcl  cs                       fixed bin(18)unsigned;
dcl  gfms_hash_cat_           entry (bit(72) aligned, char(12) var, bit(1), uns fixed bin(18) unal, uns fixed bin(18));
dcl  i                        fixed bin;
dcl  ic                       bit(1);
dcl  n                        char(12)var;
	end cat_0_1_entry;
%page;
cat_2_entry: proc;

/* Record descriptor information and
   link it to its catalog structure (in the
   description tree). Optionally display this
   (type 2 catalog) information.
*/
	     call ioa ("^8x^3i type 2 file description record.", tc);
/* Obtain next desc entry. */
	     n_desc = n_desc+1;
	     if n_desc > hbound (description, 1) then do;
		call com_err_ (
		     0
		     , "gfms_substructure_records_"
		     , "Exhausted ^i entries of desc table."
		     , hbound (description, 1)
		     );
		signal cond (gfms_fail);
	     end;
	     description (n_desc).name = gfms_catrec_2.filename;
	     s, description (n_desc).sector = gfms_catrec_2.dupl_sector_no;

/* Hash the sector number in the desc list. */
	     k = mod (s, hbound (start_list.desc, 1)+1);
	     i = start_list.desc (k);
	     do while (i>0);			/* Assure sector number unique. */
		if description (i).sector = s then do;
		     call com_err_ (
			0
			, "gfms_substructure_records_"
			, "BUG, duplicate entries in desc list (^i sector no.)"
			||"^/file ^12a smc ^12a"
			, s
			, gfms_ascii_ ((gfms_catrec_2.filename))
			, gfms_ascii_ ((gfms_catrec_2.SMC_name))
			);
		     return;
		end;
		i = description (i).link;
	     end;

/* s is a new sector number entry. */
	     description (n_desc).link = start_list.desc (k); /* Link to previous chain. */
	     start_list.desc (k) = n_desc;		/* Link new sector number to start of chain. */

	     call ioa (
		"^12x"
		||"file ^12a "
		||"smc ^12a "
		||"created by ^12a "
		||"on ^a"
		, gfms_ascii_ ((gfms_catrec_2.filename))
		, gfms_ascii_ ((gfms_catrec_2.SMC_name))
		, gfms_ascii_ ((gfms_catrec_2.creator_name))
		, gfms_date_ (gfms_catrec_2.create_date)
		);

/* Sector number of descriptor. */
	     call ioa_nnl ("^12xdesc-sect^6i", s);

/* Maximum file size. */
	     if max_size_in_llinks then
		description (n_desc).max_size_llinks = maximum_file_size;
	     else
	     description (n_desc).max_size_llinks = maximum_file_size * 12; /* 12 llinks = link. */
	     if maximum_file_size = 0 then
		call ioa_nnl ("^1xmax-file-size UNLIMITED");
	     else
	     call ioa_nnl (
		"^1xmax-file-size ^i "
		||"^[ llinks^;  links^]"
		||"^[ orig-file-written^; orig-file-not-written^]"
		, maximum_file_size
		, max_size_in_llinks
		, file_written_to
		);

/* User specified information. */
	     description (n_desc).user_info.present = user_specified_info_present;
	     if user_specified_info_present then do;
		description (n_desc).user_info.value = user_info_bits;
		call ioa_nnl (" ^12.3b", "0"b||user_info_bits);
	     end;
	     else description (n_desc).user_info.value = "0"b;

/* Mode (type) of file. */
	     modep = addr (description (n_desc).mode);
	     mode = "0"b;
	     if random_file then do;
		mode = mode | "0100"b;
		call ioa (" RANDOM");
	     end;
	     if ASCII_file then do;
		mode = mode|"0010"b;
		call ioa (" ASCII");
	     end;
	     if I_D_S_file then do;
		mode = mode|"0001"b;
		call ioa (" IDS");
	     end;
	     if ^random_file & ^ASCII_file & ^I_D_S_file then do;
		mode = mode | "1000"b;
		call ioa (" SEQUENTIAL");
	     end;

	     if file_on_nonstructured_vol = "1"b then
		call ioa ("nonstructured volume (NOT CURRENTLY PROVIDED FOR)");
	     else do;				/* Structured volume. */
		do i = 1 to hbound (gfms_catrec_2.structured_info, 1);
		     cep = addr (gfms_catrec_2.structured_info (i));
		     if cep -> b36 = "0"b then return;
		     if substr (cep -> b36, 1, 4) ^= "0101"b then /* not a device description. */
			call ioa (
			"^12xnumber llinks ^i starting llink ^i ^[ DEFECTIVE^;^s^]"
			, number_llinks
			, starting_llink
			, defective
			);
		end;
	     end;
	     return;

dcl  i                        fixed bin;
dcl  k                        fixed bin;
dcl  mode                     bit(4)unal based(modep);
dcl  modep                    ptr;
dcl  s                        fixed bin(18)unsigned;
	end cat_2_entry;
%page;
find_parent_sector: proc (pr, sn)returns (fixed bin (18)unsigned);

/* Look up prior sector number "pr" in the hash list
   recording parent sector number. Store sector number "sn"
   in hash list along with the recorded parent sector found.
   Return parent sector found.
   If no parent sector found then return zero. This catalog record is ignored.
*/
dcl  pr                       fixed bin(18)unsigned unal parm;
dcl  sn                       fixed bin(18)unsigned unal parm;

	     k = mod (pr, hbound (parent_list, 1)+1);
	     do j = k to hbound (parent_list, 1), 0 to (k-1);
		if parent_list (j).cat_sector = pr then do; /* found. */
		     parent_list (j).cat_sector = 0;	/* Make entry available. */
		     ps = parent_list (j).parent_sector;
		     call save_parent_sector (sn, (ps));
		     return (ps);
		end;
	     end;

	     return (0);           /* not found */

dcl  j                        fixed bin(18)unsigned;
dcl  k                        fixed bin(18)unsigned;
dcl  ps                       fixed bin(18)unsigned;
	end find_parent_sector;
%page;
first_rec: proc (cp);

/* Display first record(s) information.
   Set "cp" to locate catalog records.
*/
dcl  cp                       ptr parm;
	     bc = bc+1;				/* Block count. */
	     call ioa (
		"^6i. (block^6i)  size^6i  record-size^6i"
		, bc
		, sub.block_serial_number
		, sub.block_size
		, sub.record_size
		);

/* Display substructure records. */
	     rl = nw-1;				/* Remaining length (words) for catalog records. */
	     if mod (rl, size (gfms_catrec_0)) ^= 0 then do;
		call com_err_ (
		     0
		     , "gfms_substructure_records_"
		     , "Not modulo (^i) number of words for catalog records (^i)"
		     , size (gfms_catrec_0)
		     , rl
		     );
fail:		;
		signal cond (gfms_fail);
	     end;

/* Set pointer to initial catalog record. */
	     cp = addr (sub.catalog_records);
	     return;
	end first_rec;
%page;
force_parent_sector: proc (pr, sn, cel, ep)returns (fixed bin (18)unsigned);

/* IF the entry in the type 1 catalog list is not null 
   THEN
     put prior sector number "pr" in the hash list as the parent sector.
     Store sector number "sn" in hash list along with the recorded parent.
     Return sn as parent sector.
     This "step" parent will be replaced with the "true" parent when the 
     subsequent type 0 or type 1 catalog pointed to by pr comes along.
     (If it doesn't, then the files and catalogs in this and linked type 1's
     are dumped at the top level and not where they belong.)
   ELSE return zero. This catalog record is ignored.
*/
dcl  pr                       fixed bin(18)unsigned unal parm; /* prior sector */
dcl  sn                       fixed bin(18)unsigned unal parm; /* this sector */
dcl  cel                      fixed bin parm;                  /* count of entries */
dcl  ep                       ptr parm;                        /* first entry pointer */

	     cep = ep;				/* Pointer to initial name entry in catalog. */
	     do i = 1 to cel;
		if (ce.name ^= "0"b) 
		     then if (ce.name ^= (12)"20"b3) then goto force;
		if i < cel then			/* Position to the next name entry. */
		     cep = addrel (cep, size (ce));
	     end;
	     return(0); /* all null */

force:	     call save_parent_sector (pr, pr);
	     ps = find_parent_sector (pr, sn);

	     call ioa ("^11x *** Parent not found yet. Prior ^6i, Sector ^6i, StepParent ^6i.",
		pr, sn, ps);

	     return (ps);
/************/
dcl  ps                       fixed bin(18)unsigned;
dcl  i                        fixed bin;

	end force_parent_sector;
%page;
get_rec:	proc returns (bit (1));

/* Obtain the next SUBSTRUCTURE record from tape.
   Return "1"b when record read is the EOF record
   (position past the EOF record).
   Return "0"b when SUBSTRUCTURE record read.
*/
	     call iox_$read_record (
		cbp				/* (input) pointer to control block. */
		, addr (sub_space)			/* (input) record buffer. */
		, size (sub_space)*4		/* (input) buffer length in bytes. */
		, nbr				/* (output) number of bytes read. */
		, code				/* (output) I/O system status. */
		);
	     if code ^= 0 then
		if code = error_table_$end_of_info then
		     if gfms_end_of_input_ (
		     addr (sub_space)		/* (input) pointer to input buffer. */
		     , size (sub_space)*4		/* (input) length of buffer (bytes). */
		     , nbr			/* (input/output) current number bytes in buffer. */
		     ) then do;			/* No more tape input. */
			call com_err_ (
			     0
			     , "gfms_substructure_records_"
			     , "End of tape input reached in substructure records."
			     );
			signal cond (gfms_fail);
		     end;
		     else goto cont;		/* Next reel in process. */
		else
		if code ^= error_table_$long_record then do;
		     call com_err_ (
			code
			, "gfms_substructure_records_"
			, "Attempting to read substructure record."
			||"^/Tape status ^4.3b"
			||"^/buffer length ^i (bytes)."
			||"^/bytes read ^i."
			||"^/attach description ""^a"""
			, gfms_tape_status_ (cbp)
			, size (sub_space)*4
			, nbr
			, attach_description
			);
fail:		     ;
		     signal cond (gfms_fail);
		end;

/* Assure length in words is conistent. */
cont:	     ;
	     if mod (nbr, 4) ^= 0 then
		call com_err_ (
		0
		, "gfms_substructure_records_"
		, "Bytes read (^i) not word modulo, will truncate to word and continue."
		, nbr
		);
	     nwr = divide (nbr, 4, 17);		/* Number of words read. */
	     nw = nwr-1;				/* upper bound of sub structure. */
	     if nw < 2 then do;
		call com_err_ (
		     0
		     , "gfms_substructure_records_"
		     , "Record ^i bytes long (<2 words)"
		     , nbr
		     );
		goto fail;
	     end;

/* Determine if EOF record reached. */
	     if sub.eof_mark = "170017"b3 then do;
		p = addr (sub_space);
		if p -> k65 ^= 65
		| p -> k64 ^= 64
		| p -> EOF_number ^= 1 then
		     call com_err_ (
		     0
		     , "gfms_sub_records_"
		     , "Faulty EOF record. Continuing."
		     ||"^/1st 4 words:^4( ^12.3b^)"
		     , unspec (p -> EOF_record.word0)
		     , unspec (p -> EOF_record.word1)
		     , unspec (p -> EOF_record.word2)
		     , unspec (p -> EOF_record.word3)
		     );
		call ioa (
		     "^6i. (block^6i) EOF record."
		     , i
		     , p -> EOF_record.bsn
		     );
		return ("1"b);			/* EOF record input, no more substructure. */
	     end;
	     return ("0"b);				/* Next substructure record. */

dcl  p                        ptr;
%include gfms_EOF_record;
	end get_rec;
%page;
reunite_orphan: proc (step_parent, true_parent);

/* replace the step_parent sector with the true parent sector in the 
   parent_list and gfms_hash table. Needed to restore the actual cat/file
   structure. See force_parent_sector.
*/
dcl step_parent fixed bin (18) unsigned unal parm;
dcl true_parent fixed bin (18) unsigned unal parm;

dcl i	      fixed bin;

	      if step_parent = true_parent then return;

	      do i = 0 to hbound(parent_list,1);
		 if parent_list(i).parent_sector = step_parent
		      then parent_list(i).parent_sector = true_parent;
	      end;
	      do i = 1 to n_cat;
		 if cat(i).parent_sector = step_parent
		      then cat(i).parent_sector = true_parent;
	      end;

	      call ioa ("^11x *** Replaced StepParent ^6i with Parent ^6i.",
		 step_parent, true_parent);

	      return;
	 end reunite_orphan;
%page;
save_parent_sector: proc (cs, ps);

/* Save parent sector number "ps" in a
   hash list to provide for type 1 catalog
   records obtaining parent sector of corresponding
   type 0 catalog record.
*/
dcl  cs                       fixed bin(18)unsigned unal parm;
dcl  ps                       fixed bin(18)unsigned unal parm;

	     k = mod (cs, hbound (parent_list, 1)+1);
	     do j = k to hbound (parent_list, 1), 0 to (k-1);
		if parent_list (j).cat_sector = 0 then do; /* Available. */
		     parent_list (j).cat_sector = cs;
		     if (parent_list (j).parent_sector ^= ps) then 
			if (parent_list (j).parent_sector ^= 0) then call reunite_orphan(cs, ps);
		     else parent_list (j).parent_sector = ps;
		     return;
		end;
	     end;

/* No entryies available. */
	     call com_err_ (
		0
		, "gfms_substructure_records_"
		, "Exhaused ^i entries available for parent sector list."
		||" GCOS file structure is too large or too fragmented."
		, hbound (parent_list, 1)
		);
	     signal cond (gfms_fail);

dcl  j                        fixed bin(18)unsigned;
dcl  k                        fixed bin(18)unsigned;
	     return;
	end save_parent_sector;
%page;
scan:	proc;

/* Scan the input tape substructure records.
   For type 0 and 1 catalog records, store entry
   information in cat array.
   For type 2 catalog records, store description information.
*/
more:	     ;
	     if rl < 1 then do;			/* Obtain next input record. */
		if get_rec () then return;
		call first_rec (cat_ptr);		/* Display header, position to 1st catalog record. */
	     end;
	     else					/* Record already available. */
	     cat_ptr = addrel (cat_ptr, size (cat_common)); /* Position to the next catalog record (within input record). */
	     tc = tc+1;				/* Catalog record count. */
	     t = cat_common.type;			/* Type of catalog record. */
	     goto cat (CTYPE (t));

cat (-1):	     ;
	     call com_err_ (
		0
		, "gfms_substructure_records_"
		, "Catalog type ^i not expected on save tape."
		, t
		);
	     call gfms_dump_rec_ (cat_ptr, 64);
	     goto cont;

cat (0):	     ; /* Catalog description */
	     call ioa (
		"^8x^3i Type 0 catalog record (Prior ^6i, Parent-sector ^6i, Next ^6i)."
		||"^/^12x^12a create by ^12a on ^a modified ^a."
		, tc
		, gfms_catrec_0.prior_cat_sector_org
		, gfms_catrec_0.dupl_sector_no
		, gfms_catrec_0.cat_contin_sector_org
		, gfms_ascii_ ((gfms_catrec_0.catname))
		, gfms_ascii_ ((gfms_catrec_0.creator_name))
		, gfms_date_ (gfms_catrec_0.create_date)
		, gfms_date_ (gfms_catrec_0.modified_date)
		);
	     call save_parent_sector (gfms_catrec_0.dupl_sector_no, gfms_catrec_0.dupl_sector_no);
	     call cat_0_1_entry (
		gfms_catrec_0.dupl_sector_no
		, hbound (gfms_catrec_0.entry, 1)
		, addr (gfms_catrec_0.entry)
		);
	     goto cont;

cat (1):	     ; /* Catalog description (type 0) continuation */
	     call ioa ("^8x^3i Type 1 catalog record. Prior ^6i, Sector ^6i, Next ^6i, empty ^3i."
		, tc
		, gfms_catrec_1.prior_cat_sector_org
		, gfms_catrec_1.dupl_sector_no
		, gfms_catrec_1.cat_contin_sector_org
		, e
		);
	     p_sec = find_parent_sector (gfms_catrec_1.prior_cat_sector_org, gfms_catrec_1.dupl_sector_no);
	     if p_sec = 0
		then p_sec = force_parent_sector (gfms_catrec_1.prior_cat_sector_org
				, gfms_catrec_1.dupl_sector_no
				, hbound (gfms_catrec_1.entry, 1)
				, addr (gfms_catrec_1.entry)
				);
	     call cat_0_1_entry (p_sec
		, hbound (gfms_catrec_1.entry, 1)
		, addr (gfms_catrec_1.entry)
		);
	     goto cont;

cat (2):	     ; /* File Description */
	     call ioa ("^8x^3i Type 2 catalog record.", tc);
	     call cat_2_entry;
	     goto cont;

cat (3):	     ; /* type 2 continuation ? */

cat (4):	     ; /* Specific permissions */

cat (5):	     ; /* type 4 continuation */

cat (7):	     ; /* attributes */

cat (9):	     ; /* timed passwords */

cat (62):	     ;
	     call ioa (
		"^8x^3i Type ^2i catalog (^3i) not currently provided for."
		,tc
		, t
		, CTYPE (t)
		);
	     goto cont;

cat (63):	     ;					/* Empty catalog record. */
	     e = e+1;				/* Count empties. */
	     call ioa ("^8x^3i Empty (type 63) catalog record. Prior ^6i, sector ^6i, empty ^3i."
		, tc
		, gfms_catrec_1.prior_cat_sector_org
		, gfms_catrec_1.dupl_sector_no
		, e
		);

	     goto cont_1;
	     
cont:	     ;
	     e = 0;  /* all catalog types but empty initialize empty count */
cont_1:	     ;

	     rl = rl - size (cat_common);
	     goto more;
/*************/
dcl  p_sec                    fixed bin(18) unsigned unal;
dcl  t                        fixed bin;

dcl 1 cat_common		aligned based(cat_ptr)
,     3 word0
,       4 type		fixed bin(06)unsigned unal
,       4 fill1		bit(30)unal
,     3 words1_63		(1:63)bit(36)
;

dcl  CTYPE                    (0:63)fixed bin static int options(constant)init(
 /* 00 */ 0
,/* 01 */ 1
,/* 02 */ 2
,/* 03 */ 3
,/* 04 */ 4
,/* 05 */ 5
,/* 06 */ -1 /* Not allowed. */
,/* 07 */ 7
,/* 08 */ -1 /* Not allowed. */
,/* 09 */ 9
,/* 10-61 */ (52)-1
,/* 62 (76octal) */ 62
,/* 63 (77octal) */ 63
);
	end scan;
%page;
/*   Variables for gfms_substructure_records_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  b36                      bit(36)aligned based;
dcl  bc                       fixed bin;
dcl  cat_ptr                  ptr init(null());
dcl  cep                      ptr;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  divide                   builtin;
dcl  e                        fixed bin;
dcl  error_table_$end_of_info fixed bin(35) ext static;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_date_               entry (bit(36) aligned) returns(char(8));
dcl  gfms_dump_description_tree_ entry;
dcl  gfms_dump_rec_           entry (ptr,fixed bin);
dcl  gfms_end_of_input_       entry (ptr, fixed bin(21), fixed bin(21)) returns(bit(1));
dcl  gfms_fail                condition ext;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  hbound                   builtin;
dcl  i                        fixed bin;
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  mod                      builtin;
dcl  nbr                      fixed bin(21);
dcl  null                     builtin;
dcl  nw                       fixed bin;
dcl  nwr                      fixed bin;
dcl  rl                       fixed bin;
dcl  rtrim                    builtin;
dcl  size                     builtin;
dcl  substr                   builtin;
dcl  sub_space                (3842)bit(36)aligned;
dcl  tc                       fixed bin;
dcl  unspec                    builtin;


dcl 1 ce aligned like gfms_catrec_0.entry based(cep);

dcl 1 parent_list		(0:1020)aligned
,     3 cat_sector		fixed bin(18)unsigned unal
,     3 parent_sector	fixed bin(18)unsigned unal
;
%page;
/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-26 SUBSTRUCTURE RECORDS (<=3842 words)
*/
dcl 1 sub			aligned based(addr(sub_space))
,     3 word0
,       4 block_serial_number	fixed bin(18)unsigned unal
,       4 block_size	fixed bin(18)unsigned unal
,     3 word1
,       4 record_size	fixed bin(18)unsigned unal
,       4 eof_mark		bit(18)unal
,     3 words2_3841
,       4 catalog_records	(2:nw)bit(36)
;

/* From DC26 ??? page 4-12
   description of array of FD2VAR fields in
   type 2 catalog record.
*/
dcl 1 FS2VAR		aligned based(cep)
,     3 b0_1		bit(2)unal
,     3 defective		bit(1)unal
,     3 number_llinks	fixed bin(15)unsigned unal
,     3 starting_llink	fixed bin(18)unsigned unal
;
%page;
%include gfms_description_tree;
%page;
%include gfms_catrec_0;
%page;
%include gfms_catrec_1;
%page;
%include gfms_catrec_2;
%page;
%include gfms_ext;
     end gfms_substructure_records_;




		    gfms_tape_status_.pl1           12/11/84  1355.9rew 12/10/84  1042.0       10179



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_tape_status_: proc (p)returns (bit (12));

/* Return tape_nstd_ request_status.

   Author: Dave Ward	10/28/80
*/
dcl  p                        ptr parm;
	call iox_$control (
	     p					/* (input) pointer to switch's control block. */
	     , "request_status"			/* (input) control order. */
	     , addr (s12)				/* (input) pointer to 12 bit status. */
	     , code				/* (output) status code. */
	     );
	if code ^= 0 then
	     call com_err_ (
	     code
	     , "gfms_tape_status_"
	     , "pointer to switch iocb (^p)"
	     , p
	     );
	return (s12);

dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  iox_$control             entry (ptr, char(*), ptr, fixed bin(35));
dcl  s12                      bit(12)aligned;
     end gfms_tape_status_;




		    gfms_task_block_record_.pl1     12/11/84  1355.9rew 12/10/84  1042.0       90117



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gfms_task_block_record_: proc (ms);

/* Display task block record information.
   "ms" is set to "1"b if tape is a master save,
   or "0"b if a user save (any other type of save is
   reported and processing discontinued).

   Author: Dave Ward	10/01/80
   Change: Dave Ward	10/03/80 compensated for words5_6 not 0 as advertised.
*/
dcl  ms                       bit(1)parm;
	call iox_$read_record (
	     cbp					/* (input) pointer to control block. */
	     , addr (tbr_space)			/* (input) record buffer. */
	     , size (tbr_space)*4			/* (input) buffer length in bytes. */
	     , nbr				/* (output) number of bytes read. */
	     , code				/* (output) I/O system status. */
	     );
	if code ^= 0 then
	     if code ^= error_table_$long_record then do;
		call com_err_ (
		     code
		     , "gfms_task_block_record_"
		     , "Attempting to read task block record."
		     ||"^/Tape status ^4.3b"
		     ||"^/buffer length ^i (bytes)."
		     ||"^/bytes read ^i."
		     ||"^/attach description ""^a"""
		     , gfms_tape_status_ (cbp)
		     , size (tbr_space)*4
		     , nbr
		     , attach_description
		     );
fail:		;
		signal cond (gfms_fail);
	     end;

/* Assure length in words is conistent. */
	if mod (nbr, 4) ^= 0 then
	     call com_err_ (
	     0
	     , "gfms_task_block_record_"
	     , "Bytes read (^i) not word modulo, will truncate to word and continue."
	     , nbr
	     );
	nwr = divide (nbr, 4, 17);			/* Number of words read. */
	nw = nwr-1;				/* upper bound of tbr structure. */

	call ioa ("^|TASK BLOCK RECORD INFORMATION (block 2):");
	if word0.b00_17 = 2				/* Must be block 2 of record. */
	& word1.b18_35 = "0"b
	& word2.savhdr = "622165302451"b3 then do;	/* bcd SAVHDR */
	     call ioa ("block_size^4(.^) ^i", block_size);
	     call ioa ("record_size^3(.^) ^i", record_size);
	     call ioa ("date^10(.^) ^a", gfms_date_ (date));
	     call ioa ("clock_pulses^2(.^) ^i", clock_pulses);
	     rw = nwr - 7;				/* Words remaining for copy of task block. */

	     sqll = rw - 12 - 1;			/* Words remaining for qualifier list. */

/* Verify "some" FACT fields. */
	     if task_header = 1
	     & word0.b18_35 = "0"b
	     & type_code = 10
	     & serial_num = (10)"1"b3
	     & subtask_header = 2
	     & word3.b18_35 = "0"b
	     & report_code = 33
	     & file_code = "4754"b3			/* bcd "P*" */
	     & last_word.b00_17 = (6)"7"b3
	     & last_word.b18_35 = "0"b then do;		/* FACT constants as expected. */
		call ioa (" FACT overlay info:");
		if subtask_code = 1 then do;
		     ms = "1"b;			/* Master save. */
		     call ioa (" MASTER SAVE");
		end;
		else
		if subtask_code = 2 then do;
		     ms = "0"b;			/* User save. */
		     call ioa (" USER SAVE");
		end;
		else do;
		     call ioa (" Subtask code ^i.^/  TYPE NOT PROCESSED BY THIS COMMAND, TERMINATING."
			, subtask_code
			);
		     goto fail;
		end;
		call ioa (" subtask options ^6.3b", string (subtask_options));
		call ioa (" user ^a", gfms_ascii_ ((user_name)));
		call ioa (" qualifier list:");
		i = 1;
		do while (i <= sqll);
		     if subtask_qualifier_list (i).b00_17 = 3 then do; /* => subtask qualifier. */
			j = subtask_qualifier_list (i).b18_35; /* Qualifier code. */
			if (j<1) | (j>10) then do;
			     call ioa ("    QUALIFIER CODE (^i) OUT OF RANGE 1 to 10.", j);
			     goto dump_fact;
			end;
			call ioa_nnl ("^2x[^4i]^1x", i);
			i = i+1;
			goto stq (j);

stq (01):			;
			call ioa ("(01) User Save.");
			do while (i <= sqll);
			     if subtask_word (i) = (12)"7"b3 then do;
				i = i+1;
				goto cont;
			     end;
			     call ioa (
				"^14x^6.3b ^6.3b"
				, substr (subtask_word (i), 01, 18)
				, substr (subtask_word (i), 19, 18)
				);
			     i = i+1;
			end;

off_end:			;
			call ioa ("EXCEEDED END OF SUBTASK LIST (^i entries)", sqll);
			goto dump_fact;

stq (02):			;
			call ioa ("(02) Master Save DON'T DO or DO ONLY names");
display_names:		;
			do while (i <= sqll);
			     if subtask_word (i) = (12)"7"b3 then do;
				i = i+1;
				goto cont;
			     end;
			     call ioa ("^14x^a", gfms_ascii_ (Name));
			     i = i+2;
			end;
			goto off_end;

stq (03):			;
			call ioa ("(03) Device Names");
			do while (i <= sqll);
			     if subtask_word (i) = (12)"7"b3 then do;
				i = i+1;
				goto cont;
			     end;
			     call ioa ("^14x^a", gfms_ascii_ (substr (subtask_word (i), 1, 18)));
			     i = i+1;
			end;
			goto off_end;

stq (04):			;
			call ioa ("(^2i) -NO DISPLAY-");
display_word:		;
			do while (i <= sqll);
			     if subtask_word (i) = (12)"7"b3 then do;
				i = i+1;
				goto cont;
			     end;
			     call ioa ("^14x^12.3b", subtask_word (i));
			     i = i+1;
			end;
			goto cont;

stq (05):			;
			call ioa ("(05) New Names");
			goto display_names;

stq (06):			;
			call ioa ("(06) Pack Identification");
			goto display_word;

stq (07):			;
			call ioa ("(07) ALL");
			call ioa (
			     "(07) Date ^6a Time ^6a"
			     , gfms_date_ (Date (i))
			     , gfms_ascii_ (Time (i))
			     );
			i = i+1;
			goto cont;

stq (08):			;
			call ioa ("(08) ILLEGAL Qualifier Code.");
			goto dump_fact;

stq (09):			;
			call ioa ("(09) SMC Sections ^32b", subtask_word (i));
			i = i+1;
			goto cont;

stq (10):			;
			call ioa (
			     "(10) Journal Search ^6a ^6a"
			     , gfms_date_ (Date (i))
			     , gfms_ascii_ (Time (i))
			     );
			i = i+2;
			goto cont;

cont:			;

		     end;
		end;
	     end;
	     else do;				/* FACT constants not as expected. */
		call ioa ("FACT constants not as expected (octal dump):");
dump_fact:	;
		do i = 0 to hbound (fact_word, 1) by 4;
		     call ioa_nnl ("^3i. ", i);
		     do j = i to (i+3);
			call ioa_nnl (" ^12.3b", fact_word (j));
		     end;
		     call ioa_nnl ("^/");
		end;
		goto fail;
	     end;
	end;
	else do;					/* Constant(s) improper. */
	     call ioa ("constants not as expected (octal dump):");
	     do i = 0 to hbound (word, 1) by 4;
		call ioa_nnl ("^3i. ", i);
		do j = i to (i+3);
		     call ioa_nnl (" ^12.3b", word (j));
		end;
		call ioa_nnl ("^/");
	     end;
	     goto fail;
	end;
	return;
%page;
/*  Variables for gfms_task_block_record_:			*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  fact_word                (0:size(FACT_Overlay_Interface)-1)bit(36)aligned based(addr(FACT_Overlay_Interface));
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_date_               entry (bit(36) aligned) returns(char(8));
dcl  gfms_fail                condition ext;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  i                        fixed bin;
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  j                        fixed bin;
dcl  l                        fixed bin;
dcl  Name                     bit(72)based(addr(subtask_qualifier_list(i)));
dcl  nbr                      fixed bin(21);
dcl  nw                       fixed bin;
dcl  nwr                      fixed bin;
dcl  rw                       fixed bin;
dcl  size                     builtin;
dcl  sqll                     fixed bin;
dcl  subtask_word             (sqll)bit(36)based(addr(subtask_qualifier_list));
dcl  tbr_space                (1117)bit(36)aligned;
dcl  word                     (0:nw)bit(36)aligned based(addr(tbr));
%page;
/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-25 TASK BLOCK RECORD (<=1117 words)
*/
dcl 1 tbr			aligned based(addr(tbr_space))
,     3 word0
,       4 b00_17		fixed bin(18)unsigned unal
,       4 block_size	fixed bin(18)unsigned unal
,     3 word1
,       4 record_size	fixed bin(18)unsigned unal
,       4 b18_35		bit(18)unal
,     3 word2
,       4 savhdr		bit(36)	/* bcd constant "SAVHDR" */
,     3 word3
,       4 date		bit(36)	/* bcd MMDDYY */
,     3 word4
,       4 clock_pulses	fixed bin(36)unsigned unal
,     3 words5_6		bit(72)	/* should be zero. */
,     3 words7_nw		(7:nw)bit(36) /* Copy of task block. */
;
%page;
/* See DD14, Rev 1 (June 1976) SYSTEM TABLES
   Page 16-30 FACT Overlay Interface
*/
dcl 1 FACT_Overlay_Interface	aligned based(addr(tbr.words7_nw))
,     3 word0
,       4 task_header	fixed bin(18)unsigned unal
,       4 b18_35		bit(18)unal
,     3 word1
,       4 restore		bit(01)unal
,       4 b01_17		bit(17)unal	/* Reserved for GCOS. */
,       4 task_ordinal	fixed bin(18)unsigned unal
,     3 word2
,       4 type_code		fixed bin(06)unsigned unal	/* 10 decimal. */
,       4 serial_num	bit(30)unal /* octal 1's. */
,     3 word3
,       4 subtask_header	fixed bin(18)unsigned unal	/* 2. */
,       4 b18_35		bit(18)unal
,     3 word4
,       4 subtask_code	fixed bin(18)unsigned unal
,       4 subtask_options	(18:35)bit(1)unal
,     3 word5		bit(36)	/* Reserved. */
,     3 words6_7
,       4 user_name		bit(72)
,     3 words8_9		bit(72)	/* Reserved. */
,     3 word10
,       4 address_of_return_pair bit(18)unal
,       4 b18_35		bit(18)unal	/* Reserved. */
,     3 word11
,       4 report_code	fixed bin(18)unsigned unal	/* decimal 33. */
,       4 b18_23		bit(06)unal	/* Reserved. */
,       4 file_code		bit(12)unal	/* P*. */
,     3 word12
,       4 subtask_qualifier_list (sqll)
,         5 b00_17		fixed bin(18)unsigned unal
,         5 b18_35		fixed bin(18)unsigned unal
,     3 last_word
,       4 b00_17		bit(18)unal
,       4 b18_35		bit(18)unal
;

dcl 1 stq_ovl		(sqll)aligned based(addr(subtask_qualifier_list))
,     2 Date		bit(36)
,     2 Time		bit(36)unal
;
%page;
%include gfms_ext;
     end gfms_task_block_record_;




		    gfms_test_ascii_.pl1            12/11/84  1355.9rew 12/10/84  1042.0        4239



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
x:   proc;
	call ioa_ ("^a", gfms_ascii_ ("212223"b3));
dcl  ioa_ entry() options(variable);
dcl  gfms_ascii_ entry (bit(*)) returns(char(*));
     end;




		    gfms_test_date_.pl1             12/11/84  1355.9rew 12/10/84  1042.0        6552



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
test_gfms_date_: proc;
	call ioa_ ("^12.3b = ""^a""", (12)"7"b3, gfms_date_ ((12)"7"b3));
	call ioa_ ("^12.3b = ""^a""", (12)"0"b3, gfms_date_ ((12)"0"b3));
	call ioa_ ("^12.3b = ""^a""", (6)"11"b3, gfms_date_ ((6)"11"b3));
	call ioa_ ("^12.3b = ""^a""", "010000041000"b3, gfms_date_ ("010000041000"b3));
dcl  ioa_ entry() options(variable);
dcl  gfms_date_ entry (bit(36) aligned) returns(char(8));
     end;




		    gfms_trailer_label_.pl1         12/11/84  1355.9rew 12/10/84  1022.4       33453



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

/* Process the tape trailer label.
   Return "1"b if this is end of file (EOF) label
   versus end of reel (EOR) label.

   Author: Dave Ward	10/17/80
   Changed: Ron Barstad  84-11-21  Fixed processing of multiple tape saves.
*/

	call iox_$read_record (			/* Read the trailer record. */
	     cbp					/* (input) pointer to control block. */
	     , addr (tape_label)			/* (input) record buffer. */
	     , size (tape_label)*4			/* (input) buffer length in bytes. */
	     , nbr				/* (output) number of bytes read. */
	     , code				/* (output) I/O system status. */
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gfms_trailer_label_"
		, "Attempting to read tape trailer label file."
		||"^/Tape status ^4.3b"
		||"^/buffer length ^i (bytes)."
		||"^/bytes read ^i."
		||"^/attach description ""^a"""
		, gfms_tape_status_ (cbp)
		, size (tape_label)*4
		, nbr
		, attach_description
		);
	     signal cond (gfms_fail);
	end;

	if end_label = "202546262020"b3 then		/* " EOF  " bcd. */
	     r = "1"b;				/* EOF */
	else
	if end_label = "202546512020"b3 then		/* " EOR  " bcd */
	     r = "0"b;				/* EOR */
	else do;					/* Neither EOF or EOR. */
	     call com_err_ (
		0
		, "gfms_trailer_label_"
		, "Trailer label, ""^6a"", not EOF or EOR."
		, gfms_ascii_ ((end_label))
		);
	     call gfms_dump_rec_ (
		addr (tape_label)
		, divide (nbr+3, 4, 17)
		);
	     signal cond (gfms_fail);
	end;

	call ioa ("^|TRAILER LABEL INFORMATION:");
	call ioa ("end_label......... ^a", gfms_ascii_ ((end_label)));
	if r then
	     reel_serial_num = "NOREEL";
	else do;
	     call ioa ("next_reel_serial.. ^a", gfms_ascii_ ((next_reel_serial)));
	     reel_serial_num = gfms_ascii_ ((next_reel_serial));
	     substr (reel_serial_num, 1, 1) = " ";  /* strip off the "#" */
	     sequence_pic = decimal (reel_sequence_num, 6) + 1;
	     reel_sequence_num = sequence_pic;
	     if (gfms_close_ ()) then signal cond (gfms_fail);
	     call gfms_detach_ ();
	     attach_description = before (attach_description, " ") || reel_serial_num || after (after (attach_description, " "), " ");

	end;
	return (r);
%page;
/*  Variables for gfms_trailer_label_:			*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  divide                   builtin;
dcl  gfms_ascii_              entry(bit(*))returns(char(*));
dcl  gfms_close_              entry() returns(bit(1));
dcl  gfms_detach_             entry options(variable);
dcl  gfms_dump_rec_           entry (ptr, fixed bin);
dcl  gfms_fail                condition ext;
dcl  gfms_tape_status_        entry (ptr) returns(bit(12));
dcl  ioa_                     entry() options(variable);
dcl  iox_$control             entry (ptr, char(*), ptr, fixed bin(35));
dcl  iox_$read_record         entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  nbr                      fixed bin(21);
dcl  r                        bit(1);
dcl  sequence_pic             pic "zz9999";
dcl  size                     builtin;

/* See DD07 (April 1974) FILE AND RECORD CONTROL
   Page 11-3 trailer label format.
*/
dcl 1 tape_label		aligned
,     3 end_label		bit(36)
,     3 block_count		bit(36)
,     3 arbitrary		(3:13)bit(36)
,     3 next_reel_serial	bit(36)
;
%page;
%include gfms_ext;
     end gfms_trailer_label_;




		    use_big_tape_blocks_.pl1        12/11/84  1355.9rew 12/10/84  1042.1       22986



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

/* Determine whether caller has access to Multics facilities
   (see dir, ent arrays) to provide for tape blocks larger than
   11888 bytes (See "tape_nstd_" I/O module, AX49.
   The parameter "code" is returned in one of three categories:
   1) zero implies the caller has access,
   2) error_table_$big_ws_req the caller does not,
   3) any other value implies there was failure in attempting to
   determine (a normal multics status code).
   Include file "use_big_tape_blocks.incl.pl1" provides declarations
   for dir, ent arrays.

   Author: Dave Ward	04/21/81
*/
dcl  code                     fixed bin(35)parm;
	code = 0;					/* Assume caller has access. */
	call user_info_ (per, prj, act);
	per_prj = rtrim (per)||"."||rtrim (prj)||".*";
	do i = 1 to hbound (dir, 1);
	     mode = 0;
	     call hcs_$get_user_effmode (
		dir (i), ent (i)			/* (input) directory and entry name. */
		, per_prj				/* (input) PERSON.PROJECT.* */
		, get_ring_ ()
		, mode				/* (output). */
		, code				/* (output) status. */
		);
	     if code ^= 0 then return;		/* Failure to determine. */
	     if read then
		if nex (i) then do;
		     if exec then return;		/* Success, has access. */
		end;
		else do;
		     if writ then return;		/* Success, has access. */
		end;
	end;
	code = error_table_$big_ws_req;
	return;					/* Success, does not have access. */
%page;
/*   Variables for use_big_tape_blocks_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  act                      char(32);
dcl  error_table_$big_ws_req  fixed bin(35) ext static;
dcl  get_ring_                entry() returns(fixed bin(3));
dcl  hcs_$get_user_effmode    entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35));
dcl  i                        fixed bin;
dcl  mode                     fixed bin(5);
dcl  per                      char(22);
dcl  per_prj                  char(32);
dcl  prj                      char(9);
dcl  user_info_               entry (char(*), char(*), char(*));

dcl 1 mode2 aligned based(addr(mode))
,     3 skip1	bit(32)unal
,     3 read	bit( 1)unal
,     3 exec	bit( 1)unal
,     3 writ	bit( 1)unal
,     3 skip2	bit( 1)unal
;
%page;
%include use_big_tape_blocks;
     end use_big_tape_blocks_;





		    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
