



		    copy_erf_seg_.pl1               11/21/84  1206.5rew 11/21/84  1034.8       51165



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



/* Extract segments from a Multics dump */

/* Created:  by C. Hornig */
/* Modified: 24 February 1981 by J. A. Bush for larger fdump header size */
/* Modified: 29 December 1981 by G. Palter to not fault when asked about the same dump multiple times and to not reference
   a non-existant error code */
/* Modified: October 1984 by Greg Texada to use amu_ and change Erf to character.			*/

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


copy_erf_seg_:
     procedure (Erf, Segno, Out_ptr, Out_len, Code);


dcl  Erf char (*) parameter;				/* ERF number */

dcl  Segno fixed binary (15) unsigned parameter;		/* segment to copy out */
dcl  Segname character (*) parameter;			/* name of segment to copy out */

dcl  Out_ptr pointer parameter;			/* where to copy */
dcl  Out_len fixed binary (19) unsigned parameter;	/* how long it was */

dcl  Code fixed binary (35) parameter;

dcl  cleanup condition;

dcl  (addr, baseno, baseptr, binary, null, pointer) builtin;

dcl  amu_$fdump_mgr_init_fdump entry(char(*), ptr, ptr, fixed bin(35)),
     amu_$find_system_fdump entry (char(*), ptr, fixed bin(35)),
     amu_$terminate_translation entry (ptr),
     amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin(18), fixed bin(18), fixed bin(35)),
     amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr);

dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$truncate_seg entry (ptr, uns fixed bin (19), fixed bin (35));
dcl  ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr);
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, uns fixed bin (19), fixed bin (35));

dcl  segno uns fixed bin (15);
dcl  segname char (32);
dcl  optr ptr;
dcl  segp ptr;
dcl  sdw_hold bit (72) aligned;
dcl  seg_size uns fixed bin (19);
dcl  offset fixed bin (18);
dcl  range fixed bin (18);

/**/

/* Extract a segment by segment number */
/* copy_erf_seg_:
   entry (Erf, Segno, Out_ptr, Out_len, Code);							*/

	segno = Segno;
	segname = "";				/* flag that we ARE the number entry		*/
	goto common_amu;


/* Extract a segment by name */

name:
     entry (Erf, Segname, Out_ptr, Out_len, Code);


	segname = Segname;				/* Flag that we are the name entry		*/
common_amu:
	Code = 0;
	optr = Out_ptr;
	if Erf = "-1" then do;			/* wants data form the running system		*/
	     if Segname ^= "" then
		goto OLD_WAY_FOR_RUNNING_SYSTEM_NAME;
	     else goto OLD_WAY_FOR_RUNNING_SYSTEM_NO;

	end;
	amu_info_ptr = null ();			/* so below will make one for us		*/
	on cleanup
	     begin;
	     if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr);
	end;
	system_dump_info_ptr = addr (sdi);
	sdi.version = SYSTEM_DUMP_INFO_VERSION_1;
	sdi.dump_dir_name, sdi.dump_seg_prefix, sdi.dump_name, sdi.dump_entry_format = "";
	call amu_$find_system_fdump (Erf, system_dump_info_ptr, Code);
						/* uses the dumps search list to find		*/
	if Code ^= 0 then goto return_to_caller_amu;	/* the erf 				*/
	call amu_$fdump_mgr_init_fdump ("copy_erf_seg_", system_dump_info_ptr, amu_info_ptr, Code);
	if Code ^= 0 then goto return_to_caller_amu;
	if segname ^= "" then do;			/* name entry, get hardcore info		*/
	     call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, addr (local_hardcore));

	     call ring0_get_$segptr_given_slt ("", segname, segp, Code, local_hardcore.sltp, local_hardcore.sltntp);
	     if Code ^= 0 then goto return_to_caller_amu;
	     segno = binary (baseno (segp), 15);
	end;

	call hcs_$truncate_seg (optr, 0, (0));		/* ok, all the same from here on..		*/
	offset = 0;
	range = sys_info$max_seg_size;		/* because amu_ wants to WRITE to it!		*/
	call amu_$do_translation (amu_info_ptr, (segno), optr, offset, range, Code);
          if Code = 0 then call hcs_$set_bc_seg(optr, (range * 36), Code);	
return_to_caller_amu:
	if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr);
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


OLD_WAY_FOR_RUNNING_SYSTEM_NO:
	segno = Segno;
	goto common;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


OLD_WAY_FOR_RUNNING_SYSTEM_NAME:
	segname = Segname;
	call ring0_get_$segptr ("", segname, segp, Code);
	if Code ^= 0 then return;
	segno = binary (baseno (segp), 15);

common:
	call hcs_$truncate_seg (optr, 0, (0));
	sdwp = addr (sdw_hold);
	call ring_zero_peek_ (pointer (baseptr (0), 2 * segno), sdwp, 2, Code);
						/* get SDW */
	if Code ^= 0 then return;
	seg_size = 16 * (1 + binary (sdw.bound, 14));
	segp = baseptr (segno);
	call ring_zero_peek_ (segp, optr, seg_size, Code);
	if Code ^= 0 then return;
	Out_len = seg_size;
return_to_caller:
	return;

/**/
%include sdw;

%include system_dump_info;

dcl  1 sdi like system_dump_info;

%include amu_info;


%include amu_hardcore_info;
dcl  1 local_hardcore like hardcore_cur;







     end copy_erf_seg_;




		    get_gate_data_.pl1              11/20/86  1410.4r w 11/20/86  1145.0       81342



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


