



		    bce_alert.pl1                   11/11/89  1134.3r w 11/11/89  0826.1       17811



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_alert: proc (p_ss_info_ptr);

/* Write a message with alert on the operators console.
Keith Loepere, January 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  addr			        builtin;
dcl  arg			        char (arg_len) based (arg_ptr);
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_num		        fixed bin;
dcl  arg_ptr		        ptr;
dcl  bce_data$console_alert_put_chars entry (ptr, ptr, fixed bin, fixed bin (35)) ext variable;
dcl  code			        fixed bin (35);
dcl  cu_$arg_count_rel	        entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  message		        char (256);
dcl  message_len		        fixed bin;
dcl  p_ss_info_ptr		        ptr parameter;
dcl  substr		        builtin;

	ss_info_ptr = p_ss_info_ptr;
	message_len = 0;
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code = 0 then do arg_num = 1 to arg_count;
	     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     substr (message, message_len + 1, arg_len) = arg;
	     substr (message, message_len + arg_len + 1, 1) = " ";
	     message_len = message_len + arg_len + 1;
	end;
	message_len = message_len + 1;
	substr (message, message_len, 1) = "
";
	call bce_data$console_alert_put_chars (addr (bce_data$console_alert_put_chars), addr (message), message_len, code);
	return;
%page; %include bce_subsystem_info_;
     end;




		    bce_appending_simulation.pl1    11/11/89  1134.3r w 11/11/89  0826.1      204669



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


/****^  HISTORY COMMENTS:
  1) change(86-01-14,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-12,Farley), install(86-07-17,MR12.0-1097):
     Changed to add Subvolume support.
                                                   END HISTORY COMMENTS */


bce_appending_simulation: proc;

/* Routine to access segments in the saved Multics memory image.
   Written October 1983 and beyond by Keith Loepere.
   Modified to better handle a few unusual occurences by Allen Ball, July 1984.
   Modified to correctly set cmep, Keith Loepere, November 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

dcl  Read				bit (1) aligned static options (constant) init ("1"b);
dcl  Write			bit (1) aligned static options (constant) init ("0"b);
dcl  abs_seg0$			(0:256 * 1024 - 1) bit (36) aligned ext;
dcl  abs_seg_pt			(0:255) bit (36) aligned based (static.abs_seg_ptp);
dcl  abs_seg_pt_addr		fixed bin (26);	/* address of page table for abs_seg0 */
dcl  absadr			entry (ptr, fixed bin (35)) returns (fixed bin (26));
dcl  addr				builtin;
dcl  address			fixed bin (26);	/* absolute address to get */
dcl  addwordno			builtin;
dcl  bin				builtin;
dcl  code				fixed bin (35) parameter;
dcl  core_map$			external;
dcl  core_map_ptw			bit (36) aligned;	/* for finding its absadr */
dcl  core_map_sdw			fixed bin (71);	/* for finding its absadr */
dcl  core_map_segnum		fixed bin (15);	/* for getting its absadr */
dcl  data_length			fixed bin (18);	/* amount left to get/put */
dcl  data_part			(data_part_length) bit (36) aligned based (data_ptr);
dcl  data_part_length		fixed bin (18);	/* of desired that fits (in page) under examination */
dcl  data_ptr			ptr;		/* where to get/put */
dcl  dbr_util_$dissect		entry (ptr, ptr);
dcl  dbr_value			bit (72) aligned parameter; /* descriptor base register value for simulation */
dcl  desired_segnum			fixed bin (15) parameter;
dcl  divide			builtin;
dcl  dseg$			(0:511) fixed bin (71) ext;
dcl  dseg_page_address		fixed bin (26);	/* for finding dseg sdw */
dcl  dseg_sdw			fixed bin (71);
dcl  error_table_$argerr		fixed bin (35) ext static;
dcl  error_table_$boundviol		fixed bin (35) ext static;
dcl  error_table_$dev_offset_out_of_bounds fixed bin (35) ext static;
dcl  error_table_$fsdisk_pvtx_oob	fixed bin (35) ext static;
dcl  error_table_$fsdisk_phydev_err	fixed bin (35) ext static;
dcl  error_table_$invalidsegno	fixed bin (35) ext static;
dcl  get_ptrs_$given_segno		entry (fixed bin (15)) returns (ptr);
dcl  int_unpaged_page_tables$		external;
dcl  min				builtin;
dcl  mod				builtin;
dcl  multics_data_ptr		ptr;
dcl  multics_high_mem$		(0:256 * 1024 - 1) bit (36) aligned ext;
dcl  multics_low_mem$		(0:256 * 1024 - 1) bit (36) aligned ext;
dcl  1 my_cme			aligned like cme;
dcl  my_dbr			bit (72) aligned;	/* either mine, or from crash */
dcl  1 my_dbr_info			aligned like dbr_info;
dcl  1 my_ptw_info			aligned like ptw_info;
dcl  1 my_sdw_info			aligned like sdw_info;
dcl  op_not_complete		condition;
dcl  parity			condition;
dcl  p_address			fixed bin (26) parameter; /* absolute address desired */
dcl  p_data_length			fixed bin (18) parameter; /* length desired */
dcl  p_data_ptr			ptr parameter;	/* user's area */
dcl  p_examine_crash		bit (1) aligned parameter; /* as opposed to bce */
dcl  p_last_segnum			fixed bin (15) parameter;
dcl  p_seg_info_ptr			ptr parameter;
dcl  p_seg_sdw			fixed bin (71) parameter;
dcl  page_fault_error		condition;
dcl  page_num			fixed bin;	/* loop counter */
dcl  page_offset			fixed bin (10);	/* start of desired data in this page */
dcl  pc$cleanup			entry (ptr);
dcl  pc_wired$write_wait		entry (ptr, fixed bin, fixed bin);
dcl  pmut$camp			entry;
dcl  ptr				builtin;
dcl  ptw_util_$dissect		entry (ptr, ptr);
dcl  ptw_util_$make_core		entry (ptr, fixed bin (26));
dcl  ptw_util_$make_disk		entry (ptr, fixed bin (20));
dcl  ptw_util_$make_null_disk		entry (ptr, fixed bin (20));
dcl  ptw_util_$reset_phm		entry (ptr);
dcl  ptw_util_$set_phm		entry (ptr);
dcl  pvt$root_pvtx			fixed bin external;
dcl  rdisk_seg$			external;		/* for reading/writing disk pages */
dcl  read_write			bit (1) aligned;	/* get versus put operation */
dcl  sdw_util_$dissect		entry (ptr, ptr);
dcl  sdw_util_$get_address		entry (ptr, fixed bin (26));
dcl  seg_sdw			fixed bin (71);	/* describe new segment */
dcl  segno			builtin;
dcl  1 static			aligned internal static, /* things remembered about current simulation */
       2 abs_seg_ptp		ptr,		/* page table ptr for abs_seg0 */
       2 core_map_address		fixed bin (26),	/* for finding cme entries */
       2 core_map_present		bit (1) aligned,	/* coremap exists to resolve out-of-service pages */
       2 current_abs_seg_addr		fixed bin (26) init (-256 * 1024), /* current absolute address of pages described by abs_seg0
						initial value is such as to be not confused with a good abs-seg addr */
       2 dseg_info			aligned like seg_info,
       2 examine_crash		bit (1) aligned,	/* as opposed to bce memory */
       2 high_mem_astep		ptr,		/* astep for multics_high_mem */
       2 last_segnum		fixed bin (15) init (-1), /* highest valid segno for this dbr */
       2 low_mem_astep		ptr,		/* astep for multics_low_mem */
       2 rdisk_astep		ptr,		/* for reading page of arbitrary disk */
       2 rdisk_ptp			ptr,		/* to ptw for rdisk_seg */
       2 rdisk_ptr			ptr,		/* to seg for reading arbitrary disk pages */
       2 toehold_addr		fixed bin (26),	/* absadr of toehold */
       2 toehold_data_addr		fixed bin (26);	/* absadr of toehold_data (holder of first two pages of low mem) */
dcl  size				builtin;
dcl  store			condition;
dcl  substr			builtin;
dcl  sys_boot_info$bce_dbr		bit (72) aligned external;
dcl  1 toehold$			external aligned like toe_hold;
dcl  toehold_data$			external;
dcl  unspec			builtin;
%page;
init: entry (p_examine_crash, code);

/* Initialize various static variables. */

	code = 0;
	static.examine_crash = p_examine_crash;
	call sdw_util_$get_address (addr (dseg$ (segno (addr (abs_seg0$)))), abs_seg_pt_addr);
	static.abs_seg_ptp = ptr (addr (int_unpaged_page_tables$), abs_seg_pt_addr - absadr (addr (int_unpaged_page_tables$), (0)));
	static.toehold_data_addr = absadr (addr (toehold_data$), (0));
	static.toehold_addr = absadr (addr (toehold$), (0));

	static.low_mem_astep = get_ptrs_$given_segno (segno (addr (multics_low_mem$)));
	static.high_mem_astep = get_ptrs_$given_segno (segno (addr (multics_high_mem$)));

	static.rdisk_ptr = addr (rdisk_seg$);
	static.rdisk_astep = get_ptrs_$given_segno (segno (static.rdisk_ptr));
	static.rdisk_ptp = addwordno (static.rdisk_astep, size (aste));
	static.rdisk_astep -> aste.pvtx = pvt$root_pvtx;	/* good initial state */
	call ptw_util_$make_disk (static.rdisk_ptp, 0);

	static.current_abs_seg_addr = -256 * 1024;
	if static.examine_crash then my_dbr = toehold$.multics_state.dbr; /* assume dbr from mc */
	else my_dbr = sys_boot_info$bce_dbr;
	call new_dbr (my_dbr, (0), code);

abort:	return;
%page;
new_dbr: entry (dbr_value, p_last_segnum, code);

/* Supply a new dseg for the simulation. */

	code = 0;
	dbr_info_ptr = addr (my_dbr_info);
	sdw_info_ptr = addr (my_sdw_info);
	ptw_info_ptr = addr (my_ptw_info);

	on page_fault_error call page_error;

/* Examine the new dbr. */

	call dbr_util_$dissect (addr (dbr_value), dbr_info_ptr);
	static.last_segnum, p_last_segnum = divide (dbr_info.bound, 2, 15) - 1;
	static.dseg_info.sdwi.paged = dbr_info.paged;
	static.dseg_info.sdwi.address = dbr_info.address;

/* Get the sdw & page table for dseg. */

	if static.dseg_info.sdwi.paged then do;
	     call get_absolute (static.dseg_info.sdwi.address - size (aste), size (aste) + divide (dbr_info.bound + 1023, 1024, 8), addr (static.dseg_info.sst_data), code);
	     if code ^= 0 then return;
	     call ptw_util_$dissect (addr (static.dseg_info.page_table (0)), ptw_info_ptr);
	     call get_absolute (ptw_info.address, 2, addr (dseg_sdw), code);
	     if code ^= 0 then return;
	end;
	else do;
	     call get_absolute (static.dseg_info.sdwi.address, 2, addr (dseg_sdw), code);
	     if code ^= 0 then return;
	end;
	call sdw_util_$dissect (addr (dseg_sdw), addr (static.dseg_info.sdwi));

/* Find the core_map, if present, which is needed to resolve pages that were
out of service for io. */

	static.core_map_present = "0"b;
	if segno (addr (core_map$)) <= p_last_segnum then do;
	     core_map_segnum = segno (addr (core_map$));	/* in first dseg page - known to be in memory */
	     if static.dseg_info.sdwi.paged then dseg_page_address = ptw_info.address;
	     else dseg_page_address = static.dseg_info.sdwi.address;
	     call get_absolute (dseg_page_address + 2 * core_map_segnum, 1, addr (core_map_sdw), code);
	     if code ^= 0 then return;
	     call sdw_util_$dissect (addr (core_map_sdw), sdw_info_ptr);
	     if sdw_info.paged then do;
		call get_absolute (sdw_info.address, 1, addr (core_map_ptw), code);
		if code ^= 0 then return;
		call ptw_util_$dissect (addr (core_map_ptw), ptw_info_ptr);
		static.core_map_address = ptw_info.address;
	     end;
	     else static.core_map_address = sdw_info.address;
	     static.core_map_present = static.core_map_address ^= 0;
	end;
	return;
%page;
get_absolute: entry (p_address, p_data_length, p_data_ptr, code);

	read_write = Read;
	go to absolute;

put_absolute: entry (p_address, p_data_length, p_data_ptr, code);

	read_write = Write;

absolute:

/* Get or put a range of memory given an absolute address. 
We access Multics memory through one of three segments.  The segment 
multics_low_mem maps onto the first 256k of memory (saved to disk).  (Actually,
pages 0 and 1 of this memory are actually in toehold_data within this segment.)
multics_high_mem is the next 256k.  The abs-seg abs_seg0 is mapped onto the nth
256k;  its page table is changed as needed.  We do all of this one page at a
time, backwards, to provide better disk latency. */

	code = 0;
	on page_fault_error call page_error;
	on parity call mem_error;
	on store call mem_error;
	on op_not_complete call mem_error;

	data_length = p_data_length;

/* We march the address we desire downwards, by at most a page at a time. */

	do while (data_length > 0);

/* Find amount of data in this page. */

	     data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */
	     if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */
	     else do;				/* data within a page */
		address = p_address;
		data_part_length = data_length;
	     end;
	     page_num = divide (address, 1024, 16);

	     data_ptr = addwordno (p_data_ptr, address - p_address);

	     if ^static.examine_crash | (address >= (512 * 1024)) then
		if (static.current_abs_seg_addr <= address) & (address < (static.current_abs_seg_addr + 256 * 1024)) then do; /* memory extent we already have mapped */
		     multics_data_ptr = ptr (addr (abs_seg0$), address - static.current_abs_seg_addr);
		     if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		     else multics_data_ptr -> data_part = data_ptr -> data_part;
		end;
		else do;				/* we must re-map abs_seg0$ */
		     static.current_abs_seg_addr = divide (address, 256 * 1024, 8) * 256 * 1024;
		     do page_num = 0 to 255;
			call ptw_util_$make_core (addr (abs_seg_pt (page_num)), static.current_abs_seg_addr + page_num * 1024);
		     end;
		     call pmut$camp;
		     multics_data_ptr = ptr (addr (abs_seg0$), address - static.current_abs_seg_addr);
		     if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		     else multics_data_ptr -> data_part = data_ptr -> data_part;
		end;
	     else if address >= 256 * 1024 then do;	/* Must be low memory of crash image to examine */
		multics_data_ptr = ptr (addr (multics_high_mem$), address - 256 * 1024);
		if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		else do;
		     multics_data_ptr -> data_part = data_ptr -> data_part;
		     call pc_wired$write_wait (static.high_mem_astep, page_num - 256, 1);
		end;
	     end;
	     else if address >= static.toehold_addr + 2048 then do;
		multics_data_ptr = ptr (addr (multics_low_mem$), address);
		if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		else do;
		     multics_data_ptr -> data_part = data_ptr -> data_part;
		     call pc_wired$write_wait (static.low_mem_astep, page_num, 1);
		end;
	     end;
	     else if address >= static.toehold_addr then do; /* toehold stays in memory */
		multics_data_ptr = ptr (addr (toehold$), address - static.toehold_addr);
		if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		else multics_data_ptr -> data_part = data_ptr -> data_part;
	     end;
	     else if address >= 2 * 1024 then do;	/* below toehold */
		multics_data_ptr = ptr (addr (multics_low_mem$), address);
		if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		else do;
		     multics_data_ptr -> data_part = data_ptr -> data_part;
		     call pc_wired$write_wait (static.low_mem_astep, page_num, 1);
		end;
	     end;
	     else do;				/* page is in toehold_data area of saved memory */
		multics_data_ptr = ptr (addr (multics_low_mem$), static.toehold_data_addr + address);
		if read_write = Read then data_ptr -> data_part = multics_data_ptr -> data_part;
		else do;
		     multics_data_ptr -> data_part = data_ptr -> data_part;
		     call pc_wired$write_wait (static.low_mem_astep, divide (static.toehold_data_addr, 1024, 16) + page_num, 1);
		end;
	     end;
	     data_length = data_length - data_part_length;
	end;
	return;
