



		    deckfile_manager.pl1            10/21/92  1023.4rew 10/21/92  1021.1      118197



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



/****^  HISTORY COMMENTS:
  1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515),
     audit(87-01-07,Farley), install(87-01-08,MR12.0-1263):
     Originally coded 0682 by R. Fakoury for MR12.
  2) change(89-11-08,Fakoury), approve(89-11-20,MECR0014),
     audit(89-11-09,Parisek), install(89-11-20,MR12.3-1120):	
     To correct the path for the info dir.
  3) change(89-11-20,Fakoury), approve(89-11-20,PBF8146),
     audit(89-11-20,Parisek), install(89-11-20,MR12.3-1120):	
     Again, correct info dir problem. Let ssu_ figure it out.
                                                   END HISTORY COMMENTS */


/* The deckfile_manager command provides the functionallity to maintain a tandd_deck_file */


/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
deckfile_manager:
dfm: proc ();


/* Automatic */

dcl  ab_sw bit (1) aligned;
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  arg_num fixed bin;
dcl  code fixed bin (35);
dcl  debug_sw bit (1) aligned;
dcl  deckfile_length fixed bin (21);
dcl  deckfile_ptr ptr;
dcl  nargs fixed bin;
dcl  profile_dir char (168);
dcl  profile_entry char (32);
dcl  profile_length fixed bin (21);
dcl  profile_ptr ptr;
dcl  profile_sw bit (1);
dcl  prompt_length fixed bin (21);
dcl  prompt_ptr ptr;
dcl  prompt_sw bit (1);
dcl  quit_sw bit (1);
dcl  request_loop_sw bit (1);
dcl  ready_sw bit (1) aligned;
dcl  request_sw bit (1);
dcl  request_line_length fixed bin (21);
dcl  request_line_ptr ptr;
dcl  sci_ptr ptr;
dcl  startup_sw bit (1);

/*  Based */

dcl  arg char (argl) based (argp);
dcl  deckfile_string char (deckfile_length) based (deckfile_ptr);
dcl  free_area area based (get_system_free_area_ ());
dcl  profile_string char (profile_length) based (profile_ptr);
dcl  prompt_string char (prompt_length) aligned based (prompt_ptr);


/*  Builtins */

dcl  addr builtin;
dcl  codeptr builtin;
dcl  null builtin;


/* Conditions */

dcl  cleanup condition;


/* Constants */

dcl  dfm_version_1 char (4) int static options (constant) init ("1.0a");
dcl  false bit (1) int static options (constant) init ("0"b);
dcl  last_position fixed bin int static options (constant) init (9999);
dcl  max_prompt_length fixed bin int static options (constant) init (64);
dcl  myname char (3) int static options (constant) init ("dfm");
dcl  true bit (1) int static options (constant) init ("1"b);

/* Entries */

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry () options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_list_ptr entry () returns (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$generate_call entry (entry, ptr);
dcl  dfm_$clean_up entry (ptr, ptr);
dcl  dfm_$pi_handler entry;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35));
dcl  ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
dcl  ssu_$destroy_invocation entry (ptr);
dcl  ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  ssu_$execute_start_up entry () options (variable);
dcl  ssu_$get_temp_segment entry (ptr, char (*), ptr);
dcl  ssu_$listen entry (ptr, ptr, fixed bin (35));
dcl  ssu_$record_usage entry (ptr, ptr, fixed bin (35));
dcl  ssu_$release_temp_segment entry (ptr, ptr);
dcl  ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned);
dcl  ssu_$set_debug_mode entry (ptr, bit (1) aligned);
dcl  ssu_$set_ec_suffix entry (ptr, char (32));
dcl  ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35));
dcl  ssu_$set_prompt entry (ptr, char (64) var);
dcl  ssu_$set_prompt_mode entry (ptr, bit (*));
dcl  ssu_$set_ready_mode entry (ptr, bit (1) aligned);

/* External */

dcl  dfm_request_table_$dfm_request_table_ fixed bin ext static;
dcl  error_table_$active_function fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$bigarg fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$not_act_fnc fixed bin (35) ext static;
dcl  ssu_et_$subsystem_aborted fixed bin (35) ext static;
dcl  ssu_et_$program_interrupt fixed bin (35) ext static;
dcl  ssu_et_$null_request_line fixed bin (35) ext static;
dcl  ssu_et_$request_line_aborted fixed bin (35) ext static;
dcl  ssu_info_directories_$standard_requests char (168) external;
dcl  ssu_request_tables_$standard_requests bit (36) aligned external;


%page;

      call cu_$af_return_arg (nargs, null (), 0, code);
      if code ^= error_table_$not_act_fnc then do;
         if code = 0 then call active_fnc_err_ (error_table_$active_function, myname);
         else call com_err_ (code, myname);
         return;
      end;

      call dfm_init ();

      on cleanup call deckfile_manager_cleanup ();

      do arg_num = 1 to nargs;			/* process all the arguments			*/
         call cu_$arg_ptr (arg_num, argp, argl, code);
         if code ^= 0 then call complain (code, myname, "Getting arg ptr.");

         if arg = "-abbrev" | arg = "-ab" then ab_sw = true;

         else if arg = "-debug" | arg = "-db" then debug_sw = true;

         else if arg = "-deckfile" | arg = "-dkf" then do;
	  call next_arg (deckfile_ptr, deckfile_length, code);
	  if code ^= 0 then call complain (code, myname, "Getting deckfile pathname.");
	  call expand_pathname_ (deckfile_string, dfm_info.deckfile_dir,
	   dfm_info.deckfile_entry, code);
	  if code ^= 0 then call complain (code, myname, "Expanding deckfile pathname.");
         end;

         else if arg = "-no_abbrev" | arg = "-nab" then ab_sw = false;

         else if arg = "-no_debug" | arg = "-ndb" then debug_sw = false;

         else if arg = "-no_prompt" then prompt_sw = false;

         else if arg = "-no_startup" | arg = "-nsu" then startup_sw = false;

         else if arg = "-profile" | arg = "-pf" then do;
	  call next_arg (profile_ptr, profile_length, code);
	  if code ^= 0 then call complain (code, myname, "Getting profile pathname.");
	  call expand_pathname_$add_suffix (profile_string, "profile", profile_dir, profile_entry, code);
	  if code ^= 0 then call complain (code, myname, "Expanding profile pathname.");
	  call initiate_file_ (profile_dir, profile_entry, R_ACCESS, profile_ptr, 0, code);
	  if profile_ptr = null () then call complain (code, myname,
	      "Initiating the profile ^a>^a.", profile_dir, profile_entry);

	  ab_sw, profile_sw = true;
         end;

         else if arg = "-prompt" then do;
	  call next_arg (prompt_ptr, prompt_length, code);
	  if code ^= 0 then call complain (code, myname, "Getting prompt string");
	  if prompt_length > max_prompt_length then
	     call complain (error_table_$bigarg, myname,
	      "The prompt may be a maximum of ^d characters", max_prompt_length);
	  prompt_sw = true;
         end;

         else if arg = "-quit" | arg = "-q" then
	  quit_sw, dfm_info.flags.force_quit = true;

         else if arg = "-ready_off" | arg = "-rdf" then ready_sw = false;

         else if arg = "-ready_on" | arg = "-rdn" then ready_sw = true;

         else if arg = "-request" | arg = "-rq" then do;
	  if request_sw then call complain (error_table_$inconsistent,
	      myname, "Only one request per invocation");
	  call next_arg (request_line_ptr, request_line_length, code);
	  if code ^= 0 then call complain (code, myname, "Getting request line");
	  request_sw = true;
         end;

         else if arg = "-request_loop"
	| arg = "-rql" then request_loop_sw = true;

         else if arg = "-startup" | arg = "su" then startup_sw = true;

         else call complain (error_table_$badopt, myname, "^a", arg);

      end;					/* end argument processing */

      call ssu_$create_invocation (myname, dfm_version_1, dfm_infop,
       addr (dfm_request_table_$dfm_request_table_), ">doc>subsystem>dfm", sci_ptr, code);
      if code ^= 0 then call complain (code, myname, "Creating subsystem invocation.");

      call ssu_$record_usage (sci_ptr, codeptr (dfm), 0);

      call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, last_position, code);
      if code ^= 0 then call complain (code, myname, "Adding ssu info dir.");

      call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), last_position, code);
      if code ^= 0 then call complain (code, myname, "Adding ssu request table.");

      call ssu_$set_procedure (sci_ptr, "program_interrupt", dfm_$pi_handler, code);
      if code ^= 0 then call complain (code, myname, "Adding pi handler.");

      call ssu_$set_ec_suffix (sci_ptr, "dfmec");

      call ssu_$get_temp_segment (sci_ptr, "dfm_data", dfm_info.dfm_data_ptr);

      call ssu_$set_abbrev_info (sci_ptr, profile_ptr, profile_ptr, ab_sw);

      call ssu_$set_debug_mode (sci_ptr, debug_sw);

      if prompt_sw & prompt_length > 0 then
         call ssu_$set_prompt (sci_ptr, (prompt_string));

      call ssu_$set_prompt_mode (sci_ptr, ^prompt_sw);

      call ssu_$set_ready_mode (sci_ptr, ready_sw);

      if startup_sw then do;
         call ssu_$execute_start_up (sci_ptr, code);
         if code ^= 0 then call complain (code, myname, "Executing ssu startup.");
      end;

      if request_sw then do;
         call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_length, code);
         if code ^= 0 then do;
	  if (code = ssu_et_$null_request_line
	   | code = ssu_et_$program_interrupt
	   | code = ssu_et_$request_line_aborted)
	   & request_loop_sw then goto listen;
	  else if code = ssu_et_$subsystem_aborted then goto subsystem_wrapup; /* normal end of subsystem */
	  else call complain (code, myname, "Encountered while executing request line");
         end;
      end;

      if quit_sw then goto subsystem_wrapup;


listen:
      call ssu_$listen (sci_ptr, null (), code);
      if code ^= ssu_et_$subsystem_aborted then
         call com_err_ (code, myname, "Calling the listener.");

subsystem_wrapup:
      call deckfile_manager_cleanup ();
      return;
%page;

/* complain - an internal proc to print an error message and wrapup. */


complain: proc () options (variable);

      call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
      goto subsystem_wrapup;


   end complain;



%page;

/* deckfile_manager_cleanup - internal proc to cleanup a deckfile_manager invocation. */


deckfile_manager_cleanup: proc ();

      if dfm_infop ^= null then do;

         if dfm_info.flags.request_active then call dfm_$clean_up (sci_ptr, dfm_infop);

         if dfm_info.dfm_data_ptr ^= null () then
	  call ssu_$release_temp_segment (sci_ptr, dfm_info.dfm_data_ptr);

         if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr);

         free dfm_info in (free_area);
         dfm_infop = null;
      end;


   end deckfile_manager_cleanup;
%page;

/* Internal proc that initializes dfm variables */

dfm_init: proc ();

      dfm_infop = null;
      allocate dfm_info in (free_area) set (dfm_infop);

      ab_sw = false;
      debug_sw = false;
      dfm_info.deckfile_dir = "";
      dfm_info.deckfile_entry = "";
      dfm_info.dfm_data_ptr = null;
      dfm_info.page_number = 0;
      dfm_info.flags.request_active = false;
      dfm_info.force_quit = false;
      dfm_info.pad = "0"b;
      dfm_info.version = dfm_info_version_1;
      profile_ptr = null;
      profile_sw = false;
      prompt_length = 0;
      prompt_ptr = null;
      prompt_sw = true;				/* default is to prompt */
      quit_sw = false;
      request_loop_sw = false;
      ready_sw = false;
      request_sw = false;
      request_line_length = 0;
      request_line_ptr = null;
      sci_ptr = null;
      startup_sw = false;

   end dfm_init;

%page;

/*  Internal proc that gets the next argument from the argument string, complaining if it's not there  */

next_arg: proc (nargp, nargl, nacode);

dcl  nargp ptr;
dcl  nacode fixed bin (35);
dcl  nargl fixed bin (21);

      arg_num = arg_num + 1;
      call cu_$arg_ptr (arg_num, nargp, nargl, nacode);


   end next_arg;

%page;
%include access_mode_values;
%page;
%include dfm_info;
%page;
%include ssu_prompt_modes;

   end deckfile_manager;




		    dfm_.pl1                        10/21/92  1023.4rew 10/21/92  1021.6      553842



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



/****^  HISTORY COMMENTS:
  1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515),
     audit(87-01-07,Farley), install(87-01-08,MR12.0-1263):
     Originally coded 0782 by Rick Fakoury for MR12.
  2) change(87-01-13,Fakoury), approve(87-01-13,MCR7515),
     audit(87-01-14,Martinson), install(87-01-14,MR12.0-1278):
     PBF to correct -deckfile short name to -df from -dkf.
  3) change(89-02-06,Fakoury), approve(90-10-03,MCR8147),
     audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049):
     to to allow tape copy without using a deck file or list seg.
  4) change(89-06-01,Fakoury), approve(90-10-03,MCR8147),
     audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049):
     to to insert a space in the copy tape attach description for TR21325
     to increase the size of att_desc from 64 to 181 for TR21336.
  5) change(90-10-30,Fakoury), approve(90-11-28,MCR8219),
     audit(90-11-28,Schroth), install(90-11-28,MR12.4-1051):
     PBF correct to previous installation: changed to call dfm_util_$make_key
     after call to get_cata for catalog record.
                                                   END HISTORY COMMENTS */

/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
dfm_: proc ();

      return;					/* not a valid entry */



/* AUTOMATIC */

dcl  N fixed bin;
dcl  X fixed bin;
dcl  al fixed bin (21);
dcl  all_diskettes bit (1);
dcl  alp ptr;
dcl  ap ptr;
dcl  c_att_desc char (181);
dcl  code fixed bin (35);
dcl  decks_tb_deleted (10) char (24) varying;
dcl  deck_tb_patched char (24) varying;
dcl  deckfile_path char (168);
dcl  diskettes_tb_read (hbound (valid_diskettes, 1)) char (8) varying;
dcl  diskette_type char (4);
dcl  dkf_dir (3) char (168);
dcl  dkf_entry (3) char (32);
dcl  dkf_path (3) char (168);
dcl  dkf_path_idx fixed bin;
dcl  dl_patch bit (1);
dcl  dwg_num_tab char (2);
dcl  eof bit (1);
dcl  err bit (1);
dcl  lsf_dir char (168);
dcl  lsf_entry char (32);
dcl  i fixed bin;
dcl  j fixed bin;
dcl  list_all_keys bit (1);
dcl  mca bit (1);
dcl  mca_err bit (72);
dcl  mca_id char (4);
dcl  ml fixed bin (21);
dcl  n_diskettes_tb_read fixed bin;
dcl  nargs fixed bin;
dcl  npatches fixed bin;
dcl  ndecks_tb_deleted fixed bin;
dcl  of_dir char (168);
dcl  of_entry char (32);
dcl  of_path char (168);
dcl  output_mode_specified bit (1);
dcl  patch_length fixed bin;
dcl  patch_ptr ptr;
dcl  patch_word char (84) varying;
dcl  pname char (72) varying;
dcl  prod_num_tab char (2);
dcl  query_info_ptr ptr;
dcl  query_message char (256);
dcl  rl fixed bin (21);
dcl  sci_ptr ptr;
dcl  tdec fixed bin (35);
dcl  term bit (1);
dcl  user_entry char (8) varying;
dcl  user_reply char (256) varying;
dcl  vfile_open_mode fixed bin;
dcl  xofn char (2);
dcl  yes_sw bit (1);


/*  BASED */

dcl  add_pic pic "999999" based;
dcl  arg char (al) based (ap);
dcl  bin_arg fixed bin (35) based (ap);
dcl  bit_arg bit (al) based (ap);
dcl  1 df_keys based (dfm_data.dfkp) aligned,		/* template for deckfile catalog keys */
       2 n_entries fixed bin,				/* number of catalog entries */
       2 key (1 refer (df_keys.n_entries)) char (24);	/* entry search keys */

dcl  free_area area based (get_system_free_area_ ());

dcl  ptr_arg ptr based (ap);


/* BUILTINS */

dcl  addr builtin;
dcl  before builtin;
dcl  bin builtin;
dcl  char builtin;
dcl  clock builtin;
dcl  convert builtin;
dcl  index builtin;
dcl  hbound builtin;
dcl  lbound builtin;
dcl  length builtin;
dcl  ltrim builtin;
dcl  null builtin;
dcl  rtrim builtin;
dcl  search builtin;
dcl  string builtin;
dcl  substr builtin;
dcl  translate builtin;
dcl  unspec builtin;


/* CONDITIONS */

dcl  cleanup condition;


/* CONSTANTS */

dcl  deckfile char (16) int static options (constant) init (">tandd_deck_file");
dcl  false bit (1) int static options (constant) init ("0"b);
dcl  minargs fixed bin int static options (constant) init (3);
dcl  nl_sw bit (1) aligned int static options (constant) init ("0"b);
dcl  pad_sw bit (1) aligned int static options (constant) init ("0"b);
dcl  print bit (1) int static options (constant) init ("0"b);
dcl  system_dir char (21) int static options (constant) init
      (">system_library_tandd");
dcl  true bit (1) int static options (constant) init ("1"b);
dcl  wrapup bit (1) int static options (constant) init ("1"b);


/* EXTERNAL ENTRIES */

dcl  command_query_ entry () options (variable);
dcl  command_query_$yes_no entry () options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  dfm_util_$ck_applic entry (ptr) returns (bit (1));
dcl  dfm_util_$copy_eof entry (ptr);
dcl  dfm_util_$delete_deck entry (ptr, char (24) var, fixed bin (35));
dcl  dfm_util_$detach_file entry (ptr, ptr);
dcl  dfm_util_$find_dkend entry (ptr, char (24) var, ptr, fixed bin, fixed bin (35));
dcl  dfm_util_$find_file entry (ptr, char (*), char (*));
dcl  dfm_util_$find_key entry (ptr, ptr, char (24) var, ptr, fixed bin (35));
dcl  dfm_util_$get_cata entry (ptr, ptr, char (24) var, ptr, ptr, fixed bin (35));
dcl  dfm_util_$insert_deck entry (ptr, ptr, ptr, fixed bin (21), char (24) varying);
dcl  dfm_util_$make_key entry (ptr);
dcl  dfm_util_$mca_attach entry (ptr, char (4));
dcl  dfm_util_$mca_detach entry (ptr);
dcl  dfm_util_$merge_files entry (ptr, ptr, ptr);
dcl  dfm_util_$mount_diskette entry (ptr, char (8) var, ptr) returns (bit (1));
dcl  dfm_util_$open_file entry (ptr, char (64), char (181), fixed bin (17), ptr);
dcl  dfm_util_$print_list entry (ptr, ptr, char (24) varying);
dcl  dfm_util_$read_deck entry (ptr, bit (1), bit (1));
dcl  dfm_util_$read_diskette entry (ptr, char (*), ptr, fixed bin (21), bit (72), fixed bin (35));
dcl  dfm_util_$update_list entry (ptr, fixed bin (2));
dcl  dfm_util_$valid_diskette entry (ptr, char (8) varying) returns (bit (1));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$rsnnl entry () options (variable);
dcl  mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$get_info_ptr entry (ptr) returns (ptr);
dcl  ssu_$get_temp_segment entry (ptr, char (*), ptr);
dcl  ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var);
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$release_temp_segment entry (ptr, ptr);
dcl  sub_err_ entry () options (variable);