/* GET_GATE_DATA_ - Procedure to Get Metering Data from a Gate.
   revised 9/15/76 by Noel I. Morris	
   Modified June 1981 by J. Bongiovanni to fix zero linkage size bug	
   Modified July 1984 by Keith Loepere to work against the new, larger hcs_. */
	
get_gate_data_: proc (gate_name, table, nentries, tempp, reset_sw, code);

dcl  gate_name char (*),				/* name of gate */
     nentries fixed bin,				/* number of gate entries */
     tempp ptr,					/* pointer to temp segment */
     reset_sw bit (1) aligned,			/* "1"b if reset operation to be performed at end */
     code fixed bin (35);				/* error code */

dcl 1 table (*) like gate_table aligned;		/* gate information table */

dcl  gp ptr,					/* pointer to gate_info */
     caller_ptr ptr,				/* pointer to caller of this procedure */
     gatep ptr,					/* pointer to gate */
     gateno fixed bin (18),				/* segno of gate */
     savep ptr,					/* pointer to original copy of linkage */
     slp ptr,					/* pointer to static copy of linkage */
     type fixed bin (2),				/* segment type */
     bc fixed bin (24),				/* segment bit count */
     pptr ptr unal,					/* packed pointer from lot */
     l0p ptr,					/* pointer to linkage in ring 0 */
     llth fixed bin (18),				/* length of linkage */
     linkp ptr,					/* pointer to linkage */
     tlth fixed bin (18),				/* length of text */
     textp ptr,					/* pointer to copy of teext */
     defp ptr,					/* pointer to defs */
     no_entries fixed bin,				/* number of gate entries */
     p ptr,					/* working pointer for searching defs */
     i fixed bin,					/* gate table index */
     namep ptr,					/* pointer to entry name */
     entryp ptr,					/* pointer to gate entry point */
     vrel bit (18),					/* rel pointer to gate validation info */
     vp ptr,					/* pointer to validation info */
     datarel bit (18);				/* rel ptr to gate data */

dcl 1 linkhdr like header auto;			/* automatic copy of linkage header */

dcl  ap ptr static init (null ()),			/* pointer to system free area */
     fgp ptr static init (null ()),			/* ptr to first gate_info */
     lotp0 ptr static init (null ());			/* pointer to ring 0 lot */

dcl  caller entry returns (ptr),
     ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)),
     hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
     ring_zero_peek_ entry (ptr, ptr, fixed bin (18), fixed bin (35)),
     get_system_free_area_ entry (ptr);

dcl (addr, addrel, baseno, bin, divide, hbound, lbound, null, ptr, size, unspec) builtin;



dcl 1 gate_info aligned based (gp),
    2 name char (32),				/* name of gate */
    2 user ptr unal,				/* pointer to caller */
    2 textp ptr unal,				/* ptr to segment in ring 0 */
    2 linkp ptr unal,				/* ptr to linkage in ring 0 */
    2 defp ptr unal,				/* pointer to defs */
    2 textl fixed bin (18),				/* length of text in words */
    2 linkl fixed bin (18),				/* length of linkage in words */
    2 stp ptr unal,					/* pointer to static buffer used when doing resets */
    2 next ptr unal;

dcl 1 acc_name based (namep) aligned,			/* name in ACC format */
   (2 size fixed bin (8),
    2 name char (acc_name.size)) unaligned;

dcl 1 gate_entry based aligned,			/* entry pointer to gate */
    2 body_ptr bit (18);				/* pointer to body of gate entry */

dcl 1 gate_body based aligned,			/* body of gate entry */
    2 nargs bit (18) unal,				/* number of arguments */
    2 info_ptr bit (18) unal;				/* rel pointer to information in linkage */

dcl 1 save_data (no_entries) aligned based (savep) like gate_entry_data,
  1 static_data (no_entries) aligned based (slp) like gate_entry_data,
  1 current_data (no_entries) aligned based (tempp) like gate_entry_data;

dcl  based_area area based (ap);


dcl 1 definitions_$ (0:511) ext aligned,		/* hardcore definitions */
   (2 offset bit (18),
    2 length bit (18)) unal;



% include gate_data;



% include linkdcl;



% include definition;



	code = 0;

/* If this is the first call, get static pointers. */

	if ap = null () then			/* Get pointer to system free area. */
	     call get_system_free_area_ (ap);

	if lotp0 = null () then			/* Get a pointer to ring 0 lot. */
	     call ring0_get_$segptr ("", "lot", lotp0, code);
	if code ^= 0 then return;

/* See if we already have data. */

	caller_ptr = caller ();
						/* Get pointer to this procedure's caller. */
	gp = fgp;
	do while (gp ^= null ());
	     if (gate_info.name = gate_name) & (gate_info.user = caller_ptr) then go to found;
	     gp = gate_info.next;
	end;

/* Set up new entry. */

	allocate gate_info in (ap -> based_area) set (gp);
	gate_info.next = fgp;
	fgp = gp;

	call hcs_$status_minf (">system_library_1", gate_name, 1, type, bc, code);
	if code ^= 0 then return;			/* Get length of text. */
	tlth = divide (bc, 36, 18, 0);

	call ring0_get_$segptr ("", gate_name, gatep, code); /* Get segno of gate. */
	if code ^= 0 then return;
	gateno = bin (baseno (gatep), 18);

	call ring_zero_peek_ (addrel (lotp0, gateno), addr (pptr), 1, code); /* Find linkage for gate. */
	if code ^= 0 then return;
	l0p = pptr;

	call ring_zero_peek_ (l0p, addr (linkhdr), size (linkhdr), code); /* Copy linkage header. */
	llth = bin (linkhdr.begin_links, 18) - size (linkhdr); /* Get length of linkage from header. */
	no_entries = divide (llth, size (gate_entry_data), 17, 0); /* Compute no of elements. */
	if no_entries > 0 then do;
	     allocate static_data in (ap -> based_area) set (slp); /* Allocate static buffer. */
	     unspec (static_data) = "0"b;			/* Clear the data. */
	end;
	else slp = null ();

	defp = ptr (addr (definitions_$), definitions_$ (gateno).offset);
						/* Get pointer to definitions for gate. */



