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

/* LOAD_FIRMWARE_FILE - Load Firmware, ITR's and MDR's from tape or segment.
   coded 11/19/74 by Noel I. Morris	*/
/* Extensively modified June-July 1975 by Larry Johnson */
/* Modified January 1976 by Larry Johnson for new disk config cards */
/* Modified August 1976 by Larry Johnson to fix some bugs. */
/* Modified January 1979 by Michael R. Jordan for MSS0500 & CCU401. */

load_firmware_file: lff: proc;

dcl  data_ptr ptr;					/* Pointer to data being loaded */
dcl  segp ptr;					/* Pointer to firmware segment */
dcl  data_len fixed bin (6);				/* Number of words being loaded */
dcl  data_offset fixed bin;				/* Offset into segment where they are loaded */
dcl  len fixed bin;					/* Length of current record */
dcl  ctl bit (12);					/* Control info from tape record */
dcl  load bit (1) init ("1"b);			/* ON to load files */
dcl  rp ptr;					/* Pointer to current tape record */
dcl  eof bit (1);					/* Tape EOF flag */
dcl  prev_eof bit (1) init ("1"b);			/* Previous EOF flag */
dcl  total_len fixed bin (18);			/* Total length of this F/W file */
dcl  code fixed bin (35);				/* Error code */
dcl  iostatus bit (72) aligned;			/* IOS_ error code */
dcl  argptr ptr;					/* Pointer to command argument */
dcl  arglen fixed bin;				/* Length of command argument */
dcl  argument char (arglen) based (argptr);		/* Command argument */
dcl  data (data_len) bit (36) based (data_ptr);		/* Used to copy data */
dcl  tape char (200) var;				/* Name of tape or segment being loaded */
dcl  tape_name char (32) var;				/* Edited name of tape */
dcl  output_dir char (168);				/* The output directory */
dcl  segname char (32);				/* Current firmware segment name */
dcl  time_string char (24);				/* Current date and time */
dcl  fileno fixed bin init (1);			/* Tape file number */
dcl  objcard char (80);				/* $ OBJECT card after ASCII translation */
dcl  dkecard char (80);				/* $ DKEND card after ASCII translation */
dcl  type char (6);					/* Program type */
dcl  ident char (6);				/* Program identifier */
dcl  lff_name char (18) init ("load_firmware_file");
dcl  pgm_name char (4);				/* Name of firmware program */
dcl  dev_name char (6);				/* Name of device a program is for */
dcl  i fixed bin;					/* Index for loops */
dcl  files_loaded fixed bin init (0);			/* Count of files created */
dcl  ptr_array (2) ptr init (null, null);		/* For get_temp_segments_ */
dcl  arg_cnt fixed bin;				/* Count of command arguments */
dcl  arg_no fixed bin;				/* Current argument */
dcl  dev_cnt fixed bin init (0);			/* Number of devices in command */
dcl  name_cnt fixed bin init (0);			/* Number of names specified */
dcl  file_cnt fixed bin init (0);			/* Number of files specified */
dcl  dev_list (32) char (6);				/* List of devices specified */
dcl  name_list (32) char (4);				/* List of programs specified */
dcl  file_list (32) fixed bin;			/* List of files specified */
dcl  dev_flags (32) bit (1);				/* Set if corresponding entry in dev_list found */
dcl  name_flags (32) bit (1);				/* Set if corresponding entry in name_list found */
dcl  file_flags (32) bit (1);				/* Set if corresponding entry if file_list found */
dcl  temp_seg_ptr ptr;				/* Pointer to temporary output segment */
dcl  name_index fixed bin;				/* Index in list of names */
dcl  dev_index fixed bin;				/* Index in list of devices */
dcl  file_index fixed bin;				/* Index to list of files */
dcl  line_cnt fixed bin init (0);			/* Count lines on listing */
dcl  pgm_type char (1);				/* Type of current program */
dcl  cv_dec_err fixed bin;				/* Error code from cv_dec_check */
dcl  cv_dec_result fixed bin (35);			/* Result from cv_dec_check_ */
dcl  type_offset fixed bin;				/* Offset in module to word containing the type code */
dcl  ident_offset fixed bin;				/* Location of ident in module */
dcl  fw_list_ptr ptr;				/* Pointer to fw_list iocb */
dcl  first_ff fixed bin init (0);			/* Flag to inhibit first formfeed in list file */
dcl  cont_sw fixed bin init (0);			/* Flag to insert cont in header */
dcl  bcp ptr;					/* Pointer to binary card header */
dcl  total_data fixed bin;				/* Accumulated length moved from card */
dcl  data_addr ptr;					/* Address of data on  card */
dcl  max_file_no fixed bin init (0);			/* Maximum file on -file */
dcl  itr_name (32) char (6);				/* List of devices to load itrs for in -config */
dcl  appl_name (32) char (4);				/* Application firmware needed for -config */
dcl  mdr_name (32) char (6);				/* Devices to load mdrs for during -config */
dcl  itr_bits (32) bit (1);				/* Indicates which itr_names not loaded yet */
dcl  appl_bits (32) bit (1);				/* Same for appl_name */
dcl  mdr_bits (32) bit (1);				/* Same for mdr_name */
dcl  itr_count fixed bin;				/* Number of entries in itr_name */
dcl  mdr_count fixed bin;				/* Number of entries in mdr_name */
dcl  appl_count fixed bin;				/* Number of entries in appl_name */
dcl  save_cnt fixed bin init (0);			/* Number of entries in save_seg array */
dcl  save_segp ptr;					/*  pointer to save_seg array */
dcl  load_comment char (32) var;
dcl  iomodule_name char (5);				/* Name of IOS input module */