/* EXTERNAL STATIC */

dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$segnamedup fixed bin (35) ext static;
dcl  error_table_$too_many_names fixed bin (35) ext static;
dcl  iox_$user_output ext ptr;

/* PARAMETERS */

dcl  P_dfm_infop ptr parameter;
dcl  P_sci_ptr ptr parameter;


%page;

/* clean_up - general clean up rountine */

clean_up: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call wrap_up;

      return;



%page;


/* This procedure is a general purpose complainer. If ABORT is true, then
   ssu_$abort_line is called. ssu_$print_message is called otherwise.	*/

/* calling sequence: dfm_$complain (dfm_datap, abort, code, ioa_control_string, arg1...argn) */

complain: entry options (variable);


dcl  ecode fixed bin (35);
dcl  message char (256);
dcl  ABORT bit (1);


      message = "";
      ml = 0;

      call cu_$arg_count (nargs, code);
      if nargs < minargs then
         call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART, null, 0, "");

      do i = 1 to minargs;
         call cu_$arg_ptr (i, ap, al, code);
         if code ^= 0 then
	  call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART,
	   null, 0, "encountered while attempting to get ^[dfm_datap^;abort^;code^] arg.", i);

         else if i = 1 then dfm_datap = ptr_arg;
         else if i = 2 then ABORT = bit_arg;
         else if i = 3 then ecode = bin_arg;
      end;

      sci_ptr = dfm_data.sci_ptr;

      if nargs > minargs then do;
         call cu_$arg_list_ptr (alp);
         call ioa_$general_rs (alp, 4, 5, message, ml, pad_sw, nl_sw);
      end;


      if ABORT then do;
         dfm_infop = dfm_data.infop;
         call wrap_up;				/* free the stuff I MAY have allocated */

         call ssu_$abort_line (sci_ptr, ecode, "^a", substr (message, 1, ml)); /* BYE! */
      end;
      else call ssu_$print_message (sci_ptr, ecode, "^a", substr (message, 1, ml));
      return;


%page;

/* delete_deck - entry to delete a deck a deckfile */

delete_deck: entry (P_sci_ptr, P_dfm_infop);


      call setup_part1;
      call setup_part2;
      dd = true;
      ndecks_tb_deleted = 0;

      on cleanup call wrap_up;

      call ssu_$arg_count (sci_ptr, nargs);

      if nargs > 0 then do i = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, i, ap, al);

         if arg = "-deckfile" | arg = "-df" then do;	/* user will specify path */
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, error_table_$bad_arg,
	      "obtaining ""-deckfile"" specification.", "");
	  else deckfile_path = arg;
         end;

         else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */

         else do;
	  ndecks_tb_deleted = ndecks_tb_deleted + 1;
	  if ndecks_tb_deleted > hbound (decks_tb_deleted, 1) then
	     call complain (dfm_datap, wrapup, error_table_$too_many_names,
	      "only ^d decks maybe deleted", hbound (decks_tb_deleted, 1));
	  decks_tb_deleted (ndecks_tb_deleted) = arg;
         end;
      end;

      if ndecks_tb_deleted = 0 then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"No key given to specify the deck to be deleted.", "");

         query_message = "Enter a key or partial key for the deck to be deleted.";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter: <key> ");

         ndecks_tb_deleted = 1;
         decks_tb_deleted (ndecks_tb_deleted) = user_reply;
      end;

      if ndecks_tb_deleted > 0 then do;

         call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp); /* get temp seg for catalog keys */
         call ssu_$get_temp_segment (sci_ptr, "catalog list", dfm_data.lcatp); /* get temp seg for list catalog */
         dfm_data.liocb_ptr = iox_$user_output;
         dfm_data.terminal_out = true;
         dfm_data.deckfile_sw = true;			/* deckfile is required */

         call get_files;
         do i = 1 to ndecks_tb_deleted;
	  call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr,
	   decks_tb_deleted (i), dfm_data.dfkp, code);
	  if code ^= 0 then
	     call complain (dfm_datap, wrapup, code,
	      "attempting to find keys for ^a", decks_tb_deleted (i));

	  term = false;
	  if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term);
	     call command_query_$yes_no (yes_sw, 0, pname, "^d ^2s entries matched the key given",
	      "key given matched ^d entries. ^/Entry ^d is ^a - Is this the deck to be deleted?",
	      df_keys.n_entries, j, df_keys.key (j));
	     if yes_sw then do;
	        term = true;
	        j = j - 1;				/* adjust to correct value */
	     end;
	  end;

	  else j = 1;

	  if j <= df_keys.n_entries then do;
	     decks_tb_deleted (i) = df_keys.key (j);
	     call dfm_util_$delete_deck (dfm_datap, decks_tb_deleted (i), code);
	     if code ^= 0 then
	        call complain (dfm_datap, wrapup, code,
	         "attempting to delete deck ^a", decks_tb_deleted (i));
	     dfm_data.list_key = "ls." || rtrim (decks_tb_deleted (i));
	     call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
	  end;
         end;
      end;


      call wrap_up;

      return;

%page;

/* list - entry to generate a list file or display on the user terminal
   all or portion of the list information in a deckfile */


list: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call setup_part2;

      dfm_data.list = true;
      list_all_keys = false;
      output_mode_specified = false;

      on cleanup call wrap_up;

      call ssu_$arg_count (sci_ptr, nargs);

      if nargs > 0 then do i = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, i, ap, al);

         if arg = "-all" | arg = "-a" then list_all_keys = true;

         else if arg = "-brief" | arg = "-bf" then
	  dfm_data.bf_sw = true;			/* user doesn't want unnecessary nessages */

         else if arg = "-deckfile" | arg = "-df" then do;	/* user will specify path */
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, error_table_$bad_arg,
	      "obtaining ""-deckfile"" specification.", "");
	  else deckfile_path = arg;
         end;

         else if arg = "-file_out" | arg = "-fo" then do;
	  dfm_data.terminal_out = false;
	  output_mode_specified = true;
         end;

         else if arg = "-term_out" | arg = "-to" then
	  dfm_data.terminal_out, output_mode_specified = true;

         else if dfm_data.list_key = "" then dfm_data.list_key = arg;
         else call complain (dfm_datap, wrapup, error_table_$bad_arg,
	     "More than one list key specified.", "");
      end;

      if ^list_all_keys & dfm_data.list_key = "" then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"Insufficient number of args supplied.", "");

         query_message = "Enter a key for the file to be listed or all to create a complete deckfile.list.";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter: <the key or -all.> ");

         if user_reply = "-all"
	| user_reply = "-a" then list_all_keys = true;
         else dfm_data.list_key = user_reply;
      end;

      if ^output_mode_specified & dfm_data.list_key ^= "" then do;
         dfm_data.terminal_out = true;
         dfm_data.page_no = 0;
      end;

      dfm_data.deckfile_sw = true;			/* deckfile is required */

      call get_files;
      call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for catalog keys */
      lcata.n_entries = 0;				/* initially set to 0 entries */
      if dfm_data.terminal_out then dfm_data.liocb_ptr = iox_$user_output;
      if list_all_keys then do i = lbound (list_types, 1) to hbound (list_types, 1);
         dfm_data.list_key = list_types (i);
         call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
         if code ^= 0 then dfm_data.list_key = "";
         if dfm_data.list_key ^= "" then
	  call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
      end;

      else if dfm_data.list_key ^= "" then do;
         if index (dfm_data.list_key, "ls.") ^= 1 then dfm_data.list_key = "ls." || dfm_data.list_key;
         call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
         if code ^= 0 then
	  call complain (dfm_datap, wrapup, code,
	   "attempting to find keys for ^a", dfm_data.list_key);

         if lcata.n_entries > 1 then do j = 1 to lcata.n_entries while (^term);
	  call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given",
	   "key given matched ^d entries.^/ Entry ^d is ^a - Is this the file to be listed?",
	   lcata.n_entries, j, lcata.key (j));
	  if yes_sw then do;
	     term = true;
	     dfm_data.list_key = lcata.key (j);
	  end;
	  else dfm_data.list_key = "";
         end;

         if dfm_data.list_key = "" then
	  call complain (dfm_datap, wrapup, 0,
	   "There are no files to be listed", "");
         else call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key);
      end;

      call wrap_up;

      return;


%page;

/* list_diskettes - entry to list valid diskette types used in the
   load_from_diskette entry */

list_diskette_types: entry (P_sci_ptr, P_dfm_infop);

dcl  out_str char (hbound (valid_diskettes, 1) * 5) varying;

      call setup_part1;

      on cleanup call wrap_up;

      out_str = "";
      do i = 1 to hbound (valid_diskettes, 1);
         out_str = out_str || substr (valid_diskettes (i), 1, 3) || "  ";
      end;
      call complain (dfm_datap, print, 0, "^/^a^/", out_str);
      dfm_data.finished = true;
      dfm_info.flags.request_active = false;
      return;


%page;

/* load_from_diskette - entry to read MCA diskettes into a deckfile */

load_from_diskette: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call setup_part2;
      dfm_data.lfd = true;
      dir_ptr = null;

      on cleanup begin;
         if dir_ptr ^= null then free directory in (free_area);
         call wrap_up;
      end;

      all_diskettes = false;
      mca = false;
      call ssu_$arg_count (sci_ptr, nargs);
      if nargs > 0 then do i = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, i, ap, al);

         if arg = "-mca" then do;
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al ^= 1 then
	     call complain (dfm_datap, wrapup, 0,
	      "arg following -mca arg incorrect", "");
	  else if search (arg, "abcd") = 0 then
	     call complain (dfm_datap, wrapup, 0,
	      "arg following -mca arg incorrect", "");
	  else mca = true;
	  mca_id = "mca" || arg;
         end;

         else if arg = "-brief"
	| arg = "-bf" then dfm_data.bf_sw = true;	/* user doesn't want unnecessary nessages */

         else if arg = "-deckfile"
	| arg = "-df" then do;			/* user will specify path */
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, error_table_$bad_arg,
	      "obtaining ""-deckfile"" specification.", "");
	  else deckfile_path = arg;
         end;

         else if arg = "-all" | arg = "-a" then all_diskettes = true;

         else if dfm_util_$valid_diskette (dfm_datap, (arg)) then do;
	  n_diskettes_tb_read = n_diskettes_tb_read + 1;
	  diskettes_tb_read (n_diskettes_tb_read) = arg;
         end;
         else call complain (dfm_datap, wrapup, 0, "Invalid arg ^a", arg);
      end;

      if n_diskettes_tb_read = 0 & ^all_diskettes then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"A diskette to be read must be specified", "");

         query_message = "Enter a diskette name, or -all for all diskettes";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter: <diskette name>");

         if user_reply = "-all"
	| user_reply = "-a" then all_diskettes = true;

         else do;
	  user_entry = substr (user_reply, 1, 8);
	  if dfm_util_$valid_diskette (dfm_datap, user_entry) then do;
	     n_diskettes_tb_read = 1;
	     diskettes_tb_read (n_diskettes_tb_read) = user_entry;
	  end;

	  else call complain (dfm_datap, wrapup, 0,
	        "Invalid diskette name, use list_diskette_types (ldt) request to obtain valid types", "");
         end;
      end;


      if ^mca then do;
         query_message = "Enter the mca (a-d) of the mca to be used";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	" Enter MCA to be used ");
         if search (user_reply, "abcd") = 0 then
	  call complain (dfm_datap, wrapup, 0, "invalid mca id entered", "");
         else mca = true;
         mca_id = "mca" || rtrim (user_reply);
      end;


      if all_diskettes then do;
         n_diskettes_tb_read = hbound (valid_diskettes, 1);
         diskettes_tb_read = valid_diskettes;
      end;

      if n_diskettes_tb_read < 1 then
         call complain (dfm_datap, wrapup, 0, "no diskette type entered", "");

      call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for list catalog */

      call ssu_$get_temp_segment (sci_ptr, "diskette catalog", dfm_data.dcatp); /* get temp seg for diskette catalog */

      call ssu_$get_temp_segment (sci_ptr, "mca catalog", dfm_data.mcatp); /* get temp seg for mca catalog */

      call ssu_$get_temp_segment (sci_ptr, "mca data read buffer", dfm_data.mca_wksp); /* get temp seg for reading mca data */



/* attach and open needed files */

      dfm_data.deckfile_sw = true;			/* deckfile is required */
      call get_files;
      call dfm_util_$mca_attach (dfm_datap, mca_id);

%page;


/* main processing loop */


      call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr,
       "cata.nio.mca", dfm_data.mcatp, dfm_data.mksp, code);
      if code ^= 0 then
         call complain (dfm_datap, wrapup, code, "can't get mca catalog", "");

      do i = 1 to n_diskettes_tb_read;
         unspec (dcata) = "0"b;

remount:
         if dfm_util_$mount_diskette (dfm_datap,
	translate (diskettes_tb_read (i), uc, lc), dfm_data.mca_wksp) then
	  call dfm_util_$read_diskette (dfm_datap, "HDR",
	   dfm_data.mca_wksp, rl, mca_err, code);

         else do;
	  call complain (dfm_datap, print, code, pname,
	   "Operator unable to mount diskette ^a", diskettes_tb_read (i));
	  query_message = "Problems encountered mounting the diskette. Enter:  - (a)bort, (s)kip or (r)etry? ";
	  query_info.explanation_len = length (rtrim (query_message));
	  query_info.explanation_ptr = addr (query_message);
	  call command_query_ (query_info_ptr, user_reply, pname,
	   "Enter:  - (a)bort, (s)kip or (r)etry? ");
	  if user_reply = "r" | user_reply = "retry" then goto remount;
	  if user_reply = "s" | user_reply = "skip" then goto next_disk;
	  else goto exit_lfd;
         end;

         header_ptr = dfm_data.mca_wksp;
         if mca_status.maj | mca_sub.data_p | code ^= 0
	| substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3)
	| substr (header.title, 1, 4) ^= "UTIL" then do;
	  if substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3) then do;
	     call complain (dfm_datap, print, pname,
	      "Diskette ^a mounted - instead of ^a? ", header.unique_id, diskettes_tb_read (i));
	     query_message = "Wrong diskette mounted. Enter:  - (a)bort, (s)kip or (r)etry? ";
	     query_info.explanation_len = length (rtrim (query_message));
	     query_info.explanation_ptr = addr (query_message);
	     call command_query_ (query_info_ptr, user_reply, pname,
	      "Enter:  - (a)bort, (s)kip or (r)etry? ");
	     if user_reply = "r" | user_reply = "retry" then goto remount;
	     if user_reply = "s" | user_reply = "skip" then goto next_disk;
	     else goto exit_lfd;
	  end;

next_disk:  if i < n_diskettes_tb_read then do;
	     call command_query_$yes_no (yes_sw, code, pname,
	      "Unable to read the HEADER - want to continue",
	      "Unable to read the ^a - read the next diskette?", "HEADER");
	     if yes_sw then goto next_diskette;
	     else goto exit_lfd;
	  end;
	  else call complain (dfm_datap, wrapup, code,
	        "reading ^a HEADER", (diskettes_tb_read (i)));
         end;

         call complain (dfm_datap, print, 0,
	"Mounted diskette ^a on drive ^d", header.unique_id, dfm_data.disk_num);
         N = bin (substr (header.x_of_n, 1, 9), 9);
         X = bin (substr (header.x_of_n, 10, 9), 9);
         unspec (xofn) = header.x_of_n;
         dir_number = 0;
         substr (unspec (dir_number), 21, 16) = header.dir_size.msb || header.dir_size.lsb;
         dir_number = dir_number / 16;
         dfm_data.edit_date = header.date_changed;
         diskette_type = header.equip_type;
         dwg_num_tab = substr (header.disk_dwg_num, 11);
         prod_num_tab = substr (header.unique_id, 7);
         dfm_data.current_disk_name = rtrim (header.unique_id);
         current_filename = rtrim ("HDR." || header.unique_id || prod_num_tab || "00");

         if i = 1 then call add_name ("mca.diskettes.rev." || prod_num_tab);
         call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr,
	"cata.nio." || rtrim (header.unique_id), dfm_data.dcatp, dfm_data.dksp, code);
         if code ^= 0 then
	  call complain (dfm_datap, wrapup, code,
	   "can't get ^a catalog", header.unique_id);
         call file_deck (dfm_data.mca_wksp, rl);
         call dfm_util_$read_diskette (dfm_datap, "DIRECTORY",
	dfm_data.mca_wksp, rl, mca_err, code);

         if mca_status.maj | mca_sub.data_p | code ^= 0 then do;
	  if i < n_diskettes_tb_read then do;
	     call command_query_$yes_no (yes_sw, code, pname,
	      "Unable to read DIRECTORY file. Want to continue?",
	      "Unable to read ^a file. Read the next diskette?", "DIRECTORY");
	     if yes_sw then goto next_diskette;
	     else goto exit_lfd;
	  end;
	  else call complain (dfm_datap, wrapup, code,
	        "reading ^a DIRECTORY", diskettes_tb_read (i));
         end;

         dir_ptr = dfm_data.mca_wksp;
         alloc directory in (free_area) set (dir_ptr);
         directory = dfm_data.mca_wksp -> directory;
         current_filename = rtrim (diskette_type || ".DIRECTRY" || prod_num_tab || "00");
         call file_deck (dfm_data.mca_wksp, rl);

         do j = 1 to dir_number;
	  dire_ptr = addr (directory.array (j));
	  if (dire.path_name = ".DPSFILE" & j < dir_number)
	   | dire.deleted then goto next_file;
	  call dfm_util_$read_diskette (dfm_datap, "P=" || dire.path_name,
	   dfm_data.mca_wksp, rl, mca_err, code);
	  if mca_status.maj | code ^= 0 then do;
	     if j < dir_number then do;
	        call command_query_$yes_no (yes_sw, code, pname,
	         "Unable to read last file. Want to continue?",
	         "Unable to read file ^a. Read the next file?", dire.path_name);
	        if yes_sw then goto next_file;
	     end;
	     else do;
	        free directory in (free_area);
	        dir_ptr = null;
	        call complain (dfm_datap, wrapup, code,
	         "unable to read file ^a", dire.path_name);
	     end;
	  end;
	  current_filename = rtrim (dire.path_name || prod_num_tab || dwg_num_tab);
	  call file_deck (dfm_data.mca_wksp, rl);