/* Fill in new gate info entry. */

	gate_info.linkp = addrel (l0p, 8);
	gate_info.linkl = llth;
	gate_info.defp = defp;
	gate_info.textp = gatep;
	gate_info.textl = tlth;
	gate_info.stp = slp;
	gate_info.name = gate_name;
	gate_info.user = caller_ptr;

found:	
	if gate_info.stp = null () then do;
	     nentries = 0;
	     return;
	end;

/* Copy the linkage from ring 0. */

	l0p = gate_info.linkp;
	llth = gate_info.linkl;
	call ring_zero_peek_ (l0p, tempp, llth, code);	/* Copy out the linkage. */
	if code ^= 0 then return;

/* Compute differences from previous data. */

	slp = gate_info.stp;
	no_entries = divide (llth, size (gate_entry_data), 17, 0);


/* Copy the text from ring 0. */

	gatep = gate_info.textp;
	tlth = gate_info.textl;
	textp = addrel (tempp, llth);
	call ring_zero_peek_ (gatep, textp, tlth, code);
	if code ^= 0 then return;

	savep = addrel (textp, tlth);			/* Get pointer for saved data. */
	save_data = current_data;			/* Save the just copied out data. */
	current_data = current_data - static_data;	/* Compute the differences. */

/* Iterate through the linkage. */

	linkp = addrel (tempp, -8);			/* Make pointer to imaginary linkage header. */
	defp = gate_info.defp;

	i = lbound (table, 1);			/* Initialize count. */
	do p = defp repeat addrel (defp, p -> definition.forward)
		while (p -> definition.forward);
	     if i > hbound (table, 1) then go to done;

	     if p -> definition.ignore then		/* If this isn't really an entry */
		go to next_entry;
	     if p -> definition.class ^= "0"b then	/* Test for segdef to text. */
		go to next_entry;

	     namep = addrel (defp, p -> definition.symbol);

	     if acc_name.name = ".my_lp" then goto next_entry; /* Skip the segdef for gate linkage pointer. */
	     if acc_name.name = ".tv_end" then goto next_entry; /* also watch out for call limited segdef */

	     entryp = addrel (textp, p -> definition.value);
						/* Generate pointer to entry point. */
	     vrel = entryp -> gate_entry.body_ptr;	/* Get relative ptr to validation information. */
	     vp = addrel (textp, vrel);		/* Convert to ITS pointer. */
	     vp = addrel (vp, -1);			/* information is instruction right before */
	     datarel = vp -> gate_body.info_ptr;	/* Get relative ptr to gate data. */
	     if datarel = "0"b then goto next_entry;	/* some gates aren't metered */
	     gate_datap = addrel (linkp, datarel);	/* Convert to ITS pointer. */

	     table (i).entryp = addr (acc_name.name);
	     table (i).entryl = acc_name.size;
	     table (i).datap = gate_datap;

	     i = i + 1;
next_entry:
	end;

done:
	nentries = i - lbound (table, 1);

	if reset_sw then				/* If reset desired ... */
	     static_data = save_data;			/* Set new static data. */

	return;




     end get_gate_data_;




		    meter_util_.pl1                 01/26/85  1313.2r w 01/22/85  1306.0       47790



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


meter_util_: proc;

/* This procedure contains several entries which are used by the hardcore
   metering programs. To use this package, the user must first
   call meter_util_$get_buffers to reserve some buffer space (in internal
   static -- or at least in the linkage segment).	 */
/* mod fall 78 REM- copy out 280 (not 256) words of tc_data */
/* Modified November 1984 by M. Pandolf to include hc_lock. */


dcl 1 pa (40) aligned static,
    2 pad (10) fixed bin;

dcl  ring_zero_peek_ ext entry (ptr, ptr, fixed bin, fixed bin (35)),
     ioa_ ext entry options (variable),
     ioa_$rsnnl ext entry options (variable),
     ring0_get_$segptr ext entry (char (*), char (*), ptr, fixed bin),
     hcs_$assign_linkage ext entry (fixed bin, ptr, fixed bin),

     unique_index fixed bin,
     meter_time float bin,
     rs char (12) aligned,
     a_meter_time float bin,
    (a_sstp1, a_sstp2, a_tcdp1, a_tcdp2, p, lp) ptr,
    (code, ignore, sec, min, hr) fixed bin,
     error_code fixed bin (35),
     static_index fixed bin static init (1),
    (sstp0, tcdp0) ptr static,
     inited bit (1) static init ("0"b),
    (mod, addr, addrel, divide, substr) builtin,
     move_280 (280) fixed bin based,
     move_512 (512) fixed bin based;

dcl 1 pa1 based (p) aligned,
    2 reset_called fixed bin,
    2 pad fixed bin,
    2 (sstp1, sstp2, tcdp1, tcdp2) ptr;

	% include sst;
	% include tcm;
	% include hc_lock;

/* 
   get_buffers

   This entry is called to reserve 4 buffers in the combined linkage
   segment(s) for the process. One buffer is used for the current sst data,
   one buffer is used for the past sst data, one buffer is used for the
   current tc_data data, and the last buffer is used for the past tc_data
   data.						 */