%page;
new_segment: entry (desired_segnum, p_seg_info_ptr, code);

/* This entry specifies what segment future calls to put/get_virtual will
reference.  The virtual operations are broken apart into this routine (which
specifies the segment number portion of an address) and the get/put_virtual 
entries which supply the word number.  This is done for efficiency. */

	code = 0;
	seg_info_ptr = p_seg_info_ptr;
	on page_fault_error call page_error;

	if desired_segnum > static.last_segnum then do;
	     code = error_table_$invalidsegno;
	     go to bad_segment;
	end;

/*  We will get the user's new segment's sdw and page table.  We use virtual
to get the seg's sdw. */

	call get_virtual (addr (static.dseg_info), desired_segnum * 2, 2, addr (seg_sdw), code);
	if code ^= 0 then go to bad_segment;
	go to new_sdw_join;

new_sdw: entry (p_seg_sdw, p_seg_info_ptr, code);

	code = 0;
	seg_sdw = p_seg_sdw;
	seg_info_ptr = p_seg_info_ptr;
	on page_fault_error call page_error;

new_sdw_join:
	call sdw_util_$dissect (addr (seg_sdw), addr (seg_info.sdwi));
	if seg_info.sdwi.faulted then do;
	     code = error_table_$invalidsegno;
	     go to bad_segment;
	end;
	if seg_info.sdwi.paged then do;		/* Get the seg's aste/page table */
	     call get_absolute (seg_info.sdwi.address - size (aste), size (aste) + divide (seg_info.sdwi.size + 1023, 1024, 8), addr (seg_info.sst_data), code);
	     if code ^= 0 then do;			/* It could just be that the page table is in good memory and has no aste in front of it, but... */
		seg_info.sdwi.faulted = "1"b;
bad_segment:	return;
	     end;
	end;
	return;
%page;
get_virtual: entry (p_seg_info_ptr, p_address, p_data_length, p_data_ptr, code);

	read_write = Read;
	go to virtual;

put_virtual: entry (p_seg_info_ptr, p_address, p_data_length, p_data_ptr, code);

	read_write = Write;

virtual:

/* Fetch a given set of words from the current segment. */

	code = 0;
	seg_info_ptr = p_seg_info_ptr;
	on page_fault_error call page_error;

	ptw_info_ptr = addr (my_ptw_info);
	data_length = p_data_length;
	if p_address + data_length > seg_info.sdwi.size then do;
	     data_part_length = min (data_length, p_address + data_length - seg_info.sdwi.size);
	     data_ptr = addwordno (p_data_ptr, data_length - data_part_length);
	     unspec (data_ptr -> data_part) = "0"b;
	     code = error_table_$boundviol;
	     data_length = data_length - data_part_length;
	end;
	if seg_info.sdwi.paged then do;
	     do while (data_length > 0);
		data_part_length = mod (p_address + data_length - 1, 1024) + 1; /* amount from start of page to last word */
		if data_part_length <= data_length then address = p_address + data_length - data_part_length; /* data crosses into this page */
		else do;				/* data within a page */
		     address = p_address;
		     data_part_length = data_length;
		end;
		data_ptr = addwordno (p_data_ptr, address - p_address);
		page_num = divide (address, 1024, 8);
		page_offset = mod (address, 1024);

/* Find the appropriate page.  Move the amount found in that page to the
user's area. */

		if page_num < 0 | page_num > 255 then go to bad_page;
		call ptw_util_$dissect (addr (seg_info.page_table (page_num)), ptw_info_ptr);
		if ptw_info.valid then		/* properly in memory */
		     if read_write = Read then call get_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code);
		     else do;
			call put_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code);
			if ^ptw_info.phm then do;	/* must update phm in ptw */
			     call ptw_util_$set_phm (addr (seg_info.page_table (page_num)));
			     call put_absolute (seg_info.sdwi.address + page_num, 1, addr (seg_info.page_table (page_num)), code);
			end;
		     end;
		else if ptw_info.add_type = add_type.disk then do;
		     if ptw_info.null_disk then
			if read_write = Read then go to zero_page;
			else go to bad_page;
		     else if read_write = Read then do;
			call map_for_read ((ptw_info.address), code);
			if code = 0 then do;
			     data_ptr -> data_part = addwordno (static.rdisk_ptr, page_offset) -> data_part;
			     call pc$cleanup (static.rdisk_astep);
			end;
			else go to bad_page;
		     end;
		     else do;
			call map_for_update ((ptw_info.address), code);
			if code = 0 then do;
			     addwordno (static.rdisk_ptr, page_offset) -> data_part = data_ptr -> data_part;
			     call pc$cleanup (static.rdisk_astep);
			end;
			else go to bad_page;
		     end;
		end;
		else if ptw_info.add_type = add_type.core then do;
		     if ^ptw_info.os then go to bad_page;
		     if ^static.core_map_present then go to bad_page;

/* find core map entry */

		     cmep = addr (my_cme);
		     call get_absolute (static.core_map_address + 8 + size (cme) * divide (ptw_info.address, 1024, 16), size (cme), cmep, code);
		     if code ^= 0 then go to bad_page;
		     if substr (cme.devadd, 19, 4) ^= add_type.disk then go to bad_page;
		     if substr (cme.devadd, 1, 1) then go to bad_page;
		     if read_write = Read then do;
			if cme.io then call get_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code); /* page was being written -> memory good */
			else do;			/* reading -> disk is better */
			     call map_for_read (bin (substr (cme.devadd, 1, 18), 18), code);
			     if code = 0 then do;
				data_ptr -> data_part = addwordno (static.rdisk_ptr, page_offset) -> data_part;
				call pc$cleanup (static.rdisk_astep);
			     end;
			     else go to bad_page;
			end;
		     end;
		     else do;
			if cme.io then do;		/* was being written - memory is best */
			     call put_absolute (ptw_info.address + page_offset, data_part_length, data_ptr, code); /* page was being written -> memory good */
			     call map_for_write (bin (substr (cme.devadd, 1, 18), 18), code); /* save on disk */
			     if code = 0 then do;
				call get_absolute (ptw_info.address, 1024, static.rdisk_ptr, code);
				call pc$cleanup (static.rdisk_astep);
			     end;
			     else go to bad_page;
			end;
			else do;			/* reading -> disk is better */
			     call map_for_update (bin (substr (cme.devadd, 1, 18), 18), code);
			     if code = 0 then do;
				addwordno (static.rdisk_ptr, page_offset) -> data_part = data_ptr -> data_part;
				call put_absolute (ptw_info.address, 1024, static.rdisk_ptr, code);
				call pc$cleanup (static.rdisk_astep);
			     end;
			     else go to bad_page;
			end;
		     end;
		end;
		else do;
bad_page:		     if code = 0 then code = error_table_$argerr;
zero_page:	     if read_write = Read then unspec (data_ptr -> data_part) = "0"b;
		end;
		data_length = data_length - data_part_length;
	     end;
	end;
	else do;					/* in memory (unpaged) */
	     address = seg_info.sdwi.address + p_address;
	     if read_write = Read then call get_absolute (address, p_data_length, p_data_ptr, code);
	     else call put_absolute (address, p_data_length, p_data_ptr, code);
	end;
	return;
%page;
map_for_read: proc (record_num, code);

/* Map rdisk_seg onto the desired page.  This routine is actually a
streamlined version of read_disk for this purpose and uses the nice rdisk_seg
aste built by read_disk. */

dcl  code				fixed bin (35) parameter;
dcl  record_num			fixed bin (20) parameter;
dcl  write_op			bit (1) aligned;

map_for_update: entry (record_num, code);

	write_op = "0"b;
	go to map;

map_for_write: entry (record_num, code);		/* previous contents don't matter */

	write_op = "1"b;

map:	pvtp = addr (pvt$);
	code = 0;
	if seg_info.sst_data.pvtx < 1 | seg_info.sst_data.pvtx > pvt.n_entries then do;
	     code = error_table_$fsdisk_pvtx_oob;
	     return;
	end;

	pvtep = addr (addr (pvt.array) -> pvt_array (seg_info.sst_data.pvtx));
	if record_num < 0 | record_num >= rec_per_sv (pvte.device_type) then do;
	     code = error_table_$dev_offset_out_of_bounds;
	     return;
	end;

	static.rdisk_astep -> aste.pvtx = seg_info.sst_data.pvtx;
	static.rdisk_astep -> aste.npfs = "0"b;

	if write_op then call ptw_util_$make_null_disk (static.rdisk_ptp, record_num);
	else call ptw_util_$make_disk (static.rdisk_ptp, record_num);
	return;
     end;

page_error: proc;

/* Abort rdisk activity, return error code. */

	call ptw_util_$reset_phm (static.rdisk_ptp);	/* don't let pc try to write */
	call pc$cleanup (static.rdisk_astep);

mem_error: entry;

	code = error_table_$fsdisk_phydev_err;
	go to abort;
     end;
%page; %include add_type;
%page; %include bce_appending_seg_info;
%page; %include cmp;
%page; %include dbr_info;
%page; %include fs_dev_types;
%page; %include ptw_info;
%page; %include pvt;
%page; %include pvte;
%page; %include toe_hold;
     end;




		    bce_copy_disk.pl1               11/11/89  1134.3r w 11/11/89  0826.1      159345



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

/****^  HISTORY COMMENTS:
  1) change(86-01-17,Fawcett), approve(86-01-17,MCR7220),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Created by Keith Loepere March 1985 to copy a disk pack to another disk
     pack.
  2) change(86-01-17,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Changed to support subvolumes by adding call to disk_name_pvtx.
                                                   END HISTORY COMMENTS */

bce_copy_disk: proc (p_ss_info_ptr);

/* Routine to copy a disk pack to another disk pack.
Written in March 1985 by Keith Loepere. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

/* Parameters */

dcl  p_ss_info_ptr			ptr parameter;

/* Variables */

dcl  arg_count			fixed bin;
dcl  arg_len			fixed bin (21);
dcl  arg_list_ptr			ptr;
dcl  arg_num			fixed bin;
dcl  arg_ptr			ptr;
dcl  buffer_address			fixed bin (26);
dcl  buffer_num			fixed bin;
dcl  buffer_ptr			(2) ptr;
dcl  buffer_to_read			(9) fixed bin;	/* buffer number to read in at given state */
dcl  buffer_to_write		(9) fixed bin;	/* buffer number to write out at given state */
dcl  buffer_waiting_for		(9) fixed bin;	/* buffer whose completion we are waiting for */
dcl  code				fixed bin (35);
dcl  device_type			fixed bin;
dcl  end_state			(9) fixed bin;	/* state to enter when the last read has completed */
dcl  f_record			fixed bin (18);
dcl  force			bit (1) aligned;	/* don't ask questions */
dcl  from_devname			char (8);
dcl  from_pvtx			fixed bin;
dcl  l_record			fixed bin (18);
dcl  1 my_label			aligned like label;
dcl  max_io_pages			fixed bin;	/* max pages to handle at a time - normally 3,
						but is temp set to 1 for error recovery */
dcl  normal_state			(9) fixed bin;	/* state to enter after a read/write completes */
dcl  1 record_info			aligned,
       2 read			aligned,
         3 new_record		fixed bin (18),
         3 prev_record		fixed bin (18),
         3 prev_record_in_cylinder	fixed bin,
         3 records_this_cylinder	fixed bin,
       2 buffer			(2) aligned like record_info.read;
dcl  state			fixed bin;
dcl  temp_astep			ptr;
dcl  temp_seg_ptr			ptr;
dcl  to_devname			char (8);
dcl  to_is_Multics			bit (1) aligned;
dcl  to_pvtx			fixed bin;
dcl  waiting_for_read		(9) bit (1) aligned;/* are we waiting for a read to complete? */
dcl  working_buffer			fixed bin;
dcl  yes_no			bit (1) aligned;

/* Constants */

/* State names */

dcl  E1R2				fixed bin init (5) static options (constant);
dcl  E1W2				fixed bin init (8) static options (constant);
dcl  Me				char (32) static options (constant) init ("copy_disk");
dcl  R1E2				fixed bin init (1) static options (constant);
dcl  R1W2				fixed bin init (7) static options (constant);
dcl  START			fixed bin init (9) static options (constant);
dcl  W1E2				fixed bin init (4) static options (constant);
dcl  W1R2				fixed bin init (3) static options (constant);

/* External */

dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  error_table_$not_done		fixed bin (35) ext static;

/* Based */

dcl  arg				char (arg_len) based (arg_ptr);

/* Entries */

dcl  absadr			entry (ptr, fixed bin (35)) returns (fixed bin (24));
dcl  bce_check_abort		entry;
dcl  disk_name_pvtx			entry (char (8), fixed bin, fixed bin (35));
dcl  bce_parse_disk_spec		entry (char (32), ptr, fixed bin, fixed bin, ptr, fixed bin (18), fixed bin (18), entry (ptr, fixed bin, ptr, fixed bin (35)), ptr, fixed bin (35));
dcl  bootload_disk_io$queue_read	entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin, fixed bin (35));
dcl  bootload_disk_io$queue_write	entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin, fixed bin (35));
dcl  bootload_disk_io$test_done	entry (fixed bin, fixed bin (35));
dcl  bce_query$yes_no		entry options (variable);
dcl  com_err_			entry () options (variable);
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  get_ptrs_$given_segno		entry (fixed bin (15)) returns (ptr);
dcl  get_temp_segment_		entry (char (*), ptr, fixed bin (35));
dcl  ioa_				entry () options (variable);
dcl  pc_abs$unwire_abs		entry (ptr, fixed bin, fixed bin);
dcl  pc_abs$wire_abs_contig		entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  read_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  release_temp_segment_		entry (char (*), ptr, fixed bin (35));

/* Misc */

dcl  (addr, addrel, max, min, mod, null, segno) builtin;