next_file: end;
         free directory in (free_area);
         dir_ptr = null;
         current_filename = rtrim ("cata." || dfm_data.current_disk_name);
         rl = dcata.n_entries * 24 + 4;
         call file_deck (dfm_data.dcatp, rl);
next_diskette:
         dfm_data.hdr_sw = true;			/* force a new header */
      end;
      dfm_data.current_filename = rtrim ("cata.mca");
      rl = mcata.n_entries * 24 + 4;
      call file_deck (dfm_data.mcatp, rl);

      call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp,
       length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list");
      call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr,
       "ls.cata." || dfm_data.ls_type || ".list");

exit_lfd:
      call wrap_up;

      return;


%page;

/* load_from_tape - entry to read an ifad or fnp tape into a deckfile */

load_from_tape: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call setup_part2;
      dfm_data.lft = true;

      on cleanup call wrap_up;

      call ssu_$arg_count (sci_ptr, nargs);

      if nargs > 0 then do j = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, j, ap, al);
         if index (arg, "-") ^= 1 then do;		/* must be tape name */
	  dfm_data.t_att_desc = "tape_nstd_ " || arg;	/* start attach description */

	  if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then
	     dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec));

	  tape_name = before (arg, ",");		/* If comma, use stuff before */
	  dfm_data.l_att_desc = "vfile_ " || tape_name;	/* start listing attach description */
         end;

         else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */
         else if arg = "-firmware" | arg = "-fw" then do;
	  dfm_data.firmware_sw = true;		/* user just wants firmware loaded */
	  dfm_data.attach_copy, dfm_data.deckfile_sw = false;
         end;

         else if arg = "-copy" | arg = "-cp" then do;	/* user wantsd to make copy of ifad tape */
	  j = j + 1;
	  call ssu_$arg_ptr (sci_ptr, j, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, code,
	      "obtaining ""-copy"" tape reel specification.", "");
	  c_att_desc = "tape_nstd_ " || arg;		/* generate initial copy attach description */

	  if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then
	     c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec));
	  dfm_data.attach_copy = true;		/* set flag */
	  dfm_data.firmware_sw = false;
         end;

         else if arg = "-deckfile" | arg = "-df" then do;	/* user will specify path */
	  j = j + 1;
	  call ssu_$arg_ptr (sci_ptr, j, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, error_table_$bad_arg,
	      "obtaining ""-deckfile"" specification.", "");
	  else deckfile_path = arg;
	  dfm_data.deckfile_sw = true;
         end;

         else if arg = "-density" | arg = "-den" then do;	/* next arg must be density value */
	  j = j + 1;
	  call ssu_$arg_ptr (sci_ptr, j, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, code,
	      "obtaining ""-density"" specification.", "");
	  tdec = cv_dec_check_ (arg, code);
	  if code ^= 0 then go to bad_arg;
	  if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then do;
	     if dfm_data.attach_copy then do;		/* if setting density on copy tape */
	        c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec));
	        cd_sw = true;			/* set indicator */
	     end;
	     if dfm_data.tape_name ^= "" then
	        dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec));
	  end;
	  else go to bad_arg;			/* make him get it right */
         end;

         else if arg = "-patches" then
	  dfm_data.allow_0_cksum = true;		/* user wants to allow firmware decks with a 0 checksum */

         else if arg = "-track" | arg = "-tk" then do;	/* next arg must be 7 or 9 */
	  j = j + 1;
	  call ssu_$arg_ptr (sci_ptr, j, ap, al);	/* get track arg */
	  if al = 0 then				/* error */
	     call complain (dfm_datap, wrapup, code,
	      "obtaining ""-track"" specification.", "");
	  tdec = cv_dec_check_ (arg, code);		/* convert to dec. for check */
	  if code ^= 0 then go to bad_arg;		/* must be numeric */
	  if tdec ^= 7 & tdec ^= 9 then go to bad_arg;	/* and only 7 or 9 */
	  if dfm_data.attach_copy then		/* if track specification of copy tape */
	     c_att_desc = rtrim (c_att_desc) || " -track " || arg; /* insert leading blank */
	  else dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -track " || arg;
         end;

         else do;
bad_arg:	  call complain (dfm_datap, wrapup, error_table_$bad_arg, "^a", arg);
         end;
      end;

      if ^dfm_data.attach_copy			/* if ^copy */
       & ^dfm_data.deckfile_sw			/* & ^deckfile */
       & ^dfm_data.firmware_sw			/* & ^firmware only */
       then dfm_data.deckfile_sw = true;		/* default is to use the deckfile */

      if ^dfm_data.firmware_sw & dfm_data.deckfile_sw	/* if ^firmware & deckfile */
       then dfm_data.firmware_sw = true;		/* default is to create firmware segs */

      if dfm_data.tape_name = "" then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"A tape name must be supplied", "");

         query_message = "Enter the name of the tape, ifad or 6670bdt, to be mounted.";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter <tape_name>: ");

         dfm_data.t_att_desc = "tape_nstd_ " || user_reply; /* start attach description */
         tape_name = before (user_reply, ",");		/* If comma, use stuff before */
         dfm_data.l_att_desc = "vfile_ " || dfm_data.tape_name; /* start listing attach description */
      end;

      if dfm_data.tape_name = "" then
         call complain (dfm_datap, wrapup, code,
	"^/Usage:^-load_from_tape reel_id {-control_args}", "");


      call ssu_$get_temp_segment (sci_ptr, "tape buffer", dfm_data.bptr); /* get temp segs for tape buffer */
      call ssu_$get_temp_segment (sci_ptr, "catalog buffer", dfm_data.catp); /* get temp segs for catalog buffer */
      call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for catalog keys */

      call get_files;				/* attach and open needed files */

      call add_name (dfm_data.tape_name);


      do while (^dfm_data.eot);			/* read tape until 2 eofs */
         call dfm_util_$read_deck (dfm_datap, eof, err);	/* read in next object deck */
         if err | (eof & one_eof) | dfm_data.eot then do;	/* if error condition or 2 eofs */
	  dfm_data.eot = true;			/* thats all there is to do */

	  if dfm_data.attach_copy then
	     call dfm_util_$copy_eof (dfm_datap);	/* if we are copying tape,write out 2nd eof */

	  if dfm_data.fnp_tape & ^err & ^dfm_data.list then do; /* write out fnp catalog record */
	     dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key); /* form completed key */
	     call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.catp,
	      length (unspec (cata)), dfm_data.current_key); /* and write catalog to deck file */
	     call dfm_util_$update_list (dfm_datap, cata_list_type); /* add catalog record to listing file */
	  end;
         end;
         else if eof then do;				/* if eof */
	  one_eof = true;				/* set flag */
	  if dfm_data.attach_copy then		/* if we are copying tape */
	     if ^dfm_data.copy_at_eof then		/* and copy tape is not already at end of file */
	        call dfm_util_$copy_eof (dfm_datap);	/* go write eof on copy tape */

	  if dfm_data.cat_build
	   & ^dfm_data.fnp_tape then do;		/* if we were building catalog */
	     dfm_data.cat_build, dfm_data.first_deck = false; /* reset flags */
	     if index (dfm_data.cat_key, "itr.") ^= 0 then do; /* if building itr catalog */
	        if id_blk.type = "itr" | id_blk.type = "mdr" then do; /* last entry must be firmware */
		 call complain (dfm_datap, print, 0, "Last object deck on itr file is not firmware", "");
		 call complain (dfm_datap, wrapup, 0, "Last object card image is:^/""^a""", dfm_data.obj_card);
	        end;
	        else do;				/* no errors form catalog name */
		 do i = cata.n_entries to 1 by -1 while (index (cata.key (i), ".") > 4);
		 end;				/* find first firmware deck */
		 cata.n_entries = cata.n_entries + 1;
		 dfm_data.cat_key = rtrim (dfm_data.cat_key)
		  || substr (cata.key (i + 1), 8, 6) || "." || substr (cata.key (i + 1), 20, 2);
	        end;
	     end;
	     dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key); /* set current key */
	     call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
	      dfm_data.catp, length (unspec (cata)), dfm_data.current_key); /* and write catalog to deck file */
	     call dfm_util_$update_list (dfm_datap, cata_list_type); /* add catalog record to listing file */
	  end;
         end;

         else do;
	  one_eof = false;				/*  reset eof flag if set */
	  if dfm_data.list then			/* if just producing listing, take all decks */
	     call dfm_util_$update_list (dfm_datap, data_list_type); /* go add entry to listing file */

	  else if dfm_data.fnp_tape			/* no applicability check for fnp decks */
	   | (dfm_util_$ck_applic (dfm_datap)		/* check for Multics applicibilty */
	   & dfm_data.deckfile_sw) then
	     call file_deck (dfm_data.bptr, dfm_data.dlen * 4); /* just loading firmware, don't insert deck into deckfile */

         end;
      end;

      call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp,
       length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list");

      call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, "ls.cata." || dfm_data.ls_type || ".list");
      call wrap_up;
      return;


%page;

/* merge_deckfiles - entry to merge two or more tandd_deck_files */

merge_deckfiles: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call setup_part2;
      dfm_data.mdf = true;

      call ssu_$arg_count (sci_ptr, nargs);
      dkf_path_idx = 1;				/* point to first path */

      do i = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, i, ap, al);

         if arg = "-brief"
	| arg = "-bf" then dfm_data.bf_sw = true;	/* user doesn't want unnecessary nessages */

         else if arg = "-output_file"
	| arg = "-of" then do;
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, code, "obtaining ""-output_file"" specification.", "");
	  else of_path = arg;
         end;

         else if dkf_path_idx > hbound (dkf_path, 1) then
	  call complain (dfm_datap, wrapup, error_table_$bad_arg,
	   "More than ^d deck files to be merged", hbound (dkf_path, 1));

         else do;
	  dkf_path (dkf_path_idx) = arg;
	  dkf_path_idx = dkf_path_idx + 1;
         end;
      end;

      if dkf_path (1) = "" then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"At least one input deckfile path is required", "");

         query_message = "Input deckfile path may be either a path or -working_dir or -system";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter <input deckfile path>: ");

         dkf_path (1) = user_reply;
      end;


      if of_path = "" & dfm_info.deckfile_dir = "" then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"An output deckfile path is required", "");

         query_message = "Output deckfile path may be either a path or -working_dir or -system";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter <output deckfile path>: ");

         of_path = user_reply;
      end;

      if dkf_path (1) = "" | of_path = "" then
         call complain (dfm_datap, wrapup, error_table_$noarg,
	"Both an input and output deckfile path are required", "");

      do i = lbound (dkf_path, 1) to hbound (dkf_path, 1);
         if dkf_path (i) = "-working_dir"
	| dkf_path (i) = "-wd" then
	  dkf_path (i) = rtrim (dir) || deckfile;

         else if dkf_path (i) = "-system"
	| dkf_path (i) = "-sys" then
	  dkf_path (i) = system_dir || deckfile;

         if of_path = "-working_dir"
	| of_path = "-wd" then
	  of_path = rtrim (dir) || ">" || deckfile;

         else if of_path = "-system"
	| of_path = "-sys" then
	  of_path = system_dir || ">" || deckfile;

         if of_path = dkf_path (i) then dkf_path (i) = "";
      end;

      call get_files;

      call ssu_$get_temp_segment (sci_ptr, "temp data buffer", dfm_data.bptr); /* get temp segs for data buffer */
      call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp); /* get temp segs for list catalog */

      do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
         if dfm_data.dkf_iocbp (i) ^= null & dfm_data.of_iocbp ^= null then
	  call dfm_util_$merge_files (dfm_datap, dfm_data.dkf_iocbp (i), dfm_data.of_iocbp);
      end;

      do i = lbound (list_types, 1) to hbound (list_types, 1);
         dfm_data.list_key = list_types (i);
         call dfm_util_$find_key (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key, dfm_data.lcatp, code);
         if code ^= 0 then dfm_data.list_key = "";
         if dfm_data.list_key ^= "" then call dfm_util_$print_list (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key);
      end;

      call wrap_up;
      return;

%page;

/* patch_deck - entry to add/delete a hex or octal patch card(s) into a deck
   in a deckfile and if it is a firmware deck create a firmware segment */

patch_deck: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;
      call setup_part2;
      dfm_data.pd = true;
      dl_patch = false;

      on cleanup call wrap_up;

      call ssu_$arg_count (sci_ptr, nargs);
      if nargs > 0 then do i = 1 to nargs;
         call ssu_$arg_ptr (sci_ptr, i, ap, al);

         if arg = "-brief"
	| arg = "-bf" then dfm_data.bf_sw = true;	/* user doesn't want unnecessary nessages */

         else if arg = "-deckfile" | arg = "-df" then do;
	  i = i + 1;
	  call ssu_$arg_ptr (sci_ptr, i, ap, al);
	  if al = 0 then
	     call complain (dfm_datap, wrapup, code, "obtaining ""-deckfile"" specification.", "");
	  else deckfile_path = arg;
         end;

         else if arg = "-delete" | arg = "-dl" then dl_patch = true;

         else if deck_tb_patched = "" then deck_tb_patched = arg;

         else call complain (dfm_datap, wrapup, error_table_$bad_arg, "only one deck may be patched");
      end;

      if deck_tb_patched = "" then do;
         call complain (dfm_datap, print, error_table_$noarg,
	"A search key for deck to be patched is required", "");

         query_message = "Enter a key or partial key to specify the deck to be patched.";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname,
	"Enter <key of deck to be patched>: ");

         deck_tb_patched = user_reply;

      end;


      call ssu_$get_temp_segment (sci_ptr, "temp buffer", dfm_data.bptr); /* get temp seg for temp buffer */
      call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp); /* get temp seg for deckfile keys */
      call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp); /* get temp segs for list catalog */

      df_keys.n_entries = 0;				/* initialy set to 0 entries */
      lcata.n_entries = 0;

      dfm_data.deckfile_sw = true;			/* deckfile is required */

      call get_files;

      call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "ls.cata.ifad.list", dfm_data.lcatp, dfm_data.lksp, code);
      if code ^= 0 then
         call complain (dfm_datap, wrapup, code, "can't get list catalog", "");

      call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr,
       deck_tb_patched, dfm_data.dfkp, code);
      if code ^= 0 then
         call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", deck_tb_patched);

      term = false;

      if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term);
         call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given",
	"key given matched ^d entries.^/ Entry ^d is ^a - Is this the deck to be patched?",
	df_keys.n_entries, j, df_keys.key (j));

         if yes_sw then do;
	  term = true;
	  j = j - 1;				/* adjust to correct value */
         end;
      end;

      else j = 1;

      if j > df_keys.n_entries & ^term then
         call complain (dfm_datap, wrapup, 0, "There is no file to be patched", "");
      deck_tb_patched = df_keys.key (j);

      term = false;
      if ^dl_patch then
         do i = lbound (dfm_data.opatches, 1) to hbound (dfm_data.opatches, 1) while (^term);

         query_message = "Patch type may either be delete, chex, rhex or octal.";
         query_info.explanation_len = length (rtrim (query_message));
         query_info.explanation_ptr = addr (query_message);
         call command_query_ (query_info_ptr, user_reply, pname, "Enter patch type: ");

         if user_reply = "delete"
	| user_reply = "dl" then dl_patch, term = true;

         else if user_reply = "octal"
	| user_reply = "mask" then do;
	  ascii_cardp = addr (dfm_data.opatches (i));
	  o_patch = " ";
	  o_patch.type = user_reply;

	  query_message = "Enter the octal address of this patch.";
	  query_info.explanation_len = length (rtrim (query_message));
	  query_info.explanation_ptr = addr (query_message);
	  call command_query_ (query_info_ptr, user_reply, pname,
	   "Enter beginning address: ");
	  o_patch.add = user_reply;

	  query_message = "Enter the patches. Consecutive locations maybe separated by a (,) up to 10 patches";
	  query_info.explanation_len = length (rtrim (query_message));
	  query_info.explanation_ptr = addr (query_message);
	  call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: ");
	  o_patch.p_fld = user_reply;
	  call ioa_$rsnnl ("^6a ^5a^[60a^;^3x^57a^]^12x",
	   patch_word, patch_length, convert (add_pic, o_patch.add),
	   o_patch.type, (o_patch.type = "mask"), o_patch.p_fld);
	  call command_query_$yes_no (yes_sw, 0, pname,
	   "Is this patch correct", "Patch entered: ^/^a^/Is this correct?  ",
	   patch_word);
	  if yes_sw then string (opatches (i)) = patch_word;
	  else i = i - 1;
	  call command_query_$yes_no (yes_sw, 0, pname,
	   "MORE PATCHES?", "Are there anymore patches?");
	  if ^yes_sw then term = true;
	  patch_ptr = addr (dfm_data.opatches);
	  npatches = i;
         end;


         else if user_reply = "chex"
	| user_reply = "rhex" then do;
	  ascii_cardp = addr (dfm_data.hpatches (i));
	  h_patch = " ";
	  h_patch.type = user_reply;
	  query_message = "Enter the hex address of this patch.";
	  query_info.explanation_len = length (rtrim (query_message));
	  query_info.explanation_ptr = addr (query_message);
	  call command_query_ (query_info_ptr, user_reply, pname, "Enter address: ");
	  h_patch.add = "0000";
	  substr (h_patch.add, 5 - length (user_reply)) = user_reply;

	  query_message = "Enter the hex patch for this location.";
	  query_info.explanation_len = length (rtrim (query_message));
	  query_info.explanation_ptr = addr (query_message);
	  call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: ");
	  h_patch.inst = "0000";
	  substr (h_patch.inst, 5 - length (user_reply)) = user_reply;
	  call ioa_$rsnnl ("^4a  ^4a^5x^4a^61x", patch_word, patch_length,
	   h_patch.add, h_patch.type, h_patch.inst);
	  call command_query_$yes_no (yes_sw, 0, pname,
	   "Is this patch correct", "Patch entered ^/^a^/Is this correct?  ",
	   patch_word);
	  if yes_sw then string (dfm_data.hpatches (i)) = patch_word;
	  else i = i - 1;
	  call command_query_$yes_no (yes_sw, 0, pname,
	   "MORE PATCHES?", "Are there anymore patches?");
	  if ^yes_sw then term = true;
	  patch_ptr = addr (dfm_data.hpatches);
	  npatches = i;
         end;
      end;

      if dl_patch then npatches = 0;

      call dfm_util_$find_dkend (dfm_datap, deck_tb_patched, patch_ptr, npatches, code);
      if code ^= 0 then
         call complain (dfm_datap, wrapup, code, "attempting to patch file ^a", deck_tb_patched);

      call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
       dfm_data.lcatp, length (unspec (lcata)), "ls.cata.ifad.list");

      call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr);
      dfm_data.liocb_ptr = iox_$user_output;
      dfm_data.terminal_out = true;

      dfm_data.list_key = "ls." || rtrim (deck_tb_patched);

      call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code);
      if code ^= 0 then
         call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", dfm_data.list_key);

      call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, rtrim (lcata.key (1)));

      call wrap_up;
      return;