dcl 1 misc_bits aligned,				/* A structure of misc bits */
    2 tape_attach bit (1) unal,			/* Set when tape attached so clean_up knows */
    2 gcos_init bit (1) unal,				/* Set when gcos_init called for same reason */
    2 fw_list_attach bit (1) unal,			/* Set when listing file attached */
    2 fw_list_open bit (1) unal,			/* Set when listing file opened */
    2 get_path bit (1) unal,				/* Set if next argument is to be path name */
    2 dev_sw bit (1) unal,				/* Set if command has device list */
    2 name_sw bit (1) unal,				/* Set if command has name list */
    2 file_sw bit (1) unal,				/* Set if command has file list */
    2 mdr_sw bit (1) unal,				/* Set if -mdr used */
    2 itr_sw bit (1) unal,				/* Set if -itr used */
    2 appl_sw bit (1) unal,				/* Set if -appl used */
    2 all_sw bit (1) unal,				/* Set if all types (mdr, itr, appl) needed */
    2 header_sw bit (1) unal,				/* Set when header printed for current file */
    2 scan_dev bit (1) unal,				/* Set during a scan for device names */
    2 scan_name bit (1) unal,				/* Set during scan for program names */
    2 scan_file bit (1) unal,				/* Set during scan for file numbers */
    2 input_segment_sw bit (1) unal,			/* Set when input is from a segment */
    2 config_sw bit (1) unal;				/* Set when -config is specified */

dcl  total_seg (total_len) bit (36) aligned based;	/* This is an entire segment */

dcl 1 card based (rp) aligned,			/* Binary card declaration */
   (2 type bit (12),				/* Card type info */
    2 count bit (6),				/* Count of data words on this card */
    2 load_address bit (18),				/* Load address for data on this card */
    2 checksum bit (36),				/* Checksum */
    2 not_used (3) bit (36),
    2 data (data_len) bit (36)) unal;			/* Data words */


dcl 1 bincard based (bcp) aligned,			/* Header word of binary data */
   (2 type bit (12),				/* Type code 2005 */
    2 count bit (6),				/* Data length */
    2 load_address bit (18)) unal;			/* Load address */

dcl 1 save_seg (save_cnt) aligned based (save_segp),	/* For saveing names of modules stored */
    2 name char (32),
    2 file fixed bin;				/* File it was loaded from */


/* Entry variables */