dcl  cleanup			condition;
%page;
	arg_list_ptr = p_ss_info_ptr -> ss_info.arg_list_ptr;
	pvtp = addr (pvt$);
	pvt_arrayp = addr (pvt.array);
	labelp = addr (my_label);

	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me);
	     return;
	end;
	if arg_count < 2 then do;
	     call ioa_ ("Usage:^/  ^a <device> <device> (<arg1> <arg2> ...)", Me);
	     return;
	end;

	arg_num = 2;
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Can't get arg");
	     return;
	end;
	to_devname = arg;

	call disk_name_pvtx (to_devname, to_pvtx, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a", arg);
	     go to RETURN;
	end;

	call read_disk (to_pvtx, (LABEL_ADDR), labelp, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Could not read label record of ^a.", to_devname);
	     return;
	end;
	to_is_Multics = (label.Multics = Multics_ID_String);

	arg_num = 1;
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Can't get arg");
	     return;
	end;
	from_devname = arg;

	call disk_name_pvtx (from_devname, from_pvtx, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a", arg);
	     go to RETURN;
	end;

	call read_disk (from_pvtx, (LABEL_ADDR), labelp, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Could not read label record of ^a.", from_devname);
	     return;
	end;

	device_type = pvt_array (from_pvtx).device_type;
	if pvt_array (to_pvtx).device_type ^= device_type then do;
	     call com_err_ (0, Me, "^a is not the same type as ^a.", from_devname, to_devname);
	     return;
	end;
	if from_pvtx = to_pvtx then do;
	     call com_err_ (0, Me, "^a is the same disk as ^a.", from_devname, to_devname);
	     return;
	end;

	force = "0"b;
	arg_num = 3;
	call bce_parse_disk_spec (Me, arg_list_ptr, arg_num, device_type, labelp, f_record, l_record, no_parse, null, code);
	if code ^= 0 then return;

/* Now that f_record and l_record are assigned we will give them their chance to turn back. */

	if f_record = l_record then call ioa_ ("Writing to record number ^oo on ^a.", f_record, to_devname);
	else call ioa_ ("Writing to records ^oo through ^oo (inclusive) on ^a.", f_record, l_record, to_devname);
	if ^force then do;
	     call bce_query$yes_no (yes_no, "Do you wish to write to the ^[non ^;^]^a - ^a? ",
		^to_is_Multics, Multics_ID_String, to_devname);
	     if ^yes_no then return;
	end;
%page;

/* Find work area */

	temp_seg_ptr = null;
	call get_temp_segment_ (Me, temp_seg_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Unable to get temp disk buffer.");
	     return;
	end;

	buffer_ptr (1) = temp_seg_ptr;
	buffer_ptr (2) = addrel (temp_seg_ptr, 3 * 1024);
	temp_astep = get_ptrs_$given_segno (segno (temp_seg_ptr));
	call pc_abs$wire_abs_contig (temp_astep, 0, 6, code); /* double buffer of three pages */
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Unable to wire temp disk buffer.");
	     call release_temp_segment_ (Me, temp_seg_ptr, code);
	     return;
	end;

	buffer_address = absadr (temp_seg_ptr, code);
	disk_post_area_ptr = addr (bootload_disk_post_seg$);
	disk_post_area.number = 2;

	disk_post_area.buffer_coreadd (1) = buffer_address;
	disk_post_area.buffer_coreadd (2) = buffer_address + 3 * 1024;
	disk_post_area.disk_complete (1) = "0"b;
	disk_post_area.disk_complete (2) = "0"b;
	disk_post_area.disk_error_code (1) = 0;
	disk_post_area.disk_error_code (2) = 0;

	on cleanup call clean_up;			/* remember, this is only called during bce_check_abort */
%page;

/* Now for the real work.  The basic flow of this program is to keep reading
pages from the from_pvtx and write them to the to_pvtx, using relatively
standard double buffering techniques.  This process is done backwards, and
(normally) three pages at a time, to minimize latency between i/o's, to
maximize the time we have between i/o's to get our next request in, within the
constraints that bootload_disk_io can handle a maximum of 4 pages at a time.
Three pages is optimal both for 451 and 501 style drives.  However, we don't
want to read/write a set of pages that cross a cylinder boundary, so we check
for this.  As such, a set may contain less than 3 pages.  Also, in case of
error (explained below), only one page is read/written so the bad pages may be
found.

So that the program does not become overly complicated via code, it is 
expressed as a finite state machine.  The idea is to start in a state where
both buffers are doing nothing, move to a state where buffer 1 is reading and
in which we are waiting for buffer 1's i/o to complete, move to a state in
which buffer 1 is writing and buffer 2 is reading (the next set of pages) and
in which we are waiting for buffer 1's i/o to complete, move to a state where
buffer 1 is done and we are waiting for buffer 2 to finish, etc.  At any given
state, we are waiting for the i/o of a particular buffer to complete before
moving to the next state.

Error philosophy: when an error occurs, we want to be sure we read/write all
of the pages that we can.  When an error occurs on a multiple page read, the
read is simple retried, asking this time for only the last (since we are
reading backwards) page.  If an error occurs on a single page read, though, we
must give up on that page, and inform the user of same.  The copy is restarted,
at the record before (less than) the faulting record.

Errors during writing are pretty much the reverse of the above.  If a single
page write fails, we must give up on the page, and inform the user.  As far as
the state goes, we pretend the write was successful and go to the
corresponding state (waiting for the next read to write out).  If a multi-page
write fails, though, we must start writing pages one at a time to find the bad
ones.  We could just do this from the data already read, but this would be too
hard to keep track of.  Besides, we are screwed, latency-wise, having to
re-write, so we wait for any read in progress to finish, and re-read the last
page of the previous read (the first page we want to write now) so that the
buffers come back into sync.

In the finite state diagram that follows, the codes (such as e1 w2) mean that
buffer 1 is empty, and buffer 2 is in process of being written. */
%page;

/*    -------		     -------
      | END |		     |START|
      -------	 /-last 1 done-|r1 e2|
         ^       /--	     -------
      1 done  /-			  \ 1 done
         |   v			   v
      -------	       -------         -------	    -------
      |w1 e2|<-last 1 done-|r1 e2|-1 done->|w1 r2|	    | END |
      -------	       -------         -------	    -------
			^	      |		       ^
		       2 done	   1 done		    2 done
			|	      v		       |
		       -------         -------	    -------
		       |r1 w2|<-2 done-|e1 r2|-last 2 done->|e1 w2|
		       -------         -------	    -------
*/

	end_state (*) = 0;
	normal_state (*) = 0;
	buffer_to_read (*) = 0;
	buffer_to_write (*) = 0;
	buffer_waiting_for (*) = 0;
	waiting_for_read (*) = "0"b;

	buffer_to_read (START) = 1;
	buffer_waiting_for (START) = 1;
	waiting_for_read (START) = "1"b;
	end_state (START) = W1E2;
	normal_state (START) = W1R2;

	buffer_waiting_for (R1E2) = 1;
	waiting_for_read (R1E2) = "1"b;
	end_state (R1E2) = W1E2;
	normal_state (R1E2) = W1R2;

	buffer_to_read (W1R2) = 2;
	buffer_to_write (W1R2) = 1;
	buffer_waiting_for (W1R2) = 1;
	normal_state (W1R2) = E1R2;

	buffer_waiting_for (E1R2) = 2;
	waiting_for_read (E1R2) = "1"b;
	end_state (E1R2) = E1W2;
	normal_state (E1R2) = R1W2;

	buffer_to_read (R1W2) = 1;
	buffer_to_write (R1W2) = 2;
	buffer_waiting_for (R1W2) = 2;
	normal_state (R1W2) = R1E2;

	buffer_to_write (E1W2) = 2;
	buffer_waiting_for (E1W2) = 2;

	buffer_to_write (W1E2) = 1;
	buffer_waiting_for (W1E2) = 1;
%page;
	max_io_pages = 3;				/* normally read/write a max of three pages at a time */

RESTART:
	record_info.read.prev_record = l_record + 1;
	record_info.read.prev_record_in_cylinder = mod (record_info.read.prev_record, rec_per_cyl (device_type));

	if record_info.read.prev_record <= f_record then state = 0;
	else state = START;

	do while (state ^= 0);
	     call bce_check_abort;

	     working_buffer = buffer_to_write (state);
	     if working_buffer > 0 then		/* last read must have finished */
		call bootload_disk_io$queue_write (to_pvtx, record_info.buffer (working_buffer).new_record, record_info.buffer (working_buffer).records_this_cylinder, buffer_ptr (working_buffer), working_buffer, code);

	     working_buffer = buffer_to_read (state);
	     if working_buffer > 0 then do;
		if record_info.read.prev_record_in_cylinder = 0 then record_info.read.prev_record_in_cylinder = rec_per_cyl (device_type); /* next cylinder */
		record_info.read.records_this_cylinder = min (record_info.read.prev_record_in_cylinder, max_io_pages); /* num pages to do this time around */
		record_info.read.new_record = max (record_info.read.prev_record - record_info.read.records_this_cylinder, f_record); /* don't go over requested area */
		record_info.read.records_this_cylinder = record_info.read.prev_record - record_info.read.new_record; /* real amt to do */

		call bootload_disk_io$queue_read (from_pvtx, record_info.read.new_record, record_info.read.records_this_cylinder, buffer_ptr (working_buffer), working_buffer, code);
		record_info.buffer (working_buffer) = record_info.read; /* record what pages are in this buffer */
	     end;

	     working_buffer = buffer_waiting_for (state);
	     code = error_table_$not_done;
	     do while (code = error_table_$not_done);
		call bootload_disk_io$test_done (working_buffer, code);
	     end;
	     if waiting_for_read (state) then
		if code = 0 then do;
		     record_info.read.prev_record = record_info.read.new_record; /* advance to next (prev) pages */
		     record_info.read.prev_record_in_cylinder = record_info.read.prev_record_in_cylinder - record_info.read.records_this_cylinder;
		     max_io_pages = 3;		/* allow full batch next time around -
						on error cases we keep it at 1 assuming that 
						next record will be bad also (same track?) */
		end;
		else do;
		     if record_info.read.records_this_cylinder > 1 then /* try i/o on just 1 record to find fault one */
			l_record = record_info.read.prev_record - 1; /* start with last record not processed */
		     else do;
			call com_err_ (0, Me, "Could not read record ^oo of ^a.", record_info.read.new_record, from_devname);
			l_record = record_info.read.prev_record - 2; /* skip the current record */
		     end;
		     go to IO_ERROR;
		end;
	     else if code ^= 0 then do;		/* error on write */
		if record_info.buffer (working_buffer).records_this_cylinder = 1 then /* consider page as done */
		     call com_err_ (0, Me, "Could not write record ^oo to ^a.", record_info.buffer (working_buffer).new_record, to_devname);
		else do;				/* multi-record, wait for all io to finish, restart */
		     l_record = record_info.buffer (working_buffer).prev_record - 1; /* restart read at pages attempted written */

IO_ERROR:		     do buffer_num = 1 to 2;
			code = error_table_$not_done;
			do while (code = error_table_$not_done);
			     call bootload_disk_io$test_done (buffer_num, code);
			end;
		     end;

		     max_io_pages = 1;		/* force just one page i/o next time */
		     go to RESTART;
		end;
	     end;

	     if record_info.read.prev_record <= f_record then state = end_state (state);
	     else state = normal_state (state);
	end;

	call clean_up;
RETURN:	return;

clean_up: proc;

	do buffer_num = 1 to 2;
	     code = error_table_$not_done;
	     do while (code = error_table_$not_done);
		call bootload_disk_io$test_done (buffer_num, code);
	     end;
	end;
	disk_post_area.number = 0;

	call pc_abs$unwire_abs (temp_astep, 0, 3);
	call release_temp_segment_ (Me, temp_seg_ptr, code);
	return;
     end;
%page;
no_parse: proc (arg_list_ptr, arg_num, info_ptr, code);

/* called by bce_parse_disk_spec when it doesn't like something */

dcl  arg_list_ptr			ptr parameter;
dcl  arg_num			fixed bin parameter;
dcl  code				fixed bin (35) parameter;
dcl  info_ptr			ptr parameter;

	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	if arg = "-force" | arg = "-fc" then force = "1"b;
	else do;
	     code = error_table_$bad_arg;
	     call com_err_ (code, Me, "^a", arg);
	end;
	return;
     end no_parse;
%page;
%include bce_subsystem_info_;
%page;
%include bootload_post_area;
%page;
%include disk_pack;
%page;
%include fs_dev_types;
%page;
%include fs_vol_label;
%page;
%include pvt;
%page;
%include pvte;
     end bce_copy_disk;




		    bce_display_disk_label.pl1      11/11/89  1134.3r w 11/11/89  0826.2       26865



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


/****^  HISTORY COMMENTS:
  1) change(86-01-14,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Changed to add Subvolume support.
                                                   END HISTORY COMMENTS */


bce_display_disk_label: proc (p_ss_info_ptr);

/* Program written by Allen Ball June of '84 to display a disk label in bce. */

/* format: style4,initcol1,indattr,declareind8,dclind4,idind35,ifthenstmt,ifthen,^indproc,delnl,insnl */

dcl addr			         builtin;
dcl arg			         char (arg_len) based (arg_ptr);
dcl arg_count		         fixed bin;
dcl arg_len		         fixed bin (21);
dcl arg_ptr		         ptr;
dcl code			         fixed bin (35);
dcl disk_name_pvtx		         entry (char (8), fixed bin (17), fixed bin (35));
dcl com_err_		         entry options (variable);
dcl cu_$arg_count_rel	         entry (fixed bin, ptr, fixed bin (35));
dcl cu_$arg_ptr_rel		         entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl display_disk_label_	         entry (ptr);
dcl devname		         char (8);
dcl ioa_			         entry options (variable);
dcl me			         char (18) static options (constant) init ("display_disk_label");
dcl 1 my_label		         aligned like label;
dcl p_ss_info_ptr		         ptr parameter;
dcl pvtx			         fixed bin;
dcl read_disk_label		         entry (fixed bin, ptr, char (*), fixed bin (35));
dcl reason		         char (128);

	ss_info_ptr = p_ss_info_ptr;
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     return;
	end;
	if arg_count ^= 1 then do;
	     call ioa_ ("Usage:^/    display_disk_label {device}");
	     return;
	end;
	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     return;
	end;
	pvtp = addr (pvt$);
	pvt_arrayp = addr (pvt.array);

	devname = arg;

	call disk_name_pvtx (devname, pvtx, code);	/* validate name and get the pvtx */
	if code ^= 0 then do;			/* not a valid name or valid drive */
	     call com_err_ (code, me, "^a", arg);
	     return;
	end;

	call read_disk_label (pvtx, addr (my_label), reason, code);
	if code ^= 0 then
	     call com_err_ (code, me, "^a", reason);

	else call display_disk_label_ (addr (my_label));

	return;

/* format: ^insnl */
%page; %include bce_subsystem_info_;
%page; %include fs_vol_label;
%page; %include pvt;
%page; %include pvte;
     end /* bce_display_disk_label */;




		    bce_get_flagbox.pl1             11/11/89  1134.3r w 11/11/89  0826.3       40068



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_get_flagbox: proc (P_ss_info_ptr);

/* Version of get_flagbox for bce.  Stolen by Keith Loepere, December 1983. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  P_ss_info_ptr		        ptr parameter;
dcl  active_fnc_err_	        entry options (variable);
dcl  active_function	        bit (1) aligned;	/* as opposed to command usage */
dcl  addbitno		        builtin;
dcl  addr			        builtin;
dcl  af_return		        char (af_return_len) based (af_return_ptr) var; /* return for active function */
dcl  af_return_len		        fixed bin (21);
dcl  af_return_ptr		        ptr;
dcl  arg			        char (arg_len) based (arg_ptr); /* command line arg */
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  bit_ptr		        ptr;		/* to bit in flagbox to examine/set */
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cv_dec_check_		        entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  error		        variable entry options (variable);
dcl  error_table_$badopt	        fixed bin (35) ext;
dcl  flag_num		        fixed bin;		/* which flag bit in flagbox */
dcl  flagbox_bit		        bit (1) based (bit_ptr); /* bit in flagbox flags */
dcl  ioa_			        entry options (variable);
dcl  me			        char (11);		/* program name */
dcl  old_value		        char (256) var;	/* result of command */
dcl  option		        char (12);		/* value desired */
dcl  requote_string_	        entry (char (*)) returns (char (*));
dcl  rtrim		        builtin;
dcl  set			        bit (1) aligned;	/* as opposed to get operation */

	set = "0"b;
	me = "get_flagbox";
	go to join;

bce_set_flagbox: entry (P_ss_info_ptr);

	set = "1"b;
	me = "set_flagbox";
join:
	ss_info_ptr = P_ss_info_ptr;
	arg_list_ptr = ss_info.arg_list_ptr;
	call cu_$af_return_arg_rel (arg_count, af_return_ptr, af_return_len, code, arg_list_ptr);
	active_function = (code = 0);
	if active_function then error = active_fnc_err_;
	else error = com_err_;
	if set then
	     if arg_count ^= 2 then do;
		call error (0, me, "Usage is: set_flagbox name old_value");
		return;
	     end;
	     else ;
	else if arg_count ^= 1 then do;
	     call error (0, me, "Usage is: get_flagbox name");
	     return;
	end;

	fgbxp = addr (flagbox$);
	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, arg_list_ptr);
	option = arg;
	if option = "bce_command" then old_value = rtrim (fgbx.return_to_bce_command);
	else do;
	     flag_num = cv_dec_check_ (option, code);
	     if code ^= 0 then do;
		do flag_num = 1 to 36 while (option ^= flagbox_flag_names (flag_num));
		end;
	     end;

	     if flag_num <= 36 then bit_ptr = addbitno (addr (fgbx.flags), flag_num - 1);
	     else if option = "ssenb" then bit_ptr = addr (fgbx.ssenb);
	     else if option = "manual_crash" then bit_ptr = addr (fgbx.manual_crash);
	     else if option = "call_bce" then bit_ptr = addr (fgbx.call_bce);
	     else if option = "shut" then bit_ptr = addr (fgbx.shut);
	     else go to fail1;
	     if flagbox_bit then old_value = "true";
	     else old_value = "false";
	end;

	if set then do;
	     call cu_$arg_ptr_rel (2, arg_ptr, arg_len, code, arg_list_ptr);
	     if option = "bce_command" then fgbx.return_to_bce_command = arg;
	     else do;
		if arg = "true" then flagbox_bit = "1"b;
		else if arg = "false" then flagbox_bit = "0"b;
		else do;
		     code = error_table_$badopt;
		     go to fail;
		end;
	     end;
	end;

	if active_function then af_return = requote_string_ ((old_value));
	else if ^set then call ioa_ (old_value);
	return;

fail1:	code = error_table_$badopt;
fail:	call error (code, me, "^a", arg);
	return;
%page; %include bce_subsystem_info_;
%page; %include flagbox;
%page; %include flagbox_flags;
     end;




		    bce_lock_mca.pl1                11/11/89  1134.3r w 11/11/89  0826.3       28431



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/****^  HISTORY COMMENTS:
  1) change(85-09-11,Farley), approve(85-09-11,MCR6979),
     audit(86-02-28,Coppola), install(86-03-21,MR12.0-1033):
     Created for IMU
     support (control MCA).
                                                   END HISTORY COMMENTS */
bce_lock_mca: proc (p_ss_info_ptr);

/* Written by Paul K Farley June 1985 to allow the MCA operator interface 
   to be either disabled (locked) or enabled (unlocked). */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

dcl  Me				char (10);
dcl  arg_count			fixed bin;
dcl  arg				char (arg_len) based (arg_ptr);
dcl  arg_len			fixed bin (21);
dcl  arg_ptr			ptr;
dcl  args_expected			fixed bin;
dcl  code				fixed bin (35);
dcl  lock_mca			bit (1);
dcl  mca_number			fixed bin (35);
dcl  mca_to_unlock			char (4);
dcl  P99				pic "99" based;
dcl  com_err_			entry () options (variable);
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cv_dec_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  ioa_				entry () options (variable);
dcl  ocdcm_$reconfigure		entry (char (4), fixed bin, fixed bin (35));
dcl  p_ss_info_ptr			ptr parameter;
dcl  convert			builtin;
%page;

	lock_mca = "1"b;
	Me = "lock_mca";
	args_expected = 0;
	goto join;

bce_lock_mca$bce_unlock_mca:
     entry (p_ss_info_ptr);

	lock_mca = "0"b;
	Me = "unlock_mca";
	args_expected = 1;

join:
	ss_info_ptr = p_ss_info_ptr;
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me);
	     return;
	end;
	if arg_count ^= args_expected then do;
	     if lock_mca then call ioa_ ("lock_mca: This command takes NO arguments.^/Usage: lock_mca");
	     else call ioa_ ("unlock_mca: This command requires one argument.^/Usage: unlock_mca MCA_NUMBER");
	     return;
	end;

	if lock_mca then do;
	     call ocdcm_$reconfigure ("", LOCK_MCA_INPUT, code);
	     call ioa_ ("lock_mca: MCA interface^[ NOT^] locked.", (code ^= 0));
	     return;
	end;
	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	mca_number = cv_dec_check_ (arg, code);
	if code ^= 0 | mca_number < 0 | mca_number > 31 then do;
	     call ioa_ ("unlock_mca: Illegal MCA number. Range is 0 - 31.");
	     return;
	end;
	mca_to_unlock = "M_" || convert (P99, mca_number);
	call ocdcm_$reconfigure (mca_to_unlock, UNLOCK_MCA_INPUT, code);
	call ioa_ ("unlock_mca: MCA(^a) interface^[ NOT^] unlocked.",
	     convert (P99, mca_number), (code ^= 0));
	return;
%page; %include bce_subsystem_info_;
%page; %include opc_reconfig_options;
     end bce_lock_mca;




		    bce_parse_disk_spec.pl1         11/11/89  1134.3r w 11/11/89  0826.3       92745



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

/****^  HISTORY COMMENTS:
  1) change(86-01-17,Fawcett), approve(86-01-17,MCR7220),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Extracted from bce_test_disk (Allen Ball) by Keith Loepere,
     This is used by bce_copy_disk, and bce_test_disk.
  2) change(86-01-17,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Changed to support subvolumes by using last_sv_rec_num (device_type)
     instead of last_rec_num (device_type).
                                                   END HISTORY COMMENTS */

bce_parse_disk_spec: proc (caller, arg_list_ptr, arg_num, device_type, p_labelp, f_record, l_record, caller_arg_parser, info_ptr, code);

/* Routine to parse a bce specification of a disk range, interspersed with
other control arguments.
Extracted from bce_test_disk (Allen Ball) by Keith Loepere, March 1985.
*/

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

/* Parameters */

dcl  arg_list_ptr			ptr parameter;	/* to arg list for calling program */
dcl  arg_num			fixed bin parameter;/* arg pos in arg list to start with */
dcl  caller			char (32) parameter;/* name for error messages */
dcl  caller_arg_parser		entry (ptr, fixed bin, ptr, fixed bin (35)) parameter; /* routine to pass of to for a non disk spec arg */
dcl  code				fixed bin (35) parameter;
dcl  device_type			fixed bin parameter;/* as in fs_dev_types */
dcl  f_record			fixed bin (18) parameter; /* first rec in range */
dcl  info_ptr			ptr parameter;	/* passed to caller_arg_parser */
dcl  l_record			fixed bin parameter;/* last rec in range */
dcl  p_labelp			ptr parameter;	/* to label for disk */

/* Constants */

dcl  First			fixed bin (18) static options (constant) init (-1);
dcl  Last				fixed bin (18) static options (constant) init (-2);
dcl  Octal			fixed bin static options (constant) init (8);
dcl  Unassigned			fixed bin (18) static options (constant) init (-3);

/* Variables */

dcl  arg_count			fixed bin;
dcl  arg_len			fixed bin (21);
dcl  arg_ptr			ptr;
dcl  n_record			fixed bin (18);	/* number of records to be read or written after f_record or before l_record */
dcl  number			fixed bin (35);
dcl  partition			char (4);
dcl  parts_index			fixed bin;	/* index of part in label list */

/* Based */

dcl  arg				char (arg_len) based (arg_ptr);

/* Entries */

dcl  com_err_			entry () options (variable);
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cv_integer_string_check_		entry (char (*), fixed bin, fixed bin (35)) returns (fixed bin (35));

/* External */

dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  error_table_$dev_offset_out_of_bounds fixed bin (35) ext static;
dcl  error_table_$fsdisk_not_storage	fixed bin (35) ext static;
dcl  error_table_$noarg		fixed bin (35) ext static;
dcl  error_table_$nopart		fixed bin (35) ext static;
%page;
	f_record = Unassigned;
	l_record = Unassigned;
	n_record = Unassigned;
	partition = "";
	labelp = p_labelp;

	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);
	do arg_num = arg_num to arg_count;
	     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	     if arg = "-partition" | arg = "-part" then do;
		if label.Multics ^= Multics_ID_String then do;
		     code = error_table_$fsdisk_not_storage;
		     call com_err_ (code, caller, "partition");
		     return;
		end;
		call get_next_arg ("partition");
		partition = arg;
	     end;
	     else if arg = "-record" | arg = "-rec" then do;
		if f_record ^= Unassigned | l_record ^= Unassigned then go to bad_rec_spec;
		call get_next_arg ("record");
		number = cv_integer_string_check_ (arg, Octal, code);
		if code = 0 then do;
		     if number < 0 then goto no_neg_rec_nums;
		     else do;
			f_record = number;
			l_record = number;
		     end;
		end;
		else do;
		     if arg = "first" then do;
			f_record = First;
			l_record = First;
		     end;
		     else if arg = "last" then do;
			f_record = Last;
			l_record = Last;
		     end;
		     else goto bad_arg;
		end;
	     end;
	     else if arg = "-first_record" | arg = "-frec" then do;
		call get_next_arg ("first_record");
		if f_record ^= Unassigned then goto bad_rec_spec;
		number = cv_integer_string_check_ (arg, Octal, code);
		if code = 0 then do;
		     if number < 0 then goto no_neg_rec_nums;
		     else f_record = number;
		end;
		else do;
		     if arg = "first" then f_record = First;
		     else if arg = "last" then f_record = Last;
		     else goto bad_arg;
		end;
	     end;
	     else if arg = "-n_records" | arg = "-nrec" then do;
		if n_record ^= Unassigned then goto bad_rec_spec;
		call get_next_arg ("n_records");
		number = cv_integer_string_check_ (arg, Octal, code);
		if code = 0 then do;
		     if number <= 0 then goto no_neg_rec_nums;
		     n_record = number;
		end;
		else goto bad_arg;
	     end;
	     else if arg = "-last_record" | arg = "-lrec" then do;
		if l_record ^= Unassigned then goto bad_rec_spec;
		call get_next_arg ("last_record");
		number = cv_integer_string_check_ (arg, Octal, code);
		if code = 0 then do;
		     if number < 0 then do;
no_neg_rec_nums:		code = error_table_$dev_offset_out_of_bounds;
			call com_err_ (code, caller, "^d", number);
			return;
		     end;
		     else l_record = number;
		end;
		else do;
		     if arg = "first" then l_record = First;
		     else if arg = "last" then l_record = Last;
		     else goto bad_arg;
		end;
	     end;
	     else do;
		call caller_arg_parser (arg_list_ptr, arg_num, info_ptr, code);
		if code ^= 0 then return;		/* routine printed error */
	     end;
next_arg: end;
%page;

/* Now figure out what f_record and l_record  are. */

	if f_record ^= Unassigned & l_record ^= Unassigned & n_record ^= Unassigned then goto bad_rec_spec; /* -frec, -lrec, and -nrec are (all three) incompatible */
	if partition ^= "" then do;
	     do parts_index = 1 to label.nparts while (label.parts (parts_index).part ^= partition);
	     end;
	     if parts_index > label.nparts then do;
		code = error_table_$nopart;
		call com_err_ (code, caller, "^a", partition);
		return;
	     end;
	     if n_record = Unassigned then do;
		if f_record = Unassigned | f_record = First then f_record = label.parts (parts_index).frec;
		else if f_record = Last then f_record = label.parts (parts_index).frec + label.parts (parts_index).nrec - 1;
		else f_record = f_record + label.parts (parts_index).frec;
		if l_record = Unassigned | l_record = Last then l_record = label.parts (parts_index).frec + label.parts (parts_index).nrec - 1;
		else if l_record = First then l_record = label.parts (parts_index).frec;
		else l_record = l_record + label.parts (parts_index).frec;
	     end;
	     else do;
		if f_record ^= Unassigned then do;
		     if f_record = First then f_record = label.parts (parts_index).frec;
		     else if f_record = Last then f_record = label.parts (parts_index).frec + label.parts (parts_index).nrec - 1;
		     else f_record = f_record + label.parts (parts_index).frec;
		     l_record = f_record + n_record - 1;
		end;
		else if l_record ^= Unassigned then do;
		     if l_record = First then l_record = label.parts (parts_index).frec;
		     else if l_record = Last then l_record = label.parts (parts_index).frec + label.parts (parts_index).nrec - 1;
		     else l_record = l_record + label.parts (parts_index).frec;
		     f_record = l_record - n_record + 1;
		end;
	     end;
	end;
%page;
	else do;
	     if n_record = Unassigned then do;
		if f_record = Unassigned | f_record = First then f_record = first_rec_num (device_type);
		else if f_record = Last then f_record = last_sv_rec_num (device_type);
		if l_record = Unassigned | l_record = Last then l_record = last_sv_rec_num (device_type);
		else if l_record = First then l_record = first_rec_num (device_type);
	     end;
	     else do;
		if f_record ^= Unassigned then do;
		     if f_record = First then f_record = first_rec_num (device_type);
		     else if f_record = Last then f_record = last_sv_rec_num (device_type);
		     l_record = f_record + n_record - 1;
		end;
		else if l_record ^= Unassigned then do;
		     if l_record = First then l_record = first_rec_num (device_type);
		     else if l_record = Last then l_record = last_sv_rec_num (device_type);
		     f_record = l_record - n_record + 1;
		end;
	     end;
	end;
%page;

/* Out of range checks */

	if f_record < first_rec_num (device_type) | f_record > first_rec_num (device_type) + rec_per_dev (device_type) - 1 then do;
	     code = error_table_$dev_offset_out_of_bounds;
	     call com_err_ (code, caller, "^d", f_record);
	     return;
	end;
	if l_record < first_rec_num (device_type) | l_record > first_rec_num (device_type) + rec_per_dev (device_type) - 1 then do;
	     code = error_table_$dev_offset_out_of_bounds;
	     call com_err_ (code, caller, "^d", l_record);
	     return;
	end;
	if l_record < f_record then do;
	     code = error_table_$dev_offset_out_of_bounds;
	     call com_err_ (code, caller, "^d is less than ^d", l_record, f_record);
	     return;
	end;

	code = 0;					/* passes all tests */
RETURN:	return;
%page;
get_next_arg: proc (arg_needed);

dcl  arg_needed			char (32);

	arg_num = arg_num + 1;
	if arg_num > arg_count then do;
	     code = error_table_$noarg;
	     call com_err_ (code, caller, arg_needed);
	     go to RETURN;
	end;
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	return;
     end get_next_arg;

bad_rec_spec:
	code = error_table_$dev_offset_out_of_bounds;
	call com_err_ (0, caller, "Incompatible use of record specifiers.");
	return;

bad_arg:
	code = error_table_$bad_arg;
	call com_err_ (code, caller, "^a", arg);
	return;
%page; %include fs_dev_types;
%page; %include fs_vol_label;
     end bce_parse_disk_spec;




		    bce_query_af.pl1                11/11/89  1134.3r w 11/11/89  0826.3       26073



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_query_af: proc (P_ss_info_ptr);

/* Version of query and response active functions for bce.  
Keith Loepere, January 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  P_ss_info_ptr		        ptr parameter;
dcl  active_fnc_err_	        entry options (variable);
dcl  active_function	        bit (1) aligned;	/* as opposed to command usage */
dcl  af_return		        char (af_return_len) based (af_return_ptr) var; /* return for active function */
dcl  af_return_len		        fixed bin (21);
dcl  af_return_ptr		        ptr;
dcl  arg			        char (arg_len) based (arg_ptr); /* command line arg */
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  bce_query		        entry options (variable);
dcl  bce_query$yes_no	        entry options (variable);
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  error		        variable entry options (variable);
dcl  ioa_			        entry options (variable);
dcl  me			        char (11);		/* program name */
dcl  must_be_yes_no		        bit (1) aligned;
dcl  requote_string_	        entry (char (*)) returns (char (*));
dcl  response		        char (256);
dcl  rtrim		        builtin;
dcl  yes_no		        bit (1);

	me = "query";
	must_be_yes_no = "1"b;
	go to join;

bce_response_af: entry (P_ss_info_ptr);

	me = "response";
	must_be_yes_no = "0"b;

join:
	ss_info_ptr = P_ss_info_ptr;
	arg_list_ptr = ss_info.arg_list_ptr;
	call cu_$af_return_arg_rel (arg_count, af_return_ptr, af_return_len, code, arg_list_ptr);
	active_function = (code = 0);
	if active_function then error = active_fnc_err_;
	else error = com_err_;

	if arg_count ^= 1 then do;
	     call error (0, me, "Usage is: ^a question", me);
	     return;
	end;

	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);

	if must_be_yes_no then do;
	     call bce_query$yes_no (yes_no, "^a ", arg);
	     if yes_no then response = "true";
	     else response = "false";
	end;
	else call bce_query (response, "^a ", arg);

	if active_function then af_return = requote_string_ (rtrim (response));
	else call ioa_ (rtrim (response));
	return;
%page; %include bce_subsystem_info_;
     end;




		    bce_ready.pl1                   11/11/89  1134.3r   11/11/89  0826.3       16614



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_ready: proc (prompt);

/* print ready message for bootload Multics.
Written June 1983 by Keith Loepere. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  addr			        builtin;
dcl  bce_data$error_put_chars	        entry (ptr, ptr, fixed bin, fixed bin (35)) ext variable;
dcl  buffer		        char (40);
dcl  buffer_len		        fixed bin;
dcl  clock		        builtin;
dcl  code			        fixed bin (35);
dcl  date_time_		        entry (fixed bin (71), char (*));
dcl  ioa_$rsnnl		        entry() options(variable);
dcl  length		        builtin;
dcl  new_line		        bit (1) aligned;
dcl  output_buffer		        char (buffer_len) based (addr (buffer));
dcl  prompt		        char (*) parameter;
dcl  substr		        builtin;
dcl  time_string		        char (24);

	new_line = "1"b;
	go to join;

nnl: entry (prompt);

	new_line = "0"b;

join:
	call date_time_ (clock (), time_string);
	call ioa_$rsnnl ("^a (^a) ^a: ", buffer, buffer_len, prompt, 
	     COLLECTION_1_PHASE_NAMES (sys_info$collection_1_phase), 
	     substr (time_string, 11, 6));
	if new_line then do;
	     buffer_len = buffer_len + 1;
	     substr (output_buffer, buffer_len, 1) = "
";
	end;
	call bce_data$error_put_chars (addr (bce_data$error_put_chars), addr (output_buffer), length (output_buffer), code);
	return;
%page; %include collection_1_phases;
     end;




		    bce_severity.pl1                11/11/89  1134.3r w 11/11/89  0826.3       23193



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_severity: proc (P_ss_info_ptr);

/* Version of severity for bce.  Keith Loepere, January 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  P_ss_info_ptr		        ptr parameter;
dcl  active_fnc_err_	        entry options (variable);
dcl  active_function	        bit (1) aligned;	/* as opposed to command usage */
dcl  af_return		        char (af_return_len) based (af_return_ptr) var; /* return for active function */
dcl  af_return_len		        fixed bin (21);
dcl  af_return_ptr		        ptr;
dcl  arg			        char (arg_len) based (arg_ptr); /* command line arg */
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  bce_dump$severity	        entry () returns (fixed bin);
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  error		        variable entry options (variable);
dcl  error_table_$badopt	        fixed bin (35) ext;
dcl  error_table_$not_act_fnc	        fixed bin (35) ext;
dcl  ioa_			        entry options (variable);
dcl  me			        char (8) init ("severity") static options (constant);/* program name */
dcl  value		        fixed bin;

	ss_info_ptr = P_ss_info_ptr;
	arg_list_ptr = ss_info.arg_list_ptr;
	call cu_$af_return_arg_rel (arg_count, af_return_ptr, af_return_len, code, arg_list_ptr);
	active_function = (code = 0);
	if active_function then error = active_fnc_err_;
	else error = com_err_;
	if arg_count ^= 1 then do;
	     call error (0, me, "Usage is: severity command_name");
	     return;
	end;

	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, arg_list_ptr);
	if arg = "dump" then value = bce_dump$severity ();
	else do;
	     call error (error_table_$badopt, me, "^a", arg);
	     return;
	end;

	if active_function then af_return = ltrim (character (value));
	else call ioa_ ("^d", value);
	return;