%page;

/* pi_handler - entry called by ssu_'s pi handler */

pi_handler: entry (P_sci_ptr);

      sci_ptr = P_sci_ptr;
      dfm_infop = ssu_$get_info_ptr (sci_ptr);
      dfm_datap = dfm_info.dfm_data_ptr;
      call wrap_up;
      return;



%page;

/* quit - entry to quit the request loop and exit the ssu envirnoment */

quit: entry (P_sci_ptr, P_dfm_infop);

      call setup_part1;

      call wrap_up;
      call ssu_$abort_subsystem (sci_ptr);
      return;



%page;


/* add name - int proc to add a name onto the current deckfile of list file */

add_name: proc (aname);

dcl  aname char (*);


      if dfm_data.deckfile_sw then do;
         call hcs_$chname_file (dkf_dir (1), dkf_entry (1), "", rtrim (aname) || ".deckfile", code);
         if code ^= 0 & code ^= error_table_$segnamedup then
	  call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a",
	   rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry);

         if ^dfm_data.bf_sw & code = 0 then
	  call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a",
	   rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry);

         call hcs_$chname_file (lsf_dir, lsf_entry, "", rtrim (aname) || ".list", code);
         if code ^= 0 & code ^= error_table_$segnamedup then
	  call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a",
	   rtrim (aname) || ".list", lsf_dir, lsf_entry);

         if ^dfm_data.bf_sw & code = 0 then
	  call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a",
	   rtrim (aname) || ".list", lsf_dir, lsf_entry);
      end;
   end add_name;

%page;

/* file_deck - internal proc to file a deck into a deckfile */

file_deck: proc (fptr, dlen);

dcl  dlen fixed bin (21);
dcl  fptr ptr;

      if dfm_data.lft
       & cata.n_entries = 0 then do;
         call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "cata." || rtrim (dfm_data.cat_key),
	dfm_data.catp, dfm_data.cksp, code);
         if code ^= 0 then call complain (dfm_datap, wrapup, code,
	   "Attempting to do a get catalog for cata.^a", rtrim (dfm_data.cat_key));
      end;

      call dfm_util_$make_key (dfm_datap);		/* produce insertion key */

      call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr,
       fptr, dlen, dfm_data.current_key);		/* copy current deck into deckfile */

      call dfm_util_$update_list (dfm_datap, data_list_type); /* add current deck entry to listing file */

   end file_deck;


%page;

/* get_files internal proc to attach & open files depending on the operation performed. */

get_files: proc ();


/* attach and open tandd_deck_file */

      if dfm_data.deckfile_sw then do;
         if deckfile_path ^= "" then do;
	  if deckfile_path = "-working_dir"
	   | deckfile_path = "-wd" then
	     deckfile_path = rtrim (dir) || deckfile;

	  else if deckfile_path = "-system"
	   | deckfile_path = "-sys" then
	     deckfile_path = system_dir || deckfile;

	  call expand_pathname_ (deckfile_path, dkf_dir (1), dkf_entry (1), code);
	  if code ^= 0 then call complain (dfm_datap, wrapup, code,
	      "encountered while expanding path ^a", deckfile_path);
         end;
         else if dfm_info.deckfile_dir ^= "" then do;
	  dkf_dir (1) = dfm_info.deckfile_dir;
	  dkf_entry (1) = dfm_info.deckfile_entry;
         end;
         else do;
	  dkf_dir (1) = dfm_data.dir;
	  dkf_entry (1) = "tandd_deck_file";
         end;


         call dfm_util_$find_file (dfm_datap, dkf_dir (1), dkf_entry (1));

         dfm_data.dir = dkf_dir (1);
         dfm_data.entry = dkf_entry (1);

         if dfm_data.list then vfile_open_mode = Keyed_sequential_input;
         else vfile_open_mode = Keyed_sequential_update;
         call dfm_util_$open_file (dfm_datap, "dk_file_sw",
	"vfile_ " || rtrim (dkf_dir (1)) || ">" || rtrim (dkf_entry (1)), vfile_open_mode, dfm_data.fiocb_ptr);

      end;


/* attach and open tandd_deck_files for merging */

      else if dfm_data.mdf then do;
         do i = lbound (dkf_path, 1) to hbound (dkf_path, 1) while (dkf_path (i) ^= "");
	  call expand_pathname_ ((dkf_path (i)), dkf_dir (i), dkf_entry (i), code);
	  if code ^= 0 then call complain (dfm_datap, wrapup, code,
	      "encountered while expanding path ^a", dkf_path (i));

	  if dkf_path (i) ^= "" then do;
	     call dfm_util_$open_file (dfm_datap, "dkf_sw" || ltrim (char (i)),
	      "vfile_ " || rtrim (dkf_dir (i)) || ">" || rtrim (dkf_entry (i)),
	      Keyed_sequential_input, dfm_data.dkf_iocbp (i));
	  end;
         end;

         if of_path ^= "" then do;
	  call expand_pathname_ (of_path, of_dir, of_entry, code);
	  if code ^= 0 then call complain (dfm_datap, wrapup, code,
	      "encountered while expanding path ^a", of_path);
         end;

         else if dfm_info.deckfile_dir ^= "" then do;
	  of_dir = dfm_info.deckfile_dir;
	  of_entry = dfm_info.deckfile_entry;
         end;

         else do;
	  of_dir = dfm_data.dir;
	  of_entry = "tandd_deck_file";
         end;


         call dfm_util_$find_file (dfm_datap, of_dir, of_entry);

         dfm_data.dir = of_dir;
         dfm_data.entry = of_entry;

         call dfm_util_$open_file (dfm_datap, "of_sw",
	"vfile_ " || rtrim (of_dir) || ">" || of_entry,
	Keyed_sequential_update, dfm_data.of_iocbp);
      end;


/* attach and open copy tape using the "tape_nstd_" io module */

      if dfm_data.attach_copy then do;			/* only attach copy if indicated */
         call dfm_util_$open_file (dfm_datap, "copy_sw",
	rtrim (c_att_desc) || " -write", Sequential_output, dfm_data.ciocb_ptr);
      end;


/* attach and open listing file */


      if (dfm_data.deckfile_sw | dfm_data.mdf)
       & ^dfm_data.terminal_out then do;

         if of_dir ^= "" then lsf_dir = of_dir;
         else if dkf_dir (1) ^= "" then lsf_dir = dkf_dir (1);
         else if dfm_info.deckfile_dir ^= "" then lsf_dir = dfm_info.deckfile_dir;
         else lsf_dir = dfm_data.dir;
         lsf_entry = "deckfile.list";

         call dfm_util_$find_file (dfm_datap, lsf_dir, lsf_entry);

         if ^dfm_data.mdf & ^dfm_data.list then
	  call dfm_util_$open_file (dfm_datap, "list_sw",
	   rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry) || " -extend"),
	   Stream_input_output, dfm_data.liocb_ptr);

         else if dfm_data.mdf | dfm_data.list then
	  call dfm_util_$open_file (dfm_datap, "list_sw",
	   rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry)), Stream_output, dfm_data.liocb_ptr);

      end;

/* attach and open tape using the "tape_nstd_" io module */

      if dfm_data.lft then
         call dfm_util_$open_file (dfm_datap, "tape_sw", dfm_data.t_att_desc, Sequential_input, dfm_data.tiocb_ptr);



   end get_files;


%page;

/* setup_part1 - internal proc to set variables required by all entries */

setup_part1: proc;

      sci_ptr = P_sci_ptr;
      dfm_infop = P_dfm_infop;
      dfm_datap = dfm_info.dfm_data_ptr;
      dfm_data.infop = dfm_infop;
      dfm_data.sci_ptr = sci_ptr;
      pname = ssu_$get_subsystem_and_request_name (sci_ptr);
   end;

%page;

/* setup_part2 - internal proc to initialize variables required by some entries */

setup_part2: proc;


      dfm_info.flags.request_active = true;
      call date_time_ (clock (), dfm_data.time_string);	/* Convert date and time. */
      dfm_data.gtime_string = date_time_$format ("^yc^my^dm", clock (), "system_zone", "system_lang");
      dfm_data.dir = get_wdir_ ();			/* Get working directory. */

      dfm_data.bptr = null;
      dfm_data.catp = null;
      dfm_data.ciocb_ptr = null;
      dfm_data.dcatp = null;
      dfm_data.dfkp = null;

      do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
         dfm_data.dkf_iocbp (i) = null;
      end;

      dfm_data.fiocb_ptr = null;
      dfm_data.hbuff_p = null;
      dfm_data.lbuff_p = null;
      dfm_data.lcatp = null;
      dfm_data.liocb_ptr = null;
      dfm_data.mca_wksp = null;
      dfm_data.mcatp = null;
      dfm_data.of_iocbp = null;
      dfm_data.tiocb_ptr = null;

      dfm_data.dd = false;
      dfm_data.allow_0_cksum = false;
      dfm_data.attach_copy = false;
      dfm_data.cat_build = false;
      dfm_data.cd_sw = false;
      dfm_data.copy_at_eof = false;
      dfm_data.deckfile_sw = false;
      dfm_data.finished = false;
      dfm_data.eot = false;
      dfm_data.first_deck = false;
      dfm_data.first_write = false;
      dfm_data.firmware_sw = false;
      dfm_data.fnp_tape = false;
      dfm_data.hdr_sw = true;
      dfm_data.lfd = false;
      dfm_data.lft = false;
      dfm_data.list = false;
      dfm_data.one_eof = false;
      dfm_data.mdf = false;
      term = false;
      dfm_data.terminal_out = false;

      deck_tb_patched = "";
      deckfile_path = "";
      dfm_data.current_key = "";
      dfm_data.cat_key = "";
      dfm_data.list_key = "";
      dfm_data.tape_name = "";
      dfm_data.crec = 0;
      dfm_data.denno = 0;
      dfm_data.fnp_key = 0;
      n_diskettes_tb_read = 0;
      dfm_data.cfile = 1;				/* set first file number */
      dfm_data.pfile = 1;				/* set first file number */
      dfm_data.page_no = dfm_info.page_number;		/* and the page number */
      dkf_dir = "";
      dkf_entry = "";
      dkf_dir = "";
      dkf_entry = "";
      dkf_path = "";
      of_dir = "";
      of_entry = "";
      of_path = "";

      query_info_ptr = addr (query_info);
      query_info.yes_or_no_sw = false;
      query_info.version = query_info_version_6;
      query_info.suppress_name_sw = false;
      query_info.suppress_spacing = false;
      query_info.cp_escape_control = "11"b;
      query_info.literal_sw = false;
      query_info.prompt_after_explanation = true;
      query_info.padding = false;
      query_info.status_code = 0;
      query_info.question_iocbp, query_info.answer_iocbp = null ();
      query_info.repeat_time = 0;

   end;

%page;

/* wrap_up - int proc to perform request clean up */

wrap_up: proc ();
      if ^dfm_info.flags.request_active then return;
      dfm_info.page_number = dfm_data.page_no;		/* save page number if needed later */
      if dfm_data.liocb_ptr ^= null & ^dfm_data.terminal_out then
         call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr);
      dfm_data.liocb_ptr = null;

      if dfm_data.ciocb_ptr ^= null then
         call dfm_util_$detach_file (dfm_datap, dfm_data.ciocb_ptr);
      dfm_data.ciocb_ptr = null;

      do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1);
         if dfm_data.dkf_iocbp (i) ^= null then
	  call dfm_util_$detach_file (dfm_datap, dfm_data.dkf_iocbp (i));
         dfm_data.dkf_iocbp (i) = null;
      end;

      if dfm_data.fiocb_ptr ^= null then
         call dfm_util_$detach_file (dfm_datap, dfm_data.fiocb_ptr);
      dfm_data.fiocb_ptr = null;

      if dfm_data.of_iocbp ^= null then
         call dfm_util_$detach_file (dfm_datap, dfm_data.of_iocbp);
      dfm_data.of_iocbp = null;

      if dfm_data.tiocb_ptr ^= null then
         call dfm_util_$detach_file (dfm_datap, dfm_data.tiocb_ptr);
      dfm_data.tiocb_ptr = null;

      if dfm_data.lbuff_p ^= null then
         free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;

      if dfm_data.hbuff_p ^= null then
         free dfm_data.hbuff_p -> hbuff in (free_area);
      dfm_data.hbuff_p = null;

      if dfm_data.m_attached then do;
         if ^mca_status.maj & mca_sub.data_p then
	  call mca_$read_data (dfm_data.mca_ioi_idx, dfm_data.mca_wksp,
	   max_words_to_rd, rl, "0"b, 0);
         call dfm_util_$mca_detach (dfm_datap);
      end;

      if dfm_data.bptr ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.bptr);
      dfm_data.bptr = null;

      if dfm_data.catp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.catp);
      dfm_data.catp = null;

      if dfm_data.dcatp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.dcatp);
      dfm_data.dcatp = null;

      if dfm_data.dfkp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.dfkp);
      dfm_data.dfkp = null;

      if dfm_data.mca_wksp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.mca_wksp);
      dfm_data.mca_wksp = null;

      if dfm_data.lcatp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.lcatp);
      dfm_data.lcatp = null;

      if dfm_data.mcatp ^= null then
         call ssu_$release_temp_segment (sci_ptr, dfm_data.mcatp);
      dfm_data.mcatp = null;

      dfm_data.finished = true;
      dfm_info.flags.request_active = false;

   end;


%page;



%include dfm_info;
%page;
%include dfm_data;
%page;
%include iox_modes;
%page;
%include mca_diskette;
%page;
%include query_info;
%page;
%include sub_err_flags;


   end dfm_;




		    dfm_util_.pl1                   10/21/92  1023.4rew 10/21/92  1020.2      674802



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

/****^  HISTORY COMMENTS:
  1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515),
     audit(87-01-07,Farley), install(87-01-08,MR12.0-1263):
     Originally coded 0682 by Rick Fakoury for MR12.
  2) change(87-01-13,Fakoury), approve(87-01-13,MCR7515),
     audit(87-01-14,Martinson), install(87-01-14,MR12.0-1278):
     PBF to correct a missing blank else statement in ck_applic.
  3) change(87-01-22,Fakoury), approve(87-01-22,MCR7515),
     audit(87-01-22,Martinson), install(87-01-23,MR12.0-1291):
     Fixed a problem encountered merging a deckfile that contained a patch.
  4) change(88-05-30,Fakoury), approve(90-10-03,MCR8147),
     audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049):
     to Fixed a bug in the merging of a deleted file.
  5) change(89-02-06,Fakoury), approve(90-10-03,MCR8147),
     audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049):
     to to increase block count size and to allow a tape copy to be run
     without using a deck_file or list segment.
  6) change(89-06-01,Fakoury), approve(90-10-03,MCR8147),
     audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049):
     to to increase the size of att_desc from 64 to 181 for TR21336.
  7) change(90-10-30,Fakoury), approve(90-11-28,MCR8219),
     audit(90-11-28,Schroth), install(90-11-28,MR12.4-1051):
     PBF correction to previous installation: correct and cleanup logic in
     ck_applic internal proc.
                                                   END HISTORY COMMENTS */

/* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
dfm_util_: proc ();

      return;					/* not a valid entry */


/* AUTOMATIC */

dcl  at_bot bit (1);
dcl  att_desc char (181);
dcl  bcard bit (540);				/* binary card */
dcl  bcnt fixed bin (18);				/* block count */
dcl  bcwp ptr;					/* block cont word p */
dcl  bit_count fixed bin (24);
dcl  c_rtrycnt fixed bin;				/* copy retry count */
dcl  cbcwp ptr;					/* current block cont word ptr */
dcl  cden char (5);					/* copy density */
dcl  code fixed bin (35);
dcl  cx fixed bin;					/* catalog index */
dcl  cvp ptr;					/* convert ptr */
dcl  cvp1 ptr;					/* cpnvert ptr hold */
dcl  dk_end bit (1);
dcl  dk_type char (6);
dcl  dkend_card char (80);
dcl  ename char (32);				/* entry name */
dcl  file_found bit (1);
dcl  first_patch bit (1);
dcl  first_rcd bit (1);				/* first record */
dcl  glrp ptr;					/* gcos log rec ptr */
dcl  glrbp ptr;					/* gcos logical record block ptr */
dcl  gki (20) bit (36);
dcl  gprp ptr;					/* gcos physical record ptr */
dcl  header_key char (24) varying;
dcl  hbuff_len fixed bin (21);			/* header buffer length */
dcl  i fixed bin;
dcl  id_ld bit (1);
dcl  ident_buf (40) bit (36) aligned;			/* load buffer */
dcl  info (20) bit (36);
dcl  info_ptr ptr;
dcl  iocbp ptr;
dcl  j fixed bin;
dcl  k fixed bin;
dcl  lbuff_len fixed bin (21);			/* line buffer length */
dcl  line_count fixed bin;
dcl  lx fixed bin;					/* load index */
dcl  m fixed bin;
dcl  merge_key char (24) varying;
dcl  mode fixed bin;
dcl  mvp ptr;					/* move ptr */
dcl  nbcwp ptr;					/* new blk cont wrd ptr */
dcl  new_iocbp ptr;
dcl  npatches fixed bin;				/* num of patches */
dcl  nwds fixed bin;				/* num of words */
dcl  obj_card_found bit (1);
dcl  ocardp ptr;					/* octal card ptr */
dcl  old_iocbp ptr;
dcl  patch_key char (24) varying;
dcl  pbuf_size fixed bin (21);			/* patch buffer size */
dcl  pptr ptr;					/* patch ptr */
dcl  psz fixed bin;					/* pad size */
dcl  px fixed bin;					/* patch index */
dcl  rcode fixed bin (35);
dcl  rec_len fixed bin (21);
dcl  rtrycnt fixed bin;
dcl  scode fixed bin (35);
dcl  segp ptr;
dcl  svp ptr;
dcl  sw_name char (64);
dcl  t_stat bit (12) aligned;
dcl  term bit (1);
dcl  type fixed bin (2);
dcl  user_access fixed bin (5);
dcl  v_patch bit (1);				/* valid patch */
dcl  wcatp ptr;
dcl  wksp ptr;
dcl  work_key char (24) varying;
dcl  yes_sw bit (1);


/* BUILTINS */

dcl  addr builtin;
dcl  addrel builtin;
dcl  after builtin;
dcl  before builtin;
dcl  bin builtin;
dcl  char builtin;
dcl  convert builtin;
dcl  currentsize builtin;
dcl  fixed builtin;
dcl  index builtin;
dcl  hbound builtin;
dcl  lbound builtin;
dcl  length builtin;
dcl  ltrim builtin;
dcl  null builtin;
dcl  ptr builtin;
dcl  rel builtin;
dcl  rtrim builtin;
dcl  string builtin;
dcl  substr builtin;
dcl  translate builtin;
dcl  unspec builtin;
dcl  verify builtin;