get_buffers: entry (unique_index, a_sstp1, a_sstp2, a_tcdp1, a_tcdp2, code);

	unique_index = static_index;
	static_index = static_index + 1;		/* increment unique index generator */
	if static_index > 40 then do;			/* don't let things get out of hand */
	     code = 1;
	     return;
	end;

	call hcs_$assign_linkage (1584, lp, code);	/* reserve the necessary storage */
	if code ^= 0 then return;

	p = addr (pa (unique_index));			/* get pointer to the current sub-structure */
	sstp1, a_sstp1 = lp;			/* generate pointers, return them, and save them */
	sstp2, a_sstp2 = addrel (lp, 512);
	tcdp1, a_tcdp1 = addrel (lp, 1024);
	tcdp2, a_tcdp2 = addrel (lp, 1304);

	if ^ inited then do;			/* if haven't got ring zero pointers yet, get them */
	     call ring0_get_$segptr ("", "sst", sstp0, code); /* get ring zero sst pointer */
	     if code ^= 0 then return;
	     call ring0_get_$segptr ("", "tc_data", tcdp0, code); /* get ring zero tc_data pointer */
	     inited = "1"b;				/* indicated we've found the pointers */
	end;

	return;

fill_buffers: entry (unique_index);

/* This entry reads the current data from the sst and tc_data and
   copies it into the "current" buffer for the specified caller. */

	p = addr (pa (unique_index));			/* get a pointer to the current set of pointers */
	call ring_zero_peek_ (sstp0, sstp2, 512, error_code); /* copy out the sst */
	call ring_zero_peek_ (tcdp0, tcdp2, 280, error_code); /* copy out the tc_data header */

	return;

reset:	entry (unique_index);

/* This entry is called to copy the current buffers into the old buffers
   and hence cause an effective reset of the meters. */

	p = addr (pa (unique_index));			/* get a pointer to the current set of pointers */
	reset_called = 1;				/* set flag saying reset was called */
	tcdp1 -> move_280 = tcdp2 -> move_280;		/* copy the tc_data header */
	sstp1 -> move_512 = sstp2 -> move_512;		/* copt the sst header */

	return;

time:	entry (unique_index, a_meter_time);

/* This entry prints the time of the metering interval and returns
   the same to the caller. */

	p = addr (pa (unique_index));			/* get a pointer to the callers variables */
	if reset_called = 0 then
	     meter_time = tcdp2 -> tcm.last_time - tcdp2 -> tcm.initialize_time; /* use time since bootload */
	else
	meter_time = tcdp2 -> tcm.last_time - tcdp1 -> tcm.last_time; /* use time since last reset */

	sec = meter_time*1e-6;			/* get number of seconds of metering */
	min = divide (sec, 60, 17, 0);		/* get minutes of metering */
	hr = divide (min, 60, 17, 0);			/* get hours of metering */
	sec = mod (sec, 60);			/* get seconds left in last minute */
	min = mod (min, 60);			/* get minutes left in last hour */
	call ioa_$rsnnl ("^4d^3d^3d", rs, ignore, hr, min+100, sec+100); /* convert to character string */
	substr (rs, 5, 1) = ":";			/* fill in separators */
	substr (rs, 8, 1) = ":";
	call ioa_ ("^/Total metering time^-^a^/", rs);	/* print out the metring time */

	a_meter_time = meter_time;			/* return metering interval lenght */

	return;

     end meter_util_;




		    metering_util_.pl1              10/24/88  1649.7r w 10/24/88  1401.3      123858



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


metering_util_$define_regions:
     proc;


/* metering utility

   This is a utility subroutine for hardcore metering commands.
   It allows definition of "regions", which are arbitrary
   sections of ring-0 segments containing information of interest
   to the invoker.  These regions are grouped by means of
   a unique index, which allows multiple use of this subroutine
   within the same process.  This subroutine maintains for each
   region two buffers in static storage -- one for the "current"
   copy of the region and one for the "previous" copy; pointers
   to these buffers are returned following definition.

   The following entries are provided:

   metering_util_$define_regions - define  hardcore regions, allocate static
   buffer space

   metering_util_$fill_buffers - copy all regions associated with a
   given unique index into the "current" buffers, and return
   pointers

   metering_util_$reset - copy all "current" buffers associated with
   a given unique index into the "previous" buffers



   Written December 1980 by J. Bongiovanni
   Modified May 1982 by J. Bongiovanni to handle area condition
*/

/* Parameter */

	dcl     current_ptrs	 (*) ptr;		/* pointers to current static buffers		*/
	dcl     formatted_time	 char (*);	/* metering time in hhhh:mm:ss		*/
	dcl     meter_time		 fixed bin (71);	/* metering time in  microseconds		*/
	dcl     previous_ptrs	 (*) ptr;		/* pointers to previous static buffers		*/
	dcl     rcode		 fixed bin (35);	/* error return code			*/
	dcl     unique		 fixed bin;	/* instance identifier			*/