dcl  ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$setsize entry (char (*), fixed bin, bit (72) aligned);
dcl  ios_$detach entry (char (*), char (*), char (*), bit (72) aligned);
dcl  gcos_gsr_read_$gsr_read_init entry (char (*), fixed bin (35));
dcl  gcos_gsr_read_$gsr_read_close entry (char (*), fixed bin (35));
dcl  gcos_gsr_read_ entry (char (*), ptr, fixed bin, bit (12), bit (1), fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch entry options (variable);
dcl  clock_ entry returns (fixed bin (52));
dcl  date_time_ entry (fixed bin (52), char (*));
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  gcos_cv_gebcd_ascii_ entry (ptr, fixed bin, ptr);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$file_not_opened ext fixed bin (35);
dcl  error_table_$inconsistent ext fixed bin (35);

dcl (addr, addrel, bin, index, max, null, substr, string, unspec, verify) builtin;

dcl  cleanup condition;

/* First argument will be the name of the tape to mount or name of input segment */

	call cu_$arg_count (arg_cnt);
	if arg_cnt = 0 then do;
	     call com_err_ (0, lff_name, "Usage: ^a -control_args- ^/^-^a", lff_name,
		"{-mdr,-appl,-itr,-list,-device,-name,-file,-pathname,-segment,-config}");
	     return;
	end;
	call date_time_ (clock_ (), time_string);	/* Convert date and time. */
	string (misc_bits) = "0"b;			/* Reset a whole lot of bits */
	output_dir = get_wdir_ ();			/* Get working directory. */
	call cu_$arg_ptr (1, argptr, arglen, code);	/* Get first argument. */
	if code ^= 0 then go to err;
	tape = argument;				/* Set tape ID. */
	i = index (tape, ",");			/* Check for commas in tape name */
	if i > 1 then tape_name = substr (tape, 1, i - 1); /* If comma, use stuff before */
	else tape_name = tape;			/* Otherwise use the whole thing */

/* Loop to scan the rest of the argument list */

	do arg_no = 2 to arg_cnt;			/* And then loop thru them */
	     call cu_$arg_ptr (arg_no, argptr, arglen, code); /* Get an argument */
	     if code ^= 0 then go to err;

	     if get_path then do;			/* If next thing expected is path name */
		get_path = "0"b;			/* Not expected any more */
		call expand_path_ (argptr, arglen, addr (output_dir), null, code);
		if code ^= 0 then go to arg_err;
	     end;

	     else if substr (argument, 1, 1) = "-" then do; /* Found a control argument */
		scan_dev, scan_name, scan_file = "0"b;	/* No longer scanning for devices or names or files */
		if argument = "-mdr" then mdr_sw = "1"b;
		else if argument = "-appl" then appl_sw = "1"b;
		else if argument = "-itr" then itr_sw = "1"b;
		else if argument = "-list" | argument = "-ls" then load = "0"b;
		else if argument = "-device" | argument = "-dv" then scan_dev, dev_sw = "1"b;
		else if argument = "-name" | argument = "-nm" then scan_name, name_sw = "1"b;
		else if argument = "-file" then scan_file, file_sw = "1"b;
		else if argument = "-pathname" | argument = "-pn" then get_path = "1"b;
		else if argument = "-segment" | argument = "-sm" then input_segment_sw = "1"b;
		else if argument = "-config" then config_sw = "1"b;
		else do;
		     code = error_table_$badopt;
		     go to arg_err;
		end;
	     end;

	     else if scan_dev then do;		/* If scanning for devices after -dv */
		if dev_cnt >= 32 then
		     call com_err_ (0, lff_name, "Too many device names: ^a ignored.", argument);
		else do;
		     dev_cnt = dev_cnt + 1;		/* Count another device */
		     dev_list (dev_cnt) = argument;	/* And save the argument */
		end;
	     end;

	     else if scan_name then do;		/* If scanning for names after -nm */
		if name_cnt >= 32 then
		     call com_err_ (0, lff_name, "Too many program names: ^a ignored.", argument);
		else do;
		     name_cnt = name_cnt + 1;		/* Count the names */
		     name_list (name_cnt) = argument;	/* And save it */
		end;
	     end;

	     else if scan_file then do;		/* If scanning for files after -file */
		if file_cnt >= 32 then
		     call com_err_ (0, lff_name, "Too many file numbers: ^a ignored.", argument);
		else do;
		     cv_dec_result = cv_dec_check_ (argument, cv_dec_err);
		     if cv_dec_err ^= 0 then do;	/* If file number is not numeric */
			call com_err_ (0, lff_name, "Invalid file number: ^a", argument);
			return;
		     end;
		     file_cnt = file_cnt + 1;
		     file_list (file_cnt) = cv_dec_result;
		     max_file_no = max (max_file_no, cv_dec_result); /* Save highest file requested */
		end;
	     end;

	     else do;				/* Ran out of things that the argument could be */
		code = error_table_$badopt;
		go to arg_err;
	     end;
	end;

/* Perform some consistency checks on the accumulated arguments */

	if get_path then do;
	     call com_err_ (0, lff_name, "Missing pathname after -pathname");
	     return;
	end;

	if config_sw then do;			/* Check for things which conflict with -config */
	     segname = "";				/* This will be name of conflicting control arg, if any */
	     if name_sw then segname = "-name";
	     else if dev_sw then segname = "-device";
	     else if file_sw then segname = "-file";
	     if segname ^= "" then do;		/* If conflict found */
		call com_err_ (error_table_$inconsistent, lff_name, "-config and ^a", segname);
		return;
	     end;
	end;

	if name_sw & (name_cnt = 0) then do;
	     call com_err_ (0, lff_name, "Missing program names after -name");
	     return;
	end;

	if dev_sw & (dev_cnt = 0) then do;
	     call com_err_ (0, lff_name, "Missing device names after -device");
	     return;
	end;

	if file_sw & (file_cnt = 0) then do;
	     call com_err_ (0, lff_name, "Missing file number after -file");
	     return;
	end;

	if ^(mdr_sw | itr_sw | appl_sw) then mdr_sw, itr_sw, appl_sw = "1"b; /* If none, then use all */
	if (mdr_sw & itr_sw & appl_sw) then all_sw = "1"b; /* If all types needed */
	string (dev_flags), string (name_flags), string (file_flags) = "0"b;


	on cleanup call clean_up;

	if config_sw then call scan_config;		/* If -config specified, scan config deck */

/* Create a temporary segment in the process directory to load firmware modules into */

	if load then do;
	     call get_temp_segments_ (lff_name, ptr_array, code);
	     if code ^= 0 then do;
		call com_err_ (code, lff_name, "Unable to get temp segment.");
		go to close;
	     end;
	     temp_seg_ptr = ptr_array (1);
	     save_segp = ptr_array (2);
	end;


/* Make attachment for the listing segment */

attach:	call iox_$attach_ioname ("fw_list", fw_list_ptr, "vfile_ " || tape_name || ".list", code);
	if code ^= 0 then do;
	     call com_err_ (code, lff_name, "Attaching listing file");
	     go to close;
	end;
	fw_list_attach = "1"b;

	call iox_$open (fw_list_ptr, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, lff_name, "Opening listing file.");
	     go to close;
	end;
	fw_list_open = "1"b;


/* Make attachment for the tape or segment input file */

	if input_segment_sw then iomodule_name = "file_"; /* If segment input */
	else iomodule_name = "nstd_";			/* Otherwise tape input */
	call ios_$attach ("fw_tape", iomodule_name, (tape), "r", iostatus); /* If segment input */
	if substr (iostatus, 1, 36) then do;
	     unspec (code) = substr (iostatus, 1, 36);
	     call com_err_ (code, lff_name, "Attaching to input file with ^a", iomodule_name);
	     go to close;
	end;
	tape_attach = "1"b;
	if input_segment_sw then do;			/* If input from segment */
	     call ios_$setsize ("fw_tape", 36, iostatus);
	     if substr (iostatus, 1, 36) then do;
		unspec (code) = substr (iostatus, 1, 36);
		call com_err_ (code, lff_name, "Setting element size to 36.");
		go to close;
	     end;
	end;


open:	call gcos_gsr_read_$gsr_read_init ("fw_tape", code);
	if code ^= 0 then do;
	     call com_err_ (code, lff_name, "From gcos_gsr_read_$gsr_read_init.");
	     go to close;
	end;
	gcos_init = "1"b;

/* The first card should be the $object card */

next:	call gcos_gsr_read_ ("fw_tape", rp, len, ctl, eof, code);
	if code ^= 0 then do;
gcos_err:	     call com_err_ (code, lff_name, "Error reported by gcos_gsr_read_");
	     go to close;
	end;
got_eof:	if eof then do;				/* If EOF encountered ... */
	     if input_segment_sw then go to done;	/* Only one file in segment */
	     if prev_eof then go to done;		/* If 2 EOF's in a row, we're finished. */
	     prev_eof = "1"b;			/* Set flag to detect consecutive EOF's. */
	     fileno = fileno + 1;			/* Bump tape file number. */
	     if file_sw then if fileno > max_file_no then go to done; /* Can quit if enough files scanned */
	     if config_sw then call config_eof;		/* Check progress */
	     header_sw = "0"b;			/* Header will be needed */
	     cont_sw = 0;				/* Continued msg not needed now */
	     go to open;				/* And open for reading again. */
	end;
	else prev_eof = "0"b;			/* Clear adjacent EOF flag. */

	if bin (substr (ctl, 3, 4), 4) ^= 2 then do;	/* Must be BCD record. */
oberr:	     call com_err_ (0, lff_name, "Could not find $ OBJECT card.");
	     go to close;
	end;

	call gcos_cv_gebcd_ascii_ (rp, 80, addr (objcard)); /* Convert the card to ASCII. */
	if substr (objcard, 1, 13) ^= "$      object" then go to oberr;

/* Next should be the preface card */

got_obj:	call gcos_gsr_read_ ("fw_tape", rp, len, ctl, eof, code);
	if code ^= 0 then go to gcos_err;
	if eof then do;				/* Read the preface card. */
eoferr:	     call com_err_ (0, lff_name, "Unexpected EOF.");
	     go to close;
	end;
	if bin (substr (ctl, 3, 4), 4) ^= 1 then do;	/* Must be binary card. */
perr:	     call com_err_ (0, lff_name, "Error reading preface card.");
	     go to close;
	end;
	if card.type ^= "100000101101"b then
	     go to perr;				/* Must be 4055(8). */

	total_len = bin (card.load_address, 18);	/* Total length of this firmware deck. */
	type = "";				/* Type isn't known til end of deck */
	type_offset = total_len - 8;			/* Type should be found in this word */
	ident = "";				/* Ident not known */
	ident_offset = total_len - 10;		/* But will be here */
	pgm_name = substr (objcard, 73, 4);		/* Name of program */
	dev_name = substr (objcard, 43, 6);		/* Name of device or mpc */

/* If selecting special devices or names, test now to see if this program is needed */

	if ^dev_sw then go to chk_name;		/* If no specific devices selected */
	else do dev_index = 1 to dev_cnt;
	     if dev_list (dev_index) = dev_name then go to chk_name;
	end;
	go to flush;				/* Not needed */

chk_name:	if ^name_sw then go to chk_file;		/* If no special names selected */
	else do name_index = 1 to name_cnt;
	     if name_list (name_index) = pgm_name then go to chk_file;
	end;
	go to flush;				/* Not needed */

chk_file:	if ^file_sw then go to passed;		/* If no specific files specified */
	else do file_index = 1 to file_cnt;
	     if file_list (file_index) = fileno then go to passed;
	end;
	go to flush;				/* Failed */

/* Flush the input tape until an eof or the next $object card */

flush:	call gcos_gsr_read_ ("fw_tape", rp, len, ctl, eof, code);
	if code ^= 0 then go to gcos_err;
	if eof then go to got_eof;
	if bin (substr (ctl, 3, 4), 4) ^= 2 then go to flush; /* If not bcd, then it can't be object card */
	call gcos_cv_gebcd_ascii_ (rp, 80, addr (objcard));
	if substr (objcard, 1, 15) = "$      object" then go to got_obj;
	go to flush;

/* Come here if all above tests have been passed succesfully */

passed:


/* Check here for wimmix unit record file and exclude it unless it has been specifically
   requested, or only a list option is being done */

	if load then if index (substr (objcard, 49, 6), "ww") ^= 0 then if ^file_sw then go to flush;

/* Now read binary cards, and if loading, store data in segment */

loop:	call gcos_gsr_read_ ("fw_tape", rp, len, ctl, eof, code);
	if code ^= 0 then go to gcos_err;		/* Read the next card. */
	if eof then go to eoferr;

	if bin (substr (ctl, 3, 4), 4) = 1 then do;	/* If binary card ... */
	     if card.type ^= "010000000101"b then do;	/* Check for legitimate card. */
		call com_err_ (0, lff_name, "Error reading binary card.");
		go to close;
	     end;

	     bcp = addr (card);			/* First control word is here */
	     data_addr = addr (card.data (1));		/* First data is here */
	     total_data = 0;			/* Data transferred so far is 0 */

loop2:	     data_len = bin (bincard.count, 6);		/* Get length */
	     data_offset = bin (bincard.load_address, 18); /* Get address */

	     if load then do;
		data_ptr = addrel (temp_seg_ptr, data_offset); /* Get pointer to data loc */
		data_ptr -> data = data_addr -> data;	/* Copy words */
	     end;


	     call find_word (type_offset, addr (type));	/* Get type if on this card */
	     call find_word (ident_offset, addr (ident)); /* Get ident if on this card */

	     if total_data = 0 then total_data = data_len; /* On first card entry */
	     else total_data = total_data + data_len + 1; /* After first, must account for control word */
	     if total_data >= 18 then go to loop;	/* If it seems card is exhausted */
	     bcp = addr (card.data (total_data+1));	/* Compute next control word address */
	     data_addr = addrel (bcp, 1);		/* And data address if more data */
	     if bincard.type = "010000000101"b then go to loop2; /* If more stuff */
	     else go to loop;			/* If not */
	end;

/* Not a binary card, so this should be the $dkend card */

	else do;					/* Must be BCD card. */
	     call gcos_cv_gebcd_ascii_ (rp, 80, addr (dkecard));
	     if substr (dkecard, 1, 12) ^= "$      dkend" then do;
		call com_err_ (0, lff_name, "Could not find $ DKEND card.");
		go to close;
	     end;

/* If not all firmware types being loaded, check the type now */

	     if substr (type, 4, 3) = "itr" then pgm_type = "i";
	     else if substr (type, 4, 3) = "mdr" then pgm_type = "m";
	     else pgm_type = "a";			/* Must be application firmware */

	     if pgm_type = "m" & load then		/* If dealing with mdr */
		if verify (substr (ident, 5, 2), "0123456789") ^= 0 then /* This is a "before-after" package */
		     if substr (ident, 5, 2) ^= "om" then go to next; /* Ignore it, cause its not for multics */

	     if config_sw then do;			/* Selection is based on config deck */
		if pgm_type = "m" then do;		/* If this is an mdr */
		     if mdr_sw then do i = 1 to mdr_count; /* If mdrs wanted, scan list */
			if dev_name = mdr_name (i) then do; /* Match */
			     mdr_bits (i) = "0"b;
			     go to need_it;
			end;
		     end;
		     go to next;
		end;
		if pgm_type = "a" then do;		/* If application firmware */
		     if appl_sw then do i = 1 to appl_count; /* If application firmware wanted, scan list */
			if pgm_name = appl_name (i) then do;
			     appl_bits (i) = "0"b;
			     go to need_it;
			end;
		     end;
		     go to next;
		end;
		if pgm_type = "i" then do;		/* If itr */
		     if itr_sw then do i = 1 to itr_count; /* If itrs wanted, scan list */
			if dev_name = itr_name (i) then do;
			     itr_bits (i) = "0"b;
			     go to need_it;
			end;
		     end;
		     go to next;
		end;
		go to next;			/* Shouldn't get here */
	     end;

	     if mdr_sw then if pgm_type = "m" then go to need_it;
	     if itr_sw then if pgm_type = "i" then go to need_it;
	     if appl_sw then if pgm_type = "a" then go to need_it;
	     go to next;				/* Don't need it */

need_it:	     if dev_sw then dev_flags (dev_index) = "1"b; /* Record fact that a match was made */
	     if name_sw then name_flags (name_index) = "1"b;
	     if file_sw then file_flags (file_index) = "1"b;

/* Now create the real segment */

	     load_comment = "";
	     if load then do;			/* If loading files ... */
		segname = "fw." || ident || "." || pgm_name;
		do i = 1 to save_cnt;		/* Scan to see if one of these already done */
		     if save_seg.name (i) = segname then do; /* Yes */
			load_comment = "(duplicate)";
			call hcs_$initiate (output_dir, segname, "", 0, 0, segp, code);
			if segp = null then do;
			     call com_err_ (code, lff_name, "Unable to initiate ^a>^a", output_dir, segname);
			     go to close;
			end;
			if unspec (segp -> total_seg) ^= unspec (temp_seg_ptr -> total_seg) then do; /* Not the same */
			     load_comment = "(duplicate, and unequal)";
			     call com_err_ (0, lff_name, "Module ^a from file ^d not the same as version in file ^d.",
				segname, fileno, save_seg.file);
			end;
			go to skip_copy;
		     end;
		end;
		save_cnt = save_cnt + 1;
		save_seg.name (save_cnt) = segname;
		save_seg.file (save_cnt) = fileno;
		call hcs_$make_seg (output_dir, segname, "", 01010b, segp, code);
		if segp = null then do;
		     call com_err_ (code, lff_name, "Unable to create ^a", segname);
		     go to close;
		end;
		segp -> total_seg = temp_seg_ptr -> total_seg; /* And copy it */
		files_loaded = files_loaded + 1;
		call hcs_$set_bc_seg (segp, total_len * 36, code);
		if code ^= 0 then do;
		     call com_err_ (code, lff_name, "Unable to set bit count of ^a", segname);
		     go to close;
		end;
skip_copy:	call hcs_$terminate_noname (segp, code);
		call hcs_$truncate_seg (temp_seg_ptr, 0, code);
		if code ^= 0 then do;
		     call com_err_ (code, lff_name, "Unable to truncate temp segment.");
		     go to close;
		end;
	     end;					/* Terminate the segment. */


/* Record firmware segment in the listing file */

	     if ^header_sw then do;
		header_sw = "1"b;
		call ioa_$ioa_switch (fw_list_ptr, "^v(^|^)^-Contents of Firmware Tape: ^a^2-^a^2/",
		     first_ff, tape_name, time_string);
		first_ff = 1;			/* Form feeds no longer inhibited */
		call ioa_$ioa_switch (fw_list_ptr, "^4-File Number ^d.^v(  (cont'd)^)^2/",
		     fileno, cont_sw);
		cont_sw = 1;			/* Print continued next time */
		call ioa_$ioa_switch (fw_list_ptr, "^-^a^a^/",
		     "P__r_o_g_r_a_m N__u_m_b_e_r      D__e_v_i_c_e    T__y_p_e    I__d_e_n_t",
		     "    N__a_m_e     V__e_r_s_i_o_n  R__e_v._  A__s_s._    D__a_t_e    L__e_n_g_t_h");
		line_cnt = 0;			/* No lines on page yet */
	     end;

	     call ioa_$ioa_switch (fw_list_ptr,
		"^-^18a  ^6a   ^6a   ^6a   ^6a   ^6a    ^2a    ^a    ^2a/^2a/^2a  ^6o  ^a^/",
		substr (objcard, 16, 18), dev_name, type, ident, pgm_name,
		substr (objcard, 49, 6), substr (dkecard, 71, 2), substr (objcard, 60, 1),
		substr (objcard, 67, 2), substr (objcard, 69, 2), substr (objcard, 71, 2),
		total_len, load_comment);
	     line_cnt = line_cnt + 1;			/* Count a line */
	     if line_cnt >= 25 then header_sw = "0"b;	/* Need a new page header */


	     go to next;				/* Go process next segment. */
	end;

/* If special devices were specified, scan the list to be sure all were found */

done:	if dev_sw then do dev_index = 1 to dev_cnt;
	     if ^dev_flags (dev_index) then
		call com_err_ (0, lff_name, "No programs loaded for device ^a.", dev_list (dev_index));
	end;
	if name_sw then do name_index = 1 to name_cnt;
	     if ^name_flags (name_index) then
		call com_err_ (0, lff_name, "No programs loaded with name ^a.", name_list (name_index));
	end;
	if file_sw then do file_index = 1 to file_cnt;
	     if ^file_flags (file_index) then
		call com_err_ (0, lff_name, "No programs loaded from file ^d.", file_list (file_index));
	end;

close:	call clean_up;

	return;



err:	call com_err_ (code, lff_name);		/* Print error message. */

	go to close;				/* Close out everything. */

arg_err:	call com_err_ (code, lff_name, "^a", argument);
	go to close;

/* Procedure to extract word from binary data */

find_word: proc (word_offset, word_ptr);

dcl  word_offset fixed bin;				/* Location in module of required word */
dcl  word_ptr ptr;					/* Pointer to where to store it */
dcl  indx fixed bin;				/* Relative loc if on current card */

	     if word_offset < data_offset then return;	/* Before this card so return */
	     if word_offset >= data_offset + data_len then return; /* After this card, so return */
	     indx = word_offset - data_offset + 1;	/* Relative word of card */
	     if total_data > 0 then indx = indx + total_data + 1; /* Adjustment if not first field on binary card */
	     call gcos_cv_gebcd_ascii_ (addr (card.data (indx)), 6, word_ptr); /* Convert to ascii */
	     return;

	end find_word;

/* This routine is called if -config is specified to determine what is needed by scanning the config deck.
   Three tables are prepared: itr_name contains device names for which itrs are needed,
   appl_name contains names of needed application firmware programs, and mdr_name contains names of devices
   for which mdrs are needed. */

scan_config: proc;

dcl (chan, chan_start, chan_end) fixed bin (6);		/* Channel numbers */
dcl  mpc_ptr ptr;					/* Pointer to mpc card */
dcl  prph_ptr ptr;					/* Pointr to prph card */
dcl  i fixed bin;
dcl  stopper fixed bin (35) based;			/* For checking end of deck */

dcl  config_deck$ ext;				/* The config deck */

dcl 1 mpc aligned based (mpc_ptr),			/* Mpc card */
    2 word char (4),				/* "mpc " */
    2 la (2),					/* A per link adapter table */
      3 iom fixed bin,
      3 chan fixed bin,
      3 nchan fixed bin;

dcl 1 prph aligned based (prph_ptr),			/* Prph card for all but dskx */
    2 word char (4),				/* "prph" */
    2 name char (4),
    2 iom fixed bin,
    2 chan fixed bin,
    2 model fixed bin;

dcl 1 prph_dsk aligned based (prph_ptr),
    2 word char (4),
    2 name char (4),
    2 iom fixed bin,
    2 chan fixed bin,
    2 nchan fixed bin,
    2 model_tab (5),
      3 model fixed bin,
      3 ndrives fixed bin;

dcl  chan_flag (4, 0:63) bit (1) unal;			/* Tells what iom,channel combos are connected to mpc */

	     mdr_count, itr_count, appl_count = 0;	/* Initialize some counters */
	     string (mdr_bits) = "0"b;
	     string (appl_bits) = "0"b;
	     string (itr_bits) = "0"b;


	     do mpc_ptr = addr (config_deck$) repeat (addrel (mpc_ptr, 16)) while (mpc_ptr -> stopper ^= -1);

		if mpc.word = "mpc" then do;		/* Found mpc card */
		     string (chan_flag) = "0"b;
		     do i = 1 to 2 while (mpc.iom (i) ^= -1); /* Build table of all iom/chan combinations */
			chan_start = mpc.chan (i);
			chan_end = chan_start + mpc.nchan (i) - 1;
			do chan = chan_start to chan_end;
			     chan_flag (mpc.iom (i), chan) = "1"b;
			end;
		     end;

/* Now find prph cards for mpc */

		     do prph_ptr = addr (config_deck$) repeat (addrel (prph_ptr, 16)) while (prph_ptr -> stopper ^= -1);
			if prph.word = "prph" then do;
			     if chan_flag (prph.iom, prph.chan) then do;
				if substr (prph.name, 1, 3) ^= "dsk" then
				     call check_dev (prph.name, prph.model);
				else do i = 1 to 6 while (prph_dsk.model (i) ^= -1);
				     if prph_dsk.model (i) ^= 0 then
					call check_dev (prph_dsk.name, prph_dsk.model (i));
				end;
			     end;
			end;
		     end;
		end;
	     end;

	     return;

	end scan_config;


/* This procedure is called at the end of each file to update what has been
   loaded. This eliminates duplicates, and may enable program to stop before the
   end of the tape. */

config_eof: proc;

	     if string (mdr_bits) = "0"b then mdr_count = 0;
	     if string (appl_bits) = "0"b then appl_count = 0;
	     if string (itr_bits) = "0"b then itr_count = 0;

	     if itr_count = 0 & appl_count = 0 & mdr_count = 0 then go to close;

	     do i = 1 to itr_count;			/* Remove all names that have been processed */
		if ^itr_bits (i) then itr_name (i) = "******";
	     end;
	     do i = 1 to mdr_count;
		if ^mdr_bits (i) then mdr_name (i) = "******";
	     end;
	     do i = 1 to appl_count;
		if ^appl_bits (i) then appl_name (i) = "****";
	     end;
	     return;

	end config_eof;

/* This procedure, given a device and model, will decide what firmware is needed */

check_dev: proc (devname, model);

dcl  devname char (4) aligned;			/* Name of device found */
dcl  model fixed bin;				/* Its model number */
dcl  device char (3);				/* This is type of device */

	     device = substr (devname, 1, 3);		/* Type is just start of device name */
	     if device = "rdr" then do;		/* If card reader */
		call store_itr ("urc002");		/* Unit record its */
		call store_appl ("ucmn");		/* Unit record common firmware */
		call store_appl ("ucrp");		/* Reader-punch overlay */
		call store_mdr ("crz301");		/* Reader mdrs */
		call store_mdr ("crdr/p");		/* Reader/Punch mdrs */
	     end;
	     else if device = "pun" then do;		/* If card punch */
		call store_itr ("urc002");		/* Unit record itrs */
		call store_appl ("ucmn");		/* Common unit record firmware */
		call store_appl ("ucrp");		/* Reader-punch overlay */
		call store_mdr ("cpz300");		/* Card punch mdrs */
		call store_mdr ("crdr/p");		/* Reader/Punch mdrs */
		call store_mdr ("cpz301");		/* Because of firmware tape inconsistency */
	     end;
	     else if device = "prt" then do;		/* If printer */
		call store_itr ("urc002");		/* Unit records itrs */
		call store_appl ("ucmn");		/* Unit record common firmware */
		if model = 203 then do;
		     call store_appl ("u203");
		     call store_mdr ("prt203");
		end;
		else if model = 303 then do;
		     call store_appl ("u303");
		     call store_mdr ("prt303");
		end;
		else if model = 401 | model = 402 | model = 1200 | model = 1600 then do;
		     call store_appl ("u400");
		     call store_mdr ("prt401");
		end;
		else go to bad_dev;
	     end;
	     else if device = "tap" then do;		/* If a tape drive */
		if model = 410 then do;
		     call store_itr ("mtc500");
		     call store_appl ("m500");
		     call store_mdr ("mtu410");
		end;
		else if model = 500 | model = 600 then do;
		     call store_itr ("mtc500");
		     call store_appl ("m500");
		     call store_mdr ("mtc500");
		end;
		else if model = 601 then do;
		     call store_itr ("mtp601");
		     call store_appl ("m601");
		     call store_mdr ("mtp601");
		end;
		else if model = 610 then do;
		     call store_itr ("mtp610");
		     call store_appl ("m610");
		     call store_mdr ("mtp601");
		end;
		else go to bad_dev;
	     end;
	     else if device = "dsk" then do;		/* Disk subsystem */
		if model = 181 then do;
		     call store_itr ("dss181");
		     call store_appl ("m181");
		     call store_mdr ("dss181");
		end;
		else if model = 190 then do;
		     call store_itr ("dss190");
		     call store_appl ("m190");
		     call store_mdr ("dss190");
		end;
		else if model = 191 | model = 400 | model = 450 | model = 451 then do;
		     call store_itr ("dss191");
		     call store_appl ("m191");
		     call store_mdr ("dss191");
		     call store_mdr ("ndm450");
		end;
		else if model = 500 then do;
		     call store_itr ("mss500");
		     call store_appl ("d500");
		     call store_mdr ("dsu500");
		end;
		else go to bad_dev;
	     end;
	     else do;
bad_dev:		call com_err_ (0, lff_name, "Device ""^a"" model ""^d"" not known.", devname, model);
	     end;

	     return;

	end check_dev;

/* These procedures store names of itrs, mdrs, and applications firmware to be loaded */

store_itr: proc (name);

dcl  name char (6);
dcl  i fixed bin;

	     do i = 1 to itr_count;
		if itr_name (i) = name then return;
	     end;
	     itr_count = itr_count+1;
	     itr_name (itr_count) = name;
	     itr_bits (itr_count) = "1"b;
	     return;

	end store_itr;

store_appl: proc (name);

dcl  name char (4);
dcl  i fixed bin;

	     do i = 1 to appl_count;
		if appl_name (i) = name then return;
	     end;
	     appl_count = appl_count+1;
	     appl_name (appl_count) = name;
	     appl_bits (appl_count) = "1"b;
	     return;

	end store_appl;

store_mdr: proc (name);

dcl  name char (6);
dcl  i fixed bin;

	     do i = 1 to mdr_count;
		if mdr_name (i) = name then return;
	     end;
	     mdr_count = mdr_count+1;
	     mdr_name (mdr_count) = name;
	     mdr_bits (mdr_count) = "1"b;
	     return;

	end store_mdr;

/* Clean up handler for when command terminates */

clean_up:	proc;

	     if ptr_array (1) ^= null then call release_temp_segments_ (lff_name, ptr_array, code);

	     if fw_list_open then do;			/* If listing file was opened */
		fw_list_open = "0"b;
		call iox_$close (fw_list_ptr, code);
		if code ^= 0 then call clean_up_err;
	     end;

	     if fw_list_attach then do;		/* If listing file attached */
		fw_list_attach = "0"b;
		call iox_$detach_iocb (fw_list_ptr, code);
		if code ^= 0 then call clean_up_err;
	     end;

	     if gcos_init then do;			/* If gcos routine was inited */
		gcos_init = "0"b;
		call gcos_gsr_read_$gsr_read_close ("fw_tape", code);
		if code ^= 0 then do;
		     if code ^= error_table_$file_not_opened then call clean_up_err;
		end;
	     end;

	     if tape_attach then do;			/* If tape was attached */
		tape_attach = "0"b;
		call ios_$detach ("fw_tape", "", "", iostatus);
		unspec (code) = substr (iostatus, 1, 36);
		if code ^= 0 then call clean_up_err;
	     end;

	     if load then if files_loaded > 0 then
		     call ioa_ ("^a: ^d firmware segment^v(s^) created.",
		     lff_name, files_loaded, bin (files_loaded ^= 1, 1));


	end clean_up;


clean_up_err: proc;

	     call com_err_ (code, lff_name);
	     return;

	end clean_up_err;



     end load_firmware_file;


*/
                                          -----------------------------------------------------------


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

*/