/* CONSTANTS */

dcl  bcd_dkend bit (72) int static options (constant) init
      ("532020202020202442254524"b3);			/* "$      dkend" in bcd */
dcl  bcd_media_code fixed bin (4) int static options (constant) init (2);
dcl  bcd_obj bit (78) int static options (constant) init
      ("53202020202020462241252363"b3);			/* "$      object" in bcd */
dcl  binary_media_code fixed bin (4) int static options (constant) init (1);
dcl  bof fixed bin int static options (constant) init (-1); /* beginning of file */
dcl  buf_size fixed bin (21) int static options (constant) init (4 * 1024); /* 1k buffer is plenty */
dcl  current_ring fixed bin int static options (constant) init (-1);
dcl  density (5) char (5) int static options (constant) init
      ("d6250", "d1600", "d800", "d556", "d200");

dcl  false bit (1) int static options (constant) init ("0"b);
dcl  fnp_355_edit_name char (4) int static options (constant) init ("0300");
dcl  fnp_355_type char (4) int static options (constant) init ("6600");
dcl  fnp_18x_edit_name char (4) int static options (constant) init ("2000");
dcl  fnp_6670_type char (4) int static options (constant) init ("6670");
dcl  fmt1 char (53) int static options (constant) init
      ("^[^5-^12s^; ^[^6x^1s^;^6a^]  ^4a  ^4a  ^2a/^2a/^2a  ");
dcl  fmt2 char (33) int static options (constant) init
      ("^[^6a  ^6a   ^2a^s^;^3s^4a^2-^]^]");
dcl  fmt3 char (62) int static options (constant) init
      ("^-^[    ^[^;^[yes^;no ^]^]^;^2s^64t^24a   ^2d   ^6o    ^8d^]^/");
dcl  g_label bit (72) int static options (constant) init	/* = "ge  600 btl " in bcd */
      ("272520200600002022634320"b3);

dcl  hdra char (18) int static options (constant) init ("Edit  Deck    Assm");
dcl  hdrb char (42) int static options (constant) init
      ("N__a_m_e  T__y_p_e    D__a_t_e");
dcl  hdra1 char (5) int static options (constant) init ("Ident");
dcl  hdrb1 char (46) int static options (constant) init
      ("C__o_d_e    M__o_d_e_l   R__e_v._");
dcl  hdrb2 char (12) int static options (constant) init ("T__y_p_e");
dcl  hdrb3 char (111) int static options (constant) init
      ("S__e_a_r_c_h K__e_y         C__o_m_p  O__f_f_s_e_t  L__e_n_g_t_h (_B__y_t_e_s)_");
dcl  hdra2 char (2) int static options (constant) init ("SS");
dcl  hdra3 char (40) int static options (constant) init
      ("Record             Location       Record");
dcl  hdra4 char (7) int static options (constant) init ("Multics");
dcl  hdrb4 char (30) int static options (constant) init
      ("A__p_p_l_i_c_a_b_l_e");

dcl  max_retrys fixed bin int static options (constant) init (10);
dcl  mpcbot bit (36) int static options (constant) init ("444723224663"b3);

dcl  NL char (1) int static options (constant) init ("
");
dcl  no_chase_sw fixed bin (1) int static options (constant) init (0);
dcl  no_type fixed bin (2) int static options (constant) init (-1);

dcl  print bit (1) int static options (constant) init ("0"b);
dcl  rec_cont_wrd bit (36) int static options (constant) init
      ("000016000200"b3);
dcl  sys_dir char (21) int static options (constant) init
      (">system_library_tandd");
dcl  true bit (1) int static options (constant) init ("1"b);

dcl  whitespace char (2) int static options (constant) init /* TAB and SPACE */
      ("	 ");
dcl  wrapup bit (1) int static options (constant) init ("1"b);


/* BASED and STRUCTURES */


dcl  1 bcw based (bcwp) aligned,
       (2 bsn fixed bin (18),
       2 blk_size fixed bin (18)) unsigned unaligned;

dcl  bit_buf bit (rec_len * 9) based (gprp);

dcl  1 cur_bcw like bcw aligned based (cbcwp);

dcl  data_move char (dfm_data.dlen * 4) based (dfm_data.bptr);

dcl  1 catalog based (c_ptr) aligned,
       2 n_entries fixed bin,
       2 key (1 refer (catalog.n_entries)) char (24);

dcl  free_area area based (get_system_free_area_ ());

dcl  1 glr based (glrp) aligned like gc_log_rec;

dcl  glrb bit (glr.rcw.rsize * 36) based (glrbp);

dcl  1 gpr based (gprp) aligned like gc_phy_rec;


dcl  id_bbuf bit (108) based (cvp);


dcl  1 new_bcw like bcw aligned based (nbcwp);

dcl  1 o_card based (ocardp) aligned,			/* template for an object card */
       (2 pad1 char (15),
       2 library char (6),				/* col 16 - either "hmpcj1" or "htnd  " */
       2 ld_type char (1),				/* col 22, module type */
       2 ss_type char (1),				/* col 23, subsystem type */
       2 pad2 char (3),
       2 m_applic char (1),				/* Multics applicability, non blank means not applicable */
       2 pad3 char (15),
       2 model char (6),				/* for hmpcj1 decks, controller model # */
       2 version char (6),				/* for hmpcj1 decks, model version # */
       2 pad4 char (5),
       2 assem char (1),				/* "m" for mpc assembler, "g" for gmap */
       2 call_name char (6),				/* module call name, or gecall name */
       2 ttl_date char (6),				/* date module assembled */
       2 edit_name char (4),				/* module edit name */
       2 pad5 char (4)) unaligned;



dcl  1 p_blk aligned int static,			/* patch card image storage */
       2 p_cnt fixed bin,				/* number of valid patches */
       2 p_card (200) char (80);			/* patch card image */

dcl  1 r_card based (dfm_data.cptr) aligned,		/* template for a binary card image */
       (2 type bit (12),				/* card type */
       2 count fixed bin (5),				/* number of wds controlled */
       2 ld_add bit (18),				/* loading address */
       2 pad (psz) bit (36),
       2 data (r_card.count) bit (36),
       2 nxt_c_wd bit (36)) unaligned;			/* to get nxt control wd */

dcl  1 rsi like rs_info aligned;			/* auto copy of record status info */

dcl  1 wcata based (wcatp),				/* working catalog */
       2 n_entries fixed bin,				/* number of catalog entries */
       2 key (1 refer (wcata.n_entries)) char (24);
						/* entry search keys */


/* EXTERNAL ENTRIES */

dcl  add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  bcd_to_ascii_ entry options (variable);
dcl  command_query_$yes_no entry () options (variable);
dcl  dfm_$complain entry () options (variable);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  gload_$allow_zero_checksums entry entry (char (*), char (*), char (*), ptr, ptr, fixed bin (18), ptr, fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  (ioa_, ioa_$ioa_switch, ioa_$rs) entry () options (variable);
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_$delete_record entry (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_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry entry options (variable);
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35));
dcl  mca_$detach_mca entry (fixed bin, fixed bin (35));
dcl  mca_$diskette_read entry (fixed bin, char (*), fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
dcl  mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35));
dcl  opr_query_ entry () options (variable);
dcl  tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*));

/* EXTERNAL */

dcl  error_table_$fatal_error fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$no_file fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$end_of_info fixed bin (35) ext static;
dcl  error_table_$tape_error fixed bin (35) ext static;

/* PARAMETERS */

dcl  P_dfm_datap ptr;

%page;


/* ck_applic - entry to check for current deck Multics Applicability. If a deck is appicable, "1"b is returned.
   If deck is the first deck of an "itr" a catalog build is begun */

ck_applic: entry (P_dfm_datap) returns (bit (1));


      dfm_datap = P_dfm_datap;

      ocardp = addr (dfm_data.obj_card);
      if o_card.m_applic ^= " " then do;		/* only take deck if Multics applicable */
         if o_card.library = "hmpcj1" then		/* if itr deck */
	  if id_blk.type = "itr" then			/* space to nxt file */
	     call space_file ();			/* space to nxt file */
	  else if o_card.ss_type = "h" then		/* space over heals files */
	     call space_file ();			/* space to nxt file */
         return (false);				/* return false */
      end;
      else do;					/* Multics applicable */
         if o_card.library = "hmpcj1" then do;		/* if itr, mdr or firmware deck */
	  if id_blk.type = "mdr" then			/* if current deck an mdr */
	     if dfm_data.firmware_sw & ^dfm_data.deckfile_sw then do;
	        dfm_data.eot = true;			/* and we are only loading firmware, thats it */
	        return (false);
	     end;
	     else ;
	  else if id_blk.type ^= "itr"		/* else if firmware deck */
	   & dfm_data.firmware_sw then		/* and not just loading deckfile */
	     call ld_fw_deck (dfm_data.bptr);		/* go load core image for BOS */
	  if ^dfm_data.first_deck then do;		/* if first deck of current file */
	     dfm_data.cat_build, dfm_data.first_deck = true; /* set flag so we don't come back */
	     cata.n_entries = 0;			/* reset number of catalog entries */
	     dfm_data.cat_key = id_blk.type || ".";	/* form suffix part of catalog key */
	     if id_blk.type = "mdr" then do;		/* if building mdr catalog */
	        if o_card.ss_type = "t" then dfm_data.sstype = "tape "; /* tape catalog */
	        else if o_card.ss_type = "p" then dfm_data.sstype = "print"; /* printer catalog */
	        else if o_card.ss_type = "c" then dfm_data.sstype = "card "; /* card catalog */
	        else if o_card.ss_type = "d" then dfm_data.sstype = "disk "; /* disk catalog */
	        else do;
		 call dfm_$complain (dfm_datap, print, 0, /* unknown type */
		  "Unknown subsystem type (col 23) on $ object card ^/Last $ object card image is: ^/""^a""",
		  dfm_data.obj_card);

		 dfm_data.first_deck = false;		/* check next $ object card */
		 return (true);
	        end;
	        dfm_data.cat_key = rtrim (dfm_data.cat_key) || dfm_data.sstype; /* complete mdr catalog key */
	     end;
	  end;
         end;
      end;
      return (true);				/* return true */

%page;


/* copy_eof - entry to write end of file mark on copy tape */

copy_eof: entry (P_dfm_datap);


      dfm_datap = P_dfm_datap;

      call iox_$control (dfm_data.ciocb_ptr, "write_eof", null, code);
      dfm_data.copy_at_eof = true;			/* set copy eof flag */

      return;


%page;


/* delete_deck - entry to delete a deck in the T & D deckfile */


delete_deck: entry (P_dfm_datap, work_key, rcode);


      dfm_datap = P_dfm_datap;

      rcode = 0;					/* reset abort flag */

      call iox_$seek_key (dfm_data.fiocb_ptr, work_key, rec_len, code); /* set key for deletion */
      if code ^= 0 then do;
         rcode = code;
         return;
      end;

      call iox_$delete_record (dfm_data.fiocb_ptr, code);
      if code ^= 0 then do;
         rcode = code;
         return;
      end;

      term = false;
      allocate lbuff in (free_area) set (dfm_data.lbuff_p);
      lbuff = "";
      dfm_data.list_key = "ls." || rtrim (work_key);
      call iox_$seek_key (dfm_data.fiocb_ptr, dfm_data.list_key, rec_len, code);
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code,
	"attempting to seek key ^a ", dfm_data.list_key);
      call iox_$read_record (dfm_data.fiocb_ptr, dfm_data.lbuff_p, rec_len, lbuff_len, code);
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code,
	"attempting to read a keyed record ^a", dfm_data.list_key);

      call ioa_$rs ("^a^86t^7a ^14a^/", lbuff, lbuff_len,
       substr (lbuff, 1, index (lbuff, rtrim (work_key)) + length (rtrim (work_key))),
       "DELETED", substr (dfm_data.time_string, 1, 14));

      call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, lbuff_len, (dfm_data.list_key));
      free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;
      return;

%page;

/* detach_file -  entry to close and  detach file */

detach_file: entry (P_dfm_datap, iocb_ptr);

dcl  iocb_ptr ptr;

      dfm_datap = P_dfm_datap;

      call iox_$close (iocb_ptr, code);
      call iox_$detach_iocb (iocb_ptr, code);
      iocb_ptr = null;


      return;
%page;


/* find_dkend - entry to find either a $deckend card or a patch card */

find_dkend: entry (P_dfm_datap, work_key, pptr, npatches, rcode);


      dfm_datap = P_dfm_datap;

      abort, dk_end, end_file, first_rcd, first_patch = false; /* reset flags */
      id_ld, obj_card_found = false;
      p_blk.p_cnt = 0;				/* initialize patch count */
      cvp, cvp1 = null;

      call iox_$seek_key (dfm_data.fiocb_ptr, work_key, rec_len, code);
      if code ^= 0 then do;
         rcode = 0;
         return;
      end;
      unspec (rsi) = "0"b;
      rsi.version = rs_info_version_2;
      call iox_$control (dfm_data.fiocb_ptr, "record_status", addr (rsi), code);
      if code ^= 0 then do;
         rcode = 0;
         return;
      end;
      bcwp, gprp, mvp = rsi.record_ptr;
      cbcwp = dfm_data.bptr;
      pbuf_size = rec_len;

      do while (^dk_end);				/* loop until entire deck is read in */
         if ^first_rcd then do;			/* if first record of deck */
	  bcnt = gpr.bcw.bsn;			/* load block serial number */
	  first_rcd = true;
         end;
         else do;					/* if not first record, check BSN */
	  bcnt = bcnt + 1;				/* increment our block count */
	  if gpr.bcw.bsn ^= bcnt then			/* something wrong here */
	     call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
	      "Block serial number error at record ^d, file ^d ^/Block serial number was ^d, S/B ^d",
	      dfm_data.crec, dfm_data.cfile, gpr.bcw.bsn, bcnt);
         end;
         glrp = addr (gpr.gc_phy_rec_data (1));		/* get pointer to first logical record */
         nwds = 0;

         do while (nwds < gpr.bcw.blk_size);		/* iterate through all logical records */

	  if glr.rcw.media_code = 2 then do;		/* bcd card image */
	     glrbp = addr (glr.gc_log_rec_data);

	     if substr (glrb, 1, 78) = bcd_obj then do;	/* object card */
	        call bcd_to_ascii_ (glrb, dfm_data.obj_card); /* convert to ascii */
	        obj_card_found = true;		/* indicate that we have gotten object card */
	        ocardp = addr (dfm_data.obj_card);
	     end;

	     else do;
	        if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */
		 id_ld = true;			/* set flag so we don't come back */
		 if cvp1 = null then cvp1 = cvp;	/* if only 1 binary card */
		 call load_ident;			/* load ident block */
	        end;

	        if ck_patch (glrb) then do;		/* go check for patch card */
		 if ^first_patch then do;
		    dfm_data.dlen = fixed (rel (glrp)) - fixed (rel (mvp));
		    data_move = mvp -> data_move;	/* move data from begin to patch */
		    mvp = addrel (mvp, dfm_data.dlen);
		    dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		    first_patch = true;
		 end;

		 call command_query_$yes_no (yes_sw, 0, "Patch Deck",
		  "A patch card has been found in the deck. Do you want to retain it?",
		  "Patch: ^/^a^/Found in deck ^a.^/Do you wish to retain it?", dfm_data.ascii_card, work_key);

		 if yes_sw then do;
		    dfm_data.dlen = glr.rcw.rsize + 1;	/* move the patch */
		    data_move = mvp -> data_move;
		    mvp = addrel (mvp, dfm_data.dlen);
		    dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		 end;

		 else do;
		    mvp = addrel (mvp, glr.rcw.rsize + 1); /* adjust the ptr past the patch */
		    call remove_patch;
		 end;
	        end;


	        if substr (glrb, 1, 72) = bcd_dkend then do; /* dkend card */
		 call bcd_to_ascii_ (glrb, dkend_card); /* convert to ascii */
		 dk_end = true;
		 if ^first_patch then do;
		    dfm_data.dlen = fixed (rel (glrp)) - fixed (rel (mvp));
		    data_move = mvp -> data_move;
		    mvp = addrel (mvp, dfm_data.dlen);
		    dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		 end;
		 if npatches > 0 then do i = 1 to npatches;
		    if dfm_data.opatches (i).type = "octal"
		     | dfm_data.opatches (i).type = "mask " then do;
		       dfm_data.opatches (i).dtime = dfm_data.gtime_string;
		       dfm_data.opatches (i).label = o_card.edit_name;
		       call tolts_alm_util_$ascii_to_bcd_ (string (dfm_data.opatches (i)), bcard);
		       if ^ck_patch (bcard) then
			call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
			 "patch: ^/^a^/ is an invalid patch");
		       bcard = rec_cont_wrd || substr (bcard, 1, 504);
		       mvp = addr (bcard);
		       dfm_data.dlen = 15;
		       data_move = mvp -> data_move;
		       dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		    end;
		    else if substr (dfm_data.hpatches (i).type, 2) = "hex" then do;
		       dfm_data.hpatches (i).dtime = dfm_data.gtime_string;
		       dfm_data.hpatches (i).lbl = o_card.edit_name;
		       dfm_data.hpatches (i).prg_id = string (id_blk.revision);
		       dfm_data.hpatches (i).rev = string (id_blk.revision);
		       dfm_data.hpatches (i).lbl = o_card.edit_name;
		       call tolts_alm_util_$ascii_to_bcd_ (string (dfm_data.hpatches (i)), bcard);
		       if ^ck_patch (bcard) then
			call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
			 "patch: ^/^a^/ is an invalid patch", dfm_data.opatches (i));
		       bcard = rec_cont_wrd || substr (bcard, 1, 504);
		       mvp = addr (bcard);
		       dfm_data.dlen = 15;
		       data_move = mvp -> data_move;
		       dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		    end;
		 end;
		 substr (dkend_card, 67, 6) = dfm_data.gtime_string;
		 call tolts_alm_util_$ascii_to_bcd_ (dkend_card, bcard);
		 bcard = rec_cont_wrd || substr (bcard, 1, 504);
		 mvp = addr (bcard);
		 dfm_data.dlen = 15;
		 data_move = mvp -> data_move;
		 dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen);
		 nbcwp = dfm_data.bptr;
		 new_bcw.blk_size = (fixed (rel (dfm_data.bptr)) - 1) - fixed (rel (cbcwp));
		 if new_bcw.blk_size > 308 then do;
		    cur_bcw.blk_size = 308;
		    new_bcw.blk_size = new_bcw.blk_size - 308;
		    new_bcw.bsn = cur_bcw.bsn + 1;
		 end;
		 else cur_bcw.blk_size = new_bcw.blk_size;
		 call insert_deck (dfm_datap, dfm_data.fiocb_ptr,
		  ptr (dfm_data.bptr, 0), fixed (rel (dfm_data.bptr)) * 4, work_key);
		 if o_card.library = "hmpcj1"
		  & id_blk.type ^= "itr" then
		    call ld_fw_deck (ptr (dfm_data.bptr, 0));
		 term = false;
		 dfm_data.list_key = "ls." || rtrim (work_key);
		 allocate lbuff in (free_area) set (dfm_data.lbuff_p);
		 lbuff = "";
		 call iox_$control (dfm_data.fiocb_ptr, "record_status", addr (rsi), code);
		 call iox_$seek_key (dfm_data.fiocb_ptr, rtrim (dfm_data.list_key), rec_len, code);
		 if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code,
		     "attempting to seek key ^a ", rtrim (dfm_data.list_key));
		 call iox_$read_record (dfm_data.fiocb_ptr, dfm_data.lbuff_p, rec_len, lbuff_len, code);
		 if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code,
		     "attempting to read a keyed record ^a", rtrim (dfm_data.list_key));
		 call ioa_$rs ("^a^86t^2d^90t^6o^103t^8d^[  PATCHED  ^14a^;^s]^/", lbuff, lbuff_len,
		  substr (lbuff, 1, index (lbuff, rtrim (work_key)) + length (rtrim (work_key))),
		  addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18),
		  rsi.record_length, (p_blk.p_cnt > 0), substr (dfm_data.time_string, 1, 20));
		 call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p,
		  lbuff_len, (dfm_data.list_key));
		 free dfm_data.lbuff_p -> lbuff in (free_area);
		 dfm_data.lbuff_p = null;
		 if p_blk.p_cnt > 0 then
		    call put_patch;
		 term = true;
	        end;
	     end;
	  end;

	  else if glr.rcw.media_code = 1 then		/* binary card image */
	     if ^obj_card_found then			/* but no $ object card yet */
	        call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
	         "Binary card image preceeds $ object card at record ^d, file ^d",
	         dfm_data.crec, dfm_data.cfile);

	     else do;
	        cvp1 = cvp;				/* save ptr to last logical record */
	        cvp = glrp;				/* save ptr to current logical record */
	     end;
	  else call dfm_$complain (dfm_datap, wrapup,	/* not a bcd or binary card image */
	        error_table_$fatal_error, "Card type ^o detected at record ^d, file ^d",
	        glr.rcw.media_code, dfm_data.crec, dfm_data.cfile);
	  nwds = nwds + glr.rcw.rsize + 1;		/* increment number of words */
	  glrp = addrel (glrp, currentsize (glr));	/* set next logical record */
         end;
         dfm_data.crec = dfm_data.crec + 1;		/* increment current record number */
         gprp = addrel (gprp, currentsize (gpr));		/* append next block */
         cbcwp = addrel (cbcwp, bcw.blk_size + 1);
         bcwp = gprp;
      end;

      return;