/* Automatic */

	dcl     acode		 fixed bin (35);
	dcl     areap		 ptr;
	dcl     arg_list_ptr	 ptr;
	dcl     arg_numeric		 fixed bin (18);
	dcl     arg_ptr		 ptr;
	dcl     arg_size		 fixed bin;
	dcl     arg_size_1		 fixed bin (21);
	dcl     arg_type		 fixed bin;
	dcl     begin_offset	 fixed bin (18);
	dcl     codep		 ptr;
	dcl     end_offset		 fixed bin (18);
	dcl     HR		 pic "zzz9";
	dcl     MIN		 pic "99";
	dcl     min		 fixed bin;
	dcl     nargs		 fixed bin;
	dcl     prev_region_ptr	 ptr;
	dcl     region_ptr		 ptr;
	dcl     region_no		 fixed bin;
	dcl     r0_ptr		 ptr;
	dcl     SEC		 pic "99";
	dcl     sec		 fixed bin;
	dcl     sub_arg_no		 fixed bin;
	dcl     time_val		 fixed bin (71);
	dcl     type		 fixed bin;
	dcl     unique_index_arg_ptr	 ptr;
	dcl     why		 char (50);

/* Static */

	dcl     our_name		 char (14) init ("metering_util_") int static options (constant);
	dcl     next_unique		 fixed bin int static init (1); /* next instance number			*/
	dcl     unique_region_ptr	 (40) ptr unal int static init ((40) null ()); /* ptrs to linked list of region	*/
	dcl     (begin_end_mess	 char (32) init ("Region must have positive length"),
	        fixed_char_mess	 char (37) init ("Argument must be type numeric or char"),
	        ptr_char_mess	 char (33) init ("Argument must be type ptr or char"),
	        std_err_mess	 char (12) init ("Invalid call"))
				 int static options (constant);

%include std_descriptor_types;

/* Based */

	dcl     arg_name		 char (arg_size) based (arg_ptr);
	dcl     code		 fixed bin (35) based (codep);
	dcl     fixed_bin_based	 fixed bin (18) aligned based (arg_ptr);
	dcl     ptr_ptr		 ptr based;
	dcl     unique_index_arg	 fixed bin based (unique_index_arg_ptr);

	dcl     1 region		 aligned based (region_ptr), /* structure in static for each region to snap	*/
		2 next_region	 ptr,		/* next region this instance			*/
		2 ring0_ptr	 ptr,		/* begin of snap region in ring-0		*/
		2 current_time	 fixed bin (71),	/* time of current snap			*/
		2 previous_time	 fixed bin (71),	/* time of previous snap			*/
		2 nwords		 fixed bin (19),	/* number of words to snap			*/
		2 nwords_alloc	 fixed bin (19),	/* number of words in array (mod 2)		*/
		2 current_snap	 (end_offset - begin_offset + mod (end_offset - begin_offset, 2) refer (region.nwords_alloc)),
		2 previous_snap	 (end_offset - begin_offset + mod (end_offset - begin_offset, 2) refer (region.nwords_alloc));

/* Area */

	dcl     static_area		 area based (areap);


/* External */

	dcl     error_table_$area_too_small fixed bin (35) external;
	dcl     error_table_$bad_arg	 fixed bin (35) external;
	dcl     error_table_$bad_index fixed bin (35) external;
	dcl     error_table_$invalid_array_size fixed bin (35) external;
	dcl     error_table_$wrong_no_of_args fixed bin (35) external;
	dcl     sys_info$time_of_bootload fixed bin (71) external;

/* Entry */

	dcl     assign_		 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	dcl     decode_descriptor_	 entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ring0_get_$definition	 entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
	dcl     ring0_get_$segptr	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     ring_zero_peek_	 entry (ptr, ptr, fixed bin (19), fixed bin (35));
	dcl     sub_err_		 entry options (variable);

/* Builtin */

	dcl     (addr, clock, divide, hbound, lbound, mod, null, ptr, unspec) builtin;

/* Condition */

	dcl     area		 condition;
	dcl     cleanup		 condition;

/*  */

/* Do preliminary check of arguments.  The number of arguments passed
   must be 2+3*N, where N is the number of hardcore regions (>0) 					*/

	call cu_$arg_count (nargs);
	if nargs <= 2 then do;
call_suberr:
		call sub_err_ (error_table_$wrong_no_of_args, our_name, "s",
		     null (), (0), std_err_mess);
		return;
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$arg_ptr (1, unique_index_arg_ptr, arg_size_1, acode);
	call cu_$arg_ptr (2, codep, arg_size_1, acode);

	code = 0;

	if mod (nargs - 2, 3) ^= 0 then goto call_suberr;




/* Make sure we havent run out of instances							*/

	if next_unique > hbound (unique_region_ptr, 1) then do;
		code = error_table_$bad_index;
		return;
	     end;

