



		    list_tape_contents.pl1          04/19/88  0829.1rew 04/19/88  0823.2      176922



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




/****^  HISTORY COMMENTS:
  1) change(76-05-01,Phillipps), approve(), audit(), install():
     old history comments.
     Written by J.B.  Phillipps.
     change 76-09-01 Phillipps.
     change 78-06-01 Jordan.
     change 78-10-01 Jordan.
     change 80-06-01 Jordan to remove backspace characters from usage message.
     change 81-06-01 Jordan to fix some bugs.
  2) change(85-10-01,GWMay), approve(84-02-29,MCR7154),
     audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1191):
     Complete Rewrite - changed to use mtape_ instead of the tape_ansi_
     and tape_ibm_ i/o modules.  Removed the -io_module(iom) control by
     undocumenting it and replaced it with the -volume_type(-vt) control
     arg when -iom is used -vt is assumed. Removed the -retain control by
     undocumenting and ingnoring the control in the code.
  3) change(88-02-17,GWMay), approve(88-03-14,MCR7856),
     audit(88-03-15,Wallman), install(88-04-19,MR12.2-1039):
     Changed to use -next_file for first open call.
                                                   END HISTORY COMMENTS */

%page;
/****^ PROGRAM DESCRIPTION:

   Command to list tape characteristics and file attributes of
   OS and ANSI standard labeled volumes. 
                                                   END PROGRAM DESCRIPTION */


list_tape_contents: ltc: procedure;

/* based storage */

       dcl arg			char (Larg) aligned based (Parg);

/* builtin functions */

       dcl (addr, char, fixed, length, null, rtrim, search, substr)
				builtin;

/* conditions */

       dcl (cleanup, command_error)	condition;

/* automatic storage */      

       dcl 1 lto aligned,
	 2 print_mode fixed bin,	/* 1 - long info; 2 - brief info;   */
				/* 3 - default info		      */
	 2 list_limit fixed bin (24),	/* list list_limit number           */
           2 volid char (6);		/* volume-set name */


       dcl Larg			fixed bin,
	 Lcurrent_line		fixed bin,
           Parg_list		ptr,
           Parg			ptr,
           Piocb			ptr,
	 Sprint_banner                bit(1),
           cmd_name			char (18),
           code			fixed bin (35),
           number_of_like_files	fixed bin initial (0),
           1 current_file		aligned like mtape_fst,
           current_file_no		fixed bin (24),
	 current_line                 char(256) varying,
           input_attach_args		char (270) aligned varying,
           mtape_attach_desc		char (270) aligned varying,
           mtape_open_desc		char (270) aligned varying,
           n_args			fixed bin,
           next_arg			fixed bin,
	 previous_line		char(256) varying,
           tape_io_switch		char (26),
           temp			fixed bin(24);
		     

/* constants */

       dcl ANSI_TAPE_ATTACH_DESC        char (104) internal static
				options (constant) init
              ("mtape_ -volume_type ansi -no_display -density 1600 -track 9 -error -device 1 -label -no_system -no_wait "),
           ANSI_TAPE_OPEN_DESC          char (46) internal static
				options (constant) init 
	    ("-no_display -not_last_file -next_file"),
           BRIEF			fixed bin (2) internal static
				options (constant) init (2),
           DEFAULT			fixed bin (2) internal static
				options (constant) init (3),
           FALSE			bit(1) internal static 
				options (constant) init ("0"b),
           IBM_TAPE_ATTACH_DESC         char (103) internal static
				options (constant) init
              ("mtape_ -volume_type ibm -no_display -density 1600 -track 9 -error -device 1 -label -no_system -no_wait "),
           IBM_TAPE_OPEN_DESC		char (69) internal static
				options (constant) init
              ("-no_display -not_last_file -next_file -no_system_use -ndos"),
           LONG			fixed bin (2) internal static
				options (constant) init (1),
           TRUE			bit(1) internal static
				options (constant) init ("1"b);

/* error codes */

       dcl (error_table_$bad_arg,
	  error_table_$bad_volid,
	  error_table_$noarg,
	  error_table_$nodescr,
	  error_table_$no_file,
	  error_table_$not_detached)	fixed bin (35) ext;

/* external procedures */

       dcl com_err_			entry options (variable),
	 convert_date_to_binary_	entry (char(*), fixed bin(71), 
				fixed bin(35)),
           cu_$arg_count		entry (fixed bin),
           cu_$arg_list_ptr		entry (ptr),
           cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin,
				fixed bin (35), ptr),
           cv_dec_check_		ext entry (char (*), fixed bin (35))
				returns (fixed bin (35)),
           date_time_$format		entry (char(*), fixed bin(71), char(*),
				char(*)) returns(char(250) var),
           ioa_			entry() options(variable),
           ioa_$rsnnl		entry() options(variable),
           iox_$attach_ioname		entry (char (*), ptr, char (*), 
				fixed bin (35)),
           iox_$close_file		entry (ptr, char(*), fixed bin(35)),
           iox_$control		entry (ptr, char(*), ptr,
				fixed bin(35)),
           iox_$detach		entry (ptr, char(*), fixed bin(35)),
           iox_$open_file		entry (ptr, fixed bin, char(*), 
				bit(1) aligned, fixed bin(35)),
           requote_string_		entry (char (*)) returns (char (*));
%page;     
/* ************************************************************************ */
/*							      */
/* Begin  Execution  Here:					      */
/*   1) set up condition handlers.				      */
/*   2) set up work area.					      */
/*   3) check for arguments,  if none found abort.		      */
/*   4) check arguments for conditional input of first argument.  It must be*/
/*      either "-volume", "-vol" or a value that does not begin with a "-". */
/*   5) If the first input value is the volume identifier, prefice it with  */
/*      the word " -volume ".					      */
/*							      */
/* ************************************************************************ */

program_setup:	     
       do;
          cmd_name = "list_tape_contents";
	Piocb = null();
	on cleanup call janitor;

	mtape_attach_desc = ANSI_TAPE_ATTACH_DESC;
	mtape_open_desc = ANSI_TAPE_OPEN_DESC;
          temp = 0;
	lto.print_mode = DEFAULT;
	lto.list_limit = 99999;	/* set to no limit                  */
				/* set the default IO module	      */
	current_file_no = 0;	/* default start -next_file         */
	Sprint_banner = TRUE;
	number_of_like_files = 0;
	current_file.version = fst_version_1;

	call cu_$arg_count (n_args);	/* get number of args typed in      */
	if n_args = 0 then		
	   code = error_table_$noarg;
	else do;
	   call cu_$arg_list_ptr (Parg_list);
	   next_arg = 1;
	   call get_arg_ptr;
	   if length (arg) = 0 then
	      code = error_table_$noarg;
	   else do;
	      if substr(arg, 1, length("-")) = "-" then
	         if arg = "-volume" | arg = "-vol" then
	            if get_another_arg () then;
	            else code = error_table_$noarg;
	         else
		  code = error_table_$bad_volid;
	     end;
	  end;