%page;


/* find_file - entry to find the correct file */

find_file: entry (P_dfm_datap, d_name, e_name);

dcl  e_name char (*);
dcl  d_name char (*);

      dfm_datap = P_dfm_datap;

      type = no_type;				/* set to novalid value */
      file_found = false;
      yes_sw = false;
      term = false;

      do while (^term);
         call hcs_$status_minf (d_name, e_name, no_chase_sw, type, bit_count, code);
         if code ^= 0 then do;			/* err or noentry */
	  if code ^= error_table_$noentry then		/* error */
	     call dfm_$complain (dfm_datap, wrapup, code, "looking for ^a in ^a", e_name, d_name);
	  else do;				/* no entry */
	     if accessible (d_name, "", SMA_ACCESS_BIN) then do; /* dir access? */
	        call command_query_$yes_no (yes_sw, 0, "Find File",
	         "^a does not exist in ^a. Do you wish to create it?",
	         "File ^a does not exist in ^a. ^/Create it? ", e_name, d_name);
	        if yes_sw then do;			/* okey - create */
		 file_found, term = true;
		 if index (ename, ".list") ^= 0 then	/* if creating new list */
		    dfm_data.page_no = 0;
	        end;

	        else if d_name ^= sys_dir then		/* haven't tried >firmware */
		 d_name = sys_dir;			/* try it */
	        else goto exit_ff_loop;		/* user doesn't want any of these choices */
	     end;
	     else goto exit_ff_loop;			/* not enough access */
	  end;
         end;

         else if type = Directory then do;		/* entry exists - dir (msf) */
	  if accessible (d_name, "", SMA_ACCESS_BIN) then /* dir access? */
	     if d_name = sys_dir then			/* sys dir - ask */
	        if accessible (d_name, e_name, RW_ACCESS_BIN)
	         & ^dfm_data.list then do;
		 call command_query_$yes_no (yes_sw, 0, "Find File",
		  "^a does not exist in working dir. Use the one found in ^a?",
		  "You have access to modify ^a in ^a.^/Use it?", e_name, sys_dir);
		 if ^yes_sw then goto exit_ff_loop;
	        end;
	  file_found, term = true;			/* must be ok */
         end;

         else if type = Link then do;			/* entry exist & link */
	  call hcs_$get_link_target (d_name, e_name,	/* get dir & entry */
	   d_name, e_name, code);

	  if code ^= 0 then do;
	     if code ^= error_table_$noentry then	/* error */
	        call dfm_$complain (dfm_datap, wrapup, code,
	         "chasing link to ^a", d_name, e_name);

	     else if accessible (d_name, "", SMA_ACCESS_BIN) then do;
	        call command_query_$yes_no (yes_sw, 0, "Find File",
	         "^a is a link in your working dir.^/Use the one found in ^a?",
	         "You have access to create ^a in ^a. ^/Create it?", e_name, d_name);
	        if yes_sw then do;			/* okey - got it */
		 file_found, term = true;
		 if index (ename, ".list") ^= 0 then	/* if creating new list */
		    dfm_data.page_no = 0;
	        end;
	        else goto exit_ff_loop;
	     end;
	     else goto exit_ff_loop;			/* need more access */
	  end;

	  else if accessible (d_name, e_name, RW_ACCESS_BIN)
	   & ^dfm_data.list then do;
	     call command_query_$yes_no (yes_sw, 0, "Find File",
	      "^a is a link in your working dir. ^/Use the one found in ^a?",
	      "You have access to modify ^a in ^a. ^/Use it?", e_name, d_name);
	     if yes_sw then				/* okey - got it */
	        file_found, term = true;
	     else goto exit_ff_loop;			/* suer doesn't want it */
	  end;
	  else file_found, term = true;		/* must be ok */
         end;

         else if type = Segment			/* single segment deckfile */
	& index (e_name, ".list") = 0 then do;
	  if d_name = sys_dir then			/* sys dir - ask */
	     if accessible (d_name, e_name, RW_ACCESS_BIN)
	      & ^dfm_data.list then do;
	        call command_query_$yes_no (yes_sw, 0, "Find File",
	         "^a does not exist in working dir. Use the one found in ^a?",
	         "You have access to modify ^a in ^a.^/Use it?", e_name, sys_dir);
	        if ^yes_sw then goto exit_ff_loop;
	     end;
	  file_found, term = true;			/* must be ok */
         end;

         else if index (e_name, ".list") ^= 0
	& accessible (d_name, e_name, RW_ACCESS_BIN) then /* must be a listing seg */

	  file_found, term = true;

         else goto exit_ff_loop;			/* seg not valid */
      end;

exit_ff_loop:
      if ^file_found then				/* can't continue */
         call dfm_$complain (dfm_datap, wrapup, error_table_$no_file,
	"using ^a>^a", rtrim (d_name), rtrim (e_name));

      if ^dfm_data.bf_sw & file_found then
         call dfm_$complain (dfm_datap, print, 0, "using ^a>^a", rtrim (d_name), rtrim (e_name));

      return;

%page;


/* find_key - entry to find all search keys, given search key head */

find_key: entry (P_dfm_datap, iocbp, c_name, c_ptr, rcode);


dcl  c_ptr ptr;
dcl  c_name char (24) varying;

      dfm_datap = P_dfm_datap;

      rcode = 0;
      ename = c_name;				/* copy search name */
      info_ptr = addr (info);
      unspec (info) = "0"b;
      common_sl_info.version = sl_info_version_0;
      common_sl_info.list_type = 1;			/* set to reuse subset */
      common_sl_info.output_descriptors = true;		/* want descriptors */
      common_sl_info.array_limit = 1;			/* 1 element array */
      common_sl_info.desc_arrayp = null;		/* let vfile_ allocate area for storage */
      hi_sl_info.first_head (1).length, hi_sl_info.last_head (1).length = length (rtrim (ename));
      hi_sl_info.first_head (1).kptr, hi_sl_info.last_head (1).kptr = addr (ename);
      call iox_$control (iocbp, "select", info_ptr, code);	/* get select info */
      if code ^= 0 then do;				/* problem with select */
         rcode = code;
         return;
      end;
      call iox_$position (iocbp, bof, 0, code);		/* position to beginning of file */

      if code ^= 0 then do;				/* problem with select */
         rcode = code;
         return;
      end;
      catalog.n_entries = common_sl_info.count;		/* copy number of descriptors */
      gk_info_ptr = addr (gki);			/* set info ptr */
      unspec (gki) = "0"b;				/* clear structure first */
      gk_info.input_desc = true;			/* using input descriptors */
      gk_info.reset_pos = true;			/* don't change position */
      do i = 1 to common_sl_info.count;			/* find each key */
         gk_info.descrip = desc_array (i);		/* insert each descriptor */
         call iox_$control (iocbp, "get_key", gk_info_ptr, code);
         if code ^= 0 then do;			/* error */
	  rcode = code;
	  return;
         end;
         catalog.key (i) = gk_info.key;			/* copy key */
      end;
      common_sl_info.list_type = 0;			/* set to reuse subset */
      common_sl_info.subset_no = 0;
      common_sl_info.array_limit = 0;			/* 0 element array */
      common_sl_info.desc_arrayp = null;		/* let vfile_ allocate area for storage */
      call iox_$control (iocbp, "select", info_ptr, code);	/* reset current subset */
      rcode = 0;					/* If we get this far insure 0 code is returned */

      return;					/* thats it folks */

%page;


/* get_cata - entry to search a deckfile for a catalog. If one exists
   it is read out, else a new one is initialized. */

get_cata: entry (P_dfm_datap, iocbp, cata_name, wcatp, wksp, rcode);

dcl  rec_length fixed bin (21);
dcl  cata_name char (24) varying;


      dfm_datap = P_dfm_datap;

      call iox_$seek_key (iocbp, cata_name, rec_length, code);
      if code ^= 0 then do;
         if code = error_table_$no_record then do;
	  wcata.key = " ";
	  wcata.n_entries = 0;
	  code = 0;
         end;
      end;
      else call iox_$read_record (iocbp, wcatp, rec_length, rec_len, code);
      wksp = addr (wcata.key (1));
      rcode = code;

      return;

%page;


/* insert_deck - entry to insert current deck into the T & D deckfile */

insert_deck: entry (P_dfm_datap, iocbp, bufp, buf_len, work_key);


dcl  bufp ptr;
dcl  buf_len fixed bin (21);


      dfm_datap = P_dfm_datap;

      if ^dfm_data.deckfile_sw & ^dfm_data.mdf then return; /* not using a deckfile - return */

      call iox_$seek_key (iocbp, work_key, rec_length, code); /* set key for insertion */
      if code ^= error_table_$no_record then do;		/* if record already exists */
         if code = 0 then do;				/* check for common itr */
	  call iox_$rewrite_record (iocbp, bufp, buf_len, code); /* write the record */
	  if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */
	      "attempting to rewrite record whose key is ""^a"" to the ^a>^a",
	      work_key, dfm_data.dir, dfm_data.entry);
	  return;
         end;
         else if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */
	   "attempting to rewrite record whose key is ""^a"" to the ^a>^a",
	   work_key, dfm_data.dir, dfm_data.entry);
      end;
      call iox_$write_record (iocbp, bufp, buf_len, code);	/* write the record */
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */
	"attempting to write record whose key is ""^a"" to the ^a>^a",
	work_key, dfm_data.dir, dfm_data.entry);


      return;

%page;

/* make_key - entry to make up a key for insertion into the deckfile based on object card info */

make_key: entry (P_dfm_datap);

      dfm_datap = P_dfm_datap;
      ocardp = addr (dfm_data.obj_card);
      dfm_data.current_key = "";			/* initialize key first */

      if dfm_data.fnp_tape then do;			/* make special key for fnp bin deck tapes */
         dfm_data.fnp_key = dfm_data.fnp_key + 1;		/* increment fnp key number */
         dfm_data.current_key = "fnp." || dfm_data.fnp_type || ".pol." || ltrim (char (dfm_data.fnp_key)) || "." ||
	substr (o_card.edit_name, 1, 2);
      end;

      else if lfd then do;
         if index (dfm_data.current_filename, "cata.") ^= 0 then do;
	  dfm_data.current_key = rtrim ("cata.nio." || substr (dfm_data.current_filename, 6));
	  if index (dfm_data.current_filename, "mca") = 0
	   & index (mcata_key_string, dfm_data.current_key) = 0 then do;
	     mcata.n_entries = mcata.n_entries + 1;
	     mcata.key (mcata.n_entries) = dfm_data.current_key;
	  end;
         end;

         else do;
	  dfm_data.current_key = "nio." || rtrim (dfm_data.current_filename);
	  if index (dcata_key_string, dfm_data.current_key) = 0 then do;
	     dcata.n_entries = dcata.n_entries + 1;
	     dcata.key (dcata.n_entries) = dfm_data.current_key;
	  end;
         end;
         return;
      end;

      else if o_card.library = "hmpcj1" then do;		/* if mpc deck */
         if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then/* if firmware deck */
	  dfm_data.current_key = string (id_blk.type_code); /* set firmware identification */
         else dfm_data.current_key = id_blk.type;		/* itr or mdr */
         dfm_data.current_key = rtrim (dfm_data.current_key) || "." || id_blk.ident;
         dfm_data.current_key = rtrim (dfm_data.current_key) || "." || o_card.edit_name;
         dfm_data.current_key = rtrim (dfm_data.current_key) || "." || id_blk.rev; /* set revision */
      end;

      else do;					/* must be htnd deck */
         if o_card.ss_type = "s" then			/* take care of special cases first */
	  dfm_data.current_key = "pas." || substr (o_card.edit_name, 1, 3); /* isolts deck */
         else if o_card.ss_type = "u" then		/* utility deck */
	  dfm_data.current_key = "utl." || o_card.call_name;
         else dfm_data.current_key = o_card.ss_type || "lt." || o_card.call_name; /* most common case */
         return;
      end;

      if index (cata_key_string, dfm_data.current_key) = 0 then do;
         cata.n_entries = cata.n_entries + 1;		/* increment  number of catalog entries */
         cata.key (cata.n_entries) = dfm_data.current_key;	/* and add current entry to catalog */
      end;

      return;

%page;


/* mca_attach - entry to attach an MCA for diskette reads */

mca_attach: entry (P_dfm_datap, mca_id);

dcl  mca_id char (4);


      dfm_datap = P_dfm_datap;

      if dfm_data.m_attached then return;
      call mca_$attach_mca (mca_id, 0, dfm_data.mca_ioi_idx, code);
      if code ^= 0 then
         call dfm_$complain (dfm_datap, wrapup, code, "Attempting to attach mca ^a", mca_id);
      dfm_data.m_attached = true;
      return;


%page;


/* mca_detach - entry to detach an MCA */

mca_detach: entry (P_dfm_datap);


      dfm_datap = P_dfm_datap;

      if ^dfm_data.m_attached then return;
      call mca_$detach_mca (dfm_data.mca_ioi_idx, code);
      if code ^= 0 then
         call dfm_$complain (dfm_datap, print, code, "Attempting to detach the mca", "");
      dfm_data.m_attached = false;

      return;


%page;


/* merge deckfiles - entry to merge two deckfiles */

merge_files: entry (P_dfm_datap, old_iocbp, new_iocbp);


      dfm_datap = P_dfm_datap;

      unspec (rsi) = "0"b;
      rsi.version = rs_info_version_2;
      allocate lbuff in (free_area) set (dfm_data.lbuff_p);
      lbuff = "";

      do i = lbound (list_types, 1) to hbound (list_types, 1);
         dfm_data.list_key = list_types (i);
         call find_key (dfm_datap, old_iocbp, (dfm_data.list_key), dfm_data.lcatp, code);
         if code ^= 0 then dfm_data.list_key = "";
         if dfm_data.list_key ^= "" then do;
	  call get_cata (dfm_datap, old_iocbp, dfm_data.list_key, dfm_data.lcatp, dfm_data.lksp, code);
	  if code ^= 0 then
	     call dfm_$complain (dfm_datap, wrapup, code, "attempting to find catalog for ^a", dfm_data.list_key);
	  do j = 1 to lcata.n_entries;
	     call iox_$seek_key (old_iocbp,		/* get the ls. key entry */
	      rtrim (lcata.key (j)), rec_len, code);
	     if code ^= 0 then
	        call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", lcata.key (j));
	     call iox_$read_record (old_iocbp, dfm_data.lbuff_p, rec_len, lbuff_len, code);
	     if code ^= 0 then
	        call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", lcata.key (j));

	     if index (lbuff, "DELETED") = 0
	      & index (lcata.key (j), ".hdr") = 0	/* if not hdr */
	      & index (lcata.key (j), ".P.") = 0 then do; /* or patch headr move data */
	        merge_key = substr (lcata.key (j), verify (lcata.key (j), "ls."));

	        call iox_$seek_key (old_iocbp, merge_key, rec_length, code);
	        if code ^= 0 then
		 call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", merge_key);
	        call iox_$read_record (old_iocbp, dfm_data.bptr, rec_length, rec_len, code);
	        if code ^= 0 then
		 call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", merge_key);
	        call insert_deck (dfm_datap, new_iocbp, dfm_data.bptr, rec_len, merge_key);
	        call iox_$control (new_iocbp, "record_status", addr (rsi), code); /* get record position */
	        call ioa_$rs ("^a^86t^2d^5x^6o^4x^8d^/", lbuff, lbuff_len,
	         substr (lbuff, 1, index (lbuff, rtrim (merge_key)) + length (rtrim (merge_key))),
	         addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length);
	     end;
	     else do;				/* update time & pathname */
	        if after (lcata.key (j), ".hdr") = "1" then /* time */
		 call ioa_$rs ("^a^61tTime - ^a", lbuff, lbuff_len,
		  before (lbuff, "Time"), dfm_data.time_string);
	        else if after (lcata.key (j), ".hdr") = "2" then /* pathname */
		 call ioa_$rs ("^a^51tStored in ^a>^a", lbuff, lbuff_len,
		  before (lbuff, "Stored"), dfm_data.dir, dfm_data.entry);
	     end;

	     call insert_deck (dfm_datap, new_iocbp,	/* write the ls entry */
	      dfm_data.lbuff_p, lbuff_len, (lcata.key (j)));
	  end;
	  call insert_deck (dfm_datap, new_iocbp, dfm_data.lcatp, length (unspec (lcata)), dfm_data.list_key);
         end;
      end;
      free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;

      return;