%page; %include bce_subsystem_info_;
     end;




		    bce_shutdown_state.pl1          11/11/89  1134.3r w 11/11/89  0826.3       21501



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_shutdown_state: proc (P_ss_info_ptr);

/* Fetch the shutdown state from the rpv. Keith Loepere, January 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  P_ss_info_ptr		        ptr parameter;
dcl  active_fnc_err_	        entry options (variable);
dcl  active_function	        bit (1) aligned;	/* as opposed to command usage */
dcl  addr			        builtin;
dcl  af_return		        char (af_return_len) based (af_return_ptr) var; /* return for active function */
dcl  af_return_len		        fixed bin (21);
dcl  af_return_ptr		        ptr;
dcl  arg_count		        fixed bin;
dcl  character		        builtin;
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  error		        variable entry options (variable);
dcl  ioa_			        entry options (variable);
dcl  ltrim		        builtin;
dcl  me			        char (14) init ("shutdown_state") static options (constant); /* program name */
dcl  pvt$root_pvtx		        fixed bin external;
dcl  1 my_label		        aligned like label;
dcl  read_disk		        entry (fixed bin, fixed bin, ptr, fixed bin (35));

	ss_info_ptr = P_ss_info_ptr;
	arg_list_ptr = ss_info.arg_list_ptr;
	call cu_$af_return_arg_rel (arg_count, af_return_ptr, af_return_len, code, arg_list_ptr);
	active_function = (code = 0);
	if active_function then error = active_fnc_err_;
	else error = com_err_;
	if arg_count ^= 0 then do;
	     call error (0, me, "Usage is: ^a", me);
	     return;
	end;

	labelp = addr (my_label);
	call read_disk (pvt$root_pvtx, 0, labelp, code);
	if code ^= 0 then call error (code, me);

	if active_function then af_return = ltrim (character (label.shutdown_state));
	else call ioa_ ("^d", label.shutdown_state);
	return;