%page;
         if code = 0 then do;
	  input_attach_args = " -volume ";
	  lto.volid = arg;
	  tape_io_switch = cmd_name || "." || lto.volid;
	  if search (arg, """ ") ^= 0 then
	     input_attach_args =
	        input_attach_args || requote_string_ ((arg));
	  else
	     input_attach_args = input_attach_args || arg;
	  end;
         else do;
	  call com_err_ (code, cmd_name, "
Usage:  list_tape_contents vn1 {-comment c1} ... vnN {-comment cN} 
                               {-attach_args} {-control_args}

        attach_args:  any combination of mtape_ attach control arguments.");
            call ioa_ ("
        control_args: -volume_type (""ansi""|""ibm""), -vt (""ansi""|""ibm"")
		  -from file_number,   0 < file_number < 10000
		  -to file_number,     0 < file_number < 10000
		  -long,  -lg
		  -brief, -bf");

	  return;
	  end;
         end program_setup;
%page;
/* ************************************************************************ */
/*							      */
/* Argument Processing Loop:					      */
/*    1) get the next arg.					      */
/*    2) if found, check for a length > 0.			      */
/*    3) if ok, then check to see if it is a control for ltc. If so,	      */
/*       evaluate it.					      */
/*       if not, pass it along to mtape_ for evaluation.		      */
/*							      */
/* ************************************************************************ */
process_input_arg_loop:

       do while (get_another_arg ());

          if arg = "-long" | arg = "-lg" then lto.print_mode = LONG;

	else
	   if arg = "-brief" | arg = "-bf" then lto.print_mode = BRIEF;



				/* convert to binary                */
				/* only up to 4 digit file sequence */
				/* numbers allowed                  */
	else
	   if arg = "-from" then 
from_ctl:	   do;
	      if get_another_arg () then do;
	         temp = fixed (cv_dec_check_ ((arg), code), 17);
	         if code = 0 then
		  if temp > 0 & temp < 10000 then
		     current_file_no = temp;
		     else call com_err_ (error_table_$bad_arg, cmd_name, "
-from ^a
 value must be an integer from 1 to 9999.", arg);
	         else call com_err_ (error_table_$bad_arg, cmd_name, "
-from ^a
 value must be an integer from 1 to 9999.", arg);
	         end;
	   else call com_err_ (error_table_$noarg, cmd_name, "
-from requires an operand of an integer from 1 to 9999.");
	   end from_ctl;



				/* convert to binary                */
				/* only up to 4 digit file sequence */
				/* numbers allowed                  */
          else 
	   if arg = "-to" then 
to_ctl:	   do;
	      if get_another_arg () then do;
	         temp = fixed (cv_dec_check_ ((arg), code), 17);
	         if code = 0 then
		  if temp > 0 & temp < 10000 then
		     lto.list_limit = temp;
		  else call com_err_ (error_table_$bad_arg, cmd_name, "
-to ^a
 value must be an integer from 1 to 9999.", arg);
                   else call com_err_ (error_table_$bad_arg, cmd_name, "
-to ^a
 value must be an integer from 1 to 9999.", arg);
	         end;
	   else call com_err_ (error_table_$noarg, cmd_name, "
-to requires an operand of an integer from 1 to 9999.");
	   end to_ctl;



          else
	   if arg = "-io_module" | arg = "-iom" then
iom_ctl:	   do;
	      if get_another_arg () then
	         if arg = "tape_ansi_" then do;
		  mtape_attach_desc = ANSI_TAPE_ATTACH_DESC;
		  mtape_open_desc = ANSI_TAPE_OPEN_DESC;
		  end;
	         else if arg = "ibm" then do;
		  mtape_attach_desc = IBM_TAPE_ATTACH_DESC;
		  mtape_open_desc = IBM_TAPE_OPEN_DESC;
		  end;
	         else call com_err_ (error_table_$bad_arg, cmd_name, "
-io_module(-iom) ^a
 operand value must be ""tape_ansi_"" or ""tape_ibm_"".", arg);
	      else call com_err_ (error_table_$noarg, cmd_name, "
-io_module(-iom) requires an operand of ""tape_ansi_"" or ""tape_ibm_"".");
	      end iom_ctl;



          else
	   if arg = "volume_type" | arg = "-vt" then
vt_ctl:	   do;
	      if get_another_arg () then
	         if arg = "tape_ansi_" then do;
		  mtape_attach_desc = ANSI_TAPE_ATTACH_DESC;
		  mtape_open_desc = ANSI_TAPE_OPEN_DESC;
		  end;
	         else if arg = "ibm" then do;
		  mtape_attach_desc = IBM_TAPE_ATTACH_DESC;
		  mtape_open_desc = IBM_TAPE_OPEN_DESC;
		  end;
	         else call com_err_ (error_table_$bad_arg, cmd_name, "
-volume_type(-vt) ^a
 operand must be ""ansi"" or ""ibm"".", arg);
	      else call com_err_ (error_table_$noarg, cmd_name, "
-volume_type(-vt) requires an operand value of ""ansi"" or ""ibm"".");
	      end vt_ctl;



          else 
	   if arg = "-retain" | arg = "-ret" then
retain_ctl:  do;
	      if get_another_arg () then;
	      end retain_ctl;



          else
mtape_ctls:  do;			/* all remaining input arguments are*/
				/* passed along to mtape_ for	      */
				/* evaluation.		      */
             input_attach_args = input_attach_args || " ";
   	   if search (arg, """ ") ^= 0 then
	      input_attach_args = 
	         input_attach_args || requote_string_ ((arg));
	   else input_attach_args = input_attach_args || arg;

	   end mtape_ctls;
	     

          end process_input_arg_loop;



       /* If any of the arguments were found to be in error, then stop the  */
       /*	program.						      */

       if code ^= error_table_$nodescr then
	return;
%page;
/* ************************************************************************ */
/*							      */
/* Attach mtape_ to the requested volume set.			      */
/*   1) establish a condition handler to trap mtape_ errors.	      */
/*							      */
/* ************************************************************************ */

       mtape_attach_desc = mtape_attach_desc || input_attach_args;

       on command_error code=0;

       call iox_$attach_ioname
	(tape_io_switch, Piocb, (mtape_attach_desc), code);
       if code = error_table_$not_detached | code = 0 then;
       else do;			/* unable to attach tape file       */
	call com_err_ (code, cmd_name, "
While attaching file number ^d, volume ^a.  Attach description:^/^a",
	   current_file_no, lto.volid, mtape_attach_desc);
	call janitor;
	return;
	end;
%page;
/* ************************************************************************ */
/* Print information about the files in the volume set		      */
/* ************************************************************************ */
print_loop:

       do while (current_file_no <= lto.list_limit & code = 0);
          if current_file_no > 0 then
	   call iox_$open_file (Piocb, 4,
	     (mtape_open_desc || " -number" || char(current_file_no)),
	     "0"b, code);
	else
	   call iox_$open_file (Piocb, 4, (mtape_open_desc), "0"b, code);

	if code = 0 then
	   call iox_$control (Piocb, "file_status", addr (current_file), 
	      code);



	if code = 0 then
print_file_info:
	do;
	   if lto.print_mode = BRIEF then
brief_print_mode:
	   do;
	      if Sprint_banner then do;
	         call ioa_ ("
ID                                Number
");
	         Sprint_banner = FALSE;
	         end;
	      call ioa_ ("^32a^3x^5d", current_file.file_id, 
	         current_file.file_seq);
	      end brief_print_mode;



	   else
	      if lto.print_mode = LONG then
long_print_mode:
	      do;
	         call ioa_$rsnnl ("Section:^5x^4d
Created:^1x^8a^20tExpires:^1x^8a^40tGeneration:^1x^4d^58tVersion:^5x^4d
^[Format:^2x^4a^20tMode:^4x^6a^40tBlksize:^3x^5d^58tLrecl:^4x^7d^]",
		  current_line,
		  Lcurrent_line,
		  current_file.begin_vol_index,
		  cv_date (current_file.creation),
		  cv_date (current_file.expiration),
		  current_file.generation,
		  current_file.gen_version,
		  current_file.file_format ^= "",
		  current_file.file_format,
		  current_file.recording_mode,
		  current_file.block_len,
		  current_file.reclen);

	         if current_line = previous_line then
		  number_of_like_files = number_of_like_files + 1;
	         else
		  if number_of_like_files > 0 then do;
		     call ioa_ ("
The last ^d files have the same characteristics.", number_of_like_files + 1);
		     number_of_like_files = 0;
		     end;

	         call ioa_ ("
ID: ^32a^40tNumber:^4x^5d^[^58t^a^]",
		  current_file.file_id,
		  current_file.file_seq,
		  current_line ^= previous_line,
		  current_line);

	         previous_line = current_line;
	         end long_print_mode;



	   else
default_print_mode:
	      do;
	         if Sprint_banner then do;
		  call ioa_ ("
ID                Number   Format   Blksize   Lrecl    Mode   Created   Expires
");
		  Sprint_banner = FALSE;
		  end;

	         call ioa_$rsnnl ("^[****^6x****^4x****^4x**** ^s4"
		  || "^;^3a^5x^5d^2x^7d^3x^6a^]^2x^8a^2x^8a",
		  current_line,
		  Lcurrent_line,
		  current_file.file_format = "",
		  current_file.file_format,
		  current_file.block_len,
		  current_file.reclen,
		  current_file.recording_mode,
		  cv_date (current_file.creation),
		  cv_date (current_file.expiration));

	         if current_line = previous_line then
		  number_of_like_files = number_of_like_files + 1;
	         else
		  if number_of_like_files > 0 then do;
		     call ioa_ ("
The last ^d files have the same characteristics.", number_of_like_files + 1);
		     number_of_like_files = 0;
		     end;

	         call ioa_ ("^[^17a^;^a^/^17x^]^5d^[^7x^a^]",
		     length (rtrim (current_file.file_id)) < 18,
		     current_file.file_id, 
		     current_file.file_seq,
                         current_line ^= previous_line,
                         current_line);

	         previous_line = current_line;
	         end default_print_mode;



	      call iox_$close_file (Piocb,
	         "-no_display -close_position leave", code);

	      end print_file_info;
	   current_file_no = current_file_no + 1; 
	   end print_loop;



       if code = error_table_$no_file | code = 0 then;
       else 
	call com_err_ (code, cmd_name, "
While processing file number ^d, volume ^a
Attach description:^/^a", current_file_no, lto.volid, mtape_attach_desc);

       call janitor;

       if number_of_like_files > 0 then
	call ioa_ ("
The last ^d files have the same characteristics.", number_of_like_files + 1);

       if lto.list_limit = 99999 then;
       else if lto.list_limit > current_file_no then
	call ioa_ ("
Warning: file listing limit ^d, specified exceeds the number of
         files on the tape, ^d.", lto.list_limit, current_file_no);
%page;
/* ************************************************************************ */
/*     sees if 2nd part of two-part option exists			      */
/* ************************************************************************ */

get_another_arg: procedure returns (bit (1));

       if next_arg + 1 > n_args then do;
	code = error_table_$nodescr;
	return (FALSE);
	end;
       else do;			/* 2nd part does exist              */
	next_arg = next_arg + 1;	/* increment the option index	      */
	call get_arg_ptr;
	if code ^= 0 then
	   return (FALSE);
	else
	   return (TRUE);
	end;

       end get_another_arg;


/* ************************************************************************ */
get_arg_ptr: procedure;

       code = 0;
       call cu_$arg_ptr_rel (next_arg, Parg, Larg, code, Parg_list);
       return;
       end get_arg_ptr;
%page;
/* ************************************************************************ */
janitor: procedure;			/* cleanup control file, temp, obj, */
				/* and status segments	      */

       if Piocb ^= null () then do;
	call iox_$close_file (Piocb, "-no_display -close_position leave",
	   code);
	call iox_$detach (Piocb, "-no_display -rewind", code);
	end;
       return;
       end janitor;
%page;
/* ************************************************************************ */
cv_date: proc (julian) returns (char (8) aligned);

				/* date in form: yyddd              */
       dcl julian			char(6) aligned;
 
       dcl clock_value		fixed bin (71),
	 code			fixed bin (35);


       call convert_date_to_binary_ (("January 1, 19" ||
	substr(julian, 2, length("yy")) || " +" ||
	substr(julian, 4, length("ddd")) || "days -1day"),
	clock_value, code);

       if code ^= 0 then
	return (" unknown");

       return (date_time_$format ("multics_date", clock_value, "", ""));

       end cv_date;
%page;
%include mtape_file_status;

     end list_tape_contents;




		    tape_io.rd                      03/17/86  1520.3rew 03/17/86  1430.1      332478



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* tape_inout: Created 3/15/76 by J.B. Phillipps */
/* Modified extensively 6/79 by Michael R. Jordan to fix many bugs */
/* Modified extensively 4/82 by J. A. Bush for installation in MR10.0 */
/* format: style4 */

/*++
BEGIN	/<no-token>
		/Error (1)			/RETURN\

newVol	/Volume :
		/build_vcb
		 LEX (2)				/Volume\
	/<any-token>
		/Error (2)			/RETURN\
	/<no-token>
		/				/RETURN\

Volume	/<valid_volidp>
		/[ii = 1]
		 [vcb.volid(ii) = token_value]
		 LEX (1)				/morevols\
	/<any-token>
		/Error (6)
		 NEXT_STMT			/global\
	/<no-token>
		/				/notoken\
nextvol	/<valid_volidp>
		/[ii = ii + 1]
		 [if ii <= hbound (vcb.volid, 1)
		      then vcb.volid(ii) = token_value]
		 [else if ii = hbound (vcb.volid, 1)+1
		      then call Error (25)]
		 LEX (1)				/morevols\
	/<any-token>
		/Error (6)
		 NEXT_STMT			/global\
	/<no-token>
		/				/notoken\

morevols  /"-comment"
		/LEX (1)				/comment\
	/"-com"
		/LEX (1)				/comment\
	/<any-token>
		/				/ck_pun\
	/<no-token>
		/				/notoken\

comment	/<quoted-string>
		/[vcb.comment (ii) = token_value]
		 LEX (1)				/ck_pun\
	/<name>
		/[vcb.comment (ii) = token_value]
		 LEX (1)				/ck_pun\
	/<any-token>
		/[vcb.comment (ii) = token_value]
		 LEX (1)				/ck_pun\
	/<no-token>
		/				/notoken\

ck_pun	/;
		/[vcb.nvols = min (ii, hbound (vcb.volid, 1))]
		 LEX (1)				/global\
	/,
		/LEX (1)				/nextvol\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/global\
	/<no-token>
		/				/notoken\

global	/File :
		/LEX (2)
		 build_fcb (vcb.first_fcb_ptr, current_fcb_ptr)
		 [fcb.file_token_ptr = Ptoken]
		 [if current_default_fcb_ptr ^= null then
		     fcb.default_fcb_ptr = current_default_fcb_ptr]
						/File\
	/End ;
		/end_vcb
		 LEX (2)				/newVol\
	/Volume :
		/Error (4)
		 end_vcb				/newVol\
	/Tape :
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 LEX (2)				/Tape\
	/Density :
		/[if vcb.density ^= 0
		      then call Error (14)]
		 LEX (2)				/Density\

	/<any-token>
		/PUSH (global)
		 [if ^build_default_fcb then do;
		    call build_fcb (vcb.first_default_fcb_ptr, current_default_fcb_ptr);
		    build_default_fcb = "1"b;
		  end]
						/gloop\
	/<no-token>
		/				/notoken\

gloop	/Storage :
		/LEX (2)				/Storage\
          /Expiration :
		/LEX (2)				/Expires\
	/Mode :
		/LEX (2)				/Mode\
	/Format :
		/LEX (2)				/Format\
	/Block :
		/LEX (2)				/Block\
	/Record :
		/LEX (2)				/Record\

	/mode :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/storage :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/expiration :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/number :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/replace :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
      	/modify ;
		/Error (50)
		 NEXT_STMT			/STACK_POP\
      	/generate ;
		/Error (50)
		 NEXT_STMT			/STACK_POP\
      	/tape_extend ;
		/Error (50)
		 NEXT_STMT			/STACK_POP\
      	/storage_extend ;
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/format :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/block :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/record :
		/Error (50)
		 NEXT_STMT			/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\

Tape	/ANSI ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 1]
		 LEX (2)				/global\
          /ansi ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 1]
		 LEX (2)				/global\
	/IBMSL ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 2]
		 LEX (2)				/global\
          /ibmsl ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 2]
		 LEX (2)				/global\
	/IBMNL ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 3]
		 LEX (2)				/global\
          /ibmnl ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 3]
		 LEX (2)				/global\
	/IBMDOS ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 4]
		 LEX (2)				/global\
          /ibmdos ;
		/[if vcb.tape_type ^= 0
		      then call Error (20)]
		 [else vcb.tape_type = 4]
		 LEX (2)				/global\
	/<any-token> ;
		/Error (21)
		 LEX (2)				/global\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/global\
	/<no-token>
		/				/notoken\

Density	/6250 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 4]
		 LEX (2)				/global\
	/4 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 4]
		 LEX (2)				/global\
	/1600 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 3]
		 LEX (2)				/global\
	/3 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 3]
		 LEX (2)				/global\
	/800 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 2]
		 LEX (2)				/global\
	/2 ;
		/[if vcb.density ^= 0
		      then call Error (14)]
		 [else vcb.density = 2]
		 LEX (2)				/global\
	/<decimal-integer> ;
		/Error (7)
		 LEX (2)				/global\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/global\
	/<no-token>
		/				/notoken\

Storage	/unstructured ;
		/[if fcb.segment.format ^= 0
		      then call Error (33)]
		 [else fcb.segment.format = 1]
		 LEX (2)				/STACK_POP\

	/sequential ;
		/[if fcb.segment.format ^= 0
		      then call Error (33)]
		 [else fcb.segment.format = 2]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (12)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

Expires   /<valid_datep> ;
		/[if fcb.tape.expiration ^= "" ""
		      then call Error (34)]
		 [else fcb.tape.expiration = token_value]
		 LEX (2)				/STACK_POP\
          /<any-token> ;
		/Error (22)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

Mode	/ascii ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 1]
		 LEX (2)				/STACK_POP\
	/ASCII ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 1]
		 LEX (2)				/STACK_POP\
	/ebcdic ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 2]
		 LEX (2)				/STACK_POP\
	/EBCDIC ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 2]
		 LEX (2)				/STACK_POP\
	/binary ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 3]
		 LEX (2)				/STACK_POP\
	/BINARY ;
		/[if fcb.tape.cmode ^= 0
		      then call Error (44)]
		 [else fcb.tape.cmode = 3]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (8)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

Format	/U ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 1]
		 LEX (2)				/STACK_POP\
	/u ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 1]
		 LEX (2)				/STACK_POP\
	/F ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 2]
		 LEX (2)				/STACK_POP\
	/f ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 2]
		 LEX (2)				/STACK_POP\
	/FB ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 5]
		 LEX (2)				/STACK_POP\
	/fb ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 5]
		 LEX (2)				/STACK_POP\
	/D ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 3]
		 LEX (2)				/STACK_POP\
	/d ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 3]
		 LEX (2)				/STACK_POP\
	/DB ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 6]
		 LEX (2)				/STACK_POP\
	/db ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 6]
		 LEX (2)				/STACK_POP\
	/S ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 8]
		 LEX (2)				/STACK_POP\
	/s ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 8]
		 LEX (2)				/STACK_POP\
          /SB ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 9]
		 LEX (2)				/STACK_POP\
	/sb ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 9]
		 LEX (2)				/STACK_POP\
          /V ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 4]
		 LEX (2)				/STACK_POP\
	/v ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 4]
		 LEX (2)				/STACK_POP\
	/VB ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 7]
		 LEX (2)				/STACK_POP\
	/vb ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 7]
		 LEX (2)				/STACK_POP\
	/VS ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 10]
		 LEX (2)				/STACK_POP\
	/vs
		;			/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 10]
		 LEX (2)				/STACK_POP\
	/VBS ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 11]
		 LEX (2)				/STACK_POP\
	/vbs ;
		/[if fcb.tape.format ^= 0
		      then call Error (45)]
		 [else fcb.tape.format = 11]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (9)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

Block	/<valid_block_sizep> ;
		/[if fcb.tape.blklen ^= 0
		      then call Error (46)]
		 [else fcb.tape.blklen = token.Nvalue]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (10)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

Record	/<valid_record_sizep> ;
		/[if fcb.tape.reclen ^= 0
		      then call Error (47)]
		 [else fcb.tape.reclen = token.Nvalue]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (11)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

File      /<valid_file_namep> ;
		/[fcb.tape.file_id = token_value]
		 [build_default_fcb = "0"b]
		 LEX (2)				/local\
	/<any-token> ;
		/Error (37)
		 LEX (2)				/local\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/local\
	/<no-token>
		/				/notoken\

local	/<any-token>
		/PUSH (local)			/lloop\
	/<no-token>
		/				/notoken\

lloop	/path :
		/LEX (2)				/path\
	/mode :
		/LEX (2)				/Mode\
	/storage :
		/LEX (2)				/Storage\
	/expiration :
		/LEX (2)				/Expires\
	/number :
		/LEX (2)				/number\
	/replace :
		/LEX (2)				/replace\
	/format :
		/LEX (2)				/Format\
	/block :
		/LEX (2)				/Block\
	/record :
		/LEX (2)				/Record\
      	/modify ;
		/[if fcb.tape.output_mode ^= 0
		      then call Error (38)]
		 [else fcb.tape.output_mode = 2]
		 LEX (2)				/STACK_POP\
      	/generate ;
		/[if fcb.tape.output_mode ^= 0
		      then call Error (38)]
		 [else fcb.tape.output_mode = 3]
		 LEX (2)				/STACK_POP\
      	/tape_extend ;
		/[if fcb.tape.output_mode ^= 0
		      then call Error (38)]
		 [else fcb.tape.output_mode = 1]
		 LEX (2)				/STACK_POP\
      	/storage_extend ;
		/[if fcb.segment.extend ^= 0
		      then call Error (27)]
		 [fcb.segment.extend = 2]
		 LEX (2)				/STACK_POP\
	/File :
		/POP
						/global\
	/End
		/POP				/global\
	/Storage :
		/POP
		 				/global\
	/Expiration :
		/POP
		 				/global\
	/Mode :
		/POP
		 				/global\
          /Format :
		/POP
		 				/global\
	/Block :
		/POP
		 				/global\
          /Record :
		/POP
		 				/global\

	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

path	/<valid_pathnamep> ;
		/[if fcb.segment.ename ^= "" ""
		      then call Error (23)]
		 [fcb.segment.dirname = dirname]
		 [fcb.segment.ename = ename]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (13)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

number	/<valid_file_numberp> ;
		/[if fcb.tape.sequence ^= 0
		      then call Error (51)]
		 [else fcb.tape.sequence = token.Nvalue]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (48)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\
	/<no-token>
		/				/notoken\

replace	/<valid_file_namep> ;
		/[if fcb.tape.output_mode ^= 0
		      then call Error (38)]
		 [else fcb.tape.output_mode = 4]
		 [fcb.tape.replace_id = token_value]
		 LEX (2)				/STACK_POP\
	/<any-token> ;
		/Error (37)
		 LEX (2)				/STACK_POP\
	/<any-token>
		/Error (5)
		 NEXT_STMT			/STACK_POP\

notoken	/<no-token>
		/Error (3)			/RETURN\
++*/

tape_io: procedure;

/* CONSTANTS */

dcl  ANSI fixed bin internal static options (constant) init (1);
dcl  IBMNL fixed bin internal static options (constant) init (3);
dcl  DEFAULT_DENSITY (4) fixed bin internal static options (constant) init (2, 3, 3, 3);
dcl  SERROR_CONTROL bit (2) internal static options (constant) init ("10"b);
dcl  USAGE_MESSAGE char (115) internal static options (constant) init
	("^a^/Usage:  ^a tcl_path {-control_args}^/where control args are: -check, -ck, -force, -fc, -severityN, -svN, -ring");
dcl  sys_info$max_seg_size fixed bin (35) external static;	/* maximum segment size in words */

dcl  1 EMPTY_FCB aligned static internal options (constant),
       2 file_token_ptr ptr init (null),		/* none */
       2 next_fcb_ptr ptr init (null),			/* none */
       2 prev_fcb_ptr ptr init (null),			/* none */
       2 default_fcb_ptr ptr init (null),		/* none */
       2 segment,
         3 dirname char (168) init ((168)" "),
         3 ename char (32) init ((32)" "),
         3 format fixed bin init (0),			/* not specified */
         3 extend fixed bin init (0),			/* not specified */
         3 truncate_lines fixed bin init (0),		/* not specified */
       2 tape,
         3 cmode fixed bin init (0),			/* not specified */
         3 format fixed bin init (0),			/* not specified */
         3 output_mode fixed bin init (0),		/* not specified */
         3 file_id char (17) init (""),			/* not specified */
         3 replace_id char (17) init (""),		/* not specified */
         3 expiration char (16) init (""),		/* not specified */
         3 sequence fixed bin init (0),			/* not specified */
         3 blklen fixed bin init (0),			/* not specified */
         3 reclen fixed bin (21) init (0);		/* not specified */

dcl  1 EMPTY_VCB aligned static internal options (constant),
       2 volume_token_ptr ptr init (null),		/* none */
       2 next_vcb_ptr ptr init (null),			/* none */
       2 first_fcb_ptr ptr init (null),			/* none */
       2 first_default_fcb_ptr ptr init (null),		/* none */
       2 nvols fixed bin init (0),			/* no volumes */
       2 volid (64) char (32) init ((64) (32)" "),
       2 comment (64) char (64) init ((64) (64)" "),
       2 tape_type fixed bin init (0),			/* not specified */
       2 density fixed bin init (0);			/* not specified */


/* STATIC STORAGE */

dcl  breaks char (128) varying aligned internal static;	/* break characters for lex_string_ */
dcl  ignored_breaks char (128) varying aligned internal static; /* ignored breaks for lex_string_ */
dcl  init_req bit (1) internal static initial ("1"b);	/* initialization switch: 0-not required; 1-required */
dcl  lex_control_chars char (128) varying aligned internal static; /* control characters for lex_string_ */
dcl  lex_delims char (128) varying aligned internal static; /* delimiters for lex_string_ */


/* AUTOMATIC STORAGE */

dcl  1 tid like tape_io_data aligned;
dcl  1 ai like area_info aligned;

dcl  aL fixed bin;
dcl  aP ptr;
dcl  arg_num fixed bin;
dcl  clk_val fixed bin (71);
dcl  bc fixed bin (24);
dcl  code fixed bin (35);
dcl  current_default_fcb_ptr ptr init (null);
dcl  current_fcb_ptr ptr init (null);
dcl  dfcbp ptr;
dcl  dirname char (168);
dcl  ename char (32);
dcl  error_count fixed bin;
dcl  ii fixed bin;
dcl  j fixed bin;
dcl  max_severity_num fixed bin;			/* max severity printed by lex_error_ */
dcl  name char (8);					/* command name */
dcl  nargs fixed bin;
dcl  serror_printed (dimension (error_control_table, 1)) bit (1) unaligned; /* is "1"b if error msg printed prev. */
dcl  temp_ptr ptr;
dcl  writing bit (1);				/* ON => tape_out */
dcl  build_default_fcb bit (1) aligned init ("0"b);

/* BASED STORAGE */

dcl  arg char (aL) based (aP);
dcl  my_area area based (tape_io_data.temp (1));


/* ERROR CODES */

dcl  error_table_$active_function fixed bin (35) ext static;
dcl  error_table_$badopt 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_$translation_failed fixed bin (35) ext static;


/* BUILTIN FUNCTIONS */

dcl  (addr, collate, dimension, divide, hbound, min, mod, null, substr, unspec) builtin;

/* CONDITIONS */

dcl  cleanup condition;


/* EXTERNAL PROCEDURES */

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ ext entry options (variable);
dcl  convert_date_to_binary_ ext entry (char (*), fixed bin (71), fixed bin (35));
dcl  cu_$af_arg_count ext entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  translator_temp_$get_next_segment entry (ptr, ptr, fixed bin (35));
dcl  translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35));
dcl  translator_temp_$release_segment entry (ptr, fixed bin (35));
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
dcl  ioa_ ext entry options (variable);
dcl  lex_error_ ext entry options (variable);
dcl  lex_string_$init_lex_delims ext entry (char (*), char (*), char (*), char (*),
	char (*), bit (*), char (*) varying aligned, char (*) varying aligned, char (*) varying aligned,
	char (*) varying aligned);
dcl  lex_string_$lex ext entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*),
	char (*), char (*), char (*) varying aligned, char (*) varying aligned, char (*) varying aligned,
	char (*) varying aligned, ptr, ptr, fixed bin (35));
dcl  tape_io_interpret_ entry (ptr);

tape_in: tin: entry;

	name = "tape_in";				/* set command name */
	writing = "0"b;				/* not writing tape */
	go to common_code;				/* begin processing */

tape_out: tout: entry;

	name = "tape_out";				/* set command name */
	writing = "1"b;				/* writing tape */

common_code:

	tape_io_data_ptr = addr (tid);
	tape_io_data.temp (*) = null;
	tape_io_data.first_vcb_ptr = null;
	tape_io_data.source.dirname = "";
	tape_io_data.source.ename = "";
	tape_io_data.source.ptr = null;
	tape_io_data.control.ck = "0"b;
	tape_io_data.control.force = "0"b;
	tape_io_data.control.ring = "0"b;
	tape_io_data.control.writing_tape = writing;
	tape_io_data.control.max_severity = 0;

	call cu_$af_arg_count (nargs, code);
	if code = error_table_$not_act_fnc then
	     code = 0;
	else if code = 0 then do;
	     call active_fnc_err_ (error_table_$active_function, name);
	     return;
	end;
	else do;
	     call com_err_ (code, name);
	     return;
	end;
	if nargs < 1 then do;
	     call com_err_ (error_table_$noarg, name, USAGE_MESSAGE,
		"Control file pathname is missing.", name);
	     return;
	end;
	call cu_$arg_ptr (1, aP, aL, (0));
	call expand_pathname_$add_suffix (arg, "tcl",
	     tape_io_data.source.dirname, tape_io_data.source.ename, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "^a", arg);
	     return;
	end;

	on cleanup call Cleaner;

	call hcs_$initiate_count (tape_io_data.source.dirname,
	     tape_io_data.source.ename, "", bc, 0, tape_io_data.source.ptr,
	     code);
	if tape_io_data.source.ptr = null then do;
	     call com_err_ (code, name, "^a^[>^]^a", tape_io_data.source.dirname,
		(tape_io_data.source.dirname ^= ">"), tape_io_data.source.ename);
	     return;
	end;
	unspec (ai) = "0"b;				/* clear out area info */
	ai.version = area_info_version_1;		/* set up area info block */
	ai.control.extend = "1"b;
	ai.control.zero_on_alloc = "1"b;
	ai.owner = name;
	ai.size = sys_info$max_seg_size;
	ai.version_of_area = area_info_version_1;
	ai.areap = null;
	call define_area_ (addr (ai), code);		/* get an area */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Cannot define an area");
	     go to EXIT;
	end;
	tape_io_data.temp (1) = ai.areap;		/* copy area ptr */
	call translator_temp_$get_segment ((name), tape_io_data.temp (2), code);
	if code = 0 then
	     call translator_temp_$get_next_segment (tape_io_data.temp (2), tape_io_data.temp (3), code);
	if tape_io_data.temp (2) = null | tape_io_data.temp (3) = null then do;
	     call com_err_ (code, name, "Cannot allocate necessary temporary segments.");
	     go to EXIT;
	end;

	do arg_num = 2 repeat arg_num + 1 while (arg_num <= nargs);
	     call cu_$arg_ptr (arg_num, aP, aL, (0));
	     if arg = "-check" | arg = "-ck" then
		tape_io_data.control.ck = "1"b;
	     else if arg = "-severity" | arg = "-sv" then do;
		arg_num = arg_num + 1;
		if arg_num > nargs then do;
		     call com_err_ (error_table_$noarg, name,
			"Severity level missing following ^a.", arg);
		     goto EXIT;
		end;
		call cu_$arg_ptr (arg_num, aP, aL, (0));
		tape_io_data.control.max_severity = cv_dec_check_ (arg, code);
		if code ^= 0 then
		     go to bad_arg;
	     end;
	     else if arg = "-force" | arg = "-fc" then
		tape_io_data.control.force = "1"b;	/* force all file expiration dates */
	     else if arg = "-ring" then
		tape_io_data.control.ring = "1"b;
	     else do;
bad_arg:		call com_err_ (error_table_$badopt, name, "^a", arg);
		goto EXIT;
	     end;
	end;
	error_count = 0;				/* initialize syntatical error counter */
	if init_req then do;			/* initialize static values if necessary */
	     breaks = substr (collate, 1, 33);		/* control characters */
	     breaks = breaks || ":;, ";		/* my definitions */
	     breaks = breaks || substr (collate, 128, 1); /* ....and the null (pad) character */
	     ignored_breaks = substr (collate, 1, 8);	/* control characters.... */
	     ignored_breaks = ignored_breaks || substr (collate, 10, 24); /* ....excluding backspace */
	     ignored_breaks = ignored_breaks || substr (collate, 128, 1); /* and null character */
	     init_req = "0"b;			/* initialization no longer necessary */
	end;

	call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "1"b, /* initialize the lexing routine */
	     breaks, ignored_breaks, lex_delims, lex_control_chars);

/* call to parse character string input into tokens  */
/* chained list of token descriptors generated in temp seg pointed to by temp (2)  */

	call lex_string_$lex (tape_io_data.source.ptr, divide (bc, 9, 21, 0),
	     0, tape_io_data.temp (2), "1"b, """", """", "/*", "*/", ";",
	     breaks, ignored_breaks, lex_delims, lex_control_chars, Pstmt,
	     Pthis_token, code);
	if code ^= 0 then
	     call com_err_ (code, name);
	if Pthis_token = null then do;
	     call com_err_ (error_table_$translation_failed, name, "The source file is uninterpretable.");
	     goto EXIT;
	end;

/* invoke subroutine which translates tokens */

	max_severity_num = 0;			/* initialize */

	call SEMANTIC_ANALYSIS ();
	if max_severity_num > 1 then do;
	     call com_err_ (error_table_$translation_failed, name);
	     goto EXIT;
	end;

/* if user only wants syntax checking then that's all here  */

	if ^tape_io_data.control.ck then
	     call tape_io_interpret_ (tape_io_data_ptr);	/* go do the requested I/O */
	else call ioa_ ("^/^a: Translation finished; Number of errors encountered was ^d", name, error_count);
EXIT:
	call Cleaner;
	return;

Cleaner: procedure;

	if tape_io_data.source.ptr ^= null then
	     call hcs_$terminate_noname (tape_io_data.source.ptr, 0);
	if tape_io_data.temp (1) ^= null then
	     call release_area_ (tape_io_data.temp (1));
	if tape_io_data.temp (2) ^= null then
	     call translator_temp_$release_segment (tape_io_data.temp (2), code);
	if tape_io_data.temp (3) ^= null then
	     call translator_temp_$release_segment (tape_io_data.temp (3), code);

     end Cleaner;


Error: proc (en);					/* subroutine to check severify before printing errors */

dcl  en fixed bin;
dcl  pstmt ptr;

	if Ptoken = null () then pstmt = null ();
	else pstmt = token.Pstmt;
	if error_control_table (en).severity >= tape_io_data.control.max_severity then
	     call lex_error_ (en, serror_printed (en),
		error_control_table (en).severity, max_severity_num, pstmt, null (),
		SERROR_CONTROL, error_control_table (en).message, error_control_table (en).brief_message);

	error_count = error_count + 1;


     end Error;

valid_block_sizep: procedure returns (bit (1) aligned);	/* defines <valid_block_sizep> token */

	token.Nvalue = cv_dec_check_ (token_value, code);
	if code ^= 0 then return ("0"b);
	if token.Nvalue < 18 then return ("0"b);	/* not valid if too small */
	if token.Nvalue > 99996 then return ("0"b);	/* not valid if too large */
	return ("1"b);				/* valid */

     end valid_block_sizep;

valid_file_namep: procedure returns (bit (1) aligned);	/* defines valid_file_namep */

	if token.Lvalue < 1 then return ("0"b);
	if token.Lvalue > 17 then return ("0"b);
	return ("1"b);
     end valid_file_namep;

valid_file_numberp: procedure returns (bit (1) aligned);	/* defines <valid_file_numberp> token */

	if token_value = "*" then do;			/* file number not specified */
	     token.Nvalue = -1;
	     return ("1"b);
	end;
	token.Nvalue = cv_dec_check_ (token_value, code);
	if code ^= 0 then return ("0"b);
	if token.Nvalue > 9999 then return ("0"b);
	if token.Nvalue <= 0 then return ("0"b);
	return ("1"b);				/* valid */
     end valid_file_numberp;

valid_pathnamep: procedure returns (bit (1) aligned);	/* defines <valid_pathnamep> token */

	call expand_pathname_ (token_value, dirname, ename, code);
	return (code = 0);
     end valid_pathnamep;

valid_record_sizep: procedure returns (bit (1) aligned);	/* defines <valid_record_sizep> token */

	token.Nvalue = cv_dec_check_ (token_value, code);
	if code ^= 0 then return ("0"b);
	if token.Nvalue < 1 then return ("0"b);		/* not valid if 0 (or negative) */
	if token.Nvalue > sys_info$max_seg_size * 4 then return ("0"b); /* not valid if > segment size in chars */
	return ("1"b);				/* meets requirements */
     end valid_record_sizep;

valid_volidp: procedure returns (bit (1) aligned);	/* defines <valid_volidp> token */

	if token.Lvalue > 32 then return ("0"b);	/* not <valid_volidp> if greater than 32 characters */
	if token.Lvalue < 1 then return ("0"b);		/* not <valid_volidp> if less than 1 character */
	return ("1"b);				/* no other requirements */
     end valid_volidp;

valid_datep: procedure returns (bit (1) aligned);		/* defines <valid_datep> token */

	call convert_date_to_binary_ (token_value, clk_val, code); /* convert date */
	return (code = 0);
     end valid_datep;

build_vcb: procedure;				/* procedure to build a vcb */

	allocate vcb in (my_area) set (temp_ptr);
	if tid.first_vcb_ptr = null then
	     tid.first_vcb_ptr = temp_ptr;
	else vcb.next_vcb_ptr = temp_ptr;
	vcb_ptr = temp_ptr;
	vcb = EMPTY_VCB;				/* Initialize the vcb */

     end build_vcb;


end_vcb: procedure;					/* procedure to add defaults to VCBs and FCBs */

	if vcb.tape_type = 0 then
	     vcb.tape_type = ANSI;
	if vcb.density = 0 then			/* Must set the default density */
	     vcb.density = DEFAULT_DENSITY (vcb.tape_type);
	if vcb.first_fcb_ptr = null then do;		/* no file-groups in this volume-group */
	     Ptoken = vcb.volume_token_ptr;		/* no source line to be printed */
	     call Error (52);
	     return;
	end;

	do fcb_ptr = vcb.first_fcb_ptr repeat fcb.next_fcb_ptr while (fcb_ptr ^= null ());
	     call Complete_FCB ();			/* add defaults to FCB */
	     call Check_FCB ();			/* and validate FCB */
	end;

     end end_vcb;

build_fcb: procedure (head, tail);			/* procedure to allocate and initialize an FCB */

dcl  (head, tail) ptr;				/* ptr to head & tail of FCB chain */

	allocate fcb in (my_area) set (temp_ptr);
	if head = null then
	     head = temp_ptr;
	else tail -> fcb.next_fcb_ptr = temp_ptr;
	fcb_ptr = temp_ptr;
	fcb = EMPTY_FCB;				/* reset for next <file-group> */
	if tail ^= null then
	     fcb.prev_fcb_ptr = tail;			/* set backward fcb thread */
	tail = temp_ptr;				/* and update fcb tail for next allocation */

     end build_fcb;

Complete_FCB: procedure;				/* procedure to add defaults to FCB */

/* first, add in global default values, if any */

	do dfcbp = fcb.default_fcb_ptr repeat dfcbp -> fcb.prev_fcb_ptr while (dfcbp ^= null);
	     if fcb.tape.blklen = 0 then fcb.tape.blklen = dfcbp -> fcb.tape.blklen;
	     if fcb.tape.reclen = 0 then fcb.tape.reclen = dfcbp -> fcb.tape.reclen;
	     if fcb.tape.format = 0 then fcb.tape.format = dfcbp -> fcb.tape.format;
	     if fcb.tape.cmode = 0 then fcb.tape.cmode = dfcbp -> fcb.tape.cmode;
	     if fcb.tape.expiration = "" then fcb.tape.expiration = dfcbp -> fcb.tape.expiration;
	     if fcb.segment.format = 0 then fcb.segment.format = dfcbp -> fcb.segment.format;
	end;

/* Set the defaults up according to what kind of tape is to be processed */

	if vcb.tape_type = ANSI then do;		/* If ANSI tape, set the ANSI defaults */
	     if fcb.tape.cmode = 0 then		/* if recording mode not specified.. */
		fcb.tape.cmode = 1;			/* set ANSI default to ASCII */
	     if tape_io_data.control.writing_tape then do;/* if tape output */
		if fcb.tape.format = 0 then		/* if tape format not specified.. */
		     fcb.tape.format = 6;		/* set ANSI default to DB */
		if fcb.tape.blklen = 0 then		/* if block length not specified.. */
		     fcb.tape.blklen = 2048;		/* set ANSI default */
		if fcb.tape.reclen = 0 then		/* if Record length not specified.. */
		     fcb.tape.reclen = 2048;		/* set ANSI default  */
	     end;
	end;
	else do;					/* No, its an IBMSL, IBMNL, or IBMDOS tape */
	     if fcb.tape.cmode = 0 then		/* if recording mode not specified.. */
		fcb.tape.cmode = 2;			/* set IBM default to EBCDIC */
	     if tape_io_data.control.writing_tape then do;/* if tape output */
		if fcb.tape.format = 0 then		/* if tape format not specified.. */
		     fcb.tape.format = 7;		/* set IBM default to VB */
		if fcb.tape.blklen = 0 then		/* if block length not specified.. */
		     fcb.tape.blklen = 8192;		/* set IBM default */
		if fcb.tape.reclen = 0 then		/* if Record length not specified.. */
		     fcb.tape.reclen = 8188;		/* set IBM default  */
	     end;
	end;

/* Now do the common defaults */

	if tape_io_data.control.writing_tape then	/* if tape output */
	     if fcb.tape.output_mode = 0 then		/* if no output mode specified... */
		fcb.tape.output_mode = 4;		/* The default is "Create or Replace" */
	if fcb.segment.format = 0 then		/* if no segment format specified... */
	     fcb.segment.format = 1;			/* The default is "Unstructured" */
	if fcb.segment.extend = 0 then		/* if no extend action specified... */
	     fcb.segment.extend = 1;			/* The default is "Truncate" */
	if fcb.segment.truncate_lines = 0 then		/* if no long lines action specified... */
	     fcb.segment.truncate_lines = 1;		/* The default is to "Fold" long lines */

     end Complete_FCB;

Check_FCB: procedure;				/* procedure to validate the FCB for completness */

	Ptoken = null;				/* no source line to be printed */
	if fcb.segment.dirname = "" | fcb.segment.ename = "" then /* no "path" statement */
	     call Error (24);
	if fcb.tape.file_id = "" then			/* No file statement */
	     call Error (18);
	if fcb.tape.sequence = -1 then		/* if number statement specified as "*".. */
	     if fcb.tape.output_mode ^= 4 then		/* mode has to be append */
		call Error (49);
	if vcb.tape_type ^= ANSI then do;		/* tape volume.tape_type not ANSI */
	     if fcb.tape.output_mode = 3 then		/* generate option not supported by IBM */
		call Error (19);
	     if fcb.tape.output_mode > 0 then		/* some output option  specified */
		if fcb.tape.blklen ^= 0 then		/* block size specified */
		     if mod (fcb.tape.blklen, 4) ^= 0 then /* blklen not word multiple */
			call Error (28);
	     if fcb.tape.blklen > 32760 then		/* block size too large for tape_ibm_ */
		call Error (10);
	end;
	if vcb.tape_type = IBMNL then do;		/* unlabeled volume specified */
	     if fcb.tape.file_id ^= "*" then		/* file names not allowed with unlabled volumes */
		call Error (29);
	     if fcb.tape.sequence = 0 then		/* if no file sequence number specified */
		call Error (31);
	     if fcb.tape.replace_id ^= "" then		/* replace statement specified for unlabeled tape */
		call Error (30);
	     if fcb.tape.output_mode = 1 then		/* extend specified for unlabeled tape */
		call Error (32);
	     else if fcb.tape.output_mode = 2 then	/* modify specified for unlabeled tape */
		call Error (55);
	     if fcb.tape.expiration ^= "" then		/* expires specified for unlabeled tape */
		call Error (56);
	     if tape_io_data.control.force then		/* -force option  specified for unlabeled tape */
		call Error (35);
	end;
	else do;					/* ANSI and labeled IBM checks */
	     if fcb.tape.output_mode = 4 then		/* ANSI and IBM checks  -  create */
		if fcb.tape.file_id = "*" then	/* invalid file id for create */
		     call Error (53);
		else ;
	     else if fcb.tape.output_mode = 0 then do;	/* tape input mode */
		if fcb.tape.format = 0 then		/* no format specified on input */
		     if fcb.tape.reclen > 0 | fcb.tape.blklen > 0 then /* reclen or blklen illegal */
			call Error (42);
		if fcb.tape.format > 1 then		/* if format was specified, record and/or block */
		     if fcb.tape.reclen = 0 | fcb.tape.blklen = 0 then /*  length must be specified */
			call Error (42);
	     end;
	     else if fcb.tape.output_mode < 3 then do;	/* output mode is extend or modify */
		if fcb.tape.expiration ^= "" then	/* and expiration specified */
		     if fcb.tape.output_mode = 1 then	/* if extend.. */
			call Error (39);
		     else call Error (40);		/* if modify */
	     end;
	     if fcb.tape.sequence = 0 | fcb.tape.sequence = -1 then /* no explicit sequence  or "*" */
		if fcb.tape.file_id = "*" then	/* and no <fileid> */
		     call Error (41);
	end;

	go to test (fcb.tape.format);			/* now go validate the format */

test (1):						/* U-format   */
	if fcb.tape.reclen ^= 0 then
	     fcb.tape.reclen = 0;			/* reclen must be zero */
	if fcb.tape.blklen = 0 then do;
	     call Error (43);
	     call ioa_ ("Tape file block size is ^d", fcb.tape.blklen);
	end;
	go to out;
test (2):						/* F-format  */
test (5):						/* FB-format */
	if fcb.tape.blklen ^= 0 & fcb.tape.reclen ^= 0 then do; /* non zero block & record length  */
	     if fcb.tape.format = 5 then do;		/* FB check */
		if mod (fcb.tape.blklen, fcb.tape.reclen) ^= 0 then do;
		     call Error (16);
		     call ioa_ ("Tape file record size is ^d", fcb.tape.reclen);
		     call ioa_ ("Tape file block size is ^d", fcb.tape.blklen);
		end;
	     end;
	     else if fcb.tape.blklen ^= fcb.tape.reclen then do; /* F format check */
		call Error (15);
		call ioa_ ("Tape file record size is ^d", fcb.tape.reclen);
		call ioa_ ("Tape file block size is ^d", fcb.tape.blklen);
	     end;
	end;
	go to out;
test (3):						/* D-format */
test (4):						/* V-format */
test (6):						/* DB-format  */
test (7):						/* VB-format */
	if fcb.tape.blklen ^= 0 & fcb.tape.reclen ^= 0 then do; /* d/v format */
	     if vcb.tape_type = ANSI then
		j = 0;				/* don't allow for BDW if ANSI */
	     else j = 4;				/* IBM - allow for 4 byte BDW */
	     if fcb.tape.format > 4 then do;		/* blocked: reclen must be <= blklen */
		if fcb.tape.blklen < fcb.tape.reclen + j then do;
		     call Error (17);
		     call ioa_ ("Tape file record size is ^d", fcb.tape.reclen);
		     call ioa_ ("Tape file block size is ^d", fcb.tape.blklen);
		end;
	     end;
	     else if fcb.tape.blklen ^= fcb.tape.reclen + j then do; /* V-format, D-format */
		call Error (15);
		call ioa_ ("Tape file record size is ^d", fcb.tape.reclen);
		call ioa_ ("Tape file block size is ^d", fcb.tape.blklen);
	     end;
	end;
test (8): test (9):
test (10): test (11):				/* S, SB, VS, VB, VS, VBS formats, all is possible */
test (0):						/* for reading, format code is 0 */
out:
	return;

     end Check_FCB;

%include tape_io_data;

%include area_info;

%include tape_io_errors;




		    tape_io_interpret_.pl1          04/19/88  0829.1rew 04/19/88  0824.0      313389



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


/****^  HISTORY COMMENTS:
  1) change(87-04-13,TLNguyen), approve(87-04-13,MCR7664),
     audit(87-06-08,GWMay), install(87-07-15,MR12.1-1040):
     make tape_in able to read imcomplete ANSI tapes.
  2) change(88-02-03,GWMay), approve(88-02-03,MCR7837), audit(88-04-12,Farley),
     install(88-04-19,MR12.2-1039):
     Reformatted and simplified error messages.
     changed to pass the value of abort_sw to the close_tape_file
     routine.
                                                   END HISTORY COMMENTS */


tape_io_interpret_: proc (arg_tape_io_data_ptr);

/* format: style4 */
/* tape_io_interpret_ - This module interprets the Volume Control Blocks (VCBs)
   and File Control Blocks (FCBs) created from the tcl file by tape_io.rd (with
   the aid of the reduction compiler package), and does the actual tape to SS file
   (tape_in) or SS file to tape (tape_out) I/O.

   Modification History:
   Created circa 1979 by M. R. Jordan by extracting required functionality from tape_io.rd
   Completed and extensively modified 4/82 by J. A. Bush for understandability and
   to make it easier to convert to future improved tape software.
   Modfied 10/26/82 by J. A. Bush to fix bugs (phx10501, phx13989)
*/

/* PARAMETERS */

dcl  arg_tape_io_data_ptr ptr;


/* BASED STORAGE */

dcl  1 input_record based (wt_ptr) unaligned,		/* template for writing input record */
       2 cw char (amrl),				/* number of chars to write */
       2 next_char bit (0);				/* to allow setting ptr to end of last record */

/* AUTOMATIC STORAGE */

dcl  1 ads like device_status;			/* auto copy of device_status structure */
dcl  1 atfs like tape_file_status;			/* auto copy of tape_file_status structure */

dcl  1 tape_attach_descp aligned,			/* iox_ attachment descption structure for tape */
       2 vol_string char (256) varying,			/* volume portion of attach desc */
       2 file_string char (256) varying,		/* file portion of attach desc */
       2 string char (512) varying;			/* full attach description */

dcl  1 vfile_info aligned,				/* structure for vfile_status_ */
       2 info_version fixed,
       2 type fixed,
       2 records fixed (34),
       2 flags aligned,
         3 lock_status bit (2) unaligned,
         3 pad bit (34) unaligned,
       2 version fixed,
       2 action fixed,
       2 max_rec_len fixed (21);

/* automatic storage */
dcl  add_specified_attributes bit (1);
dcl  abort_sw bit (1) aligned;
dcl  amrl fixed bin (21);				/* number of chars requested/transmitted per io xfer */
dcl  answer char (128) varying;
dcl  blkl picture "zzzzzzz9";
dcl  recl picture "zzzzzzz9";
dcl  secq picture "zzz9";
dcl  blockl fixed bin (21);
dcl  char_cnt fixed bin (21);				/* number of characters transferred per fcb io action */
dcl  code fixed bin (35);				/* error code */
dcl  cont_sw bit (1);
dcl  control_sw bit (1);
dcl  db_sw bit (1) init ("0"b);
dcl  end_of_data bit (1);				/* EOD detected bit */
dcl  end_of_tape bit (1);				/* EOT detected bit */
dcl  file_count fixed bin;
dcl  fileid char (17) varying;
dcl  fnbr fixed bin;
dcl  i fixed bin;					/* temporary storage */
dcl  longinfo char (100) aligned;
dcl  name char (8) varying;				/* command name */
dcl  pathname char (168) varying;
dcl  rcode fixed bin (35);
dcl  ring_sw bit (1);				/* switch to make sure a ring gets in tape mounted for sqi */
dcl  (blen, rlen, wlen, b_offset) fixed bin (21);
dcl  wt_ptr ptr;
dcl  shortinfo char (8) aligned;
dcl  ss_atd char (256);
dcl  ss_iocbp ptr initial (null);
dcl  ss_open_mode fixed bin;
dcl  ss_switch char (26);				/* file switch name */
dcl  tape_iocbp ptr;
dcl  tape_switch char (26);				/* tape_switch name */
dcl  tstring char (256) varying;
dcl  vol_init bit (1);				/* ON => develop volume portion of attach desc */
dcl  writeff_sw bit (1);
dcl  zlck bit (1) aligned;
dcl  cant_cont bit (1) aligned;
dcl  output bit (1) aligned;				/* shorter form of tape_io_data.control.writing */
dcl  io_started bit (1) aligned;

/* CONSTANTS */

dcl  IBMNL fixed bin internal static options (constant) init (3);
dcl  IBMDOS fixed bin internal static options (constant) init (4);
dcl  q_mess1 char (57) int static options (constant) init
	("ride the control file and read the storage system file as");
dcl  q_mess2 char (56) int static options (constant) init
	("write this storage system file by changing its format to");
dcl  DENSITY (4) char (4) varying internal static options (constant) init ("", "800", "1600", "6250");
dcl  FORMAT (11) char (3) varying internal static options (constant) init
	("u", "f", "d", "v", "fb", "db", "vb", "s", "sb", "vs", "vbs");
dcl  MODE (3) char (8) varying internal static options (constant) init
	("ascii", "ebcdic", "binary");
dcl  IO_MODULE_NAME (4) char (12) varying internal static options (constant) init
	("tape_ansi_", "tape_ibm_", "tape_ibm_", "tape_ibm_");
dcl  OUTPUT_MODE (4) char (12) varying internal static options (constant) init
	(" -extend ", " -modify ", " -generate ", " -create ");
dcl  sys_info$max_seg_size fixed bin (35) external static;	/* maximum segment size in words */
dcl  wks_ptr ptr int static init (null);		/* I/O buffer pointer */
dcl  (tape_attached, tape_opened, ss_file_attached, ss_file_opened) bit (1) aligned int static init ("0"b);
dcl  cleanup condition;

/* ERROR CODES */

dcl  error_table_$dirseg fixed bin (35) ext static;
dcl  error_table_$end_of_info fixed bin (35) ext static;
dcl  error_table_$eov_on_write fixed bin (35) ext static;
dcl  error_table_$file_busy fixed bin (35) ext static;
dcl  error_table_$insufficient_open fixed bin (35) ext static;
dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$no_file fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$short_record fixed bin (35) ext static;


/* BUILTIN FUNCTIONS */

dcl  addr builtin;
dcl  fixed builtin;
dcl  ltrim builtin;
dcl  min builtin;
dcl  null builtin;
dcl  rtrim builtin;
dcl  substr builtin;


/* EXTERNAL PROCEDURES */

dcl  com_err_ ext entry options (variable);
dcl  command_query_ ext entry options (variable);
dcl  convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$cl entry;
dcl  ioa_ ext entry options (variable);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  vfile_status_ entry (char (*), char (*), ptr, fixed (35));
%page;
	tape_io_data_ptr = arg_tape_io_data_ptr;	/* copy arg */
	output = tape_io_data.control.writing_tape;	/* makes program easier to read */
	if output then				/* if writing tape, this is tape_out */
	     name = "tape_out";
	else name = "tape_in";

	call get_temp_segment_ ((name), wks_ptr, code);	/* get a buffer segment */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Attempting to get tape I/O buffer segment");
	     return;
	end;
	query_info.version = query_info_version_4;	/* set version number */
	vfile_info.info_version = 1;			/* set vfile_status_ info structure version */
	file_count = 0;
	ss_switch = name || "_" || "ss_file";		/* initialize the SS file switch */
	abort_sw, writeff_sw = "0"b;
	ss_iocbp, tape_iocbp = null;
	blen = sys_info$max_seg_size * 4;		/* set buffer size to max */
	ring_sw = output | tape_io_data.control.ring;
	on cleanup call Cleaner ();			/* establish cleanup handler */

	do vcb_ptr = first_vcb_ptr repeat vcb.next_vcb_ptr while (vcb_ptr ^= null () & ^abort_sw);
	     vol_init = "1"b;			/* set the init flag for each volume-group */
	     fnbr = 0;				/* reset the file number */
	     tape_switch = name || "_" || vcb.volid (1);
	     do fcb_ptr = vcb.first_fcb_ptr repeat fcb.next_fcb_ptr while (fcb_ptr ^= null () & ^abort_sw);
		call fcb_worker;			/* perform requested io */
	     end;
	end;

	if ^abort_sw then
	     call ioa_ ("^/^a: Completed processing of  ^a>^a: ^d ^[file^;files^] transferred.", name,
		tape_io_data.source.dirname, tape_io_data.source.ename, file_count, (file_count = 1));

	call Cleaner ();				/* close and detach resources still opened or attached */

	return;
%page;
fcb_worker: procedure;				/* performs io */

	char_cnt, blockl = 0;
	end_of_data, abort_sw, control_sw, cont_sw = "0"b;/* (re-) set  */
	if fcb.tape.file_id ^= "*" then		/* set fileid for error msg */
	     fileid = rtrim (fcb.tape.file_id);
	else do;					/* if name = * then use  file number for error msg */
	     secq = fixed (fcb.tape.sequence);
	     fileid = "#" || ltrim (secq);
	end;
	goto FORMAT (fcb.tape.format);		/* dispatch on format */
FORMAT (0):					/* not specified */
	amrl = sys_info$max_seg_size * 4;		/* assume the worst */
	goto COMMON_WORK;

FORMAT (1):					/* U */
	amrl = fcb.tape.blklen;			/* U - try to get blklen characters */
	goto COMMON_WORK;

FORMAT (2):					/* F */
FORMAT (5):					/* FB */
	amrl = fcb.tape.reclen;			/* F or FB - try to get reclen characters */
	goto COMMON_WORK;

FORMAT (3):					/* D */
FORMAT (4):					/* V */
FORMAT (6):					/* DB */
FORMAT (7):					/* VB */
	amrl = fcb.tape.reclen - 4;			/* D, V, DB or VB - try to get reclen - rcw/rdw characters */
	goto COMMON_WORK;

FORMAT (8):					/* S */
FORMAT (9):					/* SB */
FORMAT (10):					/* VS */
FORMAT (11):					/* VBS */
	amrl = min (fcb.tape.reclen, sys_info$max_seg_size * 4);

COMMON_WORK:
	if fcb.segment.dirname = ">" then		/* special case the root dir */
	     pathname = ">" || fcb.segment.ename;
	else pathname = rtrim (fcb.segment.dirname) || ">" || fcb.segment.ename;
	if output then
	     call write_tape ();			/* tape write logic */
	else call read_tape ();			/* tape read logic */
	if char_cnt = 0 & io_started then		/* if no date xfered, tell user */
	     if output then
		call ioa_ ("^a: Storage system file ""^a"", transfer to tape file ^a of volume-set ^a has zero length.",
		     name, pathname, fcb.tape.file_id, vcb.volid (1));
	     else call ioa_ ("^a: Tape file ""^a"" transfer to storage system file ""^a"" has zero length.",
		     name, fileid, pathname);

	return;					/* exit */


     end fcb_worker;
%page;
/* read_tape - subroutine to read tape file into SS file */

read_tape: proc;

	call check_ss_file;				/* check SS file for access and consistency */
	call build_tape_attach;			/* create tape attach description */
	call open_tape_file;			/* attach and open tape file */
	call open_ss_file;				/* attach  and open SS file */

/* main processing loop, read tape/write ss file */

	do while (^end_of_data & ^abort_sw & ^cont_sw);	/* do until no more data */
	     call iox_$read_record (tape_iocbp, wks_ptr, blen, rlen, code);
	     if code = error_table_$end_of_info then	/* EOF detected */
		end_of_data = "1"b;			/* set terminate condition */
	     else if code ^= 0 then			/* we have a real  tape error */
		call check_tape_status;		/* go report it, and determine what to do */
	     else do;				/* good read, write the data into SS file */
		wt_ptr = wks_ptr;			/* start at beginning of buffer */
		b_offset = 0;
		if rlen = 0 then			/* special case for zero length records */
		     zlck = "1"b;
		else zlck = "0"b;			/* not a zero length record */
		do while ((b_offset < rlen | zlck) & ^abort_sw & ^cont_sw); /* do while data to write */
		     zlck = "0"b;			/* only one iteration for zero length records */
		     wlen = min (amrl, rlen - b_offset);/* set length of record to write */
ss_wrt_retry:
		     call iox_$write_record (ss_iocbp, wt_ptr, wlen, code); /* write the SS file record */
		     if code ^= 0 then do;		/* if error writing to SS file */
			call check_ss_file_status;	/* go report it and determine what to do */
			if control_sw then		/* if user fixed problem */
			     go to ss_wrt_retry;
		     end;
		     else do;			/* no error */
			char_cnt = char_cnt + wlen;	/* increment file character count */
			if fcb.segment.truncate_lines = 2 then /* if user want to chop of line.. */
			     b_offset = rlen;	/* set so we only go through once */
			else b_offset = b_offset + wlen; /* increment input record char offset */
			wt_ptr = addr (input_record.next_char); /* increment input data ptr */
		     end;
		end;

	     end;
	end;
	call close_ss_file;				/* close and detach SS file */
	call close_tape_file (abort_sw);		/* close and detach tape file */

     end read_tape;
%page;
/* write_tape - subroutine to write tape file from SS file */

write_tape: proc;

	call check_ss_file;				/* check SS file for access and consistency */
	if fcb.tape.sequence = -1 then do;		/* if "tape_extend" was specified */
	     if fnbr = 0 then			/* and this is the first attachment for this volume */
		call position_to_end;		/* position tape to end of last file on tape */
	     else do;				/* otherwise increment the file number */
		fnbr = fnbr + 1;
		fcb.tape.sequence = fnbr;		/* set the valid sequence number */
	     end;
	end;
	else fnbr = fnbr + 1;
	call build_tape_attach;			/* create tape attach description */
	call open_tape_file;			/* attach and open tape file */
	call open_ss_file;				/* attach  and open SS file */

/* main processing loop, read SS file/write tape */

	do while (^end_of_data & ^abort_sw & ^cont_sw);	/* do until no more data */
ss_rd_retry:
	     call iox_$read_record (ss_iocbp, wks_ptr, blen, rlen, code);
	     if code = error_table_$end_of_info then	/* EOF detected */
		end_of_data = "1"b;			/* set terminate condition */
	     else if code ^= 0 & code ^= error_table_$short_record then do; /* if some error.. */
		call check_ss_file_status;		/* go report it, and determine what to do */
		if control_sw then			/* if user fixed problem */
		     go to ss_rd_retry;		/* go retry read */
	     end;
	     else do;				/* good read, write the date into the tape file */
		wt_ptr = wks_ptr;			/* start at beginning of buffer */
		b_offset = 0;
		if rlen = 0 then			/* special case for zero length records */
		     zlck = "1"b;
		else zlck = "0"b;			/* not a zero length record */
		do while ((b_offset < rlen | zlck) & ^abort_sw & ^cont_sw); /* do while data to write */
		     zlck = "0"b;			/* only one iteration for zero length records */
		     wlen = min (amrl, rlen - b_offset);/* set length of record to write */
		     call iox_$write_record (tape_iocbp, wt_ptr, wlen, code); /* write the tape record */
		     if code ^= 0 then		/* if error writing to tape file */
			call check_tape_status;	/* go report it and determine what to do */
		     else do;			/* no error */
			char_cnt = char_cnt + wlen;	/* increment file character count */
			if fcb.segment.truncate_lines = 2 then /* if user want to chop of line.. */
			     b_offset = rlen;	/* set so we only go through once */
			else b_offset = b_offset + wlen; /* increment input record char offset */
			wt_ptr = addr (input_record.next_char); /* increment input data ptr */
		     end;
		end;
	     end;
	end;
	call close_ss_file;				/* close and detach SS file */
	call close_tape_file (abort_sw);		/* close and detach tape file */

     end write_tape;
%page;
/* open_tape_file - procedure to attach and open tape file */

open_tape_file: proc;

	if abort_sw | cont_sw then return;		/* if a bad error has already ocurred, bail out */

	code = 0;
	do while (code = 0 & ^tape_opened);
	     call iox_$attach_name (tape_switch, tape_iocbp,
		(tape_attach_descp.string), null, code);

	     if code ^= 0 then do;			/* attach failed */
		call com_err_ (code, name, "
Unable to attach tape file ^a of volume-set ^a.
Attach description is: ""^a""",
		     fileid, vcb.volid (1), tape_attach_descp.string);
		call cntl_cont_abort ("0"b);
		return;
	     end;

	     tape_attached = "1"b;			/* set flag for cleanup handler */

	     if output then				/* tape_out command: users want to write to the tape */
		call iox_$open (tape_iocbp, Sequential_output, "0"b, code); /* open for output */
	     else					/* tape_in command: users want to read from tape files */
		call iox_$open (tape_iocbp, Sequential_input, "0"b, code); /* open for input */

	     if code = 0 then
		tape_opened = "1"b;			/* set flag for cleanup handler */
	     else do;				/* open failed */
		if code = error_table_$insufficient_open then do; /* special case of tape_in command. */

		     if add_specified_attributes then do; /* because the tape doesn't contain info,  */
						/* so add info from TCL file.  Then try to attach and open again */
			call iox_$detach_iocb (tape_iocbp, (0));

			call ioa_ ("
tape_in:  WARNING because the volume name ""^a"" cannot be read as recorded,
the structure attributes specified in the TCL file will be used.",
			     vcb.volid (1));

			recl = fixed (fcb.tape.reclen);
			tape_attach_descp.string = tape_attach_descp.string
			     || " -record " || ltrim (recl)
			     || " -block " || ltrim (blkl)
			     || " -format " || FORMAT (fcb.tape.format);

			add_specified_attributes = "0"b;
			code = 0;
		     end;
		end;

		if code ^= 0 then do;
		     call com_err_ (code, name, "
Unable to open tape file ^a of volume-set ^a for ^[output^;input^].
Attach description is: ""^a""",
			fileid, vcb.volid (1), output, tape_attach_descp.string);
		     call cntl_cont_abort ("0"b);
		     return;
		end;
	     end;
	end;
     end open_tape_file;
%page;
/* close_tape_file - procedure to close and detach tape file */

close_tape_file: proc (force_detach);

dcl  force_detach bit (1) aligned;

	if tape_opened then do;			/* if the tape was opened, close it */

/* see if any more <file-groups> this volume. If not, or if cleanup, take down tape */

	     if fcb.next_fcb_ptr = null | force_detach then
		call iox_$control (tape_iocbp, "retain_none", null, (0)); /* cause tape to be demounted */
	     call iox_$close (tape_iocbp, (0));		/* close the file */
	     tape_opened = "0"b;			/* reset flag */
	end;
	if tape_attached then do;			/* if the tape was attached, detach it */
	     call iox_$detach_iocb (tape_iocbp, (0));
	     file_count = file_count + 1;		/* increment file count */
	     tape_attached = "0"b;			/* reset flag */
	end;

     end close_tape_file;
%page;
/* open_ss_file - procedure to attach and open storage system file */

open_ss_file: proc;

	if abort_sw | cont_sw then return;		/* if a bad error has already ocurred, bail out */
	if fcb.segment.format = 1 then		/* if stream file, use record_stream_ */
	     ss_atd = "record_stream_ -target vfile_ " || pathname; /* to convert stream <--> record */
	else ss_atd = "vfile_ " || pathname;		/* structured file, attach vfile_ directly */
	if fcb.segment.extend = 2 then		/* if extending existing SS file */
	     ss_atd = rtrim (ss_atd) || " -extend";	/* put it in attach desc */
	control_sw = "1"b;				/* allow at least one iteration */
	do while (control_sw);
	     control_sw = "0"b;
	     call close_ss_file;			/* make sure file switch is closed/detached first */
	     call iox_$attach_name (ss_switch, ss_iocbp, ss_atd, null, code); /* attach SS file */
	     if code ^= 0 then do;
		call com_err_ (code, name, "
Unable to attach storage system file ""^a"" for ^[input^;output^]
(file ^a of volume-set ^a).
Attach description is: ""^a"".",
		     pathname, output, fileid, vcb.volid (1), ss_atd);
		call cntl_cont_abort ("1"b);		/* go ask user what to do */
		if ^control_sw then return;		/* give up */
	     end;
	     else do;				/* attempt opening if no errors */
		ss_file_attached = "1"b;		/* set flag for cleanup handler */
		if output then			/* if writing tape/reading ss file */
		     ss_open_mode = Sequential_input;
		else ss_open_mode = Sequential_output;	/* reading tape/writing ss file */
		call iox_$open (ss_iocbp, ss_open_mode, "0"b, code); /* open storage file for write */
		if code ^= 0 then do;
		     call com_err_ (code, name, "
Unable to open storage system file ""^a"" for ^a
(file ^a on volume-set ^a).
Attach description is: ""^a"".",
			pathname, iox_modes (ss_open_mode), fileid,
			vcb.volid (1), ss_atd);
		     call cntl_cont_abort ("1"b);
		     if ^control_sw then return;
		end;
		else do;
		     ss_file_opened = "1"b;		/* set flag for cleanup handler, if no errors */
		     io_started = "1"b;		/* I/O ready to start */
		end;

	     end;
	end;

     end open_ss_file;
%page;
/* check_ss_file - procedure to check storage system file for access etc. */

check_ss_file: proc;

	io_started = "0"b;				/* No I/O started yet */
	control_sw = "1"b;				/* allow at least one iteration */
	do while (control_sw);
	     control_sw = "0"b;
	     query_info.yes_or_no_sw = "1"b;
	     call vfile_status_ ((fcb.segment.dirname), (fcb.segment.ename), addr (vfile_info), code);
	     if code ^= 0 then do;
		if code = error_table_$moderr then
		     call com_err_ (code, name, "
Storage system file ""^a"" has incorrect access for status check.",
			pathname);
		else if code = error_table_$dirseg then
		     call com_err_ (code, name, "
Storage system file ""^a"" is a directory.",
			pathname);
		else if code = error_table_$noentry then/* if file does not exist */
		     if output then			/* if writing tape/reading ss file */
			call com_err_ (code, name, "
Storage system file ""^a"" does not already exist.",
			     pathname);
		     else if fcb.segment.extend = 2 then/* cannot extend non-existant file */
			call com_err_ (code, name, "
Cannot extend storage system file, ""^a"", as it does not already exist.",
			     pathname);
		     else return;			/* return, no problems */
		else call com_err_ (code, name, "
Cannot get status of storage system file ""^a"".",
			pathname);
		go to ask_user;			/* see what user wants to do */
	     end;
	     if ^output & fcb.segment.extend ^= 2 then do;/* reading tape/writing SS file */
		call command_query_ (addr (query_info), answer, name,
		     "Storage system file ""^a"" already exists.^/Do you wish to overwrite it? ",
		     pathname);
		if answer = "no" then
		     go to ask_user;		/* go ask user what to do */
	     end;
	     if vfile_info.type = 1 then do;		/* unstructured file */
		if fcb.segment.format = 2 then do;	/* error if specified structured file */
		     call ioa_ ("^a: Storage system file ""^a"" exists as an unstructured file.",
			name, pathname);
		     call command_query_ (addr (query_info), answer, name,
			"Do you wish to over^[^a unstructured^s^;^s^a structured^]? ",
			output, q_mess1, q_mess2);
		     if answer = "yes" then do;
			if output then		/* if writing tape/reading SS file */
			     fcb.segment.format = 1;
			else if fcb.segment.extend = 2 then /* if reading tape/writing SS file */
			     fcb.segment.extend = 1;	/* change file format by creating new file */
		     end;
		     else go to ask_user;		/* no, go see what user wants to do */
		end;
	     end;
	     else if vfile_info.type = 2 then do;	/* sequential file */
		if vfile_info.flags.lock_status ^= "00"b then do;
		     code = error_table_$file_busy;
		     call com_err_ (code, name, "
Storage system file, ""^a"", is locked.",
			pathname);
		     go to ask_user;		/* go see what user wants to do */
		end;
		if fcb.segment.format ^= 2 then do;	/* error if specified unstructured file */
		     call ioa_ ("^a: Storage system file ""^a"" already exists as a sequential file.",
			name, pathname);
		     call command_query_ (addr (query_info), answer, name,
			"Do you wish to over^[^a sequential^s^;^s^a unstructured^]? ",
			output, q_mess1, q_mess2);
		     if answer = "yes" then do;
			if output then		/* if writing tape/reading SS file */
			     fcb.segment.format = 2;
			else if fcb.segment.extend = 2 then /* if reading tape/writing SS file */
			     fcb.segment.extend = 1;	/* change file format by creating new file */
		     end;
		     else go to ask_user;		/* no, go see what user wants to do */
		end;
	     end;
	     else do;				/* error-- no other types supproted */
		call com_err_ (0, name, "
Storage system file ""^a"" is not unstructured or sequential.",
		     pathname);
ask_user:
		call cntl_cont_abort ("1"b);		/* see what user wnats to do */
		if ^control_sw then return;
	     end;
	end;

     end check_ss_file;

/* Cleaner - procedure to close and detach resources when processing completed  or on a cleanup condition */

Cleaner: proc;

	if wks_ptr ^= null then do;			/* if we have a buffer segment assigned.. */
	     call release_temp_segment_ ((name), wks_ptr, (0)); /* release it */
	     wks_ptr = null;			/* reset the ptr */
	end;
	call close_ss_file;				/* close and detach Storage system file */
	call close_tape_file ("1"b);			/* close and demount tape volume */

     end Cleaner;


/* close_ss_file - procedure to close and detach storage system file */

close_ss_file: proc;

	if ss_file_opened then do;			/* if the file is opened.. */
	     call iox_$close (ss_iocbp, (0));		/* close it unconditionaly */
	     ss_file_opened = "0"b;			/* and reset flag */
	end;
	if ss_file_attached then do;			/* if the file is attached.. */
	     call iox_$detach_iocb (ss_iocbp, (0));	/* detach it unconditionaly */
	     ss_file_attached = "0"b;			/* and reset flag */
	end;

     end close_ss_file;
%page;
/* check_ss_file_status - procedure to  check storage system file status errors */

check_ss_file_status: proc;

	call com_err_ (code, name, "
Error ^[reading from^;writing to^] storage system file ""^a""
(file ^a of volume-set ^a).",
	     output, pathname, fileid, vcb.volid (1));

	call cntl_cont_abort ("1"b);

     end check_ss_file_status;


/* check_tape_status - procedure to check tape errors */

check_tape_status: proc;

	end_of_data = "1"b;				/* Will not continue I/O  on this tape volume */
	call iox_$control (tape_iocbp, "file_status", addr (atfs), rcode);
	if atfs.state > 0 then
	     blockl = atfs.cur_blkcnt;
	if code = error_table_$eov_on_write then do;	/* End-of-Tape has been detected */
	     char_cnt = char_cnt + rlen;		/* add chars which were output to total count.	*/
	     call com_err_ (0, name, "
End-of-Tape detected while writing tape file ^a of volume-set ^a
(storage system file ""^a"").
^d characters have been written to ^d blocks.",
		fileid, vcb.volid (1), pathname, char_cnt, blockl);
	     end_of_tape = "1"b;			/* indicate we had EOT condition */
	end;
						/* format: off */
	else call com_err_ (code, name, "
Error while ^[writing^;reading^] tape file ^a of volume set ^a
(storage system file ""^a"").
^d characters have been ^[written to^;read from^] ^d blocks.
The volume-set will be detached.",
		output, fileid, vcb.volid (1), pathname, char_cnt,
		output, blockl);
/* format: on */
	call error_report;				/* go give the user the real status */
	call cntl_cont_abort ("0"b);			/* ask user what he wants to do */

     end check_tape_status;
%page;
/* internal procedure to move tape to end of files for appending a new file */
/* enter here if fcb.tape.sequence = -1 and fnbr = 0 */

position_to_end: procedure;

	if abort_sw | cont_sw then return;		/* if a bad error has already ocurred, bail out */
	do fnbr = 1 by 1;
	     secq = fixed (fnbr);			/* file number as char string */
	     call build_tape_attach;			/* go build positioning attach desc */
	     if writeff_sw then
		writeff_sw = "0"b;			/* cant write 1st file as file 1 in append mode */

	     call iox_$attach_name (tape_switch, tape_iocbp, (tape_attach_descp.string), null, rcode);
	     if rcode ^= 0 then do;			/* unable to attach tape file  */
bad_position:
		call com_err_ (rcode, name, "
Error while positioning to append to volume-set.
Attach description is: ""^a""",
		     tape_attach_descp.string);
		call error_report;
		call cntl_cont_abort ("0"b);
		fnbr = 0;
		return;
	     end;
	     call iox_$open (tape_iocbp, Sequential_input, "0"b, rcode); /* open tape file for read */
	     if rcode = error_table_$no_file then
		fcb.tape.sequence = fnbr;		/* this is the file number we will use to append as */
	     else if rcode ^= 0 then
		goto bad_position;
	     call iox_$close (tape_iocbp, rcode);	/* close the tape file */
	     call iox_$detach_iocb (tape_iocbp, rcode);
	     if rcode ^= 0 then			/* error closing or detaching */
		go to bad_position;
	     if fcb.tape.sequence ^= -1 then do;
		rcode = 0;
		call ioa_ ("^a: Tape file ""^a"" will be appended as file #^d", name, fileid, fnbr);
		return;
	     end;
	end;

     end position_to_end;

/* error_report - procedure to report the hardware status in English */

error_report: proc;

	call iox_$control (tape_iocbp, "status", addr (ads), code);
	if code = 0 then do;
	     call ioa_ ("^/^a: Description of error follows: ^/", name);
	     do i = 1 to ads.n_minor;			/* loop and print all minor status codes */
		call convert_status_code_ (ads.minor (i), shortinfo, longinfo);
		call ioa_ ("^a^/", longinfo);
	     end;
	end;
     end error_report;
%page;
build_tape_attach: procedure;
	add_specified_attributes = "1"b;
	if abort_sw | cont_sw then return;		/* if a bad error has already ocurred, bail out */
	tstring = "";				/* initialize  */
	if vol_init then do;			/* only do this once per <volume-group> */
	     if output then
		if fcb.tape.sequence = 0 then
		     writeff_sw = "1"b;
	     tstring = IO_MODULE_NAME (vcb.tape_type);
	     do i = 1 to vcb.nvols;			/* up to vcb.nvols volumes per set allowed */
		if substr (vcb.volid (i), 1, 1) = "-" then do;
		     tstring = tstring || " " || "-volume " || rtrim (vcb.volid (i));
		end;
		else tstring = tstring || " " || rtrim (vcb.volid (i));
		if vcb.comment (i) ^= " " then
		     tstring = tstring || " -comment " ||
			requote_string_ (rtrim (vcb.comment (i)));
	     end;
	     tstring = tstring || " -density " || DENSITY (vcb.density);
	     if vcb.tape_type = IBMNL then
		tstring = tstring || " -no_labels";
	     else if vcb.tape_type = IBMDOS then
		tstring = tstring || " -dos";
	     vol_init = "0"b;			/* reset for rest of <volume-group> */
	     tape_attach_descp.vol_string = tstring;	/* copy volume  portion of attach desc. */
	end;

	tstring = " -retain all";			/* keep volume mounted between attachments */
	if writeff_sw then do;			/* set up so 1st file written will be file 1 on the tape */
	     fcb.tape.sequence = 1;			/* will start at file 1 on tape */
	     secq = fixed (fcb.tape.sequence);
	     writeff_sw = "0"b;			/* reset so we don't come back */
	end;
	if ring_sw then				/* if writing or "-ring" control arg */
	     tstring = tstring || " -ring";
	if fcb.tape.sequence = -1 then		/* if tape positioning required.. */
	     tstring = tstring || " -number " || secq;
	else do;					/* no tape positioning required */
	     if fcb.tape.cmode > 0 then
		tstring = tstring || " -mode " || MODE (fcb.tape.cmode);
	     if fcb.tape.file_id ^= "*" then		/* start options check now */
		tstring = tstring || " -name " || rtrim (fcb.tape.file_id);
	     if fcb.tape.sequence > 0 then do;
		secq = fixed (fcb.tape.sequence);
		tstring = tstring || " -number " || ltrim (secq);
	     end;
	     blkl = fixed (fcb.tape.blklen);		/* convert block length to char data */
	     if output | vcb.tape_type = IBMNL | vcb.tape_type = IBMDOS then do; /* don't set for input on SL tapes */

		if fcb.tape.reclen > 0 then do;	/* set up the real attach desc. */
		     recl = fixed (fcb.tape.reclen);
		     tstring = tstring || " -record " || ltrim (recl);
		end;
		if fcb.tape.blklen > 0 then
		     tstring = tstring || " -block " || ltrim (blkl);
		if fcb.tape.format > 0 then
		     tstring = tstring || " -format " || FORMAT (fcb.tape.format);
		add_specified_attributes = "0"b;
	     end;
	     else if fcb.tape.blklen > 8192 then	/* unless large block wanted */
		tstring = tstring || " -block " || ltrim (blkl);
	     if output then do;			/* only add output options if writing tape */
		if tape_io_data.control.force then
		     tstring = tstring || " -force ";
		if fcb.tape.expiration ^= "" then
		     tstring = tstring || " -expires " || fcb.tape.expiration;
		if fcb.tape.replace_id ^= "" then
		     tstring = tstring || " -replace " || fcb.tape.replace_id;
		if fcb.tape.output_mode > 0 then
		     tstring = tstring || OUTPUT_MODE (fcb.tape.output_mode);
	     end;
	end;
	tape_attach_descp.file_string = tstring;
	tape_attach_descp.string = tape_attach_descp.vol_string || tape_attach_descp.file_string;
	if db_sw then
	     call ioa_ ("Attach desc: ""^a""", tape_attach_descp.string);

     end build_tape_attach;
%page;
/* internal procedure to help user direct the processing of his control file
   after the occurrence of an error or other interruption in execution. */

cntl_cont_abort: procedure (idx);

dcl  idx bit (1) aligned;

	query_info.yes_or_no_sw = "0"b;		/* not looking for yes or no answer */
	abort_sw, control_sw, cont_sw = "0"b;		/* reset switches */
	cant_cont = (fcb.next_fcb_ptr = null & vcb.next_vcb_ptr = null); /* determine if continuation is possible */
	if ^idx then				/* if not control option and */
	     if cant_cont then do;			/* no file/volume groups left to process */
		abort_sw = "1"b;			/* the only possible action is to abort */
		call ioa_ ("^a: Control file exhausted, aborting.", name);
		return;
	     end;
	call ioa_ ("^a: Do you wish to ^[^a^[,^] ^;^2s^]^[^[^/^-^]^a ^]or abort the control file?",
	     name, idx, "control the process", (idx & ^cant_cont), ^cant_cont,
	     (idx & ^cant_cont), "continue to the next <file-group>");
ASK1:
	call command_query_ (addr (query_info), answer, name,
	     "Please answer either ^[""control"", ^]^[""continue"", ^]or ""abort"":", idx, ^cant_cont);

	if answer = "control" & idx then do;
	     call ioa_ ("^a: You may now take action to correct the problem.^/^a",
		name, "Type ""start"" (or ""sr""), when you are ready to resume operations.");
	     control_sw = "1"b;
	     call cu_$cl ();			/* pass control to get_to_cl_$unclaimed_signal */
	end;
	else if answer = "continue" & ^cant_cont then
	     cont_sw = "1"b;
	else if answer = "abort" then
	     abort_sw = "1"b;
	else go to ASK1;

     end cntl_cont_abort;
%page;
%include tape_file_status;
%page;
%include tape_io_data;
%page;
%include device_status;

%include iox_modes;
%page;
%include query_info_;

     end tape_io_interpret_;






		    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