/* go through each region defined, validate it, and allocate
   sufficient static storage to hold 2 snapshots plus control
   information.  If an error is encountered, deallocate all
   static storage allocated this call								*/


	areap = get_system_free_area_ ();
	region_no = 1;
	prev_region_ptr = null ();

	on area begin;
		code = error_table_$area_too_small;
		why = "area condition signalled";
		goto other_error;
	     end;

	on cleanup call cleanup_regions;


	do while (3 * region_no + 2 <= nargs);
	     sub_arg_no = 1;
	     why = ptr_char_mess;
	     call arg_val (3 * region_no);		/* ring-0 segment name or pointer		*/
	     if arg_type = pointer_dtype then r0_ptr = arg_ptr -> ptr_ptr;
	     else if arg_type = char_dtype then do;
		     call ring0_get_$segptr ("", arg_name, r0_ptr, code);
		     if code ^= 0 then do;
			     why = arg_name;
			     goto other_error;
			end;
		end;
	     else goto bad_arg;

	     sub_arg_no = 2;
	     why = fixed_char_mess;
	     call arg_val (3 * region_no + 1);		/* begin offset or symbol name		*/
	     if arg_type = real_fix_bin_1_dtype then begin_offset = fixed_bin_based;
	     else if arg_type = char_dtype then do;
		     call ring0_get_$definition (r0_ptr, "", arg_name, begin_offset, type, code);
		     if code ^= 0 then do;
			     why = arg_name;
			     goto other_error;
			end;
		end;
	     else goto bad_arg;

	     sub_arg_no = 3;
	     why = fixed_char_mess;
	     call arg_val (3 * region_no + 2);		/* length or name 1-word beyond end		*/
	     if arg_type = real_fix_bin_1_dtype then end_offset = fixed_bin_based + begin_offset;
	     else if arg_type = char_dtype then do;
		     call ring0_get_$definition (r0_ptr, "", arg_name, end_offset, type, code);
		     if code ^= 0 then do;
			     why = arg_name;
			     goto other_error;
			end;
		end;
	     else goto bad_arg;

	     why = begin_end_mess;
	     if end_offset - begin_offset <= 0 then goto bad_arg;

	     allocate region in (static_area);
	     region.next_region = null ();
	     region.ring0_ptr = ptr (r0_ptr, begin_offset);
	     region.current_time, region.previous_time = sys_info$time_of_bootload;
	     region.nwords = end_offset - begin_offset;
	     unspec (region.current_snap) = ""b;
	     unspec (region.previous_snap) = ""b;

	     if prev_region_ptr = null ()		/* 1st region this instance			*/
	     then unique_region_ptr (next_unique) = region_ptr;
	     else prev_region_ptr -> region.next_region = region_ptr;

	     prev_region_ptr = region_ptr;
	     region_no = region_no + 1;
	end;

/* Return unique index to be used in future calls							*/

	unique_index_arg = next_unique;
	next_unique = next_unique + 1;

	return;




bad_arg:
	code = error_table_$bad_arg;

/* Error encountered after scan of hardcore regions.
   Deallocate all static storage allocated this call						*/

other_error:

	call cleanup_regions;

	call sub_err_ (code, our_name, "s", null (), (0), "^a. ^a. hardcore region ^d subarg no. ^d",
	     std_err_mess, why, region_no, sub_arg_no);


	return;



/*  */
fill_buffers:
     entry (unique, meter_time, formatted_time, current_ptrs, previous_ptrs, rcode);


/* validate parameters */

	if unique < lbound (unique_region_ptr, 1) | unique > hbound (unique_region_ptr, 1) then do;
fill_buffers_arg_error:
		rcode = error_table_$bad_arg;
		return;
	     end;

	if unique_region_ptr (unique) = null ()
	then goto fill_buffers_arg_error;

	region_no = 0;
	region_ptr = unique_region_ptr (unique);
	do while (region_ptr ^= null ());
	     region_no = region_no + 1;
	     region_ptr = region.next_region;
	end;
	if hbound (current_ptrs, 1) ^= region_no | hbound (previous_ptrs, 1) ^= region_no then do;
		rcode = error_table_$invalid_array_size;
		return;
	     end;

/* snap each hardcore region into the current buffer for same.
   also pick up and return pointers to current and previous buffer					*/

	time_val = clock ();
	region_ptr = unique_region_ptr (unique);
	region_no = 1;
	meter_time = time_val - region.previous_time;

	do while (region_ptr ^= null ());
	     call ring_zero_peek_ (region.ring0_ptr, addr (region.current_snap),
		region.nwords, rcode);
	     if rcode ^= 0 then return;		/* heavy Oops!				*/
	     region.current_time = time_val;
	     current_ptrs (region_no) = addr (region.current_snap);
	     previous_ptrs (region_no) = addr (region.previous_snap);
	     region_ptr = region.next_region;
	     region_no = region_no + 1;
	end;

	sec = divide (meter_time, 1000000, 17);
	SEC = mod (sec, 60);
	min = divide (sec, 60, 17);
	MIN = mod (min, 60);
	HR = divide (min, 60, 17);
	formatted_time = HR || ":" || MIN || ":" || SEC;


	return;

/*  */
reset:
     entry (unique, rcode);

/* validate unique index									*/

	if unique < lbound (unique_region_ptr, 1) | unique > hbound (unique_region_ptr, 1) then goto fill_buffers_arg_error;
	if unique_region_ptr (unique) = null ()
	then goto fill_buffers_arg_error;

	rcode = 0;


/* reset each region for this unique index by copying each current buffer
   into the corresponding previous buffer							*/

	region_ptr = unique_region_ptr (unique);
	do while (region_ptr ^= null ());
	     region.previous_snap = region.current_snap;
	     region.previous_time = region.current_time;
	     region_ptr = region.next_region;
	end;


	return;









/* 
   Internal subroutine to examine arguments and do preliminary screening.

   Assumed on input:
   arg_list_ptr points to argument list for main program

   Set on output:
   arg_type - argument type
   arg_size - argument size
   arg_ptr - pointer to argument

   If the argument is numeric, it is converted to fixed bin (18) aligned,
   and the values above set to the converted argument
*/