%page; %include bce_subsystem_info_;
%page; %include fs_vol_label;
     end;




		    bce_state.pl1                   11/11/89  1134.3r w 11/11/89  0826.3       19080



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_state: proc (P_ss_info_ptr);

/* Return state (collection_1_phase) for bce.  Keith Loepere, May 1984. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  P_ss_info_ptr		        ptr parameter;
dcl  active_fnc_err_	        entry options (variable);
dcl  active_function	        bit (1) aligned;	/* as opposed to command usage */
dcl  af_return		        char (af_return_len) based (af_return_ptr) var; /* return for active function */
dcl  af_return_len		        fixed bin (21);
dcl  af_return_ptr		        ptr;
dcl  arg_count		        fixed bin;
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  error		        variable entry options (variable);
dcl  error_table_$not_act_fnc	        fixed bin (35) ext;
dcl  ioa_			        entry options (variable);
dcl  me			        char (9) init ("bce_state") static options (constant);/* program name */

	ss_info_ptr = P_ss_info_ptr;
	arg_list_ptr = ss_info.arg_list_ptr;
	call cu_$af_return_arg_rel (arg_count, af_return_ptr, af_return_len, code, arg_list_ptr);
	active_function = (code = 0);
	if active_function then error = active_fnc_err_;
	else error = com_err_;
	if arg_count ^= 0 then do;
	     call error (0, me, "Usage is: bce_state");
	     return;
	end;

	if active_function then af_return = rtrim (COLLECTION_1_PHASE_NAMES (
sys_info$collection_1_phase));
	else call ioa_ ("^a", COLLECTION_1_PHASE_NAMES (sys_info$collection_1_phase));
	return;
%page; %include bce_subsystem_info_;
%page; %include collection_1_phases;
     end;




		    bce_test_disk.pl1               11/11/89  1134.3r w 11/11/89  0826.3      117378



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


/****^  HISTORY COMMENTS:
  1) change(86-01-17,Fawcett), approve(86-01-17,MCR7220),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Keith Loepere to extract disk spec parsing code and
     call bce_parse_disk_spec (created for bce_copy_disk).
  2) change(86-01-17,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Changed to support subvolumes by adding call to disk_name_pvtx.
                                                   END HISTORY COMMENTS */


bce_test_disk: proc (p_ss_info_ptr);

/* Written by Allen Ball June of 1984 to replace BOS command TEST. */
/* Modified 85-01-09 ADB to fix d451. 'last' still refers to last record number
                         before alt partition but user can still refer to
                         records past the beginning of the alt partition. */
/* Modified 85-02-09 Keith Loepere, to use bootload disk i/o for performance. */
/* Modified 85-03-10 Keith Loepere to extract disk spec parsing code. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

/* Constants */

dcl  Me				char (32) static options (constant) init ("test_disk");

/* Parameters */

dcl  p_ss_info_ptr			ptr parameter;

/* Variables */

dcl  arg_count			fixed bin;
dcl  arg_len			fixed bin (21);
dcl  arg_num			fixed bin;
dcl  arg_ptr			ptr;
dcl  code				fixed bin (35);
dcl  device_type			fixed bin;	/* as in fs_dev_types */
dcl  drive			char (8);		/* device name */
dcl  error_on_write			bit (1);		/* report error for write op, not read */
dcl  f_record			fixed bin (18);	/* first record to be read or written */
dcl  force			bit (1) aligned;	/* don't ask questions */
dcl  key				char (2);
dcl  l_record			fixed bin (18);	/* last record to be read or written */
dcl  1 my_label			aligned like label;
dcl  new_record			fixed bin (18);	/* first record of new set to read/write */
dcl  page_num			fixed bin;
dcl  1 pattern			aligned,
       2 word_pattern_len		fixed bin,
       2 pattern_buffer		bit (1024 * 36) aligned; /* build area for pattern to write to disk */
dcl  pattern_buffer_ptr		ptr;
dcl  prev_record			fixed bin (18);	/* last record read/written */
dcl  prev_record_in_cylinder		fixed bin;	/* (0 origin) record number within cylinder (used for detecting cylinder crossing) */
dcl  pvtx				fixed bin;
dcl  read_sw			bit (1);
dcl  read_then_write		bit (1);
dcl  records_this_cylinder		fixed bin;
dcl  temp_astep			ptr;		/* to temp_seg in use */
dcl  temp_seg_ptr			ptr;		/* to temp_seg (which we wire) */
dcl  write_then_read		bit (1);
dcl  write_sw			bit (1);
dcl  yes_no			bit (1);

/* External */

dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  error_table_$noarg		fixed bin (35) ext static;

/* Entries */

dcl  bce_check_abort		entry;
dcl  disk_name_pvtx			entry (char (8), fixed bin (17), fixed bin (35));
dcl  bce_parse_disk_spec		entry (char (32), ptr, fixed bin, fixed bin, ptr, fixed bin (18), fixed bin (18), entry (ptr, fixed bin, ptr, fixed bin (35)), ptr, fixed bin (35));
dcl  bce_query$yes_no		entry options (variable);
dcl  bootload_disk_io$read		entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin (35));
dcl  bootload_disk_io$write		entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin (35));
dcl  com_err_			entry () options (variable);
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cv_oct_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_ptrs_$given_segno		entry (fixed bin (15)) returns (ptr);
dcl  get_temp_segment_		entry (char (*), ptr, fixed bin (35));
dcl  ioa_				entry () options (variable);
dcl  pc_abs$unwire_abs		entry (ptr, fixed bin, fixed bin);
dcl  pc_abs$wire_abs_contig		entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  read_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  release_temp_segment_		entry (char (*), ptr, fixed bin (35));

/* Based */

dcl  arg				char (arg_len) based (arg_ptr);
dcl  bootload_disk_buffer		(0:2) bit (1024 * 36) aligned based (temp_seg_ptr);
dcl  word				bit (36) aligned based;
dcl  word_pattern			bit (word_pattern_len * 36) based (pattern_buffer_ptr) aligned;

/* Misc */

dcl  cleanup			condition;

dcl  (addr, addrel, copy, divide, max, min, mod, null, segno, unspec) builtin;
%page;
	ss_info_ptr = p_ss_info_ptr;
	pattern_buffer_ptr = addr (pattern.pattern_buffer);
	pvtp = addr (pvt$);
	pvt_arrayp = addr (pvt.array);
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me);
	     return;
	end;
	if arg_count < 2 then do;
	     call ioa_ ("Usage:^/  ^a <key> <device> (<arg1> <arg2> ...)", Me);
	     return;
	end;
	arg_num = 1;
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Can't get arg");
	     return;
	end;
	if arg_len < 1 | arg_len > 2 then goto bad_key;
	key = arg;
	if ^(key = "r" | key = "w" | key = "rw" | key = "wr") then do;