%page;


/* mount diskette - entry to instruct the operator to mount an MCA diskette */

mount_diskette: entry (P_dfm_datap, diskette_name, header_ptr) returns (bit (1));

dcl  diskette_name char (8) varying;


      dfm_datap = P_dfm_datap;

      opr_query_info.prim = "0 or 1";
      opr_query_info.alt = "unable";
      opr_query_info.r_comment = "";

      term = false;
      do i = 0 to 1 while (^term);
         dfm_data.disk_num = i;
read_diskette_hdr:
         call read_diskette (dfm_datap, "HDR", header_ptr, rec_len, "0"b, code);
         if code = 0 then do;
	  if substr (header.unique_id, 1, 3) = substr (diskette_name, 1, 3) then do;
	     term = true;
	     opr_query_info.q_sw = false;
	     call opr_query_ (addr (opr_query_info),
	      "Reading diskette ^a on drive ^d", header.unique_id, dfm_data.disk_num);
	     return (true);
	  end;
         end;
      end;


      if ^term then do;
ask_opr: call ioa_ ("requesting mount of ^a", diskette_name);
         opr_query_info.q_sw = true;
         opr_query_info.r_comment = "disk # used or unable";
         call opr_query_ (addr (opr_query_info),
	"Please mount diskette ^a and reply with", diskette_name);
         if opr_query_info.answer = "unable" then do;
	  call ioa_ ("unable to mount MCA diskette ^a", diskette_name);
	  return (false);
         end;
         else do;
	  dfm_data.disk_num = convert (dfm_data.disk_num, opr_query_info.answer);
	  if disk_num < 0 | dfm_data.disk_num > 1 then do;
	     call ioa_ ("operator returned incorrect reply - retrying");
	     goto ask_opr;
	  end;
	  else goto read_diskette_hdr;		/* read hdr and display message */
         end;
      end;

      return (false);				/* should never happen */


%page;

/* open_file - entry to attach and open files */

open_file: entry (P_dfm_datap, sw_name, att_desc, mode, iocbp);


      dfm_datap = P_dfm_datap;

      call iox_$attach_name (sw_name, iocbp, att_desc, null, code);
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attaching ^a", sw_name);

      call iox_$open (iocbp, mode, "0"b, code);		/* open per mode */
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "opening ^a for ^a", sw_name, iox_modes (mode));

      return;

%page;

/* print_list - entry to generate a listing of the contents of a deckfile */

print_list: entry (P_dfm_datap, iocbp, work_key);


      dfm_datap = P_dfm_datap;

      if ^dfm_data.deckfile_sw & ^dfm_data.mdf then return;

      call iox_$position (iocbp, bof, 0, code);		/* position to beginning of file */
      if index (work_key, ".list") = 0 then
         call find_key (dfm_datap, iocbp, (dfm_data.list_key), dfm_data.lcatp, code);
      else call get_cata (dfm_datap, iocbp, work_key, dfm_data.lcatp, dfm_data.lksp, code);
      if code ^= 0 then
         call dfm_$complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", work_key);

      k = 1;
      line_count = 0;
      allocate hbuff in (free_area) set (dfm_data.hbuff_p);
      allocate lbuff in (free_area) set (dfm_data.lbuff_p);
      hbuff = "";

      do j = 1 to lcata.n_entries;
         lbuff = "";
         call iox_$seek_key (iocbp, rtrim (lcata.key (j)), rec_len, code);
         if code ^= 0 then
	  call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", lcata.key (j));

         call iox_$read_record (iocbp, dfm_data.lbuff_p, rec_len, lbuff_len, code);
         if code ^= 0 then
	  call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record");

         if index (lcata.key (j), ".hdr") ^= 0 then do;
	  hbuff (k) = "";
	  if k = 1 then do;				/* Need to add page# */
	     dfm_data.page_no = dfm_data.page_no + 1;
	     line_count = 1;
	     call ioa_$rs ("^a,  Page - ^d", lbuff, lbuff_len,
	      before (lbuff, NL), dfm_data.page_no);
	  end;

	  hbuff (k) = rtrim (lbuff);
	  k = k + 1;
         end;
         if dfm_data.terminal_out then lbuff = substr (lbuff, verify (lbuff, whitespace));
         call iox_$put_chars (dfm_data.liocb_ptr, dfm_data.lbuff_p, length (rtrim (lbuff)), code);
         if code ^= 0 then
	  call dfm_$complain (dfm_datap, wrapup, code,
	   "attempting to ^[add to the deckfile.list^;display list output^]",
	   ^dfm_data.terminal_out);

         if k = hbound (hbuff, 1) + 1 then do;
	  call ioa_$ioa_switch (dfm_data.liocb_ptr, "^/");
	  k = 1;
         end;

         line_count = line_count + 1;
         if j < lcata.n_entries
	& lcata.n_entries > 1 then
	  if index (lcata.key (j + 1), ".hdr") = 0
	   & (index (lbuff, "cata") ^= 0 | line_count > 25) then do;
	     line_count = 0;
	     dfm_data.page_no = dfm_data.page_no + 1;
	     call ioa_$rs ("^a,  Page - ^d", hbuff (1), hbuff_len,
	      before (before (hbuff (1), NL), ",  Page"), dfm_data.page_no);

	     do i = lbound (hbuff, 1) to hbound (hbuff, 1);
	        call iox_$put_chars (dfm_data.liocb_ptr, addr (hbuff (i)), length (rtrim (hbuff (i))), code);
	        if code ^= 0 then
		 call dfm_$complain (dfm_datap, wrapup, code,
		  "attempting to ^[write list data^;display list output^]",
		  ^dfm_data.terminal_out);
	     end;
	     call ioa_$ioa_switch (dfm_data.liocb_ptr, "^/");
	  end;
      end;
      free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;
      free dfm_data.hbuff_p -> hbuff in (free_area);
      dfm_data.hbuff_p = null;

      return;

%page;

/* read_deck - entry to read in the next sequential object deck from the tape */

read_deck: entry (P_dfm_datap, end_file, abort);


dcl  (end_file, abort) bit (1);


      dfm_datap = P_dfm_datap;

      at_bot = true;				/* initialize flags */
      abort, dk_end, end_file = false;
      first_rcd, id_ld, obj_card_found = false;
      p_blk.p_cnt = 0;				/* initialize patch count */
      if dfm_data.pfile < dfm_data.cfile then
         dfm_data.pfile = dfm_data.cfile;		/* update listing file designator if necessary */


      gprp = dfm_data.bptr;				/* set initial blk ptr to base of tape buff */
      cvp, cvp1 = null;

      do while (^dk_end);				/* loop until entire deck is read in */
         rtrycnt = 0;				/* reset retries */
retry_rd:
         call iox_$read_record (dfm_data.tiocb_ptr, gprp, buf_size, rec_len, code);
         if code ^= 0 then do;
	  if code ^= error_table_$end_of_info then	/* if not end of file */
	     if code = error_table_$tape_error then do;
	        if at_bot then do;			/* still at bot probably wrong density */
		 dfm_data.denno = dfm_data.denno + 1;	/* increment density number */
		 if dfm_data.denno > hbound (density, 1) then /* can't set it so abort */
		    go to get_stat;
		 call iox_$control (dfm_data.tiocb_ptr, "rewind", null, code);
		 call iox_$control (dfm_data.tiocb_ptr, density (dfm_data.denno), null, code); /* set density */
		 go to retry_rd;			/* and go try again */
	        end;
	        rtrycnt = rtrycnt + 1;		/* increment retry count */
	        if rtrycnt > max_retrys then do;	/* if we have retried max number of times */
get_stat:
		 call iox_$control (dfm_data.tiocb_ptr, "saved_status", addr (t_stat), scode);
		 call dfm_$complain (dfm_datap, wrapup, code,
		  "Tape status = ^4.3b, while reading record ^d, file ^d after 10 retries",
		  t_stat, dfm_data.crec, dfm_data.cfile); /* set abort indicator */
	        end;
	        call iox_$control (dfm_data.tiocb_ptr, "backspace_record", null, code);
	        go to retry_rd;
	     end;
	     else call dfm_$complain (dfm_datap, wrapup, code, /* not a tape error report it and abort */
		 "While reading record ^d, file ^d", dfm_data.crec, dfm_data.cfile);

	  else do;				/* end of file */
	     end_file = true;			/* set eof indicator */
	     dfm_data.cfile = dfm_data.cfile + 1;	/* increment position indicators */
	     dfm_data.crec = 0;
	     return;
	  end;
         end;
         if rec_len = 56 then				/* check for partial hdr label (GCOS EOV) */
	  if substr (bit_buf, 1, 72) = g_label then
	     if substr (bit_buf, 145, 216) = "0"b then do;/* if true, partial hdr label */
	        dfm_data.eot = true;			/* set EOV flags */
	        return;
	     end;
         if ^first_rcd then do;			/* if first record of deck */
	  bcnt = gpr.bcw.bsn;			/* load block serial number */
	  first_rcd = true;
         end;
         else do;					/* if not first record, check BSN */
	  bcnt = bcnt + 1;				/* increment our block count */
	  if gpr.bcw.bsn ^= bcnt then			/* something wrong here */
	     call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
	      "Block serial number error at record ^d, file ^d^/Block serial number was ^d, S/B ^d",
	      dfm_data.crec, dfm_data.cfile, gpr.bcw.bsn, bcnt); /* set abort flag */

         end;
         glrp = addr (gpr.gc_phy_rec_data (1));		/* get pointer to first logical record */
         nwds = 0;

         do while (nwds < gpr.bcw.blk_size);		/* iterate through all logical records */
	  if glr.rcw.media_code = bcd_media_code then do; /* bcd card image */
	     glrbp = addr (glr.gc_log_rec_data);
	     if substr (glrb, 1, 78) = bcd_obj then do;	/* object card */
	        call bcd_to_ascii_ (glrb, dfm_data.obj_card); /* convert to ascii */
	        obj_card_found = true;		/* indicate that we have gotten object card */
	        ocardp = addr (dfm_data.obj_card);
	        if (o_card.edit_name = fnp_18x_edit_name
	         | o_card.edit_name = fnp_355_edit_name)
	         & at_bot then do;			/* get set to build  fnp catalog key */
		 if o_card.edit_name = fnp_18x_edit_name then /* is this an 18x fnp */
		    dfm_data.fnp_type = fnp_6670_type;	/* yes, set type */
		 else if o_card.edit_name = fnp_355_edit_name then /* is it a 355 fnp */
		    dfm_data.fnp_type = fnp_355_type;
		 else call dfm_$complain (dfm_datap, wrapup,
		       error_table_$fatal_error,	/* neither one, can't be fnp tape */
		       "First object deck image has an edit name ^a which is not a valid first deck a binary deck tape",
		       o_card.edit_name);
		 dfm_data.fnp_tape = true;
		 dfm_data.cat_key = "fnp.pol." || dfm_data.fnp_type; /* start catalog key */
		 dfm_data.l_att_desc = rtrim (dfm_data.l_att_desc) || ".fnp." || dfm_data.fnp_type;
	        end;

	     end;
	     else do;				/* must be dkend or patch card */
	        if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */
		 id_ld = true;			/* set flag so we don't come back */
		 if cvp1 = null then		/* if only 1 binary card */
		    cvp1 = cvp;
		 call load_ident;			/* load ident block */
	        end;
	        if substr (glrb, 1, 72) = bcd_dkend then	/* dkend card */
		 dk_end = true;			/* set terminate condition */
	        else if ^ck_patch (glrb) then		/* go check for patch card */
		 call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
		  "BCD card image at record ^d, file ^d is not $ object, $ dkend, or valid patch card:^/""^a""",
		  dfm_data.crec, dfm_data.cfile, dfm_data.ascii_card); /* if error, get out */
	     end;
	  end;
	  else if glr.rcw.media_code = binary_media_code then /* binary card image */
	     if ^obj_card_found then			/* but no $ object card yet */
	        call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error,
	         "Binary card image preceeds $ object card at record ^d, file ^d", dfm_data.crec, dfm_data.cfile);
	     else do;
	        cvp1 = cvp;				/* save ptr to last logical record */
	        cvp = glrp;				/* save ptr to current logical record */
	     end;
	  else call dfm_$complain (dfm_datap, wrapup,
	        error_table_$fatal_error,		/* not a bcd or binary card image */
	        "Card type ^o detected at record ^d, file ^d", glr.rcw.media_code, dfm_data.crec, dfm_data.cfile);

	  at_bot = false;
	  nwds = nwds + glr.rcw.rsize + 1;		/* increment number of words */
	  glrp = addrel (glrp, currentsize (glr));	/* set next logical record */
         end;
         dfm_data.crec = dfm_data.crec + 1;		/* increment current record number */
         gprp = addrel (gprp, currentsize (gpr));		/* append next block */
      end;
      dfm_data.dlen = fixed (rel (gprp)) + 1;		/* set total deck length in words */

      return;

%page;

/* read_diskette - entry to read a specified diskette file */

read_diskette: entry (P_dfm_datap, filename, data_bufp, total_chars, mstat, rcode);


dcl  mca_buf_size fixed bin (21) init (16 * 1024);
dcl  (current_ptr, data_bufp) ptr;
dcl  filename char (*);
dcl  mstat bit (72);
dcl  ret_len fixed bin (21);
dcl  total_chars fixed bin (21);


      dfm_datap = P_dfm_datap;

      ret_len, total_chars = 0;
      code = 0;
      current_ptr = data_bufp;
      call mca_$diskette_read (dfm_data.mca_ioi_idx, filename,
       dfm_data.disk_num, current_ptr, mca_buf_size, ret_len, mstat, code);
rd_loop:
      rcode = code;
      dfm_data.statp = addr (mstat);
      dfm_data.sub_ptr = addr (mca_status.sub);
      if code ^= 0 then do;
         if mca_status.maj = "0"b & mca_sub.data_p then
	  call mca_$read_data (dfm_data.mca_ioi_idx, current_ptr, mca_buf_size, ret_len, "0"b, 0);
         return;
      end;
      current_ptr = add_char_offset_ (current_ptr, ret_len);
      total_chars = total_chars + ret_len;
      if mca_sub.data_p then do;
         call mca_$read_data (dfm_data.mca_ioi_idx, current_ptr, mca_buf_size, ret_len, mstat, code);
         goto rd_loop;
      end;

      else return;

%page;

/* update_list - entry to add current deck entry to listing file */

update_list: entry (P_dfm_datap, ltype);


dcl  ltype fixed bin (2);


      dfm_datap = P_dfm_datap;
      ocardp = addr (dfm_data.obj_card);
      unspec (rsi) = "0"b;
      rsi.version = rs_info_version_2;
      dfm_data.lib = false;				/* reset lib <switch */
      dfm_data.dtype, dfm_data.sstype = "";

      if dfm_data.fnp_tape then do;			/* if loading fnp bin. deck tape */
         dfm_data.sstype = "pol ";			/* this stands for Partial OnLine */
         dfm_data.dtype = "fnp ";
      end;
      else if dfm_data.lfd then do;
         dfm_data.sstype = "nio";
         dfm_data.dtype = substr (translate (dfm_data.current_disk_name, lc, uc), 1, 3);
      end;


      else if o_card.library = "hmpcj1" then do;		/* mpc library */
         dfm_data.lib = true;				/* set lib switch */
         dfm_data.sstype = substr (o_card.library, 1, 5);
         if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then/* if firmware */
	  dfm_data.dtype = " fw ";
         else substr (dfm_data.dtype, 2, 3) = id_blk.type;	/* set itr or mdr type */
         if dk_type = " fw " & id_blk.type = "mdr" then dfm_data.hdr_sw = true;
         dk_type = dfm_data.dtype;
      end;

      else do;					/* must be htnd library */
         if o_card.ld_type = "m" then dfm_data.dtype = "mast"; /* pas2 master deck */
         else if o_card.ld_type = "s" then dfm_data.dtype = "slav";
         else if o_card.ld_type = "p" then dfm_data.dtype = "prog"; /* program deck */
         else if o_card.ld_type = "r" then dfm_data.dtype = "rloc"; /* relocatable deck */
         else dfm_data.dtype = "data";
         if o_card.ss_type = "p" then dfm_data.sstype = "polt";
         else if o_card.ss_type = "m" then dfm_data.sstype = "molt";

         else if o_card.ss_type = "c" then dfm_data.sstype = "colt";
         else if o_card.ss_type = "h" then dfm_data.sstype = "heal";
         else if o_card.ss_type = "u" then dfm_data.sstype = "util";
         else if o_card.ss_type = "s" then
	  if o_card.m_applic = " " then dfm_data.sstype = "isol";
	  else dfm_data.sstype = "solt";
      end;
      if ^dfm_data.list then				/* if just producing a listing, don't bother */
         call iox_$control (dfm_data.fiocb_ptr, "record_status", addr (rsi), code); /* get record position */

      if dfm_data.lfd then dfm_data.ls_type = "mca";
      else if dfm_data.fnp_tape then dfm_data.ls_type = "fnp";
      else dfm_data.ls_type = "ifad";

      if dfm_data.lib_type ^= dfm_data.sstype then do;
         dfm_data.lib_type = dfm_data.sstype;
         dfm_data.hdr_sw = true;
      end;

      if dfm_data.hdr_sw then call put_hdr ();		/* if we need a header then put it out */
      allocate lbuff in (free_area) set (dfm_data.lbuff_p);
      lbuff = "";

      if dfm_data.lfd then do;
         if index (dfm_data.current_filename, "DIR") ^= 0 then
	  dfm_data.current_filename = substr (dfm_data.current_filename, 6, 8);
         else if index (dfm_data.current_filename, "HDR") ^= 0 then
	  dfm_data.current_filename = substr (dfm_data.current_filename, 1, 7);
         else dfm_data.current_filename = substr (dfm_data.current_filename, 1, 8);
         call ioa_$rs ("^12t ^a ^31t ^a ^42t ^a ^58t ^21a ^86t  ^2d     ^6o    ^8d^/",
	lbuff, lbuff_len, dfm_data.current_filename, dfm_data.edit_date, dfm_data.sstype, dfm_data.current_key,
	addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length);
      end;


      else call ioa_$rs (fmt1 || fmt2 || fmt3, lbuff, lbuff_len,
	  (ltype = cata_list_type), dfm_data.fnp_tape, o_card.call_name,
	  o_card.edit_name, dfm_data.dtype, substr (o_card.ttl_date, 1, 2),
	  substr (o_card.ttl_date, 3, 2), substr (o_card.ttl_date, 5, 2),
	  dfm_data.lib, id_blk.ident, o_card.model, id_blk.rev, dfm_data.sstype,
	  dfm_data.list, dfm_data.fnp_tape, (o_card.m_applic = " "), dfm_data.current_key,
	  addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length);

      dfm_data.list_key = "ls." || rtrim (dfm_data.current_key);

      if index (lcata_key_string, dfm_data.list_key) = 0	/* entry not in the cata */
       | lib then do;				/* mpc cata build */
         lcata.n_entries = lcata.n_entries + 1;
         lcata.key (lcata.n_entries) = dfm_data.list_key;
      end;


      call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, lbuff_len, dfm_data.list_key);
      free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;
      if p_blk.p_cnt ^= 0 then			/* if patches exist... */
         call put_patch;				/* list them too */
      if dfm_data.attach_copy then			/* if we are writing copy tape */
         if ltype ^= cata_list_type then		/* and this is not a catalog record */
	  call write_copy ();			/* copy this deck too */

      return;