arg_val: proc (n);


	dcl     n			 fixed bin;	/* argument number				*/

	dcl     av_code		 fixed bin (35);
	dcl     len		 fixed bin (21);
	dcl     ndims		 fixed bin;
	dcl     packed		 bit (1) aligned;
	dcl     scale		 fixed bin;

	call decode_descriptor_ (arg_list_ptr, n, arg_type, packed, ndims, arg_size, scale);
	if (packed & arg_type ^= char_dtype) | arg_type = -1 | ndims ^= 0 | scale ^= 0
	then goto bad_arg;
	call cu_$arg_ptr_rel (n, arg_ptr, len, av_code, arg_list_ptr);
	if (arg_type <= cplx_flt_dec_9bit_dtype)
	     | (arg_type >= real_fix_bin_1_uns_dtype & arg_type <= real_fix_bin_2_uns_dtype)
	     | (arg_type >= real_fix_dec_4bit_ls_dtype & arg_type <= real_flt_dec_4bit_bytealigned_dtype)
	then do;
		call assign_ (addr (arg_numeric), 2 * real_fix_bin_1_dtype, 18, arg_ptr,
		     2 * arg_type, bin (arg_size, 35));
		arg_ptr = addr (arg_numeric);
		arg_size = 18;
		arg_type = real_fix_bin_1_dtype;
	     end;


     end arg_val;
						/* 
  Internal procedure to clean up any space we may have allocated
*/

cleanup_regions:
     proc;


	prev_region_ptr = unique_region_ptr (next_unique);
	do while (prev_region_ptr ^= null ());
	     region_ptr = prev_region_ptr;
	     prev_region_ptr = region.next_region;
	     free region in (static_area);
	end;

	unique_region_ptr (next_unique) = null ();

     end cleanup_regions;

     end metering_util_$define_regions;




		    get_vol_list_.pl1               01/09/87  1338.5rew 01/09/87  1314.5       79938



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


/****^  HISTORY COMMENTS:
  1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383),
     audit(86-05-27,Wallman), install(86-07-18,MR12.0-1098):
     Add support for subvolumes, 3380 and 3390.
  2) change(86-11-10,Fawcett), approve(86-11-10,MCR7125),
     audit(87-01-08,Farley), install(87-01-09,MR12.0-1266):
     Changed by Tom Oke to conform to documentation.
  3) change(86-11-10,Fawcett), approve(86-11-10,MCR7547),
     audit(87-01-08,Farley), install(87-01-09,MR12.0-1266):
     Changed so disk_meters can display subvolume devices correctly.
                                                   END HISTORY COMMENTS */


get_vol_list_:
     proc (a_pv_list_ptr, a_lv_list_ptr, a_area_ptr, a_version, a_code);

/* Program to determine logical and physical volume names in a MULTICS
   system and allocate and return structures with this information. */

/* format: off */
/* Input:
   a_pv_list_ptr	is a pointer to the pv_list structure.  If it is
		non-null, it is taken to point to an existing
		structure which is size checked for validity and
		returned and re-allocated if necessary.
   a_lv_list_ptr	is a pointer to the lv_list structure.  If it is
		non-null, it is taken to point to an existing
		structure which is size checked for validity and
		returned and re-allocated if necessary.
   a_area_ptr	is a pointer to the area to allocate the structures
		in.  If it is null (), system_free_area is used.
   a_version	is an 8 character string of the version of structure
		the calling routine is expecting to receive.
   code		error code.
*/

/* format: on */

/* Interface declaratons. */

	dcl     a_pv_list_ptr	 ptr;
	dcl     a_lv_list_ptr	 ptr;
	dcl     a_area_ptr		 ptr;
	dcl     a_version		 char (8);
	dcl     a_code		 fixed bin (35);

/* Automatic */

	dcl     area_ptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     1 ai		 like area_info;
	dcl     max_lvs		 fixed bin;
	dcl     max_pvs		 fixed bin;
	dcl     temp_ptr		 ptr;		/* to temp seg */

	dcl     (addr, currentsize, length, max, null, rtrim, unspec) builtin;

	dcl     cleanup		 condition;

/* Static */

	dcl     entry_name		 char (32) static options (constant) initial ("get_vol_list_");

/* Areas */

	dcl     areas		 area based (area_ptr);


/* Structure Funnies */
/* The following array is used to determine the size to allocate
   for the structures to return.  We overlay the lv and pv structures onto the
   array, fill in the size words (which exist within the size of the array)
   and then do a currentsize (of a structure which for the most part doesn't
   exist) to determine its real size to allocate.  We cannot do it with
   allocation, since we need the internal size words correctly set to 
   allocate the true size. */

	dcl     allocating_array	 (alloc_size) fixed bin (35) based;
	dcl     alloc_size		 fixed bin;	/* currentsize */
	dcl     sizing_array	 (10) fixed bin (35);

/* Entries */

	dcl     area_info_		 entry (ptr, fixed bin (35));
	dcl     error_table_$improper_data_format fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     mdc_$read_disk_table	 entry (ptr, fixed bin (35));
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);
%page;
	if a_version ^= get_vol_list_version then do;
BAD_VERSION:	a_code = error_table_$unimplemented_version;
		return;
	     end;

	if a_area_ptr = null () then
	     area_ptr = get_system_free_area_ ();
	else if valid_area (a_area_ptr) then
	     area_ptr = a_area_ptr;
	else do;
		a_code = error_table_$improper_data_format;
		return;
	     end;

	temp_ptr = null ();

	on cleanup begin;
		if temp_ptr ^= null () then call release_temp_segment_ (entry_name, temp_ptr, code);
	     end;

	call get_temp_segment_ (entry_name, temp_ptr, code);
	if code ^= 0 then do;
		a_code = code;
		return;
	     end;

	dtp = temp_ptr;				/* setup disk_table */
	call mdc_$read_disk_table (dtp, code);
	if code ^= 0 then do;
		a_code = code;
		goto exit;
	     end;