bad_key:	     call ioa_ ("^a: Unrecognized key - ^a", Me, arg);
	     return;
	end;
	read_sw = (key = "r");
	write_sw = (key = "w");
	read_then_write = (key = "rw");
	write_then_read = (key = "wr");

	arg_num = 2;
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);

	drive = arg;
	call disk_name_pvtx (drive, pvtx, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "^a", arg);
	     return;
	end;

	pattern.word_pattern_len = 0;
	force = "0"b;

	labelp = addr (my_label);
	call read_disk (pvtx, (LABEL_ADDR), labelp, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Could not read label of ^a.", drive);
	     return;
	end;

	device_type = pvt_array (pvtx).device_type;

	arg_num = 3;
	call bce_parse_disk_spec (Me, ss_info.arg_list_ptr, arg_num, device_type, labelp, f_record, l_record, pattern_parse, addr (pattern), code);
	if code ^= 0 then return;

/* Now that f_record and l_record are assigned we will give them their chance to turn back. */

	if write_sw | write_then_read then do;
	     if f_record = l_record then call ioa_ ("Writing to record number ^oo on ^a.", f_record, drive);
	     else call ioa_ ("Writing to records ^oo through ^oo (inclusive) on ^a.", f_record, l_record, drive);
	     if ^force then do;
		call bce_query$yes_no (yes_no, "Do you wish to write to the ^[non ^;^]^a - ^a? ",
		     (label.Multics ^= Multics_ID_String), Multics_ID_String, drive);
		if ^yes_no then return;
	     end;
	end;

	if pattern.word_pattern_len = 0 then unspec (pattern.pattern_buffer) = "0"b;
	else pattern.pattern_buffer = copy (word_pattern, divide (1024, pattern.word_pattern_len, 17) + 1);
%page;

/* Now for the real work.  The basic loop structure below implements the 4
keys as follows.  For "r", we simply keep reading into our wired buffer.
For "w", we copy our pattern into the wired buffer once, and then keep
writing from it.  For "rw", we read into and write back from the wired buffer.
For "wr", though, we must copy the pattern into the wired buffer each time
through.

The i/o is done backwards, and (normally) three pages at a time.  This is
to minimize latency between i/o's, to maximize the time we have between i/o's
to get our next request in, within the constraints that bootload_disk_io
can handle a maximum of 4 pages at a time.  Three pages is optimal both for
451 and 501 style drives.

However, we don't want to read/write a set of pages that cross a cylinder
boundary, so we check for this.  Also, if an i/o error occurs, we go back
to reading/writing a single page, so that we can eventually track down which
page(s) really can't be read/written. */

/* try to find wired work area */

	temp_seg_ptr = null;
	call get_temp_segment_ (Me, temp_seg_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Unable to get temp disk buffer.");
	     return;
	end;

	temp_astep = get_ptrs_$given_segno (segno (temp_seg_ptr));
	call pc_abs$wire_abs_contig (temp_astep, 0, 3, code);
	if code ^= 0 then do;
	     call com_err_ (code, Me, "Unable to wire temp disk buffer.");
	     call release_temp_segment_ (Me, temp_seg_ptr, code);
	     return;
	end;

	on cleanup call clean_up;			/* remember, this is only called during bce_check_abort */

	if write_sw then do page_num = 0 to 2;
	     bootload_disk_buffer (page_num) = pattern.pattern_buffer;
	end;

	prev_record = l_record + 1;
	prev_record_in_cylinder = mod (prev_record, rec_per_cyl (device_type));
	do while (prev_record > f_record);		/* stop when processed lowest record */
	     if prev_record_in_cylinder = 0 then prev_record_in_cylinder = rec_per_cyl (device_type); /* next cylinder */
	     records_this_cylinder = min (prev_record_in_cylinder, 3); /* num pages to do this time around */
	     new_record = max (prev_record - records_this_cylinder, f_record); /* don't go over requested area */
	     records_this_cylinder = prev_record - new_record; /* real amt to do */

retry:	     call bce_check_abort;
	     if write_then_read then do;
		do page_num = 0 to records_this_cylinder - 1;
		     bootload_disk_buffer (page_num) = pattern.pattern_buffer;
		end;
		call bootload_disk_io$write (pvtx, new_record, records_this_cylinder, temp_seg_ptr, code);
		if code ^= 0 then do;
		     error_on_write = "1"b;
		     go to io_error;
		end;
	     end;
	     if ^write_sw then do;
		call bootload_disk_io$read (pvtx, new_record, records_this_cylinder, temp_seg_ptr, code);
		if code ^= 0 then do;
		     error_on_write = "0"b;
		     go to io_error;
		end;
	     end;
	     if read_then_write | write_sw then do;
		call bootload_disk_io$write (pvtx, new_record, records_this_cylinder, temp_seg_ptr, code);
		if code ^= 0 then do;
		     error_on_write = "1"b;
io_error:		     if records_this_cylinder > 1 then do; /* try i/o on just 1 record to find fault one */
			new_record = prev_record - 1;
			records_this_cylinder = 1;
			go to retry;
		     end;
		     else do;
			call com_err_ (0, Me, "Could not ^[write^;read^] record ^oo on ^a.", error_on_write, new_record, drive);
			go to next_record;
		     end;
		end;
	     end;
	     if write_then_read then
		do page_num = 0 to records_this_cylinder - 1;
		if bootload_disk_buffer (page_num) ^= pattern.pattern_buffer then
		     call ioa_ ("^a: What was read did not match what was written at record ^oo of ^a.", Me, new_record + page_num, drive);
	     end;

next_record:   prev_record = new_record;
	     prev_record_in_cylinder = prev_record_in_cylinder - records_this_cylinder;
	end;

	call clean_up;
	return;

clean_up: proc;

	call pc_abs$unwire_abs (temp_astep, 0, 3);
	call release_temp_segment_ (Me, temp_seg_ptr, code);
	return;
     end;
%page;
pattern_parse: proc (arg_list_ptr, arg_num, info_ptr, code);

/* called by bce_parse_disk_spec when it doesn't like something,
most likely a pattern spec */

dcl  arg_list_ptr			ptr parameter;
dcl  arg_num			fixed bin parameter;
dcl  code				fixed bin (35) parameter;
dcl  info_ptr			ptr parameter;

dcl  number			fixed bin (35);

	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);
	call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	if arg = "-force" | arg = "-fc" then force = "1"b;
	else if arg = "-pattern" | arg = "-pat" then do;
	     pattern.word_pattern_len = 0;
	     if key = "rw" | key = "r" then do;
		code = error_table_$bad_arg;
		call com_err_ (code, Me, "-pattern is incompatible with the ^a key.", key);
		return;
	     end;
next_word:     arg_num = arg_num + 1;
	     if arg_num > arg_count then go to end_pattern;
	     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, arg_list_ptr);
	     number = cv_oct_check_ (arg, code);
	     if code ^= 0 then do;			/* not a number */
		arg_num = arg_num - 1;		/* most likely a new control arg */

end_pattern:	if pattern.word_pattern_len ^= 0 then code = 0;
		else do;				/* pattern spec missing */
		     code = error_table_$noarg;
		     call com_err_ (code, Me, "pattern");
		end;
		return;
	     end;
	     else do;
		addrel (pattern_buffer_ptr, pattern.word_pattern_len) -> word = unspec (number);
		pattern.word_pattern_len = pattern.word_pattern_len + 1;
		goto next_word;
	     end;
	end;
	else do;
	     code = error_table_$bad_arg;
	     call com_err_ (code, Me, "^a", arg);
	     return;
	end;
	code = 0;
	return;
     end pattern_parse;
%page; %include bce_subsystem_info_;
%page; %include disk_pack;
%page; %include fs_dev_types;
%page; %include fs_vol_label;
%page; %include pvt;
%page; %include pvte;
     end bce_test_disk;




		    bootload_fs_cmds_.pl1           11/11/89  1134.3r w 11/11/89  0826.3      103014



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bootload_fs_cmds_: proc; return;

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

/* Bootload multics commands to directly operate on bootload fs objects. 
Initially coded March 1983 by Keith Loepere 
Modified August 1983 by Keith Loepere for new bce switches */
%include bce_subsystem_info_;
%include bootload_fs_list;
dcl  active		        bit (1) aligned;	/* called as an active function */
dcl  active_fnc_err_	        entry options (variable);
dcl  arg			        char (arg_len) based (arg_ptr);
dcl  arg2			        char (arg_len2) based (arg_ptr2);
dcl  arg_count		        fixed bin;
dcl  arg_len		        fixed bin (21);
dcl  arg_len2		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  arg_ptr2		        ptr;
dcl  bce_data$put_chars	        entry (ptr, ptr, fixed bin, fixed bin (35)) ext variable;
dcl  bce_query$yes_no	        entry options (variable);
dcl  bootload_file_partition$	        external;
dcl  bootload_fs_$get_ptr	        entry (char (*), ptr, fixed bin (21), fixed bin (35));
dcl  bootload_fs_$delete	        entry (char (*), fixed bin (35));
dcl  bootload_fs_$init	        entry (bit (1) aligned, fixed bin (19), fixed bin (35));
dcl  bootload_fs_$list	        entry (area (*), ptr, fixed bin (35));
dcl  bootload_fs_$rename	        entry (char (*), char (*), fixed bin (35));
dcl  check_star_name_$entry	        entry (char (*), fixed bin (35));
dcl  code			        fixed bin (35);
dcl  com_err_		        entry options (variable);
dcl  cu_$af_return_arg_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$arg_count_rel	        entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  dseg$		        (0:511) bit (72) aligned external;
dcl  error		        entry options (variable) variable; /* who prints our error */
dcl  error_table_$bad_arg	        fixed bin (35) ext static;
dcl  error_table_$bad_equal_name      fixed bin (35) ext static;
dcl  error_table_$badstar	        fixed bin (35) ext static;
dcl  error_table_$noentry	        fixed bin (35) ext static;
dcl  error_table_$not_act_fnc	        fixed bin (35) ext static;
dcl  file			        char (file_len) based (file_ptr); /* to be printed */
dcl  file_found		        bit (1) aligned;	/* a file matched the current star name */
dcl  file_len		        fixed bin (21);
dcl  file_num		        fixed bin;		/* loop index */
dcl  file_ptr		        ptr;
dcl  get_equal_name_	        entry (char (*), char (*), char (32), fixed bin (35));
dcl  get_equal_name_$check_equal_name_ entry (char (*), fixed bin (35));
dcl  i			        fixed bin;		/* loop index */
dcl  ioa_			        entry options (variable);
dcl  length		        builtin;
dcl  match_star_name_	        entry (char (*), char (*), fixed bin (35));
dcl  me			        char (12);
dcl  my_area		        area (2048);	/* for listing files */
dcl  new_name		        char (32);		/* for renaming */
dcl  request_abort_		        condition;		/* abort command line */
dcl  result		        char (result_len) based (result_ptr) var; /* active function result */
dcl  result_len		        fixed bin (21);
dcl  result_ptr		        ptr;
dcl  sdw_util_$get_size	        entry (ptr, fixed bin (19));
dcl  seg_size		        fixed bin (19);	/* of initted partition */
dcl  yes_no		        bit (1);