%page;

/* valid_diskette - entry to verify a diskette as a valid diskette type */

valid_diskette: entry (P_dfm_datap, diskette) returns (bit (1));


dcl  diskette char (8) varying;


      dfm_datap = P_dfm_datap;

      if index (string (valid_diskettes), substr (translate (diskette, lc, uc), 1, 3)) > 0 then return (true);

      else return (false);

%page;

/* accessible - int function that will check the user's access to system gates & data bases */

accessible: proc (dir, entry, lowest_access) returns (bit (1));

dcl  dir char (*);
dcl  entry char (*);
dcl  lowest_access fixed bin (5);

      call hcs_$get_user_effmode (dir, entry, "", current_ring, user_access, code);
      if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code,
	"attemping to get user access to ^a>^a.", dir, entry);

      if user_access >= lowest_access then return (true);

      else return (false);				/* if we made it - all ok */

   end accessible;

%page;


/* ck_patch - int proc to check a bcd card image for a valid patch card */

ck_patch: proc (bcd_card) returns (bit (1));

dcl  bcd_card bit (*);


      call bcd_to_ascii_ (bcd_card, dfm_data.ascii_card);
      ascii_cardp = addr (dfm_data.ascii_card);
      v_patch = false;				/* reset patch flag */

      if h_patch.type = "chex"
       | h_patch.type = "rhex" then			/* for cs or r/w mem */
         if o_card.assem = "m" then			/* and deck produced with mpc assembler */
	  if h_patch.lbl = o_card.edit_name then	/* if label matches */
	     if h_patch.rev = string (id_blk.revision) then /* and rev matches */
	        v_patch = true;			/* valid hex patch */
      if ^v_patch then				/* if  it wasn't hex patch */
         if o_patch.type = "octal" | o_patch.type = "mask" then
	  v_patch = true;				/* valid octal patch */
      if v_patch then do;				/* if one of the above */
         p_blk.p_cnt = p_blk.p_cnt + 1;			/* increment patch count */

         p_blk.p_card (p_blk.p_cnt) = dfm_data.ascii_card;	/* copy image */
      end;

      return (v_patch);

   end ck_patch;

%page;


/* ld_fw_deck - int proc to load core image of firmware deck into
   a segment named "fw.<ident>.<pgm_name>.<rev>" */

ld_fw_deck: proc (fw_dkp);

dcl  fw_dkp ptr;

      ename = "fw." || id_blk.ident || "." || o_card.edit_name ||
       "." || id_blk.rev;				/* form firmware seg name */
      call hcs_$initiate (dfm_data.dir, ename, "", 0, 0, segp, code); /* attempt to initiate seg */
      if segp = null then do;				/* seg does not exist, create it */
         call hcs_$make_seg (dfm_data.dir, ename, "", 01010b, segp, code);
         if segp = null then				/*  error creating segment */
	  call dfm_$complain (dfm_datap, wrapup, code,
	   "Unable to create ^a>^a", dfm_data.dir, ename);
      end;
      if dfm_data.allow_0_cksum then call gload_$allow_zero_checksums
	("dfm_util_", dfm_data.dir, ename, fw_dkp, segp, 0,
	addr (gload_data), code);			/* load the core image */
      else call gload_ (fw_dkp, segp, 0, addr (gload_data), code); /* load the core image */
      if code ^= 0 then				/* loading error */
         call dfm_$complain (dfm_datap, wrapup, code,
	"^a^/attempting to load core image of ^a>^a", gload_data.diagnostic, dfm_data.dir, ename);

      call hcs_$set_bc_seg (segp, fixed (gload_data.text_len) * 36, code); /* set bit count of fw seg */
      if code ^= 0 then				/* error setting bit count */
         call dfm_$complain (dfm_datap, wrapup, code, "Unable to set bit count of ^a>^a", dfm_data.dir, ename);

   end ld_fw_deck;

%page;

/* load_ident - int proc to load last 2 binary card images of hmpcj1 deck and extract the ident block */

load_ident: proc;


      lx = 0;					/* set initial load index */
      ident_buf = ""b;
      svp = glrp;
      glrp = cvp1;

      do while (glr.rcw.media_code = 1);		/* process only binary cards */
         dfm_data.cptr = addrel (glrp, 1);
         psz = 4;					/* set initial pad size to 4 */
         m = r_card.count;				/* set initial count */
         term = false;

         do while (^term);				/* load all words on card */

	  do i = 1 to r_card.count;
	     ident_buf (lx + i) = r_card.data (i);	/* copy data */
	  end;
	  lx = lx + r_card.count;			/* update load index */
	  if substr (r_card.nxt_c_wd, 1, 12) ^= "2005"b3
	   | m = glr.rcw.rsize - 8 then term = true;	/* all done */

	  else do;
	     dfm_data.cptr = addr (r_card.nxt_c_wd);	/* set for nxt control word */
	     psz = 0;				/* pad size = 0 */
	     m = m + r_card.count;			/* increment counter */
	  end;
         end;

         glrp = addrel (glrp, currentsize (glr));		/* set next logical record */
         if glr.rcw.media_code ^= binary_media_code
	& glr.rcw.media_code ^= bcd_media_code then	/* ck for new blk */
	  if glrp -> gpr.bcw.bsn = bcnt then		/* if looks like bcw */
	     glrp = addrel (glrp, 1);			/* go to nxt word */
      end;

/* we have all of the ident block loaded, now lets find the words we are interested in */

      term = false;

      do i = lbound (ident_buf, 1) to hbound (ident_buf, 1) while (^term);
         if ident_buf (i) = mpcbot then			/* if word = "mpcbot" in bcd */
	  term = true;
      end;

      cvp = addr (ident_buf (i - 10));			/* cvp pts to beginning of ident block */
      call bcd_to_ascii_ (id_bbuf, dfm_data.id_buf);	/* convert ident block to ascii */
      glrp = svp;

   end load_ident;


%page;


/* put_hdr - int proc to output a listing page header */

put_hdr: proc ();

      if lcata.n_entries = 0 & (dfm_data.deckfile_sw | dfm_data.mdf) then do;
         call get_cata (dfm_datap, dfm_data.fiocb_ptr,
	"ls.cata." || dfm_data.ls_type || ".list", dfm_data.lcatp, dfm_data.lksp, code);
         if code ^= 0 then
	  call dfm_$complain (dfm_datap, wrapup, code, "can't get list catalog", "");
      end;

      allocate hbuff in (free_area) set (dfm_data.hbuff_p);
      hbuff = "";

      if dfm_data.lfd then do;

         call ioa_$rs ("^| ^- Library - MCA ^61tTime - ^a", /* page# added during output */
	hbuff (1), hbuff_len, dfm_data.time_string);

         call ioa_$rs ("^10t Contents of MCA Diskette - ^a^51tStored in ^a>^a ",
	hbuff (2), hbuff_len, dfm_data.current_disk_name, dfm_data.dir, dfm_data.entry);

         call ioa_$rs ("^9t File ^24t DATE ^45t SS ^66t Record ^87t Location ^96t Record", hbuff (3), hbuff_len);

         call ioa_$rs ("^9t N__a_m_e ^20t M__o_d_i_f_i_e_d ^32t _t_y_p_e ^65t S__e_a_r_c_h K__e_y ^82t C__o_m_p      O__f_f_s_e_t    L__e_n_g_t_h (B__y_t_e_s)",
	hbuff (4), hbuff_len);
      end;

      else do;
         call ioa_$rs ("^|^-^a ^[POL^s^;^a ^] ^61tTime - ^a", /* page# added during output */
	hbuff (1), hbuff_len, "Library -", dfm_data.fnp_tape, o_card.library, dfm_data.time_string);

         call ioa_$rs ("^a ^[FNP ^a ^a^1s^;^2s^a^] ^a^51tStored in ^a>^a",
	hbuff (2), hbuff_len, "Contents of", dfm_data.fnp_tape, dfm_data.fnp_type, "Binary Deck Tape",
	"ITR, Firmware And Diagnostic (IFAD) Tape", dfm_data.tape_name, dfm_data.dir, dfm_data.entry);

         call ioa_$rs (" ^[ Call^;     ^]   ^a     ^[^a^2-^s^;^s ^a^2-^]^-^[ ^[^a^]^;^2s      ^a^]",
	hbuff (3), hbuff_len, (o_card.call_name ^= "" & ^dfm_data.fnp_tape), hdra,
	dfm_data.lib, hdra1, hdra2, dfm_data.list, ^dfm_data.fnp_tape, hdra4, hdra3);


         call ioa_$rs (" ^[ N__a_m_e^;     ^]   ^a    ^[^a^s^;^s^a^2-^]^-^[^[^a^]^;^2s    ^a^]",
	hbuff (4), hbuff_len, (o_card.call_name ^= "" & ^dfm_data.fnp_tape), hdrb,
	dfm_data.lib, hdrb1, hdrb2, dfm_data.list, ^dfm_data.fnp_tape, hdrb4, hdrb3);
      end;

      if dfm_data.deckfile_sw | dfm_data.mdf then do i = lbound (hbuff, 1) to hbound (hbuff, 1);
         header_key = "ls." || rtrim (dfm_data.lib_type) || "." || rtrim (dfm_data.dtype) || ".hdr" || ltrim (char (i));
         call insert_deck (dfm_datap, dfm_data.fiocb_ptr, addr (hbuff (i)),
	length (rtrim (hbuff (i))), header_key);
         if index (lcata_key_string, header_key) = 0 then do;
	  lcata.n_entries = lcata.n_entries + 1;
	  lcata.key (lcata.n_entries) = header_key;
         end;
      end;

      free dfm_data.hbuff_p -> hbuff in (free_area);
      dfm_data.hbuff_p = null;
      dfm_data.hdr_sw = false;			/* do header only once */

   end put_hdr;

%page;

/* put_patch - int proc to add patch card images to listing file */

put_patch: proc;


      allocate lbuff in (free_area) set (dfm_data.lbuff_p);
      lbuff = "";
      call ioa_$rs ("^/The following patch cards are contained in the above deck:^/", lbuff, lbuff_len);
      patch_key = "ls." || rtrim (work_key) || ".P.0";

      do i = 0 to p_blk.p_cnt;			/* output all patches */
         cx = index (lcata_key_string, rtrim (patch_key)) / 24 + 1; /* see if patch exists */
         if cx = 1 then do;				/* no patch found */

	  cx = index (lcata_key_string, rtrim (work_key)) / 24 + 1; /* find entry for deck */
	  lcata.n_entries = lcata.n_entries + 1;	/* bump total */
	  do j = lcata.n_entries to cx + i + 1 by -1;	/* make a slot */
	     lcata.key (j) = lcata.key (j - 1);
	  end;
	  lcata.key (cx + i + 1) = rtrim (patch_key);	/* insert new key in slot */
         end;
         else lcata.key (cx) = rtrim (patch_key);		/* key there - overwrite it */
         call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p,
	length (rtrim (lbuff)), rtrim (patch_key));

         if i < p_blk.p_cnt then do;			/* set up for next patch */
	  call ioa_$rs ("^5t^a^/", lbuff, lbuff_len, rtrim (p_blk.p_card (i + 1)));
	  patch_key = "ls." || rtrim (work_key) || ".P." || ltrim (char (i + 1));
         end;
      end;

      free dfm_data.lbuff_p -> lbuff in (free_area);
      dfm_data.lbuff_p = null;
      p_blk.p_cnt = 0;				/* initialize count */

   end put_patch;


%page;

/* remove_patch - int proc to remove a patch from deckfile */

remove_patch: proc ();

      px = p_blk.p_cnt;

      do i = 1 to px;				/* now remove the patch */
         p_blk.p_card (i) = p_blk.p_card (i + 1);
      end;

      p_blk.p_cnt = p_blk.p_cnt - 1;			/* from patch block */
      patch_key = "ls." || rtrim (work_key) || ".P.1";

dl_patch:
      cx = index (lcata_key_string, rtrim (patch_key)) / 24;

      do i = 1 to lcata.n_entries - 1 - cx;		/* move all entries down */
         lcata.key (cx + i) = lcata.key (cx + 1 + i);
      end;

      lcata.key (lcata.n_entries) = "";
      lcata.n_entries = lcata.n_entries - 1;

      if index (patch_key, ".P.0") = 0 & p_blk.p_cnt > 0 then
         do i = 1 to px;				/* change the key names */
         lcata.key (cx + i) = lcata.key (cx + i);
         lcata.key (cx + i) = "ls." || rtrim (work_key) || ".P." || ltrim (char (i));
      end;

      call iox_$seek_key (dfm_data.fiocb_ptr, patch_key, rec_len, code); /* set key for deletion */
      if code ^= 0 then
         call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek ^a", patch_key);

      call iox_$delete_record (dfm_data.fiocb_ptr, code);
      if code ^= 0 then
         call dfm_$complain (dfm_datap, wrapup, code, "attempting to delete ^a", patch_key);

      if p_blk.p_cnt = 0 & index (patch_key, ".P.0") = 0 then do; /* cnt = 0 patch key not header */
         patch_key = "ls." || rtrim (work_key) || ".P.0";
         goto dl_patch;
      end;

   end remove_patch;


%page;

/* space_file - int proc to formward space to nxt tape file */

space_file: proc ();

      call iox_$control (dfm_data.tiocb_ptr, "forward_file", null, code);
      if code ^= 0 then
         call dfm_$complain (dfm_datap, wrapup, code, "while spacing a tape file", "");
      dfm_data.cfile = dfm_data.cfile + 1;		/* set correct position */
      dfm_data.crec = 0;
      dfm_data.one_eof = true;			/* set eof flag */

   end space_file;

%page;

/* write_copy - int proc to write current deck to copy tape */

write_copy: proc ();

      if ^dfm_data.first_write then do;			/* if this is the first time thru, set density */
         dfm_data.first_write = true;			/* set flag so we don't come back */

         if dfm_data.cd_sw | dfm_data.denno ^= 0 then do;	/* if user specified density */
	  if dfm_data.denno ^= 0 & ^dfm_data.cd_sw then	/* if master tape not standard density */
	     cden = density (dfm_data.denno);		/* set copy to same  (if not user specified) */
	  call iox_$control (dfm_data.ciocb_ptr, cden, null, code);
	  if code ^= 0 then
	     call dfm_$complain (dfm_datap, wrapup, code, "while setting copy tape density", "");
         end;
      end;

      gprp = dfm_data.bptr;				/* set block ptr to first phy. record */

      do while (bin (rel (gprp)) < dfm_data.dlen - 1 & ^dfm_data.eot); /* wrt entire deck */
         c_rtrycnt = 0;				/* initialize retry count */
retry_cp:
         call iox_$write_record (dfm_data.ciocb_ptr, gprp, (gpr.bcw.blk_size + 1) * 4, code);
         if code ^= 0 then				/* if error */

	  if code = error_table_$tape_error then do;	/* if write error */
	     c_rtrycnt = c_rtrycnt + 1;		/* increment retry count */

	     if c_rtrycnt > max_retrys then do;		/* exceeded error threshold */
	        call iox_$control (dfm_data.ciocb_ptr, "saved_status", addr (t_stat), scode);
	        call dfm_$complain (dfm_datap, print, code,
	         "Tape status = ^4.3b, while writing copy tape after 10 retrys", t_stat);
	        dfm_data.eot = true;
	     end;

	     else do;
	        call iox_$control (dfm_data.ciocb_ptr, "backspace_record", null, scode);
	        call iox_$control (dfm_data.ciocb_ptr, "erase", null, scode);
	        go to retry_cp;
	     end;
	  end;

	  else do;				/* not a tape error */
	     call dfm_$complain (dfm_datap, print, code, "while writing copy tape", "");
	     dfm_data.eot = true;			/* set abort flag */
	  end;
         else gprp = addrel (gprp, currentsize (gpr));	/* no error advance to next block */
      end;
      dfm_data.copy_at_eof = false;			/* we are no longer at an eof mark */

   end write_copy;

%page;
%include access_mode_values;
%page;
%include ak_info;
%page;
%include dfm_data;
%page;
%include gcos_ssf_records;
%page;
%include gload_data;
%page;
%include iox_modes;
%page;
%include mca_area;
%page;
%include mca_config_file;
%page;
%include mca_constants;
%page;
%include mca_data_area;
%page;
%include mca_diskette;
%page;
%include opr_query_info;
%page;
%include status_structures;
%page;
%include select_info;




   end dfm_util_;




		    dfm_request_table_.alm          10/21/92  1023.4rew 10/21/92  1020.0       16137



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

" HISTORY COMMENTS:
"  1) change(86-11-12,Fakoury), approve(86-11-12,MCR7515),
"     audit(87-01-07,Farley), install(87-01-08,MR12.0-1263):
"     Originally coded 06/82 by R. Fakoury
"                                                      END HISTORY COMMENTS

name	dfm_request_table_

"  Request definitions for Multics deck_file_manager command



	    include	ssu_request_macros

"
	begin_table dfm_request_table_

	" action requests

	request	delete_deck, 
		dfm_$delete_deck,
		(dd),
		(Deletes a deckfile deck.),
		flags.allow_command

	
	request	list,
		dfm_$list,
		(ls),
		(Create a deckfile.list from a tandd_deck_file.),
		flags.allow_command


	request	list_diskette_types,
		dfm_$list_diskette_types,
		(ldt),
		(Lists valid diskette types accepted by lfd.),
		flags.allow_command


	request	load_from_diskette,
		dfm_$load_from_diskette,
		(lfd),
		(Read mca diskettes into the deckfile.),
	          flags.allow_command


	request	load_from_tape,
		dfm_$load_from_tape,
		(lft),
		(Read a Binary Deck File / IFAD tape into the deckfile),
	          flags.allow_command


	request	merge_deckfiles,
		dfm_$merge_deckfiles,
		(mdf),
		(Merge two or more deckfiles into one deckfile.),
	          flags.allow_command


	request	patch_deck,
		dfm_$patch_deck,
		(pd),
		(Patches a selected deck.),
		flags.allow_command


 	request	quit,
		dfm_$quit,
		(q),
		(Exits the deckfile_manager request loop.),
	          flags.allow_command

	end_table	dfm_request_table_

	end


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