/* Determine if we need to allocate pv_list and lv_list. */

	do i = 1 to dt.max_n_entries;
	     if (dt.array (i).used | dt.array (i).is_sub_vol)
	     then max_pvs = i;

	     if dt.lv_array (i).used = "1"b
	     then max_lvs = i;
	end;

	pv_list_ptr = a_pv_list_ptr;
	lv_list_ptr = a_lv_list_ptr;

	if pv_list_ptr ^= null () then do;
		if pv_list_ptr -> pv_list.version ^= get_vol_list_version then goto BAD_VERSION;
		if pv_list_ptr -> pv_list.pv_name_count ^= max_pvs then do;
			if valid_area (pv_list.area_ptr) then do;
				if ^ai.no_freeing then
				     free pv_list in (pv_list.area_ptr -> areas);
			     end;
			pv_list_ptr = null ();
		     end;
	     end;

	if lv_list_ptr ^= null () then do;
		if pv_list_ptr -> pv_list.version ^= get_vol_list_version then goto BAD_VERSION;
		if lv_list_ptr -> lv_list.lv_name_count ^= max_lvs then do;
			if valid_area (lv_list.area_ptr) then do;
				if ^ai.no_freeing then
				     free lv_list in (lv_list.area_ptr -> areas);
			     end;
			lv_list_ptr = null ();
		     end;
	     end;

/* Allocate space if needed. */

	if pv_list_ptr = null () then do;
		addr (sizing_array) -> pv_list.pv_name_count = max_pvs;
		alloc_size = currentsize (addr (sizing_array) -> pv_list);
		allocate allocating_array in (areas) set (pv_list_ptr);
		pv_list.pv_name_count = max_pvs;
		pv_list.area_ptr = area_ptr;
	     end;

	if lv_list_ptr = null () then do;
		addr (sizing_array) -> lv_list.lv_name_count = max_lvs;
		alloc_size = currentsize (addr (sizing_array) -> lv_list);
		allocate allocating_array in (areas) set (lv_list_ptr);
		lv_list.lv_name_count = max_lvs;
		lv_list.area_ptr = area_ptr;
	     end;

	pv_list.version = get_vol_list_version;
	lv_list.version = get_vol_list_version;

	pv_list.pv_name_max_length = 0;
	do max_pvs = max_pvs by -1 to 1;
	     pv_list.pv_info (max_pvs).used = dt.array (max_pvs).used;
	     pv_list.pv_info (max_pvs).storage_system = dt.array (max_pvs).storage_system;
	     pv_list.pv_info (max_pvs).permanent = dt.array (max_pvs).permanent;
	     pv_list.pv_info (max_pvs).hc_accepted = dt.array (max_pvs).hc_accepted;
	     pv_list.pv_info (max_pvs).rpv = dt.array (max_pvs).rpv;
	     pv_list.pv_info (max_pvs).is_sub_vol = dt.array (max_pvs).is_sub_vol;
	     pv_list.pv_info (max_pvs).num_of_sv = dt.array (max_pvs).num_of_sv;
	     pv_list.pv_info (max_pvs).sv_num = dt.array (max_pvs).sv_num;
	     pv_list.pv_info (max_pvs).device_type = dt.array (max_pvs).device_type;
	     pv_list.pv_info (max_pvs).lvx = dt.array (max_pvs).lvx;
	     pv_list.pv_info (max_pvs).drive_name = dt.array (max_pvs).drive_name;
	     pv_list.pv_info (max_pvs).pvname = dt.array (max_pvs).pvname;
	     if dt.array (max_pvs).used = "1"b then
		pv_list.pv_name_max_length = max (length (rtrim (pv_list.pv_info (max_pvs).pvname)), pv_list.pv_name_max_length);
	end;

	lv_list.lv_name_max_length = 0;
	do max_lvs = max_lvs by -1 to 1;
	     lv_list.lv_info (max_lvs).used = dt.lv_array (max_lvs).used;
	     lv_list.lv_info (max_lvs).hv_mounted = dt.lv_array (max_lvs).hv_mounted;
	     lv_list.lv_info (max_lvs).public = dt.lv_array (max_lvs).public;
	     lv_list.lv_info (max_lvs).mounting = dt.lv_array (max_lvs).mounting;
	     lv_list.lv_info (max_lvs).demounting = dt.lv_array (max_lvs).demounting;
	     lv_list.lv_info (max_lvs).pdirs_ok = dt.lv_array (max_lvs).pdirs_ok;
	     lv_list.lv_info (max_lvs).prev_bootload = dt.lv_array (max_lvs).prev_bootload;
	     lv_list.lv_info (max_lvs).vacate_pdirs = dt.lv_array (max_lvs).vacate_pdirs;
	     lv_list.lv_info (max_lvs).lvname = dt.lv_array (max_lvs).lvname;
	     if dt.lv_array (max_lvs).used = "1"b then
		lv_list.lv_name_max_length = max (length (rtrim (lv_list.lv_info (max_lvs).lvname)), lv_list.lv_name_max_length);
	end;


/* Cleanup and exit routine. */

exit:	call release_temp_segment_ (entry_name, temp_ptr, code);
	a_pv_list_ptr = pv_list_ptr;
	a_lv_list_ptr = lv_list_ptr;
	return;

valid_area:
     proc (area_ptr) returns (bit (1));

/* validates and area and leaves area information in ai. */

	dcl     area_ptr		 ptr;

	unspec (ai) = "0"b;
	ai.version = area_info_version_1;
	ai.areap = area_ptr;
	call area_info_ (addr (ai), code);
	if code ^= 0 then
	     return ("0"b);
	if ai.version_of_area ^= ai.version then
	     return ("0"b);
	return ("1"b);
     end valid_area;
%page;
%include get_vol_list_;
%include disk_table;
%include area_info;
     end get_vol_list_;





		    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