init: entry (ss_info_ptr);

	me = "init_files";
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     signal request_abort_;
	end;
	if arg_count = 0 then do;
	     call bce_query$yes_no (yes_no, "Do you really want to initialize the bootload file system? ");
	     if ^yes_no then go to TERMINATE;
	end;
	else if arg_count > 1 then do;
	     call com_err_ (0, me, "Usage is: ^a {-force | -fc}", me);
	     go to TERMINATE;
	end;
	else do;
	     call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     if ^(arg = "-force" | arg = "-fc") then do;
		call com_err_ (error_table_$bad_arg, me, "^a", arg);
		go to TERMINATE;
	     end;
	end;

	call sdw_util_$get_size (addr (dseg$ (segno (addr (bootload_file_partition$)))), seg_size);
	call bootload_fs_$init ("1"b, seg_size, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     go to TERMINATE;
	end;
	return;

print: entry (ss_info_ptr);

	me = "print";
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     signal request_abort_;
	end;
	if arg_count ^= 1 then do;
	     call com_err_ (0, me, "Usage is: ^a <file_name>.", me);
	     go to TERMINATE;
	end;
	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	call bootload_fs_$get_ptr (arg, file_ptr, file_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, me, "^a", arg);
	     go to TERMINATE;
	end;
	call bce_data$put_chars (addr (bce_data$put_chars), file_ptr, (file_len), code);
	return;

list: entry (ss_info_ptr);

	me = "list";
	call cu_$af_return_arg_rel (arg_count, result_ptr, result_len, code, ss_info.arg_list_ptr);
	if code = error_table_$not_act_fnc then do;
	     active = "0"b;
	     error = com_err_;
	     call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	end;
	else do;
	     active = "1"b;
	     error = active_fnc_err_;
	     result = "";
	end;
	if code ^= 0 then do;
	     call error (code, me);
	     signal request_abort_;
	end;
	if active & arg_count < 1 then do;
	     call error (0, me, "Usage: [^a <star_names>]", me);
	     go to TERMINATE;
	end;
	do i = 1 to arg_count;			/* validate starnames */
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     call check_star_name_$entry (arg, code);
	     if code = error_table_$badstar then do;
		call com_err_ (code, me, "^a", arg);
		go to TERMINATE;
	     end;
	end;
	call bootload_fs_$list (my_area, bootload_fs_list_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$noentry then do;
		if active then result = "";
		else call ioa_ ("No files.");
		return;
	     end;
	     else do;
		call error (code, me);
		go to TERMINATE;
	     end;
	end;
	if ^ active then call ioa_ ("Length^-File Name^/");
	file_found = "0"b;
	do i = min (1, arg_count) to arg_count;		/* zero pass => ** for 0 args */
	     if i > 0 then call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     do file_num = 1 to bootload_fs_list.n_files; /* match all unmatched file names against current star name */
		if i > 0 & (bootload_fs_list.files (file_num).name ^= "") then call match_star_name_ (bootload_fs_list.files (file_num).name, arg, code);
		else code = 0;
		if code = 0 then do;
		     if active then result = result || bootload_fs_list.files (file_num).name || " ";
		     else do;
			call ioa_ ("^6d^-^a", bootload_fs_list.files (file_num).length,
			     bootload_fs_list.files (file_num).name);
		     end;
		     bootload_fs_list.files (file_num).name = ""; /* don't list again */
		     file_found = "1"b;
		end;
	     end;
	end;
	if active & file_found then result = substr (result, 1, length (result) - 1); /* extraneous trailing blank */
	if ^active & ^file_found then call ioa_ ("No such file(s).");
	return;

delete: entry (ss_info_ptr);

	me = "delete";
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     signal request_abort_;
	end;
	if arg_count = 0 then do;
	     call com_err_ (0, me, "Usage is: ^a <star names>", me);
	     go to TERMINATE;
	end;
	do i = 1 to arg_count;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     call check_star_name_$entry (arg, code);
	     if code = error_table_$badstar then do;
		call com_err_ (code, me, "^a", arg);
		go to TERMINATE;
	     end;
	end;
	call bootload_fs_$list (my_area, bootload_fs_list_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$noentry then call ioa_ ("No files.");
	     else call com_err_ (code, me, "Getting file list.");
	     go to TERMINATE;
	end;
	do i = 1 to arg_count;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     file_found = "0"b;
	     do file_num = 1 to bootload_fs_list.n_files;
		if bootload_fs_list.files (file_num).name ^= "" then call match_star_name_ (bootload_fs_list.files (file_num).name, arg, code);
		if code = 0 then do;
		     call bootload_fs_$delete (bootload_fs_list.files (file_num).name, code);
		     if code ^= 0 then call com_err_ (code, me, "^a", bootload_fs_list.files (file_num).name);
		     bootload_fs_list.files (file_num).name = ""; /* don't delete again */
		     file_found = "1"b;
		end;
	     end;
	     if ^file_found then call com_err_ (0, me, "File(s) not found. ^a", arg);
	end;
	return;

rename: entry (ss_info_ptr);

	me = "rename";
	call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     signal request_abort_;
	end;
	if arg_count = 0 | mod (arg_count, 2) ^= 0 then do;
	     call com_err_ (0, me, "Usage is: ^a <old_file_name> <new_file_name> {<old_file_name> <new_file_name> ...}", me);
	     go to TERMINATE;
	end;
	do i = 2 to arg_count by 2;
	     call cu_$arg_ptr_rel (i - 1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     call check_star_name_$entry (arg, code);
	     if code = error_table_$badstar then do;
		call com_err_ (code, me, "^a", arg);
		go to TERMINATE;
	     end;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     call get_equal_name_$check_equal_name_ (arg, code);
	     if code = error_table_$bad_equal_name then do;
		call com_err_ (code, me, "^a", arg);
		go to TERMINATE;
	     end;
	end;
	call bootload_fs_$list (my_area, bootload_fs_list_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$noentry then call ioa_ ("No files.");
	     else call com_err_ (code, me, "Getting file list.");
	     go to TERMINATE;
	end;
	do i = 2 to arg_count by 2;
	     call cu_$arg_ptr_rel (i - 1, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     call cu_$arg_ptr_rel (i, arg_ptr2, arg_len2, code, ss_info.arg_list_ptr);
	     file_found = "0"b;
	     do file_num = 1 to bootload_fs_list.n_files;
		if bootload_fs_list.files (file_num).name ^= "" then call match_star_name_ (bootload_fs_list.files (file_num).name, arg, code);
		if code = 0 then do;
		     call get_equal_name_ (bootload_fs_list.files (file_num).name, arg2, new_name, code);
		     if code ^= 0 then go to rename_error;
		     call bootload_fs_$rename (bootload_fs_list.files (file_num).name, new_name, code);
		     if code ^= 0 then 
rename_error:		call com_err_ (code, me, "^a to ^a", bootload_fs_list.files (file_num).name, new_name);
		     bootload_fs_list.files (file_num).name = ""; /* don't rename again */
		     file_found = "1"b;
		end;
	     end;
	     if ^file_found then call com_err_ (0, me, "File(s) not found. ^a", arg);
	end;
	return;

TERMINATE:
	return;
     end;




		    bootload_qedx.pl1               11/11/89  1134.3r w 11/11/89  0826.3       90423



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

/* format: off */

/* bootload Multics qedx Editor command interface */

/* Created:  April 1983 by Keith Loepere from
January 1983 creation by G. Palter as part of implementation of qedx_ subroutine interface */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


bootload_qedx:
     procedure (ss_info_ptr);


dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_ptr pointer;
dcl  argument_lth fixed binary (21);
dcl  (n_arguments, argument_idx) fixed binary;

dcl  input_filename character (32);
dcl  input_file_ptr pointer;

dcl  exec_filename character (32);
dcl  exec_buffer_lth fixed binary (21);
dcl  exec_buffer_ptr pointer;

dcl  args_buffer character (args_buffer_lth) based (args_buffer_ptr);
dcl  args_buffer_lth fixed bin (21);
dcl  args_buffer_used fixed binary (21);
dcl  args_buffer_ptr ptr;

dcl  1 local_qi aligned,				/* describes how we want the invocation setup */
       2 header like qedx_info.header,
       2 buffers (6) like qedx_info.buffers;		/* 0, 1, 2, 3, exec, args */

dcl  ok_to_continue bit (1) aligned;

dcl  (no_rw_path, have_pathname, have_macro_pathname, have_macro_arguments) bit (1) aligned;

dcl  idx fixed binary;
dcl  code fixed binary (35);

dcl  invocation_level fixed binary static initial (0);	/* # of active invocations of qedx */

dcl  NL character (1) static options (constant) initial ("
");

dcl  QEDX character (32) static options (constant) initial ("bootload_qedx");

						/* format: off */
dcl (error_table_$badopt, error_table_$bigarg, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args)
	fixed binary (35) external;
dcl  sys_info$max_seg_size fixed bin (18) static external;

/* format: on */

dcl  bootload_fs_$get_ptr entry (char (*), ptr, fixed bin (21), fixed bin (35));
dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  qedx_ entry (pointer, fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  (cleanup, request_abort_) condition;

dcl  (divide, length, index, null, segno, substr, string) builtin;
%page;
/* bootload_qedx: procedure (ss_info_ptr); */

	call cu_$arg_count_rel (n_arguments, ss_info.arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, QEDX);
	     signal request_abort_;
	end;

	if invocation_level > 0 then do;		/* it would be nice to eliminate this... */
	     call com_err_ (0, QEDX, "A suspended invocation is somehow on the stack.");
	     return;
	end;

	invocation_level = invocation_level + 1;	/* another qedx */

	input_file_ptr,				/* for cleanup handler */
	     exec_buffer_ptr, args_buffer_ptr = null ();

	on condition (cleanup) call cleanup_qedx_invocation ();


/* format: off */

/* Process arguments: syntax of the qedx command is --

      qedx {-control_args} {macro_path {macro_arguments}} */

/* format: on */

	no_rw_path,				/* allow r/w with pathnames and R/W */
	     have_pathname,				/* haven't seen -pathname yet */
	     have_macro_pathname,			/* haven't seen first non-control argument yet */
	     have_macro_arguments = "0"b;		/* haven't seen any macro arguments */

	do argument_idx = 1 to n_arguments;

	     call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, ss_info.arg_list_ptr);
	     if code ^= 0 then do;			/* sigh */
		call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
		go to RETURN_FROM_QEDX;
	     end;

	     if ^have_macro_pathname then		/* no non-control argument yet: can still accept -ca's */
		if index (argument, "-") = 1 then	/* ... a control argument */
		     if argument = "-no_rw_path" then no_rw_path = "1"b;
		     else if argument = "-rw_path" then no_rw_path = "0"b;

		     else if (argument = "-pathname") | (argument = "-pn") then
			if have_pathname then do;
			     call com_err_ (error_table_$too_many_args, QEDX,
				"""-pathname"" may only be specified once for this command.");
			     go to RETURN_FROM_QEDX;
			end;
			else do;			/* initial contents for buffer 0 ... */
			     have_pathname = "1"b;
			     if argument_idx = n_arguments then do;
				call com_err_ (error_table_$noarg, QEDX, "Pathname after ""^a"".", argument);
				go to RETURN_FROM_QEDX;
			     end;
			     argument_idx = argument_idx + 1;
			     call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code,
				ss_info.arg_list_ptr);
			     if code ^= 0 then do;
				call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
				go to RETURN_FROM_QEDX;
			     end;
			     input_filename = argument;
			     call bootload_fs_$get_ptr (argument, input_file_ptr, (0), code);
			     if code ^= 0 then do;	/* the file doesn't exist (sigh) */
				call com_err_ (code, QEDX, "-pathname ^a", argument);
				go to RETURN_FROM_QEDX;
			     end;
			     input_file_ptr = null ();
			end;

		     else do;
			call com_err_ (error_table_$badopt, QEDX, """^a""", argument);
			go to RETURN_FROM_QEDX;
		     end;

		else do;				/* first non-control argument: macro pathname */
		     have_macro_pathname = "1"b;
		     if index (reverse (rtrim (argument)), "xdeq.") = 1 then
			exec_filename = argument;
		     else exec_filename = rtrim (argument) || ".qedx";
		     call bootload_fs_$get_ptr (exec_filename, exec_buffer_ptr, exec_buffer_lth, code);
		     if code ^= 0 then do;		/* the file doesn't exist (sigh) */
			call com_err_ (code, QEDX, "Macro file: ^a", exec_filename);
			go to RETURN_FROM_QEDX;
		     end;
		end;

	     else do;				/* Nth non-control argument: a macro argument */
		if ^have_macro_arguments then do;	/* ... first macro argument */
		     call get_temp_segment_ (QEDX, args_buffer_ptr, code);
		     if code ^= 0 then do;
			call com_err_ (code, QEDX, "Obtaining buffer space for macro arguments");
			go to RETURN_FROM_QEDX;
		     end;
		     args_buffer_lth = sys_info$max_seg_size * 4;
		     args_buffer_used = 0;
		     have_macro_arguments = "1"b;
		end;
		call add_to_args_buffer (argument);
		call add_to_args_buffer (NL);
	     end;
	end;

	if no_rw_path & ^have_pathname then do;
	     call com_err_ (error_table_$inconsistent, QEDX, """-no_rw_path"" must be used with ""-pathname"".");
	     go to RETURN_FROM_QEDX;
	end;


/* Arguments have been validated: setup qedx_info data structure and invoke qedx_ */

	local_qi.header.version = QEDX_INFO_VERSION_1;
	local_qi.header.editor_name = QEDX;

	string (local_qi.header.flags) = ""b;
	local_qi.header.no_rw_path = no_rw_path;
	local_qi.header.query_if_modified = "1"b;	/* finally after all these years ... */

	local_qi.header.n_buffers = 0;		/* no initial buffers yet */

	if have_pathname then do;			/* include a buffer 0 containing requested file ... */
	     local_qi.header.n_buffers, idx = 1;
	     local_qi.buffers (idx).buffer_name = "0";
	     local_qi.buffers (idx).buffer_pathname = input_filename;
	     string (local_qi.buffers (idx).flags) = ""b;
	end;

	if have_macro_pathname then do;		/* exec buffer containing a macro to execute ... */
	     local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
	     local_qi.buffers (idx).buffer_name = "exec";
	     local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
	     local_qi.buffers (idx).region_ptr = exec_buffer_ptr;
	     local_qi.buffers (idx).region_max_lth,	/* ... get size from the system */
		local_qi.buffers (idx).region_initial_lth = exec_buffer_lth;
	     string (local_qi.buffers (idx).flags) = ""b;
	     local_qi.buffers (idx).read_write_region, local_qi.buffers (idx).execute_buffer = "1"b;
	end;					/* ... get initial content from us but can't write back */

	if have_macro_arguments then do;		/* a "file" of arguments to the macro ... */
	     local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
	     local_qi.buffers (idx).buffer_name = "args";
	     local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
	     local_qi.buffers (idx).region_ptr = args_buffer_ptr;
	     local_qi.buffers (idx).region_max_lth, local_qi.buffers (idx).region_initial_lth = args_buffer_used;
	     string (local_qi.buffers (idx).flags) = ""b;
	     local_qi.buffers (idx).read_write_region = "1"b;
	end;					/* ... get initial content from us but can't write back */


	call qedx_ (addr (local_qi), code);		/* INVOKE THE EDITOR */


RETURN_FROM_QEDX:
	call cleanup_qedx_invocation ();

	return;
%page;
/* Add a character string to the macro arguments buffer */

add_to_args_buffer:
     procedure (p_string);

dcl  p_string character (*) parameter;

	if (args_buffer_used + length (p_string)) > length (args_buffer) then do;
	     call com_err_ (error_table_$bigarg, QEDX, "Too many macro arguments.  First failing argument: ""^a"".", argument);
	     go to RETURN_FROM_QEDX;
	end;

	substr (args_buffer, (args_buffer_used + 1), length (p_string)) = p_string;
	args_buffer_used = args_buffer_used + length (p_string);

	return;

     end add_to_args_buffer;



/* Cleanup after an invocation of qedx */

cleanup_qedx_invocation:
     procedure ();

	if args_buffer_ptr ^= null () then do;
	     call release_temp_segment_ (QEDX, args_buffer_ptr, (0));
	     args_buffer_ptr = null ();
	end;

	invocation_level = invocation_level - 1;	/* all gone */

	return;

     end cleanup_qedx_invocation;
%page;
%include qedx_info;
%page;
%include access_mode_values;
%page;
%include bce_subsystem_info_;

     end bootload_qedx;




		    config_deck_edit_.pl1           11/11/89  1134.3r w 11/11/89  0826.3       88488



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
config_deck_edit_: proc (ss_info_ptr);

/* Program to use qedx_ to edit config decks.  config_deck_parse_ is used for 
ascii/binary conversions.
  
       In the ascii form, each field is considered to be of two types, 
labeled and unlabeled.  Labeled fields are fields preceeded by a label, 
such as "-port 7" ("-port" is the label; "7" is the value).  Unlabeled 
fields are fields not so labeled; the config card name is considered the 
first of these.  Normal text editing operations are performed on this 
source form within qedx_.  Writing the config deck out performs a per card
validity check in the process of conversion to binary form.

      Buffer 0 is wired (default path set) to <config deck>.  Reads and 
writes without a pathname operate on the binary config deck. */

/* Initially coded February 1983 by Keith Loepere */
/* Modified August 1983 by Keith Loepere for new bce switches */
/* Modified November 1983 by Keith Loepere to use qedx_. */
/* Modified March 1984 by Keith Loepere to accept a command line deck name */
/* Modified January 1985 by Keith Loepere to run at crash time. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  NL			        char (1) static options (constant) init ("
");
dcl  addr			        builtin;
dcl  arg			        char (arg_lth) based (arg_ptr);
dcl  arg_count		        fixed bin;
dcl  arg_lth		        fixed bin (21);
dcl  arg_ptr		        ptr;
dcl  bootload_fs_$get	        entry (char (*), ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  bootload_fs_$get_ptr	        entry (char (*), ptr, fixed bin (21), fixed bin (35));
dcl  bootload_fs_$put	        entry (char (*), ptr, fixed bin (21), bit (1) aligned, fixed bin (35));
dcl  code			        fixed bin (35);
dcl  com_err_		        entry () options (variable);
dcl  config_deck_parse_$ascii_to_binary entry (char (256) var, ptr, fixed bin);
dcl  config_deck_parse_$binary_to_ascii entry (ptr, char (256) var);
dcl  cu_$arg_count_rel	        entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel	        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  disk_config_deck$	        (4096) bit (36) aligned external static;
dcl  error_table_$recoverable_error   fixed bin (35) ext static;
dcl  get_ptrs_$given_segno	        entry (fixed bin (15)) returns (pointer);
dcl  index		        builtin;
dcl  ioa_			        entry () options (variable);
dcl  length		        builtin;
dcl  me			        char (11) static options (constant) init ("config_edit");
dcl  null			        builtin;
dcl  1 my_qedx_info		        aligned,
       2 header		        like qedx_info.header,
       2 buffers		        (1) like qedx_info.buffers;
dcl  pc_wired$write_wait	        entry (pointer, fixed bin, fixed bin);
dcl  qedx_		        entry (ptr, fixed bin (35));
dcl  segno		        builtin;
dcl  string		        builtin;
dcl  substr		        builtin;
dcl  sys_boot_info$config_has_been_modified bit (1) aligned external static;
%page;
	if ss_info_ptr ^= null () then do;
	     call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	     if code ^= 0 then go to TERMINATE;		/* active function? */
	end;
	else arg_count = 0;
	if arg_count > 1 then do;
	     call ioa_ ("Usage is: config_edit {file_name}");
	     go to TERMINATE;
	end;

	else if arg_count = 1 then begin;

dcl  buffer_lth		        fixed bin (21);
dcl  buffer_ptr		        ptr;

	     call cu_$arg_ptr_rel (1, arg_ptr, arg_lth, code, ss_info.arg_list_ptr);
	     call bootload_fs_$get_ptr (arg, buffer_ptr, buffer_lth, code);
	     if code ^= 0 then do;
		call com_err_ (code, me, "^a", arg);
		go to TERMINATE;
	     end;
	     call write_config_deck (buffer_ptr, buffer_lth);
	     return;
	end;

/* Enter config deck editor */

	config_max_cards, config_n_cards = 256;
	qedx_info_ptr = addr (my_qedx_info);
	qedx_info.header.version = QEDX_INFO_VERSION_1;
	qedx_info.editor_name = me;
	qedx_info.buffer_io = config_deck_io;
	string (qedx_info.header.flags) = ""b;
	qedx_info.header.query_if_modified = "1"b;
	qedx_info.caller_does_io = "1"b;
	qedx_info.n_buffers = 1;
	qedx_info.buffers (1).buffer_name = "0";
	qedx_info.buffers (1).buffer_pathname = "<config deck>";
	string (qedx_info.buffers (1).flags) = ""b;
	qedx_info.buffers (1).locked_pathname, qedx_info.buffers (1).default_read_ok, qedx_info.buffers (1).default_write_ok = "1"b;

	call qedx_ (qedx_info_ptr, code);
	if code ^= 0 then
	     if code ^= error_table_$recoverable_error then call com_err_ (code, me, "from qedx_");
TERMINATE:
	return;
%page;
config_deck_io: proc (qedx_buffer_io_info_ptr, io_okay) options (non_quick);

/* The routine to fetch data from ascii files.  It also knows how to read
and write the binary config deck. */

dcl  io_okay		        bit (1) aligned parameter; /* read or write successful */
dcl  qedx_buffer_io_info_ptr	        ptr parameter;

	qbii_ptr = qedx_buffer_io_info_ptr;
	if qedx_buffer_io_info.version ^= QEDX_BUFFER_IO_INFO_VERSION_1 then do;
	     call com_err_ (0, me, "Incorrect version of qedx_buffer_io_info supplied.");
	     go to TERMINATE;
	end;
	if qedx_buffer_io_info.pathname ^= "<config deck>" then do;
	     if qedx_buffer_io_info.direction = QEDX_READ_FILE then
		call bootload_fs_$get (qedx_buffer_io_info.pathname, qedx_buffer_io_info.buffer_ptr, qedx_buffer_io_info.buffer_max_lth, qedx_buffer_io_info.buffer_lth, code);
	     else call bootload_fs_$put (qedx_buffer_io_info.pathname, qedx_buffer_io_info.buffer_ptr, qedx_buffer_io_info.buffer_lth, "0"b, code);
	     if code ^= 0 then call com_err_ (code, me, "^a", qedx_buffer_io_info.pathname);
	     io_okay = (code = 0);
	end;
	else do;
	     if qedx_buffer_io_info.direction = QEDX_READ_FILE then do;
		call read_config_deck (qedx_buffer_io_info.buffer_ptr, qedx_buffer_io_info.buffer_max_lth, qedx_buffer_io_info.buffer_lth);
		io_okay = "1"b;
	     end;
	     else if sys_info$collection_1_phase = CRASH_INITIALIZATION then do;
		     call com_err_ (0, me, "The config deck cannot be modified with a saved crash image present.");
		     io_okay = "0"b;
		end;
		else do;
		     call write_config_deck (qedx_buffer_io_info.buffer_ptr, qedx_buffer_io_info.buffer_lth);
		     io_okay = "1"b;
		end;
	end;
	return;
     end;
%page;
read_config_deck: proc (buffer_ptr, buffer_max_lth, buffer_lth);

/* read in the current config deck into the area supplied by qedx */

dcl  ascii_config_card	        char (256) var;
dcl  buffer		        char (buffer_max_lth) based (buffer_ptr);
dcl  buffer_max_lth		        fixed bin (21) parameter;
dcl  buffer_lth		        fixed bin (21) parameter;
dcl  buffer_ptr		        ptr parameter;
dcl  cards_to_read		        fixed bin;
dcl  config_card_num	        fixed bin;		/* counter to card */

	configp = addr (disk_config_deck$);		/* using real deck easy */
	config_max_cards, config_n_cards = 256;
	do config_card_num = 1 to 256 while (config_deck.cards (config_card_num).word ^= FREE_CARD_WORD);
	end;					/* found last true card */
	cards_to_read = config_card_num - 1;

/* here we convert the config deck to an ascii form */

	buffer_lth = 0;
	do config_card_num = 1 to cards_to_read;
	     cardp = addr (config_deck.cards (config_card_num));
	     call config_deck_parse_$binary_to_ascii (cardp, ascii_config_card);
	     if buffer_lth + length (ascii_config_card) + 1 /* nl */ > buffer_max_lth then do;
		call com_err_ (0, me, "Converted config deck does not fit in file.");
		return;
	     end;
	     substr (buffer, buffer_lth + 1, length (ascii_config_card)) = ascii_config_card;
	     buffer_lth = buffer_lth + length (ascii_config_card) + 1;
	     substr (buffer, buffer_lth, 1) = NL;
	end;
	return;
     end;
%page;
write_config_deck: proc (buffer_ptr, buffer_lth);

/* Convert the supplied ascii text into a binary deck. */

dcl  ascii_config_card	        char (256) var;
dcl  buffer		        char (buffer_lth) based (buffer_ptr);
dcl  buffer_lth		        fixed bin (21) parameter;
dcl  buffer_pos		        fixed bin (21);	/* starting pos in buffer for this new line */
dcl  buffer_ptr		        ptr parameter;
dcl  card_len		        fixed bin (21);	/* length of text in card (minus nl) */
dcl  output_card_num	        fixed bin;

	configp = addr (disk_config_deck$);
	sys_boot_info$config_has_been_modified = "1"b;

	config_max_cards, config_n_cards = 256;
	output_card_num = 0;
	buffer_pos = 1;
	do while (buffer_pos <= buffer_lth);
	     output_card_num = output_card_num + 1;
	     cardp = addr (config_deck.cards (output_card_num));
	     card_len = index (substr (buffer, buffer_pos), NL);
	     if card_len = 0 then card_len = buffer_lth - buffer_pos + 1;
	     else card_len = card_len - 1;
	     ascii_config_card = substr (buffer, buffer_pos, card_len);
	     buffer_pos = buffer_pos + card_len + 1;
	     call config_deck_parse_$ascii_to_binary (ascii_config_card, cardp, output_card_num);
	end;
	do output_card_num = output_card_num + 1 to config_max_cards; /* blank out rest of deck */
	     config_deck.cards (output_card_num).word = FREE_CARD_WORD;
	end;

/*	call total_config_deck_check;  */

	call pc_wired$write_wait (get_ptrs_$given_segno (segno (addr (disk_config_deck$))), 0, 4); /* save on disk */
	return;
     end;
%page; %include bce_subsystem_info_;
%page; %include collection_1_phases;
%page; %include config_deck;
%page; %include qedx_buffer_io_info;
%page; %include qedx_info;
     end;




		    init_clocks.pl1                 12/11/99  1838.0r w 12/11/99  1815.0       81639



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
/* INIT_CLOCKS -- read time string from operator, set all clocks */
/* format: style2 */
/* BIM 10/82 */
/* Modified 2/83 by Keith Loepere to use bce_command_processor_ and
     environment */
/* Modified 6/83 by Keith Loepere so operator doesn't have to enter time. */
/* Modified 4/84 by Keith Loepere for simplification */
/* Modified 7/84 by J Falksen for new date/time software */
/* Modified 1/85 by Keith Loepere to check RPV time unmounted. */
/* Modified 1/85 by Keith Loepere to not set date/time defaults and to use
     time_info_ to automatically set delta given a zone. */



/****^  HISTORY COMMENTS:
  1) change(86-12-04,Fawcett), approve(86-12-17,MECR0006),
     audit(86-12-12,GDixon), install(86-12-17,MR12.0-1250):
     Changed to call date_time_$set_time_defaults. If the operator inputs
     a new time string with a time zone the correct time will set.
  2) change(87-01-08,Fawcett), approve(87-01-08,MCR7600),
     audit(87-01-13,GJohnson), install(87-01-13,MR12.0-1270):
     This closes MECR0006.
  3) change(99-06-23,Haggett):
     Y2K
                                                   END HISTORY COMMENTS */


init_clocks:
     procedure (success);

/* Parameters */

	declare success		 bit (1) aligned parameter;

/* Constants */

	declare me		 char (11) init ("init_clocks") static options (constant);
	declare time_format		 char (41) int static options (constant)
				 init ("^dn, ^mn ^Z9dm, ^9999yc ^Z9Hd:^MH:^SM ^za");

/* Entries */

	declare bce_query		 entry options (variable);
	declare bce_query$yes_no	 entry options (variable);
	declare com_err_		 entry options (variable);
	declare convert_date_to_binary_
				 entry (char (*), fixed bin (71), fixed bin (35));
	declare date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
	declare date_time_$set_time_defaults
				 entry ();
	declare ioa_		 entry () options (variable);
	declare privileged_mode_ut$sscr
				 entry (fixed bin (3), fixed bin (6), fixed bin (71));
	declare read_disk		 entry (fixed bin, fixed bin, ptr, fixed bin (35));

/* Variables */

	declare TIME		 fixed bin (71);
	declare bootload_scu	 fixed bin (3);
	declare code		 fixed bin (35);
	declare line		 char (80);
	declare time_correction	 fixed bin (71);
	declare time_string		 char (64) var;
	declare zone		 char (4);
	declare 1 rpv_label		 aligned like label;

/* External */

	declare disk_config_deck$	 external static;
	declare pvt$root_pvtx	 fixed bin external static;
	declare sys_info$clock_	 bit (3) aligned external static;
	declare sys_info$first_reasonable_time
				 fixed bin (71) external static;
	declare sys_info$last_reasonable_time
				 fixed bin (71) external static;
	declare sys_info$time_correction_constant
				 fixed bin (71) aligned external static;
	declare sys_info$time_zone	 char (4) aligned external static;

/* Misc */

	declare (addr, addrel, bin, clock, divide, fixed, hbound, lbound, rtrim, size, substr, unspec)
				 builtin;
%page;
	success = "0"b;

	call find_zone;				/* zone defined by current clock "card" */

	bootload_scu = fixed (sys_info$clock_, 3);

	TIME = clock ();

	call read_rpv_label ();
	time_string = date_time_$format (time_format, label.time_unmounted, zone, "");
	call ioa_ ("Multics Y2K.  System was last shudown/ESD at:^/^a", time_string);

	call check_time;
	line = "xxx";
	do while (^(line = "n" | line = "no"));
	     call bce_query (line, "Is this correct? ");
	     if line = "y" | line = "yes"
	     then do;
		     call set_defaults;		/* if things were correct set the date_time defaults */
		     call check_rpv;
		     success = "1"b;
		     return;
		end;
	     else if line = "abort"
	     then return;
	end;

CHECK_TIME:
	call bce_query (line, "Enter time: ");
	if line = "abort"
	then do;
ABORT:
		success = "0"b;
		return;
	     end;

	call set_defaults;

	call convert_date_to_binary_ (line, TIME, code);

	if code ^= 0
	then do;					/* Operator's time string invalid?		*/
		call com_err_ (code, me, "^a", rtrim (line));
		go to CHECK_TIME;
	     end;

	if scs$controller_data (bootload_scu).type < "0010"b
	then do;					/* help out operator */
		call ioa_ ("SCU Switches (octal): ^w ^w", substr (unspec (TIME), 1, 36), substr (unspec (TIME), 37));

		call bce_query (line, "Enter anything after the switches have been set. ");
		TIME = clock ();
	     end;

	call check_time;
	line = "xxx";
	do while (^(line = "n" | line = "no"));
	     call bce_query (line, "Is this correct? ");
	     if line = "y" | line = "yes"
	     then do;
		     if scs$controller_data (bootload_scu).type < "0010"b
		     then ;
		     else call set_clocks;		/* set in all controllers */
		     call check_rpv;
		     success = "1"b;
		     return;
		end;
	     else if line = "abort"
	     then return;
	end;
	go to CHECK_TIME;
%page;

set_defaults:
     proc;
	sys_info$time_zone = zone;
	sys_info$time_correction_constant = time_correction;
	call date_time_$set_time_defaults ();
     end set_defaults;

set_clocks:
     proc;

	declare controllerx		 fixed bin (3);

	do controllerx = lbound (scs$controller_data, 1) to hbound (scs$controller_data, 1);
	     if bin (scs$controller_data (controllerx).type, 4) >= 0010b & scs$controller_data (controllerx).online
	     then call privileged_mode_ut$sscr (controllerx, SC_ETC, TIME);
	end;
	return;
     end;

find_zone:
     proc;

/* Find time zone, checking that it is in time_info_.
   We must do this by looking at disk_config_deck. */

	declare idx		 fixed bin;
	declare lang_index		 fixed bin;
	declare zone_index		 fixed bin;

	cardp = addr (disk_config_deck$);
	config_max_cards = divide (4096 - 1, size (config_card), 17, 0);
						/* Assume four page default */

	do idx = 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD & config_card.word ^= CLOK_CARD_WORD);
	     cardp = addrel (cardp, size (config_card));	/* on to the next card */
	end;

	if idx <= config_max_cards
	then if config_card.word = CLOK_CARD_WORD
	     then do;
		     clok_cardp = cardp;
		     zone = clok_card.zone;
		     do lang_index = 1 to ti_zone.number_lang;
			do zone_index = 1 to ti_zone.number_zone;
			     if ti_zone.short (lang_index, zone_index) = clok_card.zone
			     then go to found_zone;
			end;
		     end;
		     call com_err_ (0, me, "The zone named on the CLOK card is not in time_info_");
		     goto ABORT;
found_zone:
		     time_correction = ti_zone.delta (lang_index, zone_index);
		end;
	     else go to no_clok;
	else do;
no_clok:
		call com_err_ (0, me, "No clok card in config deck.");
		go to ABORT;
	     end;
	return;
     end;

check_time:
     proc;

	time_string = date_time_$format (time_format, TIME, zone, "");
	call ioa_ ("Current system time is: ^a.", time_string);
	if TIME <= sys_info$first_reasonable_time | TIME >= sys_info$last_reasonable_time | TIME < label.time_unmounted
	then do;
		call ioa_ ("This is clearly incorrect.");
		go to CHECK_TIME;
	     end;
	return;
     end;
%page;
check_rpv:
     proc;

/* Make sure the time is reasonable relative to the RPV time unmounted. */

	dcl     yes_no		 bit (1) aligned;

	if label.time_unmounted <= sys_info$first_reasonable_time
	     | label.time_unmounted >= sys_info$last_reasonable_time
	then return;				/* bogus label times */

	if clock () < label.time_unmounted
	then do;
		call bce_query$yes_no (yes_no,
		     "The current time is *before* the last shutdown time recorded in the RPV.
Are you sure the time is correct? ");
		if ^yes_no
		then go to CHECK_TIME;
	     end;

	if clock () > label.time_unmounted + clok_card.boot_delta * 3600 * 1000000
	then do;
		call bce_query$yes_no (yes_no, "The current time is more than the supplied boot_delta hours beyond the
unmounted time recorded in the RPV label.  Is this correct? ");
		if ^yes_no
		then go to CHECK_TIME;

		if (divide (clock () - label.time_unmounted, 3600 * 1000000, 17, 0) > 12) then do;
		     call bce_query$yes_no (yes_no, "The current time I'm using is more than 12 hours
after the last shutdown time recorded in the RPV label.
Are you sure this is correct? ");
		     if ^yes_no then
			goto CHECK_TIME;
		end;
	     end;
	return;					/* okay */
     end;
%skip;
read_rpv_label:
     proc;

	labelp = addr (rpv_label);
	call read_disk (pvt$root_pvtx, LABEL_ADDR, labelp, code);
	if code ^= 0
	then do;
		call com_err_ (code, me, "RPV label");
		go to ABORT;
	     end;
	return;

end read_rpv_label;
%page;
%include config_deck;
%page;
%include config_clok_card;
%page;
%include disk_pack;
%page;
%include fs_vol_label;
%page;
%include scr;
%page;
%include scs;
%page;
%include time_names;
     end init_clocks;




		    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
