



		    access_class_check.pl1          11/11/89  1132.4r w 11/11/89  0800.4       95823



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



/****^  HISTORY COMMENTS:
  1) change(87-12-17,Lippard), approve(87-08-24,MCR7760),
     audit(88-02-03,Fawcett), install(88-02-16,MR12.2-1022):
     Make reset_soos work on segments.
                                                   END HISTORY COMMENTS */


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

/* Initial coding by Kobziar July 74 */
/* Modified 750523 by LJS to add protection auditing */
/* Modified 06/01/76 by R. Bratt to call find_$finished */
/* Modified 07/77 by THVV for bad_dir_ check */
/* Modified 06/84 by Keith Loepere to use the new dc_find. */
/* Modified 84-12-03 by EJ Sharpe for access_audit_ */
/* Modified 85-04-01 by Keith Loepere for access_audit_check_ep_. */

access_class_check: proc (a_dirname, a_ename, a_code);

/* This procedure turns security_oosw off if dir consistent within AI rules */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;

dcl  access_class			bit (72) aligned;
dcl  code				fixed bin (35);
dcl  crunch_sw			bit (1) init ("0"b);
dcl  d_access_class			bit (72) aligned;
dcl  dep				ptr;
dcl  dirname			char (168);
dcl  dirlocked			bit (1) aligned init ("0"b);
dcl  ename			char (32);
dcl  entries_in_dir			fixed bin;
dcl  1 event_flags			aligned like audit_event_flags;
dcl  got_branch			bit (1) init ("0"b);
dcl  i				fixed bin;
dcl  len				fixed bin;
dcl  pathname			char (168);
dcl  pdep				ptr;
dcl  1 qcell			like quota_cell aligned auto;
dcl  relp				bit (18);
dcl  segment			bit (1) aligned;
dcl  unlock_parent_parent		bit (1) init ("1"b);

dcl  access_audit_check_ep_$self	entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1));
dcl  access_audit_$log_entry_ptr	entry options (variable);
dcl  aim_check_$equal		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible;
dcl  aim_check_$greater		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible;
dcl  lock$dir_unlock		entry (ptr);
dcl  level$get			entry () returns (fixed bin);
dcl  status_$get_access_class		entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl  sum$dirmod			entry (ptr);
dcl  sum$getbranch			entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  sum$getbranch_root_my		entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  vtoc_attributes$get_quota	entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin, fixed bin (35));

dcl  access_operations_$fs_obj_set_soos ext bit (36) aligned;
dcl  error_table_$ai_son_less		ext fixed bin (35);
dcl  error_table_$argerr		ext fixed bin (35);
dcl  error_table_$bad_dir		ext fixed bin (35);
dcl  error_table_$notadir		ext fixed bin (35);
dcl  error_table_$root		ext fixed bin (35);
dcl  error_table_$rqover		ext fixed bin (35);
dcl  pds$processid			bit (36) aligned ext;

dcl  (addr, fixed, length, null, ptr, rtrim, string, substr) builtin;

dcl  bad_dir_			condition;

dcl  CHASE			fixed bin (1) aligned internal static options (constant) init (1);
%page;
START:	segment = "0"b;
	dirname = a_dirname;
	ename = a_ename;
						/* get full dirname into pathname */
	len = length (rtrim (dirname));		/* Find length. Accept imbedded blanks. */
	if ename ^= "" then do;
	     if len + length (rtrim (ename)) + 1 > length (pathname) then do; /* path name too long */
bad_path:		code = error_table_$argerr;
		goto early_fail;
	     end;
	     if len = 1 then pathname = substr (dirname, 1, 1) || ename; /* dir is root */
	     else pathname = substr (dirname, 1, len) || ">" || ename;
	end;
	else do;					/* no ename */
	     if len >= length (pathname) then goto bad_path; /* enough checking */
	     pathname = dirname;			/* only dirname valid */
	end;
						/* get access class of dir */
	call status_$get_access_class (pathname, "", access_class, code);
	if code ^= 0 then if code = error_table_$root then access_class = "0"b;
	     else goto early_fail;			/* map root's imaginary value */

	call dc_find$dir_read (pathname, dp, code);
	if code = error_table_$notadir then do;
	     call dc_find$obj_status_read (dirname, ename, CHASE, ep, code);
	     segment = "1"b;
	end;
	if code ^= 0 then goto early_fail;
	dirlocked = "1"b;

	if ^segment then do;
	     i = 0;
	     entries_in_dir = dir.seg_count + dir.dir_count + dir.lcount;
	     do relp = dir.entryfrp repeat entry.efrp while (relp);
						/* see if  equal class */
		ep = ptr (dp, relp);
		i = i + 1;
		if i > entries_in_dir then signal bad_dir_;
		if ^entry.bs then go to loop_cont;	/* skip links */
		if entry.owner ^= dir.uid
		     | (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_;
		if ^aim_check_$equal (access_class, entry.access_class) then do;
		     if ^entry.multiple_class then goto err; /* if not equal then check for consistent upgrade */
		     if ^aim_check_$greater (entry.access_class, access_class) then goto err;
		     if ^entry.dirsw then do;		/* a segment can be upgraded only if in ring 1 */
			if fixed (entry.ring_brackets (3)) > 1 then goto err;
			else goto loop_cont;
		     end;
						/* a directory */
		     else do;
			call vtoc_attributes$get_quota (entry.uid, (entry.pvid), (entry.vtocx),
			     addr (qcell), 0, code);
			if code ^= 0 then goto fail;
			if ^qcell.terminal_quota_sw then do;
			     code = error_table_$rqover;
			     goto fail;
			end;
		     end;
		end;
		else if entry.multiple_class then goto err; /* can't be multiple class if equal */
loop_cont:     end;
	end;					/* directory */

	if segment then dp = ptr (ep, 0);

	call sum$getbranch (dp, "1"b, dep, code);
	if code ^= 0 then goto fail1;
	got_branch = "1"b;

	if segment then do;
	     if ^aim_check_$equal (entry.access_class, dep -> entry.access_class) then
		if ^entry.multiple_class | ^aim_check_$greater (entry.access_class, dep -> entry.access_class) then do;
		     code = error_table_$ai_son_less;
		     goto fail1;
		end;

	     if entry.security_oosw then do;		/* If it was out of service, we are making it in-service */
		entry.security_oosw = "0"b;
		string (event_flags) = ""b;
		event_flags.special_op = "1"b;
		event_flags.grant = "1"b;
		event_flags.priv_op = "1"b;
		if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then
		     call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags),
			access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned off");
		ptr (dep, 0) -> dir.modify = "0"b;
		call sum$dirmod (dp);
	     end;
	     goto unlock3;
	end;

	call sum$getbranch_root_my (ptr (dep, 0), "0"b, pdep, code); /* get the parent's access_class */
	if code ^= 0 then				/* up to the root ? */
	     if code = error_table_$root then do;
		unlock_parent_parent = "0"b;
		d_access_class = "0"b;		/* root at 0 */
		code = 0;				/* clear for return */
	     end;
	     else goto unlock3;			/* no other err acceptable */
						/* successful */
	else d_access_class = pdep -> entry.access_class; /* save this */

	if unlock_parent_parent then call lock$dir_unlock (ptr (pdep, 0));

	if aim_check_$greater (access_class, d_access_class) then do; /* this is an upgraded dir */
	     call vtoc_attributes$get_quota (dep -> entry.uid, (dep -> entry.pvid), (dep -> entry.vtocx),
		addr (qcell), 0, code);
	     if code ^= 0 then goto fail;
	     if ^qcell.terminal_quota_sw then do;
		code = error_table_$rqover;
		goto fail;
	     end;
	end;
	else if ^aim_check_$equal (access_class, d_access_class) then do;
	     code = error_table_$bad_dir;
	     goto fail;
	end;
						/* success */
	if dep -> entry.security_oosw then do;		/* If it was out of service, we are making it in-service */
	     ptr (dep, 0) -> dir.modify = pds$processid;
	     dep -> entry.security_oosw = "0"b;
	     string (event_flags) = ""b;
	     event_flags.special_op = "1"b;
	     event_flags.grant = "1"b;
	     event_flags.priv_op = "1"b;
	     if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then
		call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags),
		     access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned off");
	end;
	ptr (dep, 0) -> dir.modify = "0"b;

	call sum$dirmod (ptr (dep, 0));		/* Must be done with dir locked */
unlock3:
	call lock$dir_unlock (ptr (dep, 0));

fail1:	call dc_find$finished (dp, dirlocked);
early_fail: a_code = code;
	return;

err:
	code = error_table_$bad_dir;
fail:	if crunch_sw then do;			/* FAILURE. If requested we will set out of service */
	     if ^got_branch then call sum$getbranch (dp, "1"b, dep, (0));
	     got_branch = "1"b;
	     ptr (dep, 0) -> dir.modify = pds$processid;
	     dep -> entry.security_oosw = "1"b;
	     string (event_flags) = ""b;
	     event_flags.special_op = "1"b;
	     event_flags.grant = "1"b;
	     event_flags.priv_op = "1"b;
	     if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then
		call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags),
		     access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned on");
	     ptr (dep, 0) -> dir.modify = "0"b;
	     call sum$dirmod (ptr (dep, 0));
	end;
	if got_branch then call lock$dir_unlock (ptr (dep, 0));
	go to fail1;

aim_check_soos: entry (a_dirname, a_ename, a_code);

	crunch_sw = "1"b;
	go to START;
%page; %include access_audit_eventflags;
%page; %include dc_find_dcls;
%page; %include dir_header;
%page; %include dir_entry;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include quota_cell;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   AUDIT (access_class_check): GRANTED modification of security out_of_service ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	The soos switch for the specified path has been turned on or
off  by the security administrator as indicated.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end access_class_check;




		    acl.pl1                         11/11/89  1132.4r w 11/11/89  0800.0      244872



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


/* format: style4 */
acl: proc;

/* This is the acl write around for the directory change of 1972. */


/****^  HISTORY COMMENTS:
  1) change(73-01-21,Kobziar), approve(), audit(), install():
      Remove append from segments and obsolete CACLs.
  2) change(73-02-01,EStone), approve(), audit(), install():
      Rewritten in v2pl1 for performance improvements.
  3) change(74-10-01,EStone), approve(), audit(), install():
      Place uid and dtem in double word.
  4) change(75-04-25,Greenberg), approve(), audit(), install():
      Modified by BSG for NSS and no perm acls.
  5) change(76-06-01,RBratt), approve(), audit(), install():
      Modified to call find_$finished.
  6) change(76-06-01,VanVleck), approve(), audit(), install():
      Modified by THVV for no perm acls.
  7) change(77-07-01,VanVleck), approve(), audit(), install():
      Modified for bad_dir_ check.
  8) change(83-08-01,Kittlitz), approve(), audit(), install():
      Modified by E. N. Kittlitz for setfault$if_active pvid, vtocx args.
  9) change(84-06-01,Loepere), approve(), audit(), install():
      Modified by Keith Loepere for the new dc_find.
 10) change(84-10-01,Loepere), approve(), audit(), install():
      Modified for auditing operation as access change.
 11) change(86-06-03,Lippard), approve(86-09-04,MCR7534),
     audit(86-09-11,Dickson), install(86-09-16,MR12.0-1159):
      Modified by Jim Lippard to make dir modes RW rather than null.
                                                   END HISTORY COMMENTS */


/* Strategy used is to move input structure into an automatic structure acl(100) and call the new single acl
   primitives , thus avoiding seg faults while dir locked */

/* The entries to this routine are
   name	     entry switch
   $aadd		1
   $a1add		1
   $areplace	2
   $adelete	3
   $alist		4

   Up to 100 entries are handeled and the arguments for all but alist and a1add are
   1)   a_dirname character(*)	a directory path name. (Input)
   2)   a_ename character(*)	an entry name for this acl; was null for now obselete cacl. (Input)
   3)   a_aclp pointer	a pointer to an array of data to be entered or returned. (Input)
   4)   a_aclct fixed bin (17)	a count of the number of entries in the array. (Output/alist Input/others)
   5)   a_code fixed bin (17)	an error code. (Output)

   For $alist the argument a_uap is a pointer to a user area where the output will beallocated.

   For $a1add the first two arguments are as above and the rest are
   1)   a_name character(*)	name to be added to the ACL. (Input)
   2)   a_mode fixed bin (5)	the mode. (Input)
   3)   a_rb fixed bin (6)	 the ring brackets. (Input)

   This routine will do as much as it can, processing good entries in the data array
   and returning an error code in acla(i).reterr for the bad entries
   as well as an error code in a_code.


   If a_aclct = -1 for $adelete or if a_uap is non-null for $alist then the whole
   ACL list (up to 100 entries) will be listed or deleted as requested.
   The target ACL for replace is deleted before the new entries are made. */
%page;

/* Parameters */

dcl  a_aclct fixed bin parameter;
dcl  a_aclp ptr parameter;
dcl  a_code fixed bin (35) parameter;
dcl  a_dirname char (*) parameter;
dcl  a_ename char (*) parameter;
dcl  a_mode fixed bin (5) parameter;
dcl  a_name char (*) parameter;
dcl  a_rb (3) fixed bin (6) parameter;
dcl  a_uap ptr parameter;

/* Constants */

dcl  add fixed bin static options (constant) init (0);
dcl  add_one fixed bin static options (constant) init (1);
dcl  delete fixed bin static options (constant) init (3);
dcl  list fixed bin static options (constant) init (4);
dcl  replace fixed bin static options (constant) init (2);

/* Variables */

dcl  1 acl (100) aligned like temp_acl;
dcl  access_id char (32) varying;
dcl  acl_start_ptr ptr;
dcl  aclp ptr;
dcl  add_sw bit (1);
dcl  all bit (1) aligned;
dcl  count fixed bin;
dcl  cnt fixed bin;
dcl  code fixed bin (35);
dcl  dirname char (168);
dcl  dirsw bit (1) aligned;
dcl  dummy char (32) aligned;
dcl  entryname char (32);
dcl  fail_sw bit (1) aligned;
dcl  function fixed bin;
dcl  gate bit (1) aligned;
dcl  i fixed bin;
dcl  in_aclp ptr;
dcl  j fixed bin;
dcl  name char (32) aligned;
dcl  offset fixed bin;
dcl  p ptr;
dcl  ring (3) bit (3) aligned;
dcl  ringno fixed bin;
dcl  uap ptr;

/* External */

dcl  error_table_$argerr fixed bin (35) ext;
dcl  error_table_$bad_ring_brackets fixed bin (35) ext;
dcl  error_table_$invalid_mode fixed bin (35) ext;
dcl  error_table_$invalid_project_for_gate fixed bin (35) ext;
dcl  error_table_$noalloc fixed bin (35) ext;
dcl  error_table_$obsolete_function fixed bin (35) ext;
dcl  1 pds$access_name aligned ext,
       2 person char (32),
       2 project char (32),
       2 tag (1);
dcl  pds$processid bit (36) aligned ext;

/* Based */

dcl  1 acla (100) aligned based (aclp) like input_acl;
dcl  1 input_acl aligned based,
       2 userid char (32) aligned,
       2 mode bit (5) unaligned,
       2 reterr bit (13) unaligned,
       2 (rb1, rb2, rb3) bit (6) unaligned;
dcl  1 temp_acl aligned based,
       2 person char (32) aligned,
       2 project char (32) aligned,
       2 tag char (1) aligned,
       2 mode bit (36) aligned,
       2 ex_mode bit (36) aligned,
       2 status fixed bin (35),
       2 (rb1, rb2, rb3) fixed bin;
dcl  1 x aligned based,
       2 person char (32) aligned,
       2 project char (32) aligned,
       2 tag char (1) aligned,
       2 mode bit (36) aligned,
       2 ex_mode bit (36) aligned,
       2 status fixed bin (35),
       2 rb (3) fixed bin;

/* Entries */

dcl  acc_list_$match entry (fixed bin, bit (36) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl  acc_name_$elements entry (ptr, ptr, fixed bin (35));
dcl  acl_$add_entry entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35));
dcl  acl_$del_acl entry (fixed bin, bit (36) aligned, ptr);
dcl  acl_$del_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (35));
dcl  acl_$list_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35));
dcl  alloc_ entry (fixed bin, ptr, ptr);
dcl  change_dtem entry (ptr);
dcl  check_gate_acl_ entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35));
dcl  freen_ entry (ptr);
dcl  level$get entry (fixed bin);
dcl  setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
dcl  sum$dirmod entry (ptr);

/* Misc */

dcl  (area, bad_dir_) condition;

dcl  (addr, bin, bit, fixed, null, ptr, rtrim, size, substr) builtin;
%page;
aadd: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code);

	function = add;				/* indicate which type of acl manipulation */

	call setup;				/* copy input arguments and initialize flags */

	if cnt = 0 then go to ret;			/* if number of acl entries to be added is zero, return */
	call check_count;				/* validate count and aclp */

	call clear_code;				/* clear return 13 bit error code */

	call fill_in_temp;				/* convert input structure to intermediate structure */

add_common:
	call get_entry_ptr;				/* get pointer to entry */

	if dirsw then call check_modes;		/* check validity of directory modes for dir acl  */

	else do;					/* for segment acl */

	     call get_rb;				/* get ring brackets of segment */
	     call check_rb;				/* perform check on input ring bracket array */

	     if gate then do;			/* if adding ACL to a gate, cannot add new project */

		call check_gate_acl_ (acl_start_ptr, "1"b, (ep -> entry.acle_count), dummy, code);
		if code ^= 0 then go to unlock;	/* cannot perform ACL addition */

	     end;

	end;

	call change_acl;				/* set modify switch and update dtm */

	call add_to_acl;				/* add acl list */

/* indicate to segment control that dir modified */
	call update_and_unlock;			/* and unlock the directory */

	go to finale;
%page;
a1add: entry (a_dirname, a_ename, a_name, a_mode, a_rb, a_code); /* add one only */

	function = add_one;				/* indicate which type of acl manipulation */

	call setup;

	p = addr (acl (1));				/* convert input to intermediate strucutre */
	cnt = 1;					/* adding one acl */

	name = a_name;				/* copy userid */

	if name = "" then do;			/* set userid to current user with tag = "*" */

	     p -> temp_acl.person = pds$access_name.person;
	     p -> temp_acl.project = pds$access_name.project;
	     p -> temp_acl.tag = "*";

	end;

	else do;					/* break up userid into 3 part access name */

	     call acc_name_$elements (addr (name), p, p -> temp_acl.status);
	     if p -> temp_acl.status ^= 0 then go to finale; /* if illegal name, stop right now */

	end;

	p -> temp_acl.mode = bit (fixed (a_mode, 4), 4);	/* copy mode, strip off trap bit */
	p -> temp_acl.ex_mode = "0"b;			/* clear extended mode */

	p -> temp_acl.status = 0;			/* clear error code */

	p -> x.rb = a_rb;				/* copy ring brackets */

	go to add_common;				/* transfer to acl adding code */
%page;
areplace: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code);

	function = replace;				/* indicate what type of acl manipulation */

	call setup;				/* copy input arguments and initialize flags */

	if cnt = 0 then go to remove_acl;		/* if no ACLs to replace current ACL, delete present ACL */
	call check_count;				/* validate count and aclp */

	call clear_code;				/* clear return 13 bit error code */

	call fill_in_temp;				/* convert input structure to intermediate structure */

	call get_entry_ptr;				/* get pointer to entry and lock parent directory */

	if dirsw then call check_modes;		/* if replacing a dir acl check validity of dir modes */

	else do;					/* for segment acl */
	     p = addr (acl (cnt));
	     ring (1) = bit (fixed (p -> temp_acl.rb1, 3), 3); /* get ring brackets from intermediate structure */
	     ring (2) = bit (fixed (p -> temp_acl.rb2, 3), 3);
	     ring (3) = bit (fixed (p -> temp_acl.rb3, 3), 3);
	     call check_rb;				/* perform check on input ring bracket array */

	end;

	call change_acl;				/* set modify switch and update dtm */

	call delete_acl;				/* delete entire acl */

	call add_to_acl;				/* add ACL list */

	if ^dirsw then ep -> entry.ring_brackets = ring;	/* change ring brackets of segment ACL */

/* indicate to segment control that dir modified */
	call update_and_unlock;			/* and unlock the directory */

	go to finale;
%page;
adelete: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code);

	function = delete;				/* indicate what type of acl manipulation we are doing */

	call setup;				/* copy input arguments and initialize flags */

	if cnt ^= -1 then do;			/* given a list of acl entries to delete */

	     if cnt = 0 then go to ret;		/* done if none to delete */
	     call check_count;			/* validate count and aclp */
	     call clear_code;			/* clear return 13 bit error code */
	     call get_names;			/* parse input userids */

	end;

	else do;					/* delete entire acl */

remove_acl:
	     all = "1"b;				/* set flag */
	     aclp = null;

	end;

	call get_entry_ptr;				/* get ptr to entry and lock directory */

	call change_acl;				/* set modify switch and update dtm */

	if all then call delete_acl;			/* delete whole acl */

	else call delete_from_acl;			/* or delete selected acl entries */

/* indicate to segment control that dir modified */
	call update_and_unlock;			/* and unlock the directory */

	go to finale;
%page;
alist: entry (a_dirname, a_ename, a_aclp, a_aclct, a_uap, a_code);

	function = list;				/* indicate what type of acl manipulation */

	call setup;				/* copy input arguments and initialize flags */

	uap = a_uap;				/* copy pointer to user's area */

	if uap = null then do;			/* if user provided no area, then list selected acl entries */

	     cnt = a_aclct;				/* copy number of acl entries to be listed */
	     if cnt = 0 then go to ret;		/* if number of acl entries is zero, return */

	     aclp = a_aclp;				/* copy pointer to input structure */

	     call check_count;			/* validate count and aclp */
	     call clear_code;			/* clear return 13 bit error code */
	     call get_names;			/* parse input userids */

	end;

	else do;					/* list entire acl */

	     all = "1"b;				/* set flag */
	     aclp = null;
	     cnt = -1;

	end;

	call get_entry_ptr;				/* get entry ptr and lock directory */

	if all then call list_acl;			/* list entire acl */

	else call list_acl_entries;			/* list certain acl entries */

	call get_rb;				/* get ring brackets of segment */

	call dc_find$finished (dp, "1"b);		/* unlock and unuse */

	if all then on area go to alloc_err;		/* enable area condition outside internal procedure */
						/* so that it will share external procedure's stack frame */
	call copy_acl;				/* copy from intermediate structure to user area */

	go to finale;
%page;
/* error and other miscellanous returns */

alloc_err:					/* user did not provide enough room when listing entire ACL */
	if aclp ^= null then call freen_ (aclp);	/* free what was allocated */
	a_aclp = null;				/* return null pointer to allocation, acl count = 0 and status code */
	a_aclct = 0;
	code = error_table_$noalloc;
	go to ret;				/* copy main status code - already unlocked directory */

arg_err:						/* global problem with input arguments */
	code = error_table_$argerr;
	go to ret;				/* copy main status code - not yet locked directory */

bracket_error:					/* rb of segment/directory not within write bracket */
	code = error_table_$bad_ring_brackets;
	go to unlock;				/* unlock directory - reflect individual errors */

unlock:						/* unlock the directory on error */
	dir.modify = "0"b;
	call dc_find$finished (dp, "1"b);		/* unlock and unuse */

finale:
	if function = add_one then do;		/* if entered via a1add, skip processing individual codes */
	     if code = 0 then code = p -> temp_acl.status;
	end;

	else if cnt > 0 then do i = 1 to cnt;		/* reflect individual code to user's structure */

	     p = addr (acl (i));
	     if p -> temp_acl.status ^= 0 then do;
		aclp -> acla (i).reterr = bit (fixed (p -> temp_acl.status, 13), 13);

/* if main status code is non-zero, reflect it up */
		if code = 0 then code = p -> temp_acl.status;

	     end;

	end;
ret:
	a_code = code;
	return;
%page;
setup:						/* copy arguments - set initial values for flags */
     proc;

	code = 0;					/* clear status code */

	dirname = a_dirname;			/* copy directory name */

	entryname = a_ename;			/* copy entry name */
						/* perform requested function */

	if function ^= list & function ^= add_one then do;/* if input args */

	     aclp = a_aclp;				/* copy pointer to input structure */
	     cnt = a_aclct;				/* copy count of entries in input structure */

	end;

	all,					/* clear various flags */
	     fail_sw,
	     gate = "0"b;

	call level$get (ringno);			/* get validation level */

     end setup;
%page;
check_count:					/* check input arguments - count of acl entries */
     proc;					/* and pointer to input structure */

	if cnt < 0 then go to arg_err;		/* count must be non-negative */
	if cnt > 100 then go to arg_err;		/* limit of 100 in this primitive */
	if aclp = null then go to arg_err;		/* trouble if pointer is null */

     end check_count;
%page;
clear_code:					/* clear error codes in user structure before doing anything */
     proc;

	do i = 1 to cnt;

	     in_aclp = addr (aclp -> acla (i));
	     in_aclp -> input_acl.reterr = "0"b;

	end;

     end clear_code;
%page;
get_entry_ptr:					/* procedure called when manipulating acls - get pointer to entry */
     proc;					/* lock dir - copy items from entry - define items for lower level primitives */

	if entryname = "" then do;			/* trying to get obsolete cacl */
	     code = error_table_$obsolete_function;
	     go to finale;
	end;

/* get pointer to entry and lock parent */

	if function = list then call dc_find$obj_status_read (dirname, entryname, 1, ep, code);
	else call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_ACL_RING_MOD, ep, code);

	dp = ptr (ep, 0);				/* get directory pointer before checking status code */

	if code ^= 0 then go to ret;			/* non-zero codes do not lock the directory */

	dirsw = ep -> entry.dirsw;			/* copy directory flag */

	acl_start_ptr = addr (ep -> entry.acl_frp);	/* lower level acl primitives want to know where acl starts */

/* check that validation level is <= write bracket of segment */

	if function ^= list then
	     if dirsw then do;
						/* if a directory look at extended ring brackets */
		if ringno > bin (ep -> entry.ex_ring_brackets (1), 3) then go to bracket_error;
	     end;

	     else do;
						/* if a segment look at actual ring bracket */
		if ringno > bin (ep -> entry.ring_brackets (1), 3) then go to bracket_error;
	     end;

     end get_entry_ptr;
%page;
get_names:					/* break input userids into 3 part access names */
     proc;					/* and store in intermediate storage */

	do i = 1 to cnt;

	     p = addr (acl (i));
	     in_aclp = addr (aclp -> acla (i));

	     call acc_name_$elements (in_aclp, p, p -> temp_acl.status);

	end;

     end get_names;
%page;
update_and_unlock:					/* reflect change to ACL */
     proc;

	call setfaults$if_active ((ep -> entry.uid), (ep -> entry.pvid), (ep -> entry.vtocx), "1"b);

	dir.modify = "0"b;
	call sum$dirmod (dp);			/* turn on file modified switch of the directory */

	call dc_find$finished (dp, "1"b);		/* unlock and unuse */

     end update_and_unlock;
%page;
change_acl:					/* set dtem if user not transparent */
						/* set dtbm in kste */
     proc;					/* turn on modify switch in directory */

	dir.modify = pds$processid;

	call change_dtem (ep);

     end change_acl;
%page;
fill_in_temp:					/* fill in intermediate structure before locking directory */
     proc;					/* essentially copying arguments */

	do i = 1 to cnt;

	     p = addr (acl (i));
	     in_aclp = addr (aclp -> acla (i));
						/* store userid as 3 part access name */
	     call acc_name_$elements (in_aclp, p, p -> temp_acl.status);

/* copy input mode as is + strip off old trap bit */
	     p -> temp_acl.mode = substr (in_aclp -> input_acl.mode, 2);
	     p -> temp_acl.ex_mode = "0"b;		/* clear extended mode */

/* copy input ring brackets */
	     p -> temp_acl.rb1 = fixed (in_aclp -> input_acl.rb1, 6);
	     p -> temp_acl.rb2 = fixed (in_aclp -> input_acl.rb2, 6);
	     p -> temp_acl.rb3 = fixed (in_aclp -> input_acl.rb3, 6);

	end;

     end fill_in_temp;
%page;
delete_acl:					/* procedure to delete entire ACL */
     proc;
						/* call lower level procedure to do work */
	call acl_$del_acl ((entry.acle_count), entry.uid, acl_start_ptr);

/* update counts */
	dp -> dir.acle_total = dp -> dir.acle_total - ep -> entry.acle_count;
	ep -> entry.acle_count = 0;
     end delete_acl;
%page;
list_acl: proc;					/* list entire ACL */

	do i = 1 to 100;

	     p = addr (acl (i));
						/* get the i th ACL */
	     call acl_$list_entry ((entry.acle_count), entry.uid, acl_start_ptr, p, i, p -> temp_acl.status);

	     if p -> temp_acl.status ^= 0 then
		if p -> temp_acl.status = error_table_$argerr then do;
						/* have reached the end of the ACL list */

		     cnt = i - 1;			/* store the number of entries in the list */
		     count = ep -> entry.acle_count;

/* check the validity of the entry ACL count count */
		     if count ^= cnt then signal bad_dir_;
		     return;

		end;

	end;

	cnt = 100;				/* there are more than 100 entries in list */
	code = error_table_$argerr;			/* return first 100 entries + status code */

     end list_acl;
%page;
add_to_acl:					/* add entries to ACL */
     proc;

	count = 0;				/* zero count of new ACL entries */

	do i = 1 to cnt;

	     p = addr (acl (i));
	     if p -> temp_acl.status = 0 then do;	/* skip over items which previously produced errors */

/* add one entry to ACL */
		call acl_$add_entry ((entry.acle_count), entry.uid, acl_start_ptr,
		     p, add_sw, p -> temp_acl.status);

		if add_sw then do;			/* if atually added, update counts */
		     ep -> entry.acle_count = ep -> entry.acle_count + 1;
		     dp -> dir.acle_total = dp -> dir.acle_total + 1;
		end;

	     end;

	end;

     end add_to_acl;
%page;
delete_from_acl:					/* remove selected ACL entries */
     proc;

	count = 0;				/* zero count of entries deleted */

	do i = 1 to cnt;

	     p = addr (acl (i));
	     if p -> temp_acl.status = 0 then do;	/* ignore requests with previous errors */

/* delete the ACL entry */
		call acl_$del_entry ((entry.acle_count), entry.uid, acl_start_ptr, p, p -> temp_acl.status);

		if p -> temp_acl.status = 0 then count = count + 1;
						/* increment count of deletions if successful */
	     end;

	end;

	if count > 0 then do;			/* if any deletions took place, update counts */

	     ep -> entry.acle_count = ep -> entry.acle_count - count;
	     dp -> dir.acle_total = dp -> dir.acle_total - count;

	end;

     end delete_from_acl;
%page;
list_acl_entries:					/* list selected ACL entries */
     proc;

	do i = 1 to cnt;

	     p = addr (acl (i));
	     if p -> temp_acl.status = 0 then do;	/* if no previous error, */

/* find ACL entry in list */
		call acc_list_$match ((entry.acle_count), entry.uid, acl_start_ptr,
		     p, aclep, offset, p -> temp_acl.status);

		if p -> temp_acl.status = 0 then do;	/* if input access name on list */

/* copy mode + extended mode into intermediate store */
		     p -> temp_acl.mode = aclep -> acl_entry.mode;
		     p -> temp_acl.ex_mode = aclep -> acl_entry.mode;

		end;

	     end;

	end;

     end list_acl_entries;
%page;
get_rb: proc;					/* obtain ring brackets from branch */

	if dirsw then do;				/* directory ACL */

	     ring (1) = ep -> entry.ex_ring_brackets (1);
	     ring (2),
		ring (3) = ep -> entry.ex_ring_brackets (2);

	end;

	else do;					/* segment ACL */

	     ring (1) = ep -> entry.ring_brackets (1);
	     ring (2) = ep -> entry.ring_brackets (2);
	     ring (3) = ep -> entry.ring_brackets (3);

	end;

     end get_rb;
%page;
check_modes:					/* perform check on input directory modes for ACLs */
     proc;					/* map old REWA modes to new SMA modes - setup intermediate structure modes */

	do i = 1 to cnt;

	     p = addr (acl (i));

/* convert REWA mode to new SMA directory modes */
	     p -> temp_acl.ex_mode = substr (p -> temp_acl.mode, 1, 1) || substr (p -> temp_acl.mode, 3, 2);

	     p -> temp_acl.mode = RW_ACCESS;		/* rw mode for directory ACLs */

/* do not allow specification of M without S */
	     if (p -> temp_acl.ex_mode & "11"b) = "01"b then do;

		p -> temp_acl.status = error_table_$invalid_mode;
		if function = add_one then go to unlock;/* stop for add1 entry */

	     end;

	end;

     end check_modes;
%page;
check_rb:						/* check input ring brackets of segments for legality + consistency */
     proc;					/* check projects of gate segments */

	if ringno > 1 then				/* perform special checks if creating a gate segment by ACL replacement */
	     if ring (2) ^= ring (3) then		/* or if adding ACL entries to a gate segment */
		gate = "1"b;			/* from rings greater than the administrative ring */

	do i = 1 to cnt;

	     p = addr (acl (i));

	     p -> temp_acl.mode = p -> temp_acl.mode & "1110"b; /* strip off old append bit for segment ACLs */

/* ring must be less than 8 and non-negative */
	     if p -> temp_acl.rb1 > 7 then go to input_rb_error;
	     if p -> temp_acl.rb1 < 0 then go to input_rb_error;
	     if p -> temp_acl.rb2 > 7 then go to input_rb_error;
	     if p -> temp_acl.rb2 < 0 then go to input_rb_error;
	     if p -> temp_acl.rb3 > 7 then go to input_rb_error;
	     if p -> temp_acl.rb3 < 0 then go to input_rb_error;

/* ring brackets must be internally consistent */
	     if ringno > p -> temp_acl.rb1 then go to input_rb_error;
	     if p -> temp_acl.rb1 > p -> temp_acl.rb2 then go to input_rb_error;
	     if p -> temp_acl.rb2 > p -> temp_acl.rb3 then do;
input_rb_error:	p -> temp_acl.status = error_table_$bad_ring_brackets;
		fail_sw = "1"b;			/* abort after checking remainder of input ACLs */
		go to skip_rb_check;		/* and skip remainder of checking */
	     end;

	     if gate then				/* if manipulating a gate segment */
						/* check that user is adding/replacing his project or service project */
		if p -> temp_acl.project ^= pds$access_name.project then
		     if p -> temp_acl.project ^= "SysDaemon" then do;
			p -> temp_acl.status = error_table_$invalid_project_for_gate;
			fail_sw = "1"b;		/* stop after checking rest of input */
			go to skip_rb_check;
		     end;

	     do j = 1 to 3;				/* if no errors thus far */

/* check input rb against rb of existing segment (adding) */
/* or check all input rb against rb of last input rb (replacing) */
		if p -> x.rb (j) ^= fixed (ring (j), 3) then go to input_rb_error;

	     end;
skip_rb_check:
	end;

	if fail_sw then go to unlock;			/* if serious error, abort */

     end check_rb;
%page;
copy_acl:						/* format ACL for entry points which list */
     proc;					/* and copy from temporary storage into user's area */

	if all then do;				/* if listing entire ACL */

/* allocate in area provided by user */
	     call alloc_ (size (input_acl) * cnt, uap, aclp);
	     if aclp = null then go to alloc_err;
	     a_aclp = aclp;
	     a_aclct = cnt;

	end;

	do i = 1 to cnt;

	     p = addr (acl (i));			/* get ptr to intermediate entry */

/* omit requests which generated errors */
	     if p -> temp_acl.status = 0 then do;

		in_aclp = addr (aclp -> acla (i));	/* get ptr to output entry */

/* construct userid - use varying character string for efficiency */
		access_id = rtrim (p -> temp_acl.person);
		access_id = access_id || ".";
		access_id = access_id || rtrim (p -> temp_acl.project);
		access_id = access_id || ".";
		access_id = access_id || p -> temp_acl.tag;
		in_aclp -> input_acl.userid = access_id;

/* format directory mode - convert from SMA to REWA */
		if dirsw then in_aclp -> input_acl.mode =
			"0"b || substr (p -> temp_acl.ex_mode, 1, 1) || "1"b || substr (p -> temp_acl.ex_mode, 2, 2);

/* return segment ACL modes - add old trap and append bits */
		else in_aclp -> input_acl.mode = "0"b || substr (p -> temp_acl.mode, 1, 4);

/* return ring brackets */
		in_aclp -> input_acl.rb1 = (3)"0"b || ring (1);
		in_aclp -> input_acl.rb2 = (3)"0"b || ring (2);
		in_aclp -> input_acl.rb3 = (3)"0"b || ring (3);

		in_aclp -> input_acl.reterr = "0"b;	/* clear code */

	     end;

	end;

     end copy_acl;

/* format: off */
%page; %include access_mode_values;
%page; %include dc_find_dcls;
%page; %include dir_acl;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include fs_obj_access_codes;
     end acl;




		    append.pl1                      11/11/89  1132.4rew 11/11/89  0800.0      349740



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



/****^  HISTORY COMMENTS:
  1) change(89-02-27,TLNguyen), approve(89-02-27,MCR8049),
     audit(89-02-28,Parisek), install(89-03-15,MR12.3-1025):
     a. removed create_branch_version_1.
     b. fixed size error.
     c. fixed stringsize error.
  2) change(89-03-31,TLNguyen), approve(89-03-31,PBF8049),
     audit(89-03-31,Farley), install(89-04-24,MR12.3-1031):
     Reinstated the check for create_branch_version_1 in order to retain
     binary compatibility.
                                                   END HISTORY COMMENTS */


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

append: procedure;

/* Modified 85-04-01 by Keith Loepere for new access_audit_check_ep_. */
/* Modified 85-01-30 by Keith Loepere to get dtem right. */
/* Modified 84-02-11 by Greg Texada to reference the arguments correctly in retv entry */
/* Modified 84-12-14 by Keith Loepere to allow setting dir quota for dirs */
/* Modified 84-11-27 by EJ Sharpe to change access_audit_ arg list */
/* Modified 10/15/84 by Keith Loepere to explicitly activate dir being created.
   Also to prevent creation of upgraded MSFs.  Also for audit info.  Also for
   admin_gate_$create_branch_ */
/* Modified 1984-10-01 BIM to fix retv max_auth for ^ac_sw case. */
/* Modified 07/10/84 by Keith Loepere to use the new dc_find. */
/* Modified 04/02/84 by K. Loepere to restrict link pathnames to valid 7-bit ASCII characters. */
/* Modified 84-03-16 BIM to make retv work with AIM.
	  this includes TEMPORARY change to set soos on multi-class
	  objects retrieved. */
/* Modified 05/07/82 by J. Bongiovanni to fix bug in cross-retrieval */
/* Modified 02/15/82 by J. Bongiovanni to fix bug in duplicate uid check */
/* Modified 11/01/79 by Mike Grady to set sons lvid for retv case (used by adopt seg) */
/* Modified 02/19/79 by C. D. Tavares to set dir ex ring brackets and to correct several bad_ring_brackets err codes */
/* modified 6/77 by D. Vinograd to check for duplicate uids in volume retriever case */
/* modified 4/77 by M. Weaver to replace makeknown with makeknown_ */
/* modified by D. Vinograd 9/76 to add entry retv. This entry used by the volume
   retriever to append an entry structure passed in by the caller. */
/* modified by S.E. Barr 8/76 to use variable sized hash tables */
/* modified by R. Bratt May 31, 1976 to call find_$finished */
/* modified by L. Scheffler March 1976 to use info-only entry in dir_control_error */
/* modified by Larry Johnson March 1976 for appending master dirs */
/* modified by Bernard S. Greenberg, 4-24-75 for NSS */
/* modified by Kobziar 4-11-75 to filter unused bits from access class */
/* modified by Kobziar 10-20-74 to add new entry: create_branch */
/* modified by Kobziar on 6-20-74 to copy  access_class from parent to branch */
/* modified by Kobziar on 11-15-73 to take out "a" mode on segs */

/*
   append$branch: Creates a non directory branch in the hierarchy and places
   the current user on the acl with the specified mode.

   USAGE: call append$branch(directory_name, entry_name, access_mode, error_code)

   1. directory_name char(*) - - - directory path name of new branch
   2. entry_name char(*) - - - created branch's name
   3. access_mode fixed bin(5) - - - mode desired on the created branch
   4. error_code fixed bin(35) - - - file system error code (Output)

   Default values are:
   1. Ringbrackets set from users validation level.
   2. User id set to creator User id with tag = "*".
   3. Copy switch set to off.
   4. Bit count set to 0.

   append$link: Creates a link in a specified directory with a given name
   to an other specified segment.

   USAGE: call append$link(directory_name, entry_name, link_to_name, error_code)

   1. directory_name char(*) - - - directory path name of new link
   2. entry_name char(*) - - - created link name
   3. link_to_name char(*) - - - path name of segment to be linked to
   4. error_code fixed bin(17) - - - file system error code (Output)

   append$branchx: Creates either a directory or non directory entry as specified with
   all the attributes described below as specified.

   USAGE: call append$branhcx(directory_name, entry_name, access_mode, ringbrackets,
   user_id, directory_switch, copy_switch, bit_count,
   error_code)

   1. directory_name char(*) - - - directory path name of new branch
   2. entry_name char(*) - - - created branch's entry name
   3. acces_mode fixed bin(5) - - - mode desired on the created branch
   4. ringbrackets arry(3) - - - fixed bin(6) - - - ring brackets desired on the created branch
   5. user_id char(*) - - - user_id desired on the acl
   6. directory_switch fixed bin(1) - - - directory branch switch
   7. copy_switch fixed bin(1) - - - segment copy switch
   8. bit_count fixed bin(24) - - - segment length in bits
   9. error_code fixed bin(17) - - - file system error code (Output)

   append$master_dir: create a master directory for a logical volume.
   Called from ring 1 after setting things up with the vol registration stuff.

   USAGE: call append$master_dir(directory_name, entry_name, access_mode, ringbrackets,
   user_id, sons_lvid, error_code);

   1-5. Same as branchx
   6. sons_lvid bit (36) - - - logical vol ID for sons
   7. error_code fixed bin - - - error code (output)

   append$create_branch_: Allows the setting of the access class field in a branch and  and the setting of
   quota in new directories.  admin_create_branch_ is the same but allows creation in lower class dirs.

   USAGE: call append$create_branch_(directory_name, entry_name, arg_ptr, code)

   1. - 2. as in branchx
   3. arg_ptr  ptr - - - pointer to a create_branch_info as given in
					create_branch_info.incl.pl1
   4. error_code as above.
*/
%page;

/* Parameters */

dcl  a_arg_ptr			ptr parameter;
dcl  a_bitcnt			fixed bin (24) parameter;
dcl  a_code			fixed bin (35) parameter;
dcl  a_copysw			fixed bin (2) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_dirsw			fixed bin (1) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_linkname			char (*) parameter;
dcl  a_mode			fixed bin (5) parameter;
dcl  a_retv_append_argp		ptr parameter;
dcl  a_ringbrack			(3) fixed bin (6) parameter;
dcl  a_sons			bit (36) parameter;
dcl  a_uid_path			(0:15) bit (36) aligned parameter;
dcl  a_userid			char (*) parameter;

/* static variable */
dcl  create_branch_version_1            fixed bin int static options (constant) init (1);

/* Variables */

dcl  ac_sw			bit (1) aligned;
dcl  acbr_version			fixed bin;
dcl  access_class			bit (72) aligned;
dcl  acl_count			fixed bin;
dcl  acl_start_ptr			ptr;
dcl  add_sw			bit (1);
dcl  admin_append			bit (1) aligned;
dcl  areap			ptr;
dcl  arg_ptr			ptr;
dcl  asize			fixed bin;
dcl  audit_eventflags		bit (36) aligned;
dcl  authp			ptr;
dcl  bcount			fixed bin;
dcl  bitcnt			fixed bin (24);
dcl  bmode			bit (3) aligned;
dcl  branch_sw			bit (1);
dcl  chase_sw			bit (1) aligned;
dcl  code				fixed bin (35);
dcl  copysw			fixed bin (1);
dcl  default_sw			bit (1);
dcl  dep				ptr;
dcl  dir_quota			fixed bin (18);
dcl  dirl				bit (1) aligned;
dcl  dirname			char (168);
dcl  dirp				ptr;
dcl  dirsw			fixed bin (1);
dcl  dtem				bit (36) aligned;
dcl  dumcode			fixed bin (35);
dcl  dummy			char (32) aligned;
dcl  ename			char (32);
dcl  ename_aligned			char (32) aligned;
dcl  i				fixed bin;
dcl  iacl_start_ptr			ptr;
dcl  iaclp			ptr;
dcl  1 initial_acl			aligned like input_acl;
dcl  level			fixed bin;
dcl  linkname			char (168) aligned;
dcl  llngth			fixed bin (18);
dcl  1 local_entry			like entry aligned;
dcl  max_access_authorization		bit (72) aligned;
dcl  1 mk_info			aligned like makeknown_info;
dcl  1 my_audit_user_info		aligned like audit_user_info;
dcl  n_iacls			fixed bin;
dcl  newuid			bit (36) aligned;
dcl  nwords			fixed bin;
dcl  parent_access_class		bit (72) aligned;
dcl  prevep			ptr;
dcl  prior_dir_acl_count		fixed bin;
dcl  priv_mqsw			bit (1) aligned;
dcl  project			char (32) aligned;
dcl  quota			fixed bin (18);
dcl  read_lock			bit (36) aligned;
dcl  retv				bit (1) aligned;
dcl  retv_cross_segment		bit (1) aligned;
dcl  ringbrack			(3) fixed bin (6);
dcl  segno			fixed bin;
dcl  1 service_acl			aligned,
       2 person			char (32) init ("*"),
       2 project			char (32) init ("SysDaemon"),
       2 tag			char (1) init ("*"),
       2 mode			bit (36) init ("101"b),
       2 exmode			bit (36) init ("0"b);
dcl  sons				bit (36) aligned;
dcl  sonsw			bit (1) aligned;
dcl  sp_sw			bit (1) aligned;
dcl  sysl				bit (1) aligned;
dcl  temp_b4			bit (4) aligned;
dcl  uid_path			(0:15) bit (36) aligned;
dcl  1 user_acl			aligned,
       2 person			char (32),
       2 project			char (32),
       2 tag			char (1),
       2 mode			bit (36) init ("111"b),
       2 exmode			bit (36) init ("0"b);
dcl  userid			char (32) aligned;
dcl  vtocx_temp			fixed bin;
dcl  xsize			fixed bin;

/* Based */

dcl  1 acbr			like create_branch_info based (arg_ptr) aligned;
dcl  1 input_acl			based aligned,
       2 person			char (32),
       2 project			char (32),
       2 tag			char (1),
       2 mode			bit (36),
       2 exmode			bit (36);

/* External */

dcl  active_all_rings_data$max_tree_depth external fixed bin;
dcl  active_hardcore_data$alloc_sizes	(6) external fixed bin;
dcl  active_hardcore_data$dir_arearp	ext fixed bin (35);
dcl  active_hardcore_data$dir_hdrsize	external fixed bin;
dcl  active_hardcore_data$elcsize	external fixed bin;
dcl  active_hardcore_data$ensize	external fixed bin;
dcl  active_hardcore_data$esize	external fixed bin;
dcl  active_hardcore_data$nalloc_sizes	external fixed bin;
dcl  error_table_$ai_restricted	external fixed bin (35);
dcl  error_table_$argerr		external fixed bin (35);
dcl  error_table_$invalid_mode	external fixed bin (35);
dcl  error_table_$invalid_project_for_gate external fixed bin (35);
dcl  error_table_$invalid_ring_brackets external fixed bin (35);
dcl  error_table_$lower_ring		external fixed bin (35);
dcl  error_table_$max_depth_exceeded	external fixed bin (35);
dcl  error_table_$namedup		external fixed bin (35);
dcl  error_table_$noalloc		external fixed bin (35);
dcl  error_table_$noentry		external fixed bin (35);
dcl  error_table_$unimplemented_version external fixed bin (35);
dcl  1 pds$access_authorization	aligned like aim_template external;
dcl  1 pds$access_name		aligned external,
       2 person			char (32),
       2 project			char (32),
       2 tag			char (1);
dcl  pds$max_access_authorization	bit (72) aligned external;
dcl  pds$processid			bit (36) aligned external;
dcl  sys_info$access_class_ceiling	external bit (72) aligned;
dcl  sys_info$default_dir_max_length	fixed bin (19) external;

/* Entries */

dcl  acc_name_$elements		entry (ptr, ptr, fixed bin (35));
dcl  acc_name_$encode		entry (ptr, ptr, fixed bin (35));
dcl  access_audit_check_ep_$self	entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1));
dcl  access_audit_check_ep_$user	entry (bit (36) aligned, bit (36) aligned, ptr, bit (72) aligned, bit (36) aligned) returns (bit (1));
dcl  access_audit_$log_entry_ptr	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), char (*));
dcl  access_audit_$log_entry_ptr_user	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), ptr, char (*));
dcl  acl_$add_entry			entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35));
dcl  acl_$del_acl			entry (fixed bin, bit (36) aligned, ptr);
dcl  acl_$list_entry		entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35));
dcl  aim_check_$equal		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater_or_equal	entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  allocate_dir_ht_		entry (ptr, fixed bin, fixed bin (35));
dcl  check_gate_acl_		entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35));
dcl  create_vtoce			entry (ptr, bit (36), fixed bin (17), fixed bin (35));
dcl  delete_vtoce			entry (ptr, fixed bin (35));
dcl  fs_alloc$alloc			entry (ptr, fixed bin, ptr);
dcl  fs_alloc$free			entry (ptr, fixed bin, ptr);
dcl  fs_alloc$init			entry (ptr, fixed bin, ptr, fixed bin);
dcl  getuid			entry () returns (bit (36) aligned);
dcl  hash$in			entry (ptr, ptr, fixed bin (35));
dcl  hash$out			entry (ptr, ptr, ptr, fixed bin (35));
dcl  hash$search			entry (ptr, ptr, ptr, fixed bin (35));
dcl  level$get			entry returns (fixed bin);
dcl  lock$dir_unlock		entry (ptr);
dcl  makeknown_			entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  makeunknown_			entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  mountedp			entry (bit (36) aligned) returns (fixed bin (35));
dcl  quota$append_mdir_set		entry (ptr, fixed bin (18), fixed bin (35));
dcl  quota$check			entry (ptr, fixed bin (18), fixed bin (35));
dcl  quota$qmove_mylock		entry (ptr, ptr, fixed bin (18), bit (1) aligned, fixed bin (35));
dcl  sum$dirmod			entry (ptr);
dcl  syserr$error_code		entry options (variable);
dcl  truncate$trentry		entry (ptr);
dcl  uid_path_util$get		entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35));

/* Misc */

dcl  (addr, baseptr, bin, bit, clock, collate, divide, fixed, length, null, ptr, rel, rtrim, substr, unspec, verify) builtin;

dcl  bad_dir_			condition;
%page;
master_dir: entry (a_dirname, a_ename, a_arg_ptr, a_sons, a_uid_path, a_code);

	call setup;

	sons = a_sons;
	sonsw = "1"b;

	max_access_authorization = pds$max_access_authorization;
	go to cbcomm;

retv: entry (a_dirname, a_ename, a_arg_ptr, a_retv_append_argp, a_code);

	call setup;

	retv = "1"b;

	retv_append_argp = a_retv_append_argp;
	if retv_append_args.version ^= RETV_APPEND_ARGS_VERSION_1 then do;
	     a_code = error_table_$unimplemented_version;
	     return;
	end;

	level = retv_append_args.level;
	max_access_authorization = retv_append_args.max_access_authorization;

	arg_ptr = addr (a_arg_ptr -> acbr);		/* prevent indirections and tallys */
	acbr_version = acbr.version;
	if acbr_version < create_branch_version_1 |
	     acbr_version > create_branch_version_2 then go to arg_err;

	audit_user_info_ptr = addr (my_audit_user_info);
	unspec (audit_user_info) = "0"b;

	audit_user_info.version = audit_user_info_version_1;
	audit_user_info.user_id = acbr.userid;		/* we'll have to trust our caller for this, 
						the retriever is good about this */
	audit_user_info.process_id = "0"b;		/* unknown whether logged in */
	audit_user_info.authorization = retv_append_args.access_authorization; /* in non-retv case, access_mode gets from the pds */
	audit_user_info.authorization_range(2) = retv_append_args.max_access_authorization;
	audit_user_info.audit_flags = (36)"1"b;		/* audit anything until we get real audit_flags */
	audit_user_info.ring = retv_append_args.level;

	if retv_append_args.link then linkname = retv_append_args.ep -> link.pathname;
	else local_entry = retv_append_args.ep -> entry;

	if retv_append_args.link then goto join_link;

	retv_cross_segment = retv_append_args.cross_segment;
	goto cbcomm2;

admin_create_branch_: entry (a_dirname, a_ename, a_arg_ptr, a_code);

	call setup;

	admin_append = "1"b;

	max_access_authorization = sys_info$access_class_ceiling;
	go to cbcomm;

create_branch_: entry (a_dirname, a_ename, a_arg_ptr, a_code);

	call setup;

	max_access_authorization = pds$max_access_authorization;

cbcomm:	arg_ptr = addr (a_arg_ptr -> acbr);		/* prevent indirections and tallys */
	acbr_version = acbr.version;
	if acbr_version < create_branch_version_1 |
	     acbr_version > create_branch_version_2 then go to arg_err;

cbcomm2:	ac_sw = ^acbr.parent_ac_sw;			/* if no ac specified, have to get parent's entry point */
	if ac_sw then do;
	     access_class = acbr.access_class;		/* If ac was specified, copy it */
	     if ^aim_check_$greater_or_equal (max_access_authorization, access_class) then do;
		code = error_table_$ai_restricted;
		go to fin;
	     end;
	end;
	copysw = fixed (acbr.switches.copy_sw, 1);
	bmode = acbr.mode;
	dirsw = fixed (acbr.switches.dir_sw, 1);
	ringbrack (1) = acbr.rings (1);
	ringbrack (2) = acbr.rings (2);
	if dirsw = 1 then ringbrack (3) = ringbrack (2);	/* ignore third bracket */
	else ringbrack (3) = acbr.rings (3);
	userid = acbr.userid;
	bitcnt = acbr.bitcnt;
	chase_sw = acbr.switches.chase_sw;
	priv_mqsw = acbr.switches.priv_upgrade_sw;
	quota = acbr.quota;
	if acbr_version > create_branch_version_1 then dir_quota = acbr.dir_quota;
	go to comm2;

branchx: entry (a_dirname, a_ename, a_mode, a_ringbrack, a_userid, a_dirsw, a_copysw, a_bitcnt, a_code);

	call setup;

	if a_copysw = 0 then copysw = 0;
	else copysw = 1;
	if a_dirsw = 0 then dirsw = 0; else dirsw = 1;
	if dirsw = 0 then bmode = substr (bit (fixed (a_mode, 4), 4), 1, 3);
	else do;					/* map rewa to sma */
	     temp_b4 = bit (fixed (a_mode, 4), 4);
	     bmode = substr (temp_b4, 1, 1) || substr (temp_b4, 3, 2);
	end;

	userid = a_userid;				/* copy process group id */
	ringbrack = a_ringbrack;			/* pick up all three */
	if dirsw = 1 then ringbrack (3) = ringbrack (2);	/* except for dirs */
	bitcnt = a_bitcnt;				/* and bitcount */
comm2:
	branch_sw = "1"b;				/* indicate that we are appending a branch */
	default_sw = "0"b;				/* turn off default attribute switch */
	do i = 1 to 3;				/* check input brackets */
	     if ringbrack (i) >= 8 then go to inv_rb_err;
	     if ringbrack (i) < 0 then go to inv_rb_err;
	end;
	if ^retv then
	     level = level$get ();			/* Get current validation level */
	if ^retv | (retv & ^local_entry.dirsw) then
	     if ringbrack (1) < level then goto lower_ring_err;
	     else if ringbrack (1) > ringbrack (2)
		     | ringbrack (2) > ringbrack (3) then
		go to inv_rb_err;

	call acc_name_$elements (addr (userid), addr (user_acl), code); /* convert userid to 3 part access name */
	if code ^= 0 then go to arg_err;
	go to join;

branch: entry (a_dirname, a_ename, a_mode, a_code);

	call setup;

	branch_sw,				/* indicate that we are appending a branch */
	     default_sw = "1"b;			/* indicate that we will select the default attributes */

	dirsw,					/* Set dirsw off -- can't be a directory */
	     copysw,				/* And no copying */
	     bitcnt = 0;				/* Bit count starts at zero */

	user_acl.person = pds$access_name.person;	/* set up final acl to be caller with a tag of "*" */
	user_acl.project = pds$access_name.project;
	user_acl.tag = "*";
	level,					/* save validation level */
	     ringbrack (*) = level$get ();		/* set brackets to V, V, V */

	bmode = substr (bit (fixed (a_mode, 4), 4), 1, 3);/* strip off trap bit */
	go to join;

link: entry (a_dirname, a_ename, a_linkname, a_code);

	call setup;

	linkname = a_linkname;			/* copy and check linkname */
join_link:
	branch_sw = "0"b;				/* indicate that we are appending a link */
	if substr (linkname, 1, 1) ^= ">" then go to arg_err;

/* find length of linkname - allow embedded blanks */
	llngth = length (rtrim (linkname));
	if verify (substr (linkname, 1, llngth), collate ()) > 0 then go to arg_err; /* link must be all ascii */
join:
	dirl = "0"b;
	code = 0;					/* clear error code */
	if retv then authp = addr (user_acl);
	else authp = addr (pds$access_name);		/* get pointer to 3 part access name */

	dirname = a_dirname;			/* copy directory and entry name arguments */
	ename = a_ename;

	if branch_sw then do;			/* if appending a branch */

/* set up ACLS with proper mode */
/* convert fixed bin(5) mode into new modes */
	     if dirsw = 0 then user_acl.mode = bmode;

	     else do;
		user_acl.exmode = bmode;
		if (user_acl.exmode & "11"b) = "01"b then /* don't allow M without S access */
		     go to invalid_mode;
		service_acl.mode = "111"b;		/* set access field for directories */
		service_acl.exmode = "111"b;		/* set extended mode for .SysDaemon access */

	     end;
	end;

	if ^branch_sw then chase_sw = "0"b;		/* don't chase when adding links */

	if retv then do;
	     call dc_find$dir_for_retrieve_append
		(dirname, ename, bin (chase_sw, 1), audit_user_info_ptr, dep, dp, code);
	     if code ^= 0 then go to fin;
	     dirl = "1"b;
	end;
	else do;
	     if admin_append then
		call dc_find$dir_for_append_raw (dirname, ename, bin (chase_sw, 1), dep, dp, code);
	     else call dc_find$dir_for_append (dirname, ename, bin (chase_sw, 1), dep, dp, code);
	     if code ^= 0 then go to fin;
	     dirl = "1"b;
	end;

	if dep = null then parent_access_class = "0"b;	/* assume root at  0 access class */
	else do;
	     if branch_sw then parent_access_class = dep -> entry.access_class;
	     call lock$dir_unlock (ptr (dep, 0));
	     dep = null;
	end;

	code = 0;
	ename_aligned = ename;

	if branch_sw then do;			/* make sure not lower than parent */
	     if ac_sw then call check_aim_access;
	     else access_class = parent_access_class;	/* make it same as parent */
	end;

	if retv then do;				/* check for duplicate uids */
	     if ^retv_append_args.link then do;
		i = 0;
		bcount = dir.dir_count + dir.seg_count + dir.lcount;
		do ep = ptr (dp, dir.entryfrp) repeat (ptr (dp, entry.efrp)) while (rel (ep) ^= "0"b);
		     i = i + 1;
		     if i > bcount then signal bad_dir_;
		     if entry.uid = local_entry.uid then goto name_dup;
		end;
	     end;
	end;

	if dirsw = 1 & dir.tree_depth >= active_all_rings_data$max_tree_depth then do;
	     code = error_table_$max_depth_exceeded;
	     go to unlock;
	end;

	call hash$search (dp, addr (ename_aligned), ep, code); /* See if the entry is already there */
	if code = 0 then go to name_dup;		/* indicates that name already on another entry */
	if code ^= error_table_$noentry then signal bad_dir_; /* another code says that hash table is messed up */

	if ^branch_sw | (dirsw = 1) then code = 0;	/* Always ok to create links or dirs */
	else code = mountedp (dir.sons_lvid);		/* Can we create a VTOCE? */
	if code ^= 0 then go to unlock;

	areap = ptr (dp, dir.arearp);			/* start to allocate */
	dir.modify = pds$processid;

	if retv then newuid = local_entry.uid;
	else newuid = getuid ();			/* Get the unique ID */
	if branch_sw then do;			/* if appending a branch */
	     if dirsw = 1 then do;
		iacl_start_ptr = addr (dir.iacl (level).dir_frp); /* get ptr to dir Initial ACL for V */
		n_iacls = dir.iacl_count (level).dir;
	     end;
	     else do;
		iacl_start_ptr = addr (dir.iacl (level).seg_frp); /* get ptr to seg IACl at validation level */
		n_iacls = dir.iacl_count (level).seg;
		if ringbrack (2) ^= ringbrack (3) then	/* check for valid project if creating gate seg */
		     if level > 1 then do;		/* in rings greater than administrative ring */
			if retv then project = user_acl.project;
			else project = pds$access_name.project;
			if user_acl.project ^= project then
			     if user_acl.project ^= "SysDaemon" then do;
				code = error_table_$invalid_project_for_gate;
				go to unlock;
			     end;
			call check_gate_acl_ (iacl_start_ptr, "1"b, 0, dummy, code); /* check Initial ACL for project */
			if code ^= 0 then go to unlock;
		     end;
	     end;
	     xsize = active_hardcore_data$esize;	/* store size of an entry */
	     call fs_alloc$alloc (areap, xsize, ep);	/* allocate the entry */
	     if ep = null then go to alloc_err;
	     if retv then do;
		entry = local_entry;
		entry.acl_frp, entry.acl_brp = "0"b;
		entry.acle_count = 0;
		dtem = entry.dtem;			/* save for later */
	     end;
	     if dirsw = 1 then entry.type = DIR_TYPE;
	     else entry.type = SEG_TYPE;
	     entry.size = xsize;
	     entry.owner = dir.uid;

	     acl_count = 0;
	     acl_start_ptr = addr (entry.acl_frp);	/* fill in items before call to acl_ */
	     prior_dir_acl_count = dir.acle_total;	/* save total number of acl entries in directory */
						/* put SysDaemon on ACL */
	     if ^retv | retv_cross_segment then do;
		call acl_$add_entry (0, newuid, acl_start_ptr, addr (service_acl), add_sw, code);
		if code ^= 0 then go to cleanup_acl;

/* This loop adds acls to the branch.  (code = error_table_$argerr is set when the end of the acl thread is passed) */

		acl_count = 1;			/* add on Initial ACL */
		dir.acle_total = dir.acle_total + 1;
		iaclp = addr (initial_acl);
		do i = 1 by 1 while (code = 0);
		     call acl_$list_entry (n_iacls, dir.uid, iacl_start_ptr, iaclp, i, code);
		     if code = 0 then do;
			call acl_$add_entry (acl_count, newuid, acl_start_ptr, iaclp, add_sw, code);
			if code ^= 0 then goto cleanup_acl;
			if add_sw then do;		/* If actually added */
			     acl_count = acl_count + 1;
			     dir.acle_total = dir.acle_total + 1;
			end;
		     end;
		     else if code ^= error_table_$argerr then go to cleanup_acl;
		end;
						/* now put on ACL for user */
		if ^retv_cross_segment then do;
		     call acl_$add_entry (acl_count, newuid, acl_start_ptr, addr (user_acl), add_sw, code);
		     if code ^= 0 then goto cleanup_acl;
		end;
		if add_sw then do;
		     acl_count = acl_count + 1;
		     dir.acle_total = dir.acle_total + 1;
		end;
		entry.acle_count = acl_count;		/* set acl count for entry */
	     end;

	end;

	else do;					/* if appending a link, allocate the link */
	     nwords = active_hardcore_data$elcsize + 3 + divide (llngth + 3, 4, 17, 0); /* first get number of words for link */

/* find appropriate allocation size */
	     do i = active_hardcore_data$nalloc_sizes - 1 to 1 by -1
		while (nwords <= active_hardcore_data$alloc_sizes (i));
	     end;
	     xsize = active_hardcore_data$alloc_sizes (i + 1);

	     call fs_alloc$alloc (areap, xsize, ep);
	     if ep = null then go to alloc_err;
	     link.type = LINK_TYPE;
	     link.size = xsize;
	     link.pathname_size = llngth;
	     link.pathname = linkname;
	     link.owner = dir.uid;			/* Pathname size MUST be set for 'refer' to be correct */

	end;

	call acc_name_$encode (addr (entry.author), authp, code); /* set author */
	if code ^= 0 then go to cleanup_acl;

	np = addr (entry.primary_name);		/* first name is in the branch */
	entry.name_frp,				/* fill in name info before hashing */
	     entry.name_brp = rel (np);
	entry.nnames = 1;
	np -> names.entry_rp = rel (ep);
	np -> names.name = ename;
	np -> names.type = NAME_TYPE;
	np -> names.size = active_hardcore_data$ensize;
	np -> names.owner = newuid;

	call hash$in (dp, np, code);			/* have already checked for name dup */
	if code ^= 0 then goto cleanup_acl;

/* Fill in general entry info */

	entry.uid = newuid;				/* Fill in the unique ID */
          entry.dtem = substr (bit (fixed (clock, 52), 52), 1, 36);
	if ^branch_sw then dir.lcount = dir.lcount + 1;	/* link */
	else do;
	     entry.bs = "1"b;			/* Entry is a branch */
	     entry.per_process_sw = dir.per_process_sw;
	     entry.bc = bitcnt;			/* set bit count */
	     entry.dirsw = bit (dirsw, 1);		/* Can't append segs to segs, you know! */
	     entry.access_class = access_class & sys_info$access_class_ceiling;
	     entry.multiple_class = sp_sw;		/* indicates class higher than parent */

/**** Set the security oos for backup-retrieved multi-class segments.
       This is a temporary fix to circumvent the lack of information
       on authorization/max authorization in the volume dumper. */

	     if retv then if entry.multiple_class then do;
		     if ^pds$access_authorization.soos then entry.security_oosw = "1"b;
		end;
	     entry.master_dir = sonsw;

	     call acc_name_$encode (addr (entry.bc_author), authp, code); /* set bc author */
	     if code ^= 0 then go to make_err;

	     call uid_path_util$get (dp, uid_path, code); /* get uid pathname of parent */
	     if code ^= 0 then go to make_err;
	     uid_path (dir.tree_depth + 1) = entry.uid;	/* last component */

	     if ^retv then do;
		call create_vtoce (ep, entry.pvid, vtocx_temp, code);
		if code ^= 0 then go to make_err;	/* problems. */
		entry.vtocx = vtocx_temp;		/* Store in unal fld in branch */
		if dirsw = 1 then call setup_directory;
		else do;				/* link */
		     entry.ring_brackets (1) = bit (fixed (ringbrack (1), 3), 3);
		     entry.ring_brackets (2) = bit (fixed (ringbrack (2), 3), 3);
		     entry.ring_brackets (3) = bit (fixed (ringbrack (3), 3), 3);
		     entry.copysw = bit (copysw, 1);	/* copy sw */
		     dir.seg_count = dir.seg_count + 1; /* and update segment count in directory */
		end;
	     end;
	     else do;				/* retv case. */
		if retv_cross_segment then do;
		     call create_vtoce (ep, entry.pvid, vtocx_temp, code);
		     if code ^= 0 then goto make_err;
		     entry.vtocx = vtocx_temp;
		end;
		if dirsw = 1 then do;
		     dir.dir_count = dir.dir_count + 1;
		     if ^entry.master_dir then
			entry.sons_lvid = dir.sons_lvid; /* propagate the correct sons lvid */
		end;
		else dir.seg_count = dir.seg_count + 1;
	     end;
	end;

	if dir.entryfrp = ""b then
	     do;					/* first entry in directory */
	     dir.entryfrp, dir.entrybrp = rel (ep);
	     entry.efrp, entry.ebrp = ""b;
	end;
	else do;
	     prevep = ptr (ep, dir.entrybrp);		/* get pointer to previous entry */
	     entry.ebrp = rel (prevep);		/* set back pointer of entry */
	     prevep -> entry.efrp = rel (ep);		/* set forward pointer of prev. entry */
	     entry.efrp = ""b;			/* set forward pointer of entry */
	     dir.entrybrp = rel (ep);			/* reset dir rel back pointer */
	end;


	if retv then entry.dtem = dtem;
	dir.modify = "0"b;
	call sum$dirmod (dp);			/* We've modified this directory */

	audit_eventflags = "0"b;
	addr (audit_eventflags) -> audit_event_flags.grant = "1"b;
	if retv then				/* audit the new object */
	     if access_audit_check_ep_$user
		(audit_eventflags, access_operations_$fs_obj_create, ep, audit_user_info.authorization, audit_user_info.audit_flags) then
		call access_audit_$log_entry_ptr_user
		     ("append", level, audit_eventflags, access_operations_$fs_obj_create, ep, 0, null, 0, audit_user_info_ptr, "");
	     else ;
	else if access_audit_check_ep_$self
		(audit_eventflags, access_operations_$fs_obj_create, ep) then
	     call access_audit_$log_entry_ptr
		("append", level, audit_eventflags, access_operations_$fs_obj_create, ep, 0, null, 0, "");

	call dc_find$finished (dp, dirl);

fin:
	a_code = code;

	return;

arg_err:
	code = error_table_$argerr; go to fin;
lower_ring_err:
	code = error_table_$lower_ring; goto fin;
inv_rb_err:
	code = error_table_$invalid_ring_brackets; go to fin;
invalid_mode:
	code = error_table_$invalid_mode; go to fin;
name_dup:
	code = error_table_$namedup; go to unlock;
alloc_err:
	code = error_table_$noalloc; go to unlock;
free_vtoce:
	call delete_vtoce (ep, dumcode);
	if dumcode ^= 0 then call syserr$error_code (4, dumcode, "append: err from delete_vtoce for ^a>^a:", dirname, ename);
make_err:
	call hash$out (dp, addr (ename_aligned), np, dumcode);
	if dumcode ^= 0 then call syserr$error_code (4, dumcode, "append: error from hash$out for ^a>^a:", dirname, ename);
cleanup_acl:
	if branch_sw then do;
	     call acl_$del_acl (acl_count, newuid, acl_start_ptr);
	     dir.acle_total = prior_dir_acl_count;	/* restore the acl count in the directory */
	end;
	call fs_alloc$free (areap, xsize, ep);
unlock:
	if dep ^= null then call lock$dir_unlock (ptr (dep, 0));
	dir.modify = "0"b;
	call dc_find$finished (dp, dirl);
	go to fin;
%page;
check_aim_access: proc;

	if aim_check_$greater (access_class, parent_access_class) then do;
	     if dirsw = 1 then do;			/* see if privileged oos creation */
		if quota <= 0 then if level > 1 then goto ai_err;
		     else if ^priv_mqsw then goto ai_err;

		if bitcnt ^= 0 then if level > 1 then goto ai_err; /* no upgraded non-multiclass MSFs */
		sp_sw = "1"b;			/* this sets entry.multiple_class */
	     end;
	     else do;				/* will be a multiclass segment */
		if ringbrack (3) > 1 then go to ai_err; /* can only create multi class seg from ring 1 */
		if priv_mqsw then sp_sw = "1"b;
		else go to ai_err;			/* wasn't reall wanted, wrong access class passed */
	     end;
	end;
	else if ^aim_check_$equal (access_class, parent_access_class) then do;
ai_err:	     code = error_table_$ai_restricted;		/* ok to return as have at least append mode */
	     goto unlock;
	end;

     end check_aim_access;

setup: proc;

	ac_sw = "0"b;
	admin_append = "0"b;
	chase_sw = "1"b;
	dir_quota = 0;
	priv_mqsw = "0"b;
	quota = 0;
	read_lock = "0"b;
	retv = "0"b;
	retv_cross_segment = "0"b;
	sonsw = "0"b;
	sp_sw = "0"b;
	sysl = "0"b;
	return;
     end setup;
%page;

/* This procedure fills in the directory header and moves quota down. */

setup_directory: proc;

	if sonsw then entry.sons_lvid = sons;		/* Master dir? */
	else entry.sons_lvid = dir.sons_lvid;		/* if not, inherit */
						/* set extended rb, normal rb are 0,0,0 */
	entry.ex_ring_brackets (1) = bit (bin (ringbrack (1), 3), 3);
	entry.ex_ring_brackets (2) = bit (bin (ringbrack (2), 3), 3);

	if ^sonsw then do;
	     call quota$check (ep, quota, code);	/* check if quota can take quota more pages */
	     if code ^= 0 then go to free_vtoce;
	end;

/* make the new directory segment known */
/* Turn the modify switch OFF in the parent while initializing the inferior directory. Note that there is a window
   until it is turned on again during which the modify   switch is OFF although the operation is not finished */

	dir.modify = "0"b;

	unspec (mk_info) = "0"b;
	mk_info.uid = entry.uid;
	mk_info.entryp = ep;
	mk_info.dirsw = "1"b;
	mk_info.allow_write = "1"b;
	mk_info.activate = "1"b;
	dirp = null;
	call makeknown_ (addr (mk_info), segno, (0), code);
	if code ^= 0 then go to free_vtoce;
	dirp = baseptr (segno);

	unspec (dirp -> dir) = "0"b;			/* Zero the header */
	dirp -> dir.type = DIR_HEADER_TYPE;		/* Fill in constants */
	dirp -> dir.size = active_hardcore_data$dir_hdrsize;
	dirp -> dir.version_number = version_number_2;
	dirp -> dir.owner = dir.uid;
	dirp -> dir.uid = entry.uid;			/* Fill in the unique id */
	dirp -> dir.arearp = bit (fixed (active_hardcore_data$dir_arearp, 18), 18);
	dirp -> dir.pvid = entry.pvid;
	dirp -> dir.per_process_sw = entry.per_process_sw;
	dirp -> dir.sons_lvid = entry.sons_lvid;
	dirp -> dir.master_dir = entry.master_dir;
	if entry.master_dir then dirp -> dir.master_dir_uid = entry.uid;
	else dirp -> dir.master_dir_uid = dir.master_dir_uid; /* Inherit */
	dirp -> dir.access_class = entry.access_class;
	dirp -> dir.vtocx = entry.vtocx;
	asize = sys_info$default_dir_max_length - fixed (dirp -> dir.arearp, 18);
	call fs_alloc$init (ptr (dirp, dirp -> dir.arearp), asize,
	     addr (active_hardcore_data$alloc_sizes), active_hardcore_data$nalloc_sizes);

	call allocate_dir_ht_ (dirp, 0, (0));
	dirp -> dir.tree_depth = dir.tree_depth + 1;	/* set tree depth */

	if quota > 0 then				/* Set quota */
	     if ^sonsw then do;			/* non-master dir, move */
		call quota$qmove_mylock (ep, dirp, quota, "0"b, code);
		if code ^= 0 then do;		/* drop this hot potato */
						/* used to unlock new dir here */
qerr:		     call truncate$trentry (ep);	/* and header page */
		     call makeunknown_ (segno, "0"b, ("0"b), dumcode);
		     if dumcode ^= 0 then call syserr$error_code (4, dumcode,
			     "append: makeunknown_ err after quota err for ^a>^a:", dirname, ename);
		     go to free_vtoce;		/* leave in kst if makeunknown_ fails */
		end;
	     end;
	     else do;				/* master dir. */
		call quota$append_mdir_set (ep, quota, code); /* set the quuota */
		if code ^= 0 then go to qerr;
	     end;
	else if priv_mqsw & ac_sw then do;		/* path for reloader to create upgraded dirs with no quota */
	     if aim_check_$greater (access_class, parent_access_class) then
		ep -> entry.security_oosw = "1"b;	/* by leaving entry oosw */
	end;

	if dir_quota > 0 then do;			/* Set quota */
	     call quota$qmove_mylock (ep, dirp, dir_quota, "1"b, code);
	     if code ^= 0 then go to qerr;		/* drop this hot potato */
	end;

	call sum$dirmod (dirp);			/* indicate that it has been modified */
	call makeunknown_ (segno, "0"b, ("0"b), code);
	if code ^= 0 then call syserr$error_code (4, code, "append: error from makeunknown_ for ^a>^a:", dirname, ename);

	dir.modify = pds$processid;			/* Turn modify sw back on again to complete the creation
						   of the branch. This call will terminate the window
						   referred to above and created at the beginning of the
						   initialization of the inferior directory. */

	dir.dir_count = dir.dir_count + 1;		/* up directory count in parent */
	if sonsw then a_uid_path = uid_path;		/* return uid pathname to ring 1 */

	return;

     end setup_directory;
%page; %include access_audit_eventflags;
%page; %include access_audit_user_info;
%page; %include aim_template;
%page; %include create_branch_info;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_ht;
%page; %include dir_link;
%page; %include dir_name;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include makeknown_info;
%page; %include null_addresses;
%page; %include retv_append_args;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   append: error from delete_vtoce for PATH: ERROR_MESSAGE

   S:	$log

   T:	$run

   M:	While deleting a VTOC entry
   to clean up an unsuccessful attempt to create an branch,
   append got an error.
   $err

   A:	$note


   Message:
   append: error from hash$out for PATH: ERROR_CODE

   S:	$log

   T:	$run

   M:	While removing a name
   to clean up an unsuccessful attempt to create a branch,
   append got an error.
   $err

   A:	$note


   Message:
   append: makeunknown_ err after quota err for PATH: ERROR_CODE

   S:	$log

   T:	$run

   M:	During the creation of a new directory, append encountered an error moving quota.
   While cleaning up from this error a further error was encountered.
   The system continues to operate.
   $err

   A:	$note


   Message:
   append: error from makeunknown_ for PATH: ERROR_CODE

   S:	$log

   T:	$run

   M:	Append made the new directory PATH unknown after initializing its header.
   While doing so it encountered an error.
   $err

   A:	$note

   END MESSAGE DOCUMENTATION */

     end append;




		    asd_.pl1                        11/11/89  1132.4r w 11/11/89  0800.0      334539



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




/****^  HISTORY COMMENTS:
  1) change(88-06-10,Lippard), approve(88-07-04,MCR7929),
     audit(88-07-08,Parisek), install(88-07-15,MR12.2-1057):
     Modified to return error code of 0 and status_code of
     error_table_$user_not_found in case where specific ACLs are requested to
     be listed and entry has an empty ACL.
                                                   END HISTORY COMMENTS */


/* format: style2 */

asd_:
     procedure;

/* Modified 10/84 Keith Loepere to audit operation as an access change. */
/* Modified 84-07-03 BIM for ring number range checks.                    */
/* Modified 6/84 Keith Loepere to use the new dc_find. */
/* Modified 8/83 E. N. Kittlitz. setfaults$if_active pvid, vtocx args	    */
/* Modified 3/83 E. N. Kittlitz. setfaults on fatal_error if acl modified */
/* Modified 5/82 BIM to use Legal PL/I in the case where list_* is called */
/*	           on a null acl with a area pointer.	              */
/*		 a one-dim array is allocated, but a count of 0 is    */
/*		 returned, for compatability. (instead of returning   */
/*		 an error code)                                       */
/* Modified 3/82 BIM for no system free seg, refer extent entrypoints */
/* Modified by B. Margulies 05/10/79 to remove pds$xmode level restriction
 		and allow setting exacls within validation level */
/* Modified 07/77 by THVV for bad_dir_ check */
/* Modified by R. Bratt 06/01/76 to call find_$finished */
/* Modified by Kobziar 10/15/75 to copy et$user_not_found errors in delete structure */
/* NSS, 4/25/75, by Greenberg */
/* Modified by E. Stone Oct 1974 to place uid and dtem in double word */
/* Modified to copy arguments before using - 9/74 by A. Mason */
/* Modified by Kobziar on 11-12-73 to return dirseg and nondirseg error codes */

/* This is the gate level acl proc and contains 18 entries for listing, deleting, replacing, and
*   adding acl entries to segments, directories, and initial acls.
*  Entrypoints whose names begin with r_ are identical in function, but take
*  refer extend structures.
*
*  There are r_ entrypoints for acl listing, since for allocation of storage
*  refer extents are cleaner. The other entrypoints stay as they are,
*  because arrays are easier to declare in automatic structures.
*
*  It is always possible to pass addr (XXX_acl.entries), XXX_acl.count
*  into the other entrypoint.
*
*   _e_n_t_r_y		_a_r_g_u_m_e_n_t_s
*
*   list_dall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code)
*   r_list_dall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code);
*   r_list_sall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code);
*   list_sall	as above.	Dall lists all of a directory acl and used the dir_acl structure(below)
*   .		while sall lists all of a segment's acl and uses the acl structure.
*
*   list_idall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code)
*   list_isall	List of initial acls for segments and directories, for the specified ring.
*   r_list_idall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code)
*   r_list_isall	(a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code);
*
*   del_dentries	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code)
*   del_sentries	as above. Dentries and sentries use the del_acl structure and delete the specified acl entries.
*   del_identries	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code)
*   del_isentries	Delete initial acls for segments and directories for the specified ring.
*   replace_dall	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code)
*   replace_sall	as above. Dall replaces a dir acl with the one given and uses the dir_acl structure
*   .		while sall replaces a segment's acl and uses the acl structure.
*   replace_idall	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code)
*   replace_isall	Replace initial acl for segments and directories fir the specified ring.
*   add_dentries	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code)
*   add_sentries	as above. Dentries adds (or changes the mode if the acl entry already exists) the
*   .		given entries to a directory acl and uses the dir_acl structure, while sentries
*   .		adds or changes the mode and uses the acl structure.
*   add_identries	(a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code)
*   add_isentries	Add to initial acls of segments or directories for the specified ring.
*
*
*
*   _a_r_g_u_m_e_n_t		_v_a_l_u_e
*
*   a_dir_name		char(*), the name of the directory (Input).
*   a_entryname		char(*), the name of the brnach in the above directory whoes acl is to be read or
*   .			written (Input).
*   a_area_ptr		ptr, used only in listing acls and pts to an area wher the entire acl should be
*   .			listed, otherwize it is null and only the modes in the given acl list will be listed.
*   .			(Input).
*   a_return_struc_ptr		ptr, is set to point to allocation in area (if a_area_ptr given) of the
*   .			acl list. (Output)
*   a_acl_ptr		ptr, points to an acl, dir_acl, or del_acl structure. (Input for all except
*   .			when listing whole acl rather than specified acl's modes, when it must be null).
*   a_acl_count		fixed bin(17), then number of acl entries in the given structure, (Input except
*   .			for list when listing whole acl, then output).
*   a_daemon_sw		bit(1) aligned, used to specify if want a *.SysDaemon.* rw or sma acl entry appended
*   .			to the acl replacement list. "0"b = yes, "1"b = no, (Input).
*   a_ring			fixed bin(3), the initial acl's ring number.(Must be >= validation level).
*   a_code			fixed bin(35), is a standard file system error code. If non zero then no
*   .			processing has been performed except in the case of deleting, where a user_not_found
*   .			code in the del_acl structure indicates that this entry wasn't found.
*
**/

	dcl     a_acl_count		 fixed bin (17) parameter;
	dcl     a_acl_ptr		 ptr parameter;
	dcl     a_area_ptr		 ptr parameter;
	dcl     a_code		 fixed bin (35) parameter;
	dcl     a_daemon_sw		 bit (1) parameter; /* indicates whether to remove a *.SysDaemon.* acl */
	dcl     a_dir_name		 char (*) parameter;
	dcl     a_entryname		 char (*) parameter;
	dcl     a_return_struc_ptr	 ptr parameter;
	dcl     a_ring		 fixed bin (3) parameter;

	dcl     1 acl1		 based (acl_entry_ptr) aligned,
						/* one entry  of an input acl list */
		2 ac_name,
		  3 person	 char (32),
		  3 project	 char (32),
		  3 tag		 char (1),
		2 mode		 bit (36),
		2 ex_mode		 bit (36);
	dcl     arg_area		 area based (area_ptr);

	dcl     1 a_n		 aligned like acl1;
	dcl     acl_entry_ptr	 ptr;
	dcl     acl_start_ptr	 ptr;
	dcl     add_sw		 bit (1);
	dcl     ael		 fixed bin;
	dcl     area_ptr		 ptr;
	dcl     called_find		 bit (1) aligned;
	dcl     caller_level	 fixed bin (3) unsigned;
	dcl     code		 fixed bin (35);
	dcl     d_s		 bit (1) aligned;
	dcl     daemon_sw		 bit (1) aligned;
	dcl     dirname		 char (168);
	dcl     entryname		 char (32);
	dcl     esw		 fixed bin (17);	/* indicates which entry point called */
	dcl     fail_sw		 bit (1) aligned;
	dcl     fatal_error_sets_faults
				 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     initial_acl		 bit (1) aligned;
	dcl     locked		 bit (1) aligned;
	dcl     locked_for_write	 bit (1) aligned;
	dcl     n_acls		 fixed bin;
	dcl     offset		 fixed bin;
	dcl     owning_structure	 bit (36) aligned;
	dcl     refer_allocation	 bit (1) aligned;	/* new style listing */
	dcl     return_acl_ptr	 pointer;
	dcl     ring		 fixed bin (17);
	dcl     structure_supplied	 bit (1) aligned;	/* no allocation needed */
	dcl     t_char1		 char (32) aligned;
	dcl     t_char2		 char (32) aligned;
	dcl     tag		 char (1) aligned;
	dcl     temp_access_name	 char (32) aligned;
	dcl     temp_extended_mode	 bit (36) aligned;
	dcl     temp_mode		 bit (36);
	dcl     work_p		 ptr;

	dcl     acc_name_$elements	 ext entry (ptr, ptr, fixed bin (35));
	dcl     acl_$add_entry	 entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35));
	dcl     acl_$del_acl	 entry (fixed bin, bit (36) aligned, ptr);
	dcl     acl_$del_entry	 entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (35));
	dcl     acl_$list_entry	 entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35));
	dcl     change_dtem		 entry (ptr);
	dcl     check_gate_acl_	 entry (ptr, bit (1) aligned, fixed bin (17), char (32) aligned, fixed bin (35));
	dcl     level$get		 entry returns (fixed bin (3));
	dcl     lock$dir_lock_read	 entry (ptr, fixed bin (35));
	dcl     lock$dir_unlock	 entry (ptr);
	dcl     setfaults$if_active	 entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
	dcl     sum$dirmod		 entry (ptr);

	dcl     error_table_$argerr	 ext fixed bin (35);
	dcl     error_table_$bad_acl_mode
				 ext fixed bin (35);
	dcl     error_table_$bad_ring_brackets
				 ext fixed bin (35);
	dcl     error_table_$dirseg	 ext fixed bin (35);
	dcl     error_table_$empty_acl ext fixed bin (35);
	dcl     error_table_$invalid_ascii
				 ext fixed bin (35);
	dcl     error_table_$invalid_mode
				 ext fixed bin (35);
	dcl     error_table_$noalloc	 ext fixed bin (35);
	dcl     error_table_$nondirseg ext fixed bin (35);
	dcl     error_table_$null_info_ptr
				 ext fixed bin (35);
	dcl     error_table_$user_not_found
				 ext fixed bin (35);
	dcl     pds$processid	 bit (36) aligned ext;

	dcl     ADD_DIR		 fixed bin static options (constant) init (4);
	dcl     ADD_SEG		 fixed bin static options (constant) init (8);
	dcl     DEL_DIR		 fixed bin static options (constant) init (2);
	dcl     DEL_SEG		 fixed bin static options (constant) init (6);
	dcl     LIST_DIR		 fixed bin static options (constant) init (1);
	dcl     LIST_SEG		 fixed bin static options (constant) init (5);
	dcl     REP_SEG		 fixed bin static options (constant) init (7);
	dcl     REP_DIR		 fixed bin static options (constant) init (3);

	dcl     (addr, bin, fixed, null, ptr, rtrim, substr)
				 builtin;

	dcl     (area, any_other, bad_dir_, cleanup, seg_fault_error)
				 condition;
%page;

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

list_idall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code);
	initial_acl = "1"b;
	go to LIST_DALL_COMMON;
list_dall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code);
	initial_acl = "0"b;

LIST_DALL_COMMON:
	refer_allocation = "0"b;

	go to R_LIST_DALL_COMMON;

r_list_idall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code);
	initial_acl = "1"b;
	go to R_LIST_DALL_COMMON_0;

r_list_dall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code);
	initial_acl = "0"b;
R_LIST_DALL_COMMON_0:
	refer_allocation = "1"b;

R_LIST_DALL_COMMON:
	if initial_acl
	then ring = a_ring;

/* list the alc of a directory */
	esw = LIST_DIR;
	go to LIST_COMMON;

list_isall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code);

	initial_acl = "1"b;
	go to LIST_SALL_COMMON;

list_sall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code);

	initial_acl = "0"b;

LIST_SALL_COMMON:
	refer_allocation = "0"b;

	go to R_LIST_SALL_COMMON;

r_list_isall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code);
	initial_acl = "1"b;
	go to R_LIST_DALL_COMMON_0;

r_list_sall:
     entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code);
	initial_acl = "0"b;
R_LIST_SALL_COMMON_0:
	refer_allocation = "1"b;

R_LIST_SALL_COMMON:
	if initial_acl
	then ring = a_ring;

	esw = LIST_SEG;

/* The listing entrypoints happen here, via two internal procedures */
/* One is used when the structure is supplied, and selection is to take */
/* place. That is process_specific_list. The other is for allocation */
/* and return. That is process_list_all. */



LIST_COMMON:
	caller_level = level$get ();

	locked, locked_for_write, called_find, fatal_error_sets_faults = "0"b;

	area_ptr = a_area_ptr;
	if initial_acl
	then if ring < 0 | ring > 7
	     then call fatal_error (error_table_$argerr);
	d_s = esw < LIST_SEG;
	structure_supplied = (area_ptr = null);

	if structure_supplied
	then do;
		if refer_allocation
		then acl_ptr = a_return_struc_ptr;
		else acl_ptr = a_acl_ptr;

		if acl_ptr = null
		then call fatal_error (error_table_$null_info_ptr);

		if /* tree */ refer_allocation
		then if d_s
		     then do;
			     acl_count = directory_acl.count;
			     acl_ptr = addr (directory_acl.entries);
			end;
		     else do;
			     acl_count = segment_acl.count;
			     acl_ptr = addr (segment_acl.entries);
			end;
		else acl_count = a_acl_count;
	     end;
	else do;
		return_acl_ptr = null;
		acl_ptr = null;
		acl_count = 0;
	     end;


	on cleanup call cleanup_;
%page;
Retry_process_list_all:				/** Come here is the dir changed asychronously */
	call check_pathname_find_read_lock_and_check_access;

	acl_entry_ptr = addr (a_n);			/* used as a temp for constructing input acl ent */
	if initial_acl
	then do;
		if d_s
		then acl_start_ptr = addr (dir.iacl (ring).dir_frp);
		else acl_start_ptr = addr (dir.iacl (ring).seg_frp);
		if d_s
		then n_acls = dir.iacl_count (ring).dir;
		else n_acls = dir.iacl_count (ring).seg;
		owning_structure = dir.uid;		/* dir is owner of iacl entries */
	     end;
	else do;
		acl_start_ptr = addr (entry.acl_frp);
		n_acls = entry.acle_count;
		owning_structure = entry.uid;		/* When checking and making acles, entry owns em */
	     end;


/***** If the acl is null, the only work to do (allocating a null structure) */
/***** is done after the dir is unlocked. */

	if structure_supplied
	then call process_specific_list;
	else if n_acls > 0
	then call process_list_all;


/* Both of these return with the dir locked, and acl_ptr and acl_count */
/* ready to return */

	call dc_find$finished (dp, "1"b);

	if refer_allocation				/* new style */
	then if structure_supplied
	     then ;
	     else do;
		     if acl_count = 0
		     then do;			/* allocate 1-dim (legal pl1) */
			     acl_count = 1;
			     if d_s
			     then do;
				     allocate directory_acl in (arg_area);
				     directory_acl.count = 0;
						/* but report the fact that it is null */
				end;
			     else do;
				     allocate segment_acl in (arg_area);
				     segment_acl.count = 0;
				end;
			     return_acl_ptr = acl_ptr;/* share code with case just below */
			end;
		     a_return_struc_ptr = return_acl_ptr;
		end;

	else /* old style */
	     if structure_supplied
	then ;
	else do;
		if acl_count = 0			/* null acl */
		then do;
			acl_count = 1;		/* allocate 1-dim (legal pl1) */
			if d_s
			then allocate directory_acl_array in (arg_area);
			else allocate segment_acl_array in (arg_area);
			acl_count = 0;		/* but report 0 count */
		     end;
		a_return_struc_ptr = acl_ptr;
		a_acl_count = acl_count;
	     end;

	a_code = code;				/* reflect code from some bad entry */
	return;					/* So much for listing */

%page;
del_identries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code);
	initial_acl = "1"b;				/* delete initial acl entries for dir at ring */
	go to DEL_DENTRIES_COMMON;
del_dentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code);
						/* del part of dir acl */
	initial_acl = "0"b;
DEL_DENTRIES_COMMON:
	esw = DEL_DIR;
	goto start_proc;

del_isentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code);
	initial_acl = "1"b;				/* delete for segments */
	go to DEL_SENTRIES_COMMON;

del_sentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code);
						/* del part of seg acl */
	initial_acl = "0"b;
DEL_SENTRIES_COMMON:
	esw = DEL_SEG;
	goto start_proc;

replace_idall:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code);
	initial_acl = "1"b;				/* replace inatial acl for dirs at ring */
	go to REPLACE_DALL_COMMON;

replace_dall:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code);
						/* replace a dir acl with one provided */
	initial_acl = "0"b;
REPLACE_DALL_COMMON:
	esw = REP_DIR;
	daemon_sw = a_daemon_sw;
	goto start_proc;

replace_isall:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code);
	initial_acl = "1"b;				/* replace for segments */
	go to REPLACE_SALL_COMMON;

replace_sall:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code);
						/* replace s seg acl with one given */
	initial_acl = "0"b;
REPLACE_SALL_COMMON:
	esw = REP_SEG;
	daemon_sw = a_daemon_sw;
	goto start_proc;

add_identries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code);
	initial_acl = "1"b;				/* add initial acls for dir at ring */
	go to ADD_DENTRIES_COMMON;

add_dentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code);
						/* add or replace  toa dir acl */
	initial_acl = "0"b;
ADD_DENTRIES_COMMON:
	esw = ADD_DIR;
	goto start_proc;

add_isentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code);
	initial_acl = "1"b;				/* add for segmemts */
	go to ADD_SENTRIES_COMMON;

add_sentries:
     entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code);
						/* add or relpace entries to seg acl */
	initial_acl = "0"b;
ADD_SENTRIES_COMMON:
	esw = ADD_SEG;

%page;
start_proc:
	caller_level = level$get ();
	locked, locked_for_write, called_find, fatal_error_sets_faults = "0"b;

	acl_ptr = a_acl_ptr;
	acl_count = a_acl_count;

	if initial_acl
	then do;
		ring = a_ring;
		if ring < 0 | ring > 7
		then call fatal_error (error_table_$argerr);
	     end;

	d_s = esw < LIST_SEG;

	if esw ^= REP_SEG & esw ^= REP_DIR
	then do;					/* if replacing, can replace with empty */
		if acl_ptr = null
		then call fatal_error (error_table_$null_info_ptr);

		if acl_count = 0
		then call fatal_error (error_table_$argerr);
	     end;

	if acl_ptr = null
	then acl_count = 0;
	else do;
		on any_other call fatal_error (error_table_$argerr);
		call check_in_structure;
		revert any_other;
	     end;

	call check_pathname_find_read_lock_and_check_access;
%page;
	acl_entry_ptr = addr (a_n);			/* used as a temp for constructing input acl ent */
	if initial_acl
	then do;
		if d_s
		then acl_start_ptr = addr (dir.iacl (ring).dir_frp);
		else acl_start_ptr = addr (dir.iacl (ring).seg_frp);
		if d_s
		then n_acls = dir.iacl_count (ring).dir;
		else n_acls = dir.iacl_count (ring).seg;
		owning_structure = dir.uid;		/* dir is owner of iacl entries */
	     end;
	else do;
		acl_start_ptr = addr (entry.acl_frp);
		n_acls = entry.acle_count;
		owning_structure = entry.uid;		/* When checking and making acles, entry owns em */
	     end;
%page;
	dir.modify = pds$processid;
	if ^initial_acl
	then do;
		call change_dtem (ep);
		fatal_error_sets_faults = "1"b;
	     end;

/*	*  *  *  delete  *  *  *	*/

	if (esw = DEL_DIR) | (esw = DEL_SEG)
	then do;

		on any_other call fatal_error (error_table_$argerr);
		delete_acl_array (*).status_code = 0;
		revert any_other;

		do i = 1 to acl_count;

		     on any_other call fatal_error (error_table_$argerr);
		     temp_access_name = delete_acl_array (i).access_name;
		     revert any_other;

		     call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code);
		     if code ^= 0
		     then do;
			     on any_other call fatal_error (error_table_$argerr);
			     delete_acl_array (i).status_code = code;
			     revert any_other;
			     call fatal_error (error_table_$argerr);
			end;

		     call acl_$del_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, code);
		     if code ^= 0
		     then do;
			     if code = error_table_$user_not_found
			     then do;
				     on any_other call fatal_error (error_table_$argerr);
				     delete_acl_array (i).status_code = code;
				     revert any_other;
				     code = 0;
				     goto del_loop;
				end;
			     else call fatal_error (code);
			end;
		     if ^initial_acl
		     then entry.acle_count = entry.acle_count - 1;
		     else if d_s
		     then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) - 1;
		     else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) - 1;
		     dir.acle_total = dir.acle_total - 1;
del_loop:
		end;

		go to CLEAN_RETURN;
	     end;					/* esw  = DEL_DIR, DEL_SEG */
%page;

/*	*  *  *  replacement and addition  *  *  *	*/

/* esw = REP_DIR, REP_SEG, ADD_DIR, ADD_SEG */
/* see if have to check gate */

	if ^initial_acl				/* ep is invalid if initial_acl = "1"b */
	then if ((esw = REP_SEG) | (esw = ADD_SEG)) & caller_level > 1
		& fixed (entry.ring_brackets (2), 3) < fixed (entry.ring_brackets (3), 3)
	     then do;
		     call check_gate_acl_ (acl_ptr, "0"b, acl_count, (""), code);
		     if code ^= 0
		     then call fatal_error (code);
		     if esw = ADD_SEG
		     then if entry.acl_frp ^= ""b
			then do;			/* trying to sneek own project in? */
				call check_gate_acl_ (acl_start_ptr, "1"b, (entry.acle_count), (""), code);
				if code ^= 0
				then call fatal_error (code);
			     end;
		end;

	if (esw = REP_DIR) | (esw = REP_SEG)
	then do;
		if initial_acl
		then if d_s
		     then ael = dir.iacl_count.dir (ring);
		     else ael = dir.iacl_count.seg (ring);
		else ael = entry.acle_count;		/* start by deleting everything */
		call acl_$del_acl (n_acls, owning_structure, acl_start_ptr);
		n_acls = 0;
		if initial_acl
		then if d_s
		     then dir.iacl_count.dir (ring) = 0;
		     else dir.iacl_count.seg (ring) = 0;
		else entry.acle_count = 0;
		dir.acle_total = dir.acle_total - ael;	/* should *.SysDaemon be put back ? */
		if ^daemon_sw
		then do;
			t_char1 = "*.SysDaemon.*  ";
			call acc_name_$elements (addr (t_char1), acl_entry_ptr, (0));
			acl_entry_ptr -> acl1.mode = RW_ACCESS;

			if d_s
			then acl_entry_ptr -> acl1.ex_mode = SMA_ACCESS;
			else acl_entry_ptr -> acl1.ex_mode = ""b;
			call acl_$add_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, add_sw, code);
			if code ^= 0		/* should never happen */
			then call fatal_error (code);

			n_acls = 1;

			if ^initial_acl
			then entry.acle_count = entry.acle_count + 1;
			else if d_s
			then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) + 1;
			else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) + 1;
			dir.acle_total = dir.acle_total + 1;
		     end;
	     end;

	do i = 1 to acl_count;

	     on any_other call fatal_error (error_table_$argerr);
	     if d_s
	     then do;
		     temp_access_name = directory_acl_array (i).access_name;
		     temp_mode = directory_acl_array (i).mode;
		     if substr (temp_mode, 4) ^= ""b
		     then do;
			     directory_acl_array (i).status_code = error_table_$bad_acl_mode;
			     call fatal_error (error_table_$argerr);
			end;
		end;
	     else do;
		     temp_access_name = segment_acl_array (i).access_name;
		     temp_mode = segment_acl_array (i).mode;
		     if substr (temp_mode, 5) ^= ""b	/* let a through */
		     then do;
			     segment_acl_array (i).status_code = error_table_$bad_acl_mode;
			     call fatal_error (error_table_$argerr);
			end;
		     temp_mode = temp_mode & REW_ACCESS;/* but not far */
		     temp_extended_mode = segment_acl_array (i).extended_mode;
		end;
	     revert any_other;

	     call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code);
	     if code ^= 0
	     then do;
		     on any_other call fatal_error (error_table_$argerr);
		     if d_s
		     then do;
			     directory_acl_array (i).status_code = code;
			     go to BAD_ACLE;
			end;
		     else do;
			     segment_acl_array (i).status_code = code;
BAD_ACLE:
			     revert any_other;
			     call fatal_error (error_table_$argerr);
			end;
		end;
	     if d_s
	     then do;
		     acl_entry_ptr -> acl1.mode = RW_ACCESS;
		     acl_entry_ptr -> acl1.ex_mode = temp_mode;
		end;
	     else do;
		     acl_entry_ptr -> acl1.mode = temp_mode;
		     acl_entry_ptr -> acl1.ex_mode = temp_extended_mode;
		end;

	     call acl_$add_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, add_sw, code);
	     if code ^= 0
	     then call fatal_error (code);		/* hate to give up here, but no choice */
	     n_acls = n_acls + 1;

	     if add_sw
	     then do;				/* acl added, up count */
		     if ^initial_acl
		     then entry.acle_count = entry.acle_count + 1;
		     else if d_s
		     then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) + 1;
		     else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) + 1;
		     dir.acle_total = dir.acle_total + 1;
		end;

	end;					/* i do loop */

CLEAN_RETURN:
	if ^initial_acl
	then call setfaults$if_active ((entry.uid), (entry.pvid), (entry.vtocx), "1"b);
	call unlock_dir;
	a_code = 0;
	return;
%page;
check_pathname_find_read_lock_and_check_access:
     procedure;

	if initial_acl
	then do;					/* need ptr to locked dir */
		dirname = a_dir_name;
		entryname = a_entryname;
		if dirname = ">"
		then dirname = ">" || entryname;
		else if entryname ^= ""		/* compatable with old idiot programs */
		then dirname = rtrim (dirname) || ">" || entryname;

		if dirname = ""			/* this is always invalid */
		then call fatal_error (error_table_$argerr);

		if esw = LIST_DIR | esw = LIST_SEG
		then do;
			call dc_find$dir_read (dirname, dp, code);
			if code ^= 0
			then go to find_error;
			called_find, locked = "1"b;
		     end;
		else do;
			call dc_find$dir_write (dirname, FS_OBJ_IACL_MOD, dp, code);
			if code ^= 0
			then go to find_error;
			called_find, locked = "1"b;
			locked_for_write = "1"b;	/* fine, ready to go for iacls */

			if ring < caller_level | ring > 7
						/* only 8 rings, folks */
			then call fatal_error (error_table_$bad_ring_brackets);
		     end;
	     end;
	else do;					/* ordinary acl */
		dirname = a_dir_name;
		entryname = a_entryname;

		if dirname = ""			/* this is always invalid */
		then call fatal_error (error_table_$argerr);

		if esw = LIST_DIR | esw = LIST_SEG
		then do;
			call dc_find$obj_status_read (dirname, entryname, 1, ep, code);
			if code ^= 0
			then go to find_error;
			locked, called_find = "1"b;
			dp = ptr (ep, 0);
		     end;
		else do;
			call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_ACL_MOD, ep, code);
			if code ^= 0
			then
find_error:
			     call fatal_error (code);
			locked, called_find = "1"b;
			dp = ptr (ep, 0);
			locked_for_write = "1"b;

			if entry.dirsw
			then if caller_level > bin (entry.ex_ring_brackets (1), 3)
						/* modify bracket */
			     then call fatal_error (error_table_$bad_ring_brackets);
			     else ;
			else if caller_level > bin (entry.ring_brackets (1))
			then call fatal_error (error_table_$bad_ring_brackets);
		     end;

		if entry.dirsw
		then do;
			if esw > ADD_DIR
			then call fatal_error (error_table_$dirseg);
						/* have already checked mode, safe to return */
		     end;

		else do;
			if esw <= ADD_DIR
			then call fatal_error (error_table_$nondirseg);
		     end;
	     end;

/* dp is set, ep is set for non-inacl case, access is okay */

     end check_pathname_find_read_lock_and_check_access;
%page;
check_in_structure:
     procedure;

/* Precheck structure to return errors without doing anything. */
/* check is repeated at actual run through acl to catch modifications */
/* from other processes */

	declare fail_sw		 bit (1) aligned;

	if esw = DEL_DIR | esw = DEL_SEG
	then delete_acl_array (*).status_code = 0;
	else if d_s
	then directory_acl_array (*).status_code = 0;
	else segment_acl_array (*).status_code = 0;

	fail_sw = "0"b;
	work_p = addr (a_n.ac_name);			/* a_n is a temp hold structure */
	do i = 1 to acl_count;			/* used for argument checking */

	     if (esw = DEL_DIR) | (esw = DEL_SEG)
	     then do;				/* when deleting acl entries, just perform name check */
		     call acc_name_$elements (addr (delete_acl_array (i).access_name), work_p, code);
		     if code ^= 0
		     then do;
			     delete_acl_array (i).status_code = code;
			     if code ^= error_table_$invalid_ascii
			     then fail_sw = "1"b;
			end;
		end;

	     else if d_s
	     then do;				/* look at directory acl modes and do name check */
		     if substr (directory_acl_array (i).mode, 4) ^= ""b
		     then do;
bad_mode:
			     directory_acl_array (i).status_code = error_table_$bad_acl_mode;
			     fail_sw = "1"b;
			end;
		     else if substr (directory_acl_array (i).mode, 1, 2) = "01"b
		     then do;			/* do not allow m without s permission */
			     directory_acl_array (i).status_code = error_table_$invalid_mode;
			     fail_sw = "1"b;
			end;

		     call acc_name_$elements (addr (directory_acl_array (i).access_name), work_p, code);
		     if code ^= 0
		     then do;
			     fail_sw = "1"b;
			     directory_acl_array (i).status_code = code;
			end;
		end;

	     else do;				/* look at segment acl modes and do name check */
		     if substr (segment_acl_array (i).mode, 5) ^= ""b
		     then do;			/* permit a mode for compatability */
			     segment_acl_array (i).status_code = error_table_$bad_acl_mode;
			     fail_sw = "1"b;
			end;
		     call acc_name_$elements (addr (segment_acl_array (i).access_name), work_p, code);
		     if code ^= 0
		     then do;
			     fail_sw = "1"b;
			     segment_acl_array (i).status_code = code;
			end;
		end;
	end;					/* do i = 1 to acl_count */
	if fail_sw
	then do;
		a_code = error_table_$argerr;
		go to ERROR_RETURN;
	     end;
     end check_in_structure;
%page;
process_specific_list:
     procedure;


	ael = acl_count;

/* zero out all status codes for unambiguous errors */

	on any_other call fatal_error (error_table_$argerr);
	if d_s
	then directory_acl_array (*).status_code = 0;
	else segment_acl_array (*).status_code = 0;
	revert any_other;

	fail_sw = "0"b;

	do i = 1 to ael;
	     offset = 0;

	     on any_other call fatal_error (error_table_$argerr);
	     if d_s
	     then temp_access_name = directory_acl_array (i).access_name;
	     else temp_access_name = segment_acl_array (i).access_name;
	     revert any_other;

	     call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code);
	     if code ^= 0
	     then do;
		     on any_other call fatal_error (error_table_$argerr);
		     if d_s
		     then directory_acl_array (i).status_code = code;
		     else segment_acl_array (i).status_code = code;
		     revert any_other;
		     fail_sw = "1"b;
		     go to list_loop;
		end;

	     call acl_$list_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, offset, code);

	     if code ^= 0
	     then if code = error_table_$empty_acl
		then do;
			on any_other call fatal_error (error_table_$argerr);
			if d_s
			then do;
				directory_acl_array (*).status_code = error_table_$user_not_found;
				directory_acl_array (*).mode = ""b;
			     end;
			else do;
				segment_acl_array (*).status_code = error_table_$user_not_found;
				segment_acl_array (*).mode = ""b;
				segment_acl_array (*).extended_mode = ""b;
			     end;
			revert any_other;
			code = 0;
			return;
		     end;
	     else if code = error_table_$user_not_found
		then do;
			on any_other call fatal_error (error_table_$argerr);
			if d_s
			then do;
				directory_acl_array (i).status_code = code;
				directory_acl_array (i).mode = ""b;
			     end;
			else do;
				segment_acl_array (i).status_code = code;
				segment_acl_array (i).mode = ""b;
				segment_acl_array (i).extended_mode = ""b;
			     end;
			revert any_other;
			code = 0;
			goto list_loop;		/* no such user is okay, continue */
		     end;
		else call fatal_error (code);

	     on any_other call fatal_error (error_table_$argerr);
	     if d_s
	     then directory_acl_array (i).mode = acl_entry_ptr -> acl1.ex_mode;
	     else do;				/* check if can return ex mode */
		     segment_acl_array (i).mode = acl_entry_ptr -> acl1.mode;
		     segment_acl_array (i).extended_mode = acl_entry_ptr -> acl1.ex_mode;
		end;
	     revert any_other;
list_loop:
	end;
	if fail_sw
	then call fatal_error (error_table_$argerr);

     end process_specific_list;
%page;
process_list_all:
     procedure;
	declare saved_dir_change_pclock
				 fixed bin (35);

	acl_count = n_acls;

/* Unlock, allocate, relock */

	saved_dir_change_pclock = dir.change_pclock;

	call lock$dir_unlock (dp);
	locked = "0"b;

	on any_other call fatal_error (error_table_$argerr);
	on area call fatal_error (error_table_$noalloc);	/* specific takes precedence */

	if refer_allocation
	then do;
		if d_s
		then do;
			allocate directory_acl in (arg_area);
			directory_acl.count = acl_count;
			directory_acl.version = ACL_VERSION_1;
			return_acl_ptr = acl_ptr;
			acl_ptr = addr (directory_acl.entries);
		     end;
		else do;
			allocate segment_acl in (arg_area);
			segment_acl.count = acl_count;
			segment_acl.version = ACL_VERSION_1;
			return_acl_ptr = acl_ptr;
			acl_ptr = addr (segment_acl.entries);
		     end;
	     end;
	else do;
		if d_s
		then allocate directory_acl_array in (arg_area);
		else allocate segment_acl_array in (arg_area);
		return_acl_ptr = acl_ptr;
	     end;

	revert any_other, area;

/* Relock */
/* hmmm, perhaps we should censor seg_deleted ... ? */

	on seg_fault_error signal bad_dir_;
	call lock$dir_lock_read (dp, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;
	revert seg_fault_error;

	if dir.change_pclock ^= saved_dir_change_pclock
	then do;
		call unlock_dir;			/* Locked_for_write guaranteed "0"b */
		go to Retry_process_list_all;
	     end;

	acl_entry_ptr = addr (a_n);

	do i = 1 to acl_count;
	     offset = i;				/* offset ^= 0, so list_entry will not match */

	     call acl_$list_entry (acl_count, owning_structure, acl_start_ptr, acl_entry_ptr, offset, code);
	     if code = error_table_$argerr
	     then /* see if listing all and count wrong */
		signal bad_dir_;

	     else if code ^= 0
	     then call fatal_error (code);

	     t_char1 = acl_entry_ptr -> acl1.ac_name.person;
	     t_char2 = acl_entry_ptr -> acl1.ac_name.project;
	     tag = acl_entry_ptr -> acl1.ac_name.tag;

	     on any_other call fatal_error (error_table_$argerr);

(nostringsize):
	     begin;
		if d_s
		then do;
			directory_acl_array (i).status_code = 0;
			directory_acl_array (i).access_name =
			     rtrim (t_char1) || "." || rtrim (t_char2) || "." || tag;
			directory_acl_array (i).mode = acl_entry_ptr -> acl1.ex_mode;
			directory_acl_array (i).status_code = 0;
		     end;
		else do;
			segment_acl_array (i).status_code = 0;
			segment_acl_array (i).access_name = rtrim (t_char1) || "." || rtrim (t_char2) || "." || tag;
			segment_acl_array (i).mode = acl_entry_ptr -> acl1.mode;
			segment_acl_array (i).extended_mode = acl_entry_ptr -> acl1.ex_mode;
		     end;
	     end /* the begin block */;
	     revert any_other;
	end;

     end process_list_all;
%page;
cleanup_:
     procedure;

						/** ASSUME that if a cleanup is in progress that verify_lock will be */
						/** called, so leave the dir locked for verify_lock to find and */
						/** salvage. */

	if /* case */ esw = LIST_DIR | esw = LIST_SEG
	then do;
		if /* case */ ^structure_supplied & acl_ptr ^= null
		then if /* tree */ refer_allocation
		     then if d_s
			then free directory_acl;
			else free segment_acl;
		     else if d_s
			then free directory_acl_array;
			else free segment_acl_array;
	     end;
	if called_find
	then call dc_find$finished (dp, "0"b);		/* leave locked for verify_lock */

     end cleanup_;

unlock_dir:
     procedure;

	if locked_for_write
	then do;
		call sum$dirmod (dp);
		dir.modify = ""b;
	     end;
	if called_find
	then call dc_find$finished (dp, locked);
	else if locked
	then call lock$dir_unlock (dp);
	locked, called_find = "0"b;
     end unlock_dir;


fatal_error:
     procedure (cc);
	declare cc		 fixed bin (35);

	a_code = cc;
	if fatal_error_sets_faults			/* only true if we have ep, etc. */
	then do;
		call setfaults$if_active ((entry.uid), (entry.pvid), (entry.vtocx), "1"b);
		fatal_error_sets_faults = ""b;
	     end;
	call unlock_dir;
	call cleanup_;				/* Free space, locking left untouched */
	go to ERROR_RETURN;
     end fatal_error;
ERROR_RETURN:
	return;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include dc_find_dcls;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include fs_obj_access_codes;
     end asd_;




		    chname.pl1                      11/11/89  1132.4r w 11/11/89  0800.4      102006



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


/* format: style4 */
chname: proc;

/*	Last modified (Date and reasons):
   by Keith Loepere to provide audit info and to change PAM to use uid's, November 1984.
   by Keith Loepere to use the new dc_find, August 1984.
   by BIM 1984 for sst reformat.
   by E. N. Kittlitz, May 1983, search_ast$check.
   by E. N. Kittlitz, March 1983, to not backup entry.dtem.
   by Keith Loepere January 1983 so bad ring bracket error makes it to user.
   by J. Bongiovanni to always flush pam on directory rename
   by THVV for bad_dir_ check, 7/77
   by D. Vinograd to add new entry retv for use by the volume retriever, 9/76
   by S. Barr to use new hash table format, 9/76
   by R. Bratt to call find_$finished, 06/01/76
   by R. Bratt for pam flush, 2/3/76.
   by BSG for NSS, 4/25/75.
   by Bernard S. Greenberg for SST name table, Feb. 18, 1975.
   by Richard H. Gumpertz 9 July 71 to interpret user not on acl as "null 7,7,7" when checking validation level
   by Richard H Gumpertz on 8 July 71 to check brackets for >= validation level
*/

cfile: entry (a_parent, a_ename, a_oldname, a_newname, a_code);

/*
   This proceedure to used to add, delete, and rename segments. It has two
   entry points. The entry point cfile" takes a directory path name and entry name
   to determine the segment affected while the entry point "cseg" uses a pointer.

   USAGE:	call chname$cfile(directory_name, entry_name, old_name, new_name, error_code);

   1. directory_name char(*)		path name of directory in which entry_name is an entry.

   2. entry_name char(*)		entry name of segment to be changed.

   3. old_name char(*)			name to be deleted from name list of entry_name.

   4. new_name char(*)			name to be added to name list of entry_name.

   5. error_code fixed bin(35)		file system error code (Output).

   USAGE:	call chname$cseg(segment_pointer, old_name, new_name, error_code);

   1. segment_pointer pointer		pointer to segment to be changed.

   2. - 4. Same as above.


   NOTE:	1. Caller must have write access with respect to the directory.

*/

dcl  a_code fixed bin (35);
dcl  a_ename char (*);
dcl  a_ep ptr;
dcl  a_newname char (*);
dcl  a_oldname char (*);
dcl  a_parent char (*);
dcl  a_sp ptr;

dcl  ep_known fixed bin static init (2) options (constant); ;
dcl  file fixed bin static init (0) options (constant);
dcl  seg fixed bin static init (1) options (constant); ;

dcl  areap ptr;
dcl  code fixed bin (35);
dcl  ename char (32);
dcl  entry_point fixed bin;
dcl  just_delete_name bit (1) aligned;
dcl  last_namep ptr;
dcl  namecnt fixed bin (18);
dcl  nep ptr;
dcl  new_np ptr;
dcl  newname char (32) aligned;
dcl  newname_p ptr;
dcl  next_np ptr;					/* ptr to next primary name before it is moved in */
dcl  old_np ptr;
dcl  oldname char (32) aligned;
dcl  oldname_p ptr;
dcl  parent char (168);
dcl  pvid bit (36) aligned;
dcl  save_fp bit (18);				/* save of old primary name forward thread */
dcl  sp ptr;
dcl  uid bit (36) aligned;
dcl  vtocx fixed bin;

dcl  active_hardcore_data$ensize fixed bin external;
dcl  error_table_$bad_ring_brackets fixed bin (35) external;
dcl  error_table_$namedup fixed bin (35) external;
dcl  error_table_$noalloc fixed bin (35) external;
dcl  error_table_$noentry fixed bin (35) external;
dcl  error_table_$nonamerr fixed bin (35) external;
dcl  error_table_$oldnamerr fixed bin (35) external;
dcl  error_table_$segnamedup fixed bin (35) external;
dcl  pds$processid bit (36) aligned ext;
dcl  1 pds$transparent aligned ext,
       2 m bit (1) unaligned,
       2 u bit (1) unaligned;
dcl  sst$ast_track bit (1) aligned external;

dcl  change_dtem entry (ptr);
dcl  fs_alloc$alloc entry (ptr, fixed bin, ptr);
dcl  fs_alloc$free entry (ptr, fixed bin, ptr);
dcl  hash$in entry (ptr, ptr, fixed bin (35));
dcl  hash$out entry (ptr, ptr, ptr, fixed bin (35));
dcl  hash$search entry (ptr, ptr, ptr, fixed bin (35));
dcl  level$get entry returns (fixed bin);
dcl  lock$dir_unlock entry (ptr);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  pathname_am$flush entry (bit (36) aligned);
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  sum$dirmod entry (ptr);

dcl  (addr, bin, bit, clock, divide, fixed, null, ptr, rel, rtrim) builtin;
%page;
	entry_point = file;				/* entered via chname entry point */
	parent = a_parent;
	ename = a_ename;

	go to common;

cseg: entry (a_sp, a_oldname, a_newname, a_code);

	entry_point = seg;				/* entered via chname$cseg entry point */
	sp = a_sp;
	goto common;

retv: entry (a_ep, a_oldname, a_newname, a_code);

	ep = a_ep;
	dp = ptr (ep, 0);
	entry_point = ep_known;

common:
	code = 0;
	oldname = a_oldname;
	newname = a_newname;

	if newname = "" then just_delete_name = "1"b;	/* if no name is to be added, then just remove a name */
	else just_delete_name = "0"b;			/* otherwise adding or replacing a name */

	if entry_point ^= ep_known then do;
	     if entry_point = file then call dc_find$obj_status_write (parent, ename, 0, FS_OBJ_RENAME, ep, code);
	     else call dc_find$obj_status_write_ptr (sp, FS_OBJ_RENAME, ep, code);
	     dp = ptr (ep, 0);
	     if code ^= 0 then go to finale;

	     if entry.bs then
		if ^(entry.dirsw) then
		     if fixed (entry.ring_brackets (1), 3) < (level$get ()) then do;
			code = error_table_$bad_ring_brackets;
			go to unlock;
		     end; else ;
		else if fixed (entry.ex_ring_brackets (1), 3) < (level$get ()) then do;
		     code = error_table_$bad_ring_brackets;
		     go to unlock;
		end; else ;
	end;

	namecnt = fixed (entry.nnames, 18);

	if namecnt = 1 then if just_delete_name		/* Will there be any names left after oldname is deleted */
	     then do;				/* and no name is added */
		code = error_table_$nonamerr;
		go to unlock;
	     end;

	areap = ptr (dp, dir.arearp);

	dir.modify = pds$processid;

	if just_delete_name then go to delete_name;

	newname_p = addr (newname);
	call hash$search (dp, newname_p, nep, code);
	if code = 0 then do;
	     if ep = nep then code = error_table_$segnamedup;
	     else code = error_table_$namedup;
	     go to unlock;
	end;
	if code ^= error_table_$noentry then go to unlock;

	call fs_alloc$alloc (areap, active_hardcore_data$ensize, new_np); /* allocate storage for newname */
	if new_np = null then go to noalloc_err;

	new_np -> names.name = newname;

	new_np -> names.entry_rp = rel (ep);
	new_np -> names.type = NAME_TYPE;
	new_np -> names.size = active_hardcore_data$ensize;
	new_np -> names.owner = entry.uid;

	call hash$in (dp, new_np, code);
	if code ^= 0 then go to hash_error;

	last_namep = ptr (ep, entry.name_brp);
	new_np -> names.bp = rel (last_namep);
	last_namep -> names.fp = rel (new_np);
	entry.name_brp = rel (new_np);
	namecnt = namecnt + 1;			/* increase count of number of names for "entry" */


delete_name: if oldname = "" then go to finish;

	oldname_p = addr (oldname);
	call hash$search (dp, oldname_p, nep, code);
	if code ^= 0 then go to finish;		/* if name not in hash table (most probably) */
	if ep ^= nep then go to name_err;		/* if name associated with another entry */

	call hash$out (dp, oldname_p, old_np, code);	/* Hash "oldname" to find its place in the */
	if code ^= 0 then do;			/* hash table and vacate this place. */
name_err:	     code = error_table_$oldnamerr;
	     go to finish;
	end;

	if old_np -> names.bp then do;		/* not primary name */
	     ptr (old_np, old_np -> names.bp) -> names.fp = old_np -> names.fp;
	     if old_np -> names.fp then ptr (old_np, old_np -> names.fp) -> names.bp = old_np -> names.bp;
	     else entry.name_brp = old_np -> names.bp;
	end;
	else do;

/* * The name entry for the primary name is stored in the entry structure.  If the name being deleted or changed
   * was the primary name, then the new primary name must be moved into this area.  The steps are:
   *	1. The new primary name is hashed out.
   *	2. The new primary name is threaded out.
   *	3. The contents of the new primary name are copied into the slot in the entry.
   *	4. The new primary name in its new location is hashed in.
*/
	     if just_delete_name then next_np = ptr (dp, old_np -> names.fp);
	     else next_np = new_np;

	     call hash$out (dp, addr (next_np -> names.name), next_np, code);
	     if code ^= 0 then goto finish;

/* Unthread new primary name. */

	     if next_np -> names.fp = "0"b
	     then entry.name_brp = next_np -> names.bp;	/* end of chain */
	     else ptr (dp, next_np -> names.fp) -> names.bp = next_np -> names.bp;
	     ptr (dp, next_np -> names.bp) -> names.fp = next_np -> names.fp;

/* Copy new primary name into entry slot, but save old primary threads. */

	     save_fp = old_np -> names.fp;
	     old_np -> names = next_np -> names;
	     old_np -> names.fp = save_fp;
	     old_np -> names.bp = "0"b;

	     call hash$in (dp, old_np, code);
	     if code ^= 0 then goto finish;
	     old_np = next_np;			/* set so space will be freed later */

	     if entry.bs & sst$ast_track then do;	/* AST names */
		uid = entry.uid;			/* Must extract info before locking AST */
		pvid = entry.pvid;
		vtocx = entry.vtocx;
		temp_entry_name = newname;		/* This is the new name */
		call lock$lock_ast;
		nm_astep = search_ast$check (uid, pvid, vtocx, (0)); /* ignore code since it's just for name table */
		if nm_astep ^= null then

%include make_sstnt_entry;
		call lock$unlock_ast;
	     end;
	end;

	namecnt = namecnt - 1;			/* decrease count of number of names for "entry" */

	call fs_alloc$free (areap, active_hardcore_data$ensize, old_np); /* free storage for "oldname" */
	if entry.dirsw
	then call pathname_am$flush (entry.uid);


finish:	entry.nnames = namecnt;
	if ^pds$transparent.m then			/* is it ok to change date */
	     if entry.dtem ^= bit (fixed (clock (), 52), 36) then /* if 'now', don't bother. we're not setfaulting */
		call change_dtem (ep);		/* if old, brighten it up */
	dir.modify = "0"b;
	call sum$dirmod (dp);			/* Notify control that "parent" has been modified */
	go to unlock1;

/* Error handlers. */

unlock:	dir.modify = "0"b;
unlock1:	if entry_point ^= ep_known then do;
	     if entry_point = file
	     then call dc_find$finished (dp, "1"b);
	     else call lock$dir_unlock (dp);
	end;
finale:	a_code = code;
	return;

hash_error:
	call fs_alloc$free (areap, active_hardcore_data$ensize, new_np);
	go to unlock;
noalloc_err:
	code = error_table_$noalloc;
	go to unlock;

/* format: off */

%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_ht;
%page; %include dir_name;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include sstnt;
     end chname;




		    copy_fdump.pl1                  11/11/89  1132.4rew 11/11/89  0800.0      159507



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

/* COPY_FDUMP - Make Copy of Information in Dump Partition:

   This program creates a toe-hold into the dump partition.
   This partition may contain dump information left by
   the bce dump program. This information is copied into
   multiple segments in the directory >dumps. These segments
   are force-deactivated as a hedge against crashes.

   4/7/71 - N. I. Morris & S. H. Webber
   9/28/71 - modified to allow setting erf no and to add error codes - D. M. Jordan
   3/2/73 - modified for 6180 and v2pl1 - RE Mullen
   7/11/73 - modified to copy dn355 core image out of part dump and added get_erf_no entry - RE Mullen
   10/08/75 - modified for multiple 355s - Robert Coren
   02/01/79 - modified to allow more than 10 segnos - F. W. Martinson
   08/25/80 - Modified to announce copy in syserr log -- W. Olin Sibert
   11/11/80 - modified for the DPS8/70M CPU -- J. A. Bush
   03/21/81, W. Olin Sibert, for ADP PTWs and ptw_util_.
   02/26/82 - J. Bongiovanni, to eliminate use of FSDCT, force deactivate
             dump segments.
   11/05/84, Keith Loepere to change terminate to terminate_.
   01/22/85, Keith Loepere for new find_partition.

   */


/****^  HISTORY COMMENTS:
  1) change(86-10-23,Fawcett), approve(86-10-23,MCR7517),
     audit(86-10-30,Beattie), install(86-11-03,MR12.0-1206):
     Changed to remove the word BOS from message.
                                                   END HISTORY COMMENTS */


copy_fdump: proc (a_code);

	dcl     i			 fixed bin,	/* page table index */
	        p			 ptr,		/* handy pointer */
	        ptp		 ptr,		/* Pointer to page table of abs-seg */
	        (dt, dt_dn355)	 char (24),	/* date and time strings */
	        (ename, a_ename, xname, ename_dn355, a_ename_dn355) char (32), /* dump segment entry names */
	        erf		 char (12),	/* converted ERF number */
	        (erf_no, a_erf_no)	 fixed bin,	/* number to set next dump to */
	        ptsi		 fixed bin,	/* page table size index */
	        code		 fixed bin (35),	/* error code */
	        a_code		 fixed bin (35),	/* error code to return to caller */
	        rb		 (3) fixed bin (6) init (7, 7, 7), /* ring brackets for call to append */
	        seqno		 fixed bin,	/* dump sequence number */
	        esw		 fixed bin,	/* entry switch */
	        dumpadd		 fixed bin (18),	/* address within dump partition */
	        nrecs		 fixed bin (18),	/* number of records in PART DUMP */
	        next_part_add	 fixed bin,	/* dumpadd of rec following PART DUMP */
	        first		 fixed bin (20),	/* first address within dump partition */
	        (length, a_length)	 fixed bin (35),	/* length dump info */
	        (a_valid, a_valid_dn355) bit (1),	/* = 1 if dumps are valid */
	        word_count		 fixed bin (18),	/* number of words to copy from dump partition at one time */
	        copy		 (word_count) fixed bin (35) based, /* structure to allow copying of dump data */
	        dump_pvtx		 fixed bin,
	        dump_pvid		 bit (36) aligned,
	        tsdwp		 ptr,		/* pointer to SDW */
	        tsdw		 bit (72);	/* temporary for SDW */

	dcl     (max_size, max_pages, dn355_size) fixed bin; /* max for output segs */
	dcl     single_dn355_size	 fixed bin (35);	/* number of bits in 355 core image */
	dcl     words_per_image	 fixed bin;
	dcl     pg_size		 fixed bin;

	dcl     (dumping_Multics, dumping_dn355) bit (1); /* to keep track of what we want to dump */

	dcl     (hdr_size, rest_size)	 fixed bin;	/* sizes in words */

	dcl     dn355_copy		 bit (single_dn355_size) aligned based; /* for copying 355 dump */

	dcl     1 din		 based aligned,	/* structure of first 64K of PART DUMP */
		2 header		 (hdr_size) fixed bin (35), /* registers, rel locs of segs, etc */
		2 dn355_images	 (4),
		  3 dn355_core	 bit (single_dn355_size) aligned, /* dn355 core image put here by FD355 */
		2 rest		 (rest_size) fixed bin (35); /* start of segments dumped by FDUMP */


	dcl     (error_table_$noaccess fixed bin (35),
	        error_table_$dmpinvld	 fixed bin (35),
	        error_table_$noprtdmp	 fixed bin (35),
	        error_table_$bdprtdmp	 fixed bin (35),
	        error_table_$dmpvalid	 fixed bin (35),
	        error_table_$nopart	 fixed bin (35),
	        sys_info$default_max_length fixed bin (35),
	        sys_info$page_size	 fixed bin (35),
	        pds$process_group_id	 char (32) aligned,
	        abs_seg$)		 ext;

	dcl     sst$astsize		 fixed bin external static;
	dcl     1 sst$level		 (0:3) aligned external static,
		2 ausedp		 bit (18) unaligned,
		2 no_aste		 bit (18) unaligned;

	dcl     privileged_mode_ut$swap_sdw ext entry (ptr, ptr),
	        thread$out		 entry (ptr, bit (18) unal),
	        lock$lock_ast	 entry,
	        lock$unlock_ast	 entry,
	        get_ptrs_$given_astep	 ext entry (ptr) returns (bit (72) aligned),
	        syserr		 ext entry options (variable),
	        condition_		 ext entry (char (*), entry),
	        reversion_		 ext entry (char (*)),
	        date_time_		 ext entry (fixed bin (71), char (*)),
	        append$branchx	 ext entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*),
				 fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)),
	        initiate		 ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
	        pc$cleanup		 entry (ptr),
	        get_aste		 ext entry (fixed bin) returns (ptr),
	        put_aste		 ext entry (ptr),
	        cv_bin_$dec		 ext entry (fixed bin (17)) returns (char (12) aligned),
	        demand_deactivate$force_given_segno entry (ptr, fixed bin (35)),
	        terminate_$noname	 entry (ptr, fixed bin (35)),
	        find_partition	 entry (char (*), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35)),
	        ptw_util_$make_disk	 entry (pointer, fixed bin (20));

	dcl     (addr, addrel, bit, char, divide, fixed, ltrim, min, null, size, substr) builtin;

/*  */

	esw = 0;
	go to setup;

set_erf_no:
     entry (a_erf_no, a_code);
	erf_no = a_erf_no;
	esw = 1;
	go to setup;

get_erf_no:
     entry (a_length, a_valid, a_ename, a_valid_dn355, a_ename_dn355, a_code);
	esw = 2;
	a_length = 0;
	a_valid, a_valid_dn355 = "0"b;
	a_ename, a_ename_dn355 = "                                ";

setup:
	a_code = 0;
	p = null ();				/* So any_other handler wins */
	pg_size = sys_info$page_size;			/* number of words per page */
	max_size = sys_info$default_max_length;		/* max number of words in segs copy_fdump creates */
	max_pages = divide (max_size + pg_size - 1, pg_size, 17, 0);
	dn355_size = 16384 * 4;			/* words equaling 32K of 18bit words for up to 4 355s */
	single_dn355_size = 16384 * 36;		/* bits for one 355 core image */
	words_per_image = 16384;			/* same in words */
	hdr_size = size (dump);			/* number of words in dump header */

/* Determine location and size of the dump partition. */

	call find_partition ("dump", dump_pvtx, dump_pvid, dumpadd, nrecs, code);
	if code ^= 0 then do;
		if code = error_table_$nopart then a_code = error_table_$noprtdmp;
		else a_code = code;
		return;
	     end;

	first = dumpadd;

	if nrecs = 0 then do;
		a_code = error_table_$bdprtdmp;
		return;
	     end;

	next_part_add = first + nrecs;		/*  Stop before here */

/* Now create an abs_seg through which to look at the dump */

	dumpptr = addr (abs_seg$);			/* get pointer to abs_seg */
	tsdwp = addr (tsdw);			/* get a pointer to the SDW to be used */
	call lock$lock_ast;
	astep = get_aste (max_pages);			/* get a large page table / ASTE */
	ptsi = fixed (aste.ptsi, 2);
	call thread$out (astep, sst$level.ausedp (ptsi));
	call lock$unlock_ast;
	ptp = addrel (astep, sst$astsize);		/* get a pointer to the page table */
	tsdw = get_ptrs_$given_astep (astep);		/* get the actual SDW to use */
	call privileged_mode_ut$swap_sdw (dumpptr, tsdwp);/* make abs_seg point to the dump seg */
	aste.pvtx = dump_pvtx;
	aste.csl = bit (fixed (max_pages,9), 9);		/* Set correct current length in AST entry. */
	aste.nqsw = "1"b;				/* indicate no quota for this segment */
						/*  */
						/* Set up a condition in case we bomb out. */
	call condition_ ("any_other", handler);
	if esw = 1 then go to set_num;		/* just set the erf number in the dump partition */
	if esw = 2 then go to get_num;		/* just return info in dump header */

/* Attempt to copy the dump information into the hierarchy. */

	do seqno = 0 by 1;				/* Keep going until we run out of information. */
	     do i = 0 to (max_pages - 1) while (i < next_part_add - dumpadd);
		call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */
	     end;
	     if seqno = 0 then do;			/* were making our first seg in >dumps */
		     call check_dump_header;		/* Initialize some variables and see whats in PART DUMP */
		     length = min (length, nrecs * pg_size - dn355_size - hdr_size);
		     if dumping_dn355 then do;	/* we want to make a special seg in >dumps for 355core image */
			     xname = ename_dn355;	/* will have ".355" suffix */
			     word_count = dn355_size; /* clearly */
			     call get_branch;	/* get and initiate a branch */
			     do i = 1 to 4;		/* copy up to four 355 core images */
				if substr (dumpptr -> dump.dumped_355s, i, 1) /* there is an image for this one */
				then p -> dn355_copy = dumpptr -> din.dn355_images (i).dn355_core; /* copy it */
				else p -> dn355_copy = "0"b;

				p = addrel (p, words_per_image); /* bump to next core image */
			     end;

			     dumpptr -> dump.valid_355 = "0"b; /*  turn off the valid bit */
			end;
		     if dumping_Multics then do;	/* need to skip over the dn355 stuff */
			     call pc$cleanup (astep); /* Force all pages from core. */
			     aste.npfs = "0"b;	/* turn off no page fault switch */
			     do i = 0 to 1;		/* fill in first 2 ptws */
				call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */
			     end;
			     dumpadd = dumpadd + divide (dn355_size, pg_size, 18, 0); /* skip over dn355 data */
			     do i = 2 to (max_pages - 1) while (i < next_part_add - dumpadd);
				call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */
			     end;
			     rest_size = min (max_size - hdr_size, length); /* does not include header */
			     word_count = hdr_size + rest_size; /* the number of words to this branch */
			     xname = ename;		/* the name of the branch we will create */
			     call get_branch;	/* get and initiate the branch */
			     p -> copy = dumpptr -> copy; /* copy the header and some Multics segs */
			     length = length - rest_size; /* remaining length is less now */
			end;
		end;
	     else do;				/* no need to worry about dn355 stuff */
		     substr (ename, 13) = ltrim (char (seqno)) || "." || ltrim (erf);
		     word_count = min (length, max_size); /* take what we can */
		     xname = ename;			/* a standard name */
		     call get_branch;
		     p -> copy = dumpptr -> copy;	/* copy the data */
		     length = length - word_count;	/* shorten remaining length */
		end;
	     call pc$cleanup (astep);			/* Force all pages from core. */
	     aste.npfs = "0"b;			/* Turn off the no page fault switch. */
	     dumpadd = dumpadd + max_pages;		/* Step partition address to next max_pagesK. */
	     if ^dumping_Multics then go to endup;	/* dn355 core is copied already */
	     if length <= 0 then go to cleanup;		/* Check for completion of Multics dump copying */
	end;					/* Continue loop until dump info exhausted. */
						/*  */
cleanup:
	call ptw_util_$make_disk (ptp, first);		/* Insert toe-hold to first record */
	dumpptr -> dump.valid = "0"b;			/* Turn off valid bit. */
	call syserr (LOG, "copy_fdump: Copied fdump image of erf ^d (^a) for ^a", /* let anyone who cares know about this */
	     dumpptr -> dump.erfno, dt, pds$process_group_id);

endup:
	call pc$cleanup (astep);			/* Force all pages from core. */

exit:
	call reversion_ ("any_other");
	if p ^= null () then do;			/* terminate and force-deactivate */
		call demand_deactivate$force_given_segno (p, code);
		call terminate_$noname (p, code);
	     end;


	call lock$lock_ast;
	call put_aste (astep);			/* return the AST entry */
	call lock$unlock_ast;
	tsdw = ""b;
	call privileged_mode_ut$swap_sdw (dumpptr, tsdwp);
	return;

set_num:						/* CODE to reset the erf number in PART DUMP */
	call ptw_util_$make_disk (ptp, first);		/* Establish address for first page */

	if (dumpptr -> dump.valid | dumpptr -> dump.valid_355)
	then do;					/* Previous dump hasn't been picked up */
		a_code = error_table_$dmpvalid;
		go to endup;
	     end;

	dumpptr -> dump.erfno = erf_no - 1;		/* set the dump number */
	go to endup;

get_num:						/* CODE to get the erf number in PART DUMP */
	call ptw_util_$make_disk (ptp, first);		/* get address of first page */

	call check_dump_header;			/* internal proc to decode header info */

	if dumping_Multics then do;
		a_length = length;
		a_valid = dumping_Multics;
		a_ename = ename;
	     end;
	if dumping_dn355 then do;
		a_valid_dn355 = dumping_dn355;
		a_ename_dn355 = ename_dn355;
	     end;

	go to endup;




/*  */

/* INTERNAL PROC to examine the dump header */
check_dump_header: proc;
	if esw ^= 1 then /* previously checked that it's invalid for set_erf_no entry */
	     if dumpptr -> dump.valid = "0"b then
		if dumpptr -> dump.valid_355 = "0"b then do;
			a_code = error_table_$dmpinvld; /* No valid dumps so scram */
			go to endup;
		     end;
	dumping_Multics = dumpptr -> dump.valid;	/* want to copy valid Multics dump */
	dumping_dn355 = dumpptr -> dump.valid_355;	/* want to copy valid 355 dump */
	length = dumpptr -> dump.words_dumped;		/* keep this number handy */
						/* Now fabricate a name for the dump. The names look like ...
						   MMDDYY.TTTT.N.EEE
						   MMDDYY	= month, day, year
						   TTTT	= time of day
						   N	= sequence number of dump segment
						   EEE	= ERF number
						   */
	erf = cv_bin_$dec ((dumpptr -> dump.erfno));	/* Convert the ERF number. */
	if dumping_Multics then do;
		call date_time_ (dumpptr -> dump.time, dt); /* Convert the date and time of dump. */
		ename = substr (dt, 1, 2) || substr (dt, 4, 2) || substr (dt, 7, 2) || "."
		     || substr (dt, 11, 5) || "0." || ltrim (erf);
	     end;
	if dumping_dn355 then do;
		call date_time_ (dumpptr -> dump.time_355, dt_dn355); /* setup name for 355 segs in >dumps similarly */
		ename_dn355 = substr (dt_dn355, 1, 2) || substr (dt_dn355, 4, 2) || substr (dt_dn355, 7, 2) || "."
		     || substr (dt_dn355, 11, 5) || "0." || ltrim (erf) || ".355";
	     end;
     end check_dump_header;

/* INTERNAL PROC to create a seg in >dumps, and initiate it */
get_branch: proc;					/* share stack frame */
append:
	if p ^= null () then do;			/* terminate and force-deactivate */
		call demand_deactivate$force_given_segno (p, code);
		call terminate_$noname (p, code);
	     end;

	call append$branchx (">dumps", xname, RW_ACCESS_BIN, rb, (pds$process_group_id), 0, 0, 36 * word_count, code);
	if code ^= 0 then do;
		if code = error_table_$noaccess then do;/* >dumps is not there */
			call append$branchx (">", "dumps", A_ACCESS_BIN, rb, "*.*.*", 1, 0, 0, code); /* create it */
			if code ^= 0 then do;
				a_code = code;
				go to endup;
			     end;
			go to append;		/* loop back to try again */
		     end;
		else do;				/* Branch cannot be created. */
			a_code = code;
			go to endup;
		     end;
	     end;
	call initiate (">dumps", xname, "", 0, 0, p, code); /* get a pointer to the new seg */
	if p = null then do;			/* If initiation failed ... */
		a_code = code;
		go to endup;
	     end;
     end get_branch;
						/*  */

/* INTERNAL PROC to handle unclaimed signals */

handler: proc (mc_ptr, name);

	dcl     mc_ptr		 ptr,		/* pointer to machine conditions (not used) */
	        name		 char (*);	/* name of the condition */


	call syserr (ANNOUNCE, "copy_fdump: unexpected ^a signal.", name);
	go to exit;				/* Print comment, and then clean up and exit. */
     end handler;

%page; %include access_mode_values;
%page; %include aste;
%page; %include bos_dump;
%page; %include syserr_constants;
/*  */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   copy_fdump: unexpected NAME signal.

   S:	$info

   T:	$run

   M:	An attempt to copy the dump from the DUMP partition with
   copy_fdump resulted in an unclaimed signal. This may be due to
   damage to the DUMP partition contents, a malfunction of the BCE
   dump command, a supervisor error, or a simple difficulty
   like running out of space in >dumps. The system continues operation.
   The copied dump may be only partly valid.

   A:	$notify


   Message:
   copy_fdump: Copied fdump image of erf NNN (MM/DD/YY HHMM.M) for USERNAME

   S:	$info

   T:	$run

   M:	The user identified by USERNAME has successfully copied the
   FDUMP image for the specified ERF out of the DUMP partition. The time
   the FDUMP was taken is also included in the message. This message is
   informational only, and is intended only as an aid in tracking system
   progress by perusing the syserr log.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end copy_fdump;




		    correct_qused.pl1               11/11/89  1132.4r w 11/11/89  0800.4       99540



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


/* format: style4 */
correct_qused: proc (a_dir, a_osu, a_odu, a_nsu, a_ndu, a_did_anything, a_code);

/* Quota used reconstructor. An original algorithm by Bernard Greenberg
   Feb. 1977

   Modified 1/82 BIM for write lock on dir to get exclusive lock.
   Modified 8/83 E. N. Kittltiz for search_ast$check.
   Modified 7/84 Keith Loepere to use the new dc_find.
   Modified 10/84 Keith Loepere to provide audit info.
   Modified 12/84 Keith Loepere for new dir quota definition.
*/

/* Parameters */

dcl  a_code fixed bin (35) parameter;
dcl  a_did_anything bit (1) aligned parameter;
dcl  a_dir char (*) parameter;
dcl  a_ndu fixed bin (34) parameter;
dcl  a_nsu fixed bin (34) parameter;
dcl  a_odu fixed bin (34) parameter;
dcl  a_osu fixed bin (34) parameter;

/* Variables */

dcl  branches_passed fixed bin;
dcl  code fixed bin (35);
dcl  correct_dir bit (1) aligned;
dcl  correct_seg bit (1) aligned;
dcl  did_anything bit (1) aligned;
dcl  dname char (168);
dcl  dpvid bit (36) aligned;
dcl  dudelta fixed bin (34);
dcl  duid bit (36) aligned;
dcl  dvtocx fixed bin;
dcl  htblsize fixed bin;
dcl  1 local_vtoce aligned like vtoce;
dcl  ndu fixed bin (34);				/* old-new X seg-dir used */
dcl  nentries fixed bin;
dcl  nsu fixed bin (34);
dcl  odu fixed bin (34);
dcl  osu fixed bin (34);
dcl  scode fixed bin (35);
dcl  scode1 fixed bin (35);
dcl  sudelta fixed bin (34);

/* External */

dcl  error_table_$rqover fixed bin (35) ext;
dcl  error_table_$vtoce_connection_fail fixed bin (35) ext;

/* Misc */

dcl  (addr, fixed, mod, null, ptr, rel, unspec) builtin;

dcl  bad_dir_ condition;

/* Entries */

dcl  get_pvtx entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  logical_volume_manager$lvtep entry (bit (36) aligned, ptr, fixed bin (35));
dcl  quotaw$rvq entry (ptr, fixed bin (34), fixed bin (34), fixed bin (34), fixed bin (34));
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  syserr entry options (variable);
dcl  vtoc_attributes$correct_qused entry (bit (36) aligned, bit (36) aligned,
	fixed bin, fixed bin (34), fixed bin (34), fixed bin (35));
dcl  vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35));
%page;

/* The basic operational theorem of this program is that the quota used total for any directory quota cell  is
   either  right  or  wrong  by  a finite and constant amount.  If that amount of error can be computed at any
   given time (T0) by figuring out what it should be, it can be corrected at any time  later  by  adding  this
   fixed correction, regardless of how many pages were created or destroyed in the interim. */

	correct_dir, correct_seg = "1"b;
	go to join;

correct_seg_qused: entry (a_dir, a_osu, a_nsu, a_did_anything, a_code);

	correct_dir = "0"b;
	correct_seg = "1"b;
	go to join;

correct_dir_qused: entry (a_dir, a_odu, a_ndu, a_did_anything, a_code);

	correct_dir = "1"b;
	correct_seg = "0"b;

join:	dname = a_dir;
	did_anything = "0"b;
	scode, code = 0;
	vtocep = addr (local_vtoce);

	call dc_find$dir_write_priv (dname, FS_OBJ_CORRECT_QUSED, dp, code);
	if code ^= 0 then go to err;

	if correct_seg then do;
	     call logical_volume_manager$lvtep (dir.sons_lvid, (null ()), code);
						/* We check before and after cycle, the
						   first time to rule out problem. We check at the
						   end if demount occured during run. Still small window. */
	     if code ^= 0 then go to unlock_err;
	end;

/* Directory is locked at this point (actually back at dc_find). Until we 
   unlock it, nobody can  truncate  VTOCEs  or  create  or  delete segments
   or dirs in it. Finite and constant set of inferior UID's from here to the
   end.   Furthermore,  all  "used"  change  can only be on active segments,
   all of which must be active now, and no new ones can become active because
   we have the directory locked. */

	nentries = dir.seg_count + dir.dir_count;
	htblsize = (nentries * 7) / 5;

	duid = dir.uid;				/* Get uid into automatic */
	dpvid = dir.pvid;				/* pvid of directory, copied from branch */
	dvtocx = dir.vtocx;				/* vtocx of directory, copied from branch */

	call lock$lock_ast;

/* Lock the AST.  If this dir is not active, none of its sons can become active until
   we unlock this dir. If it is, we must call quotaw to get info. */

	astep = search_ast$check (duid, dpvid, dvtocx, code); /* is it there? */
	if code ^= 0 then do;			/* double-uid */
	     call lock$unlock_ast;
	     go to unlock_err;
	end;

	if astep = null then do;
	     nsu = 0;				/* At time T0, which never existed, no active inferior
						   quota was found */
	     call lock$unlock_ast;			/* And will remain so. */

	     call internal_vtoc_man (dir.uid, dir.pvid, dir.vtocx);
						/* Get current quota numbers for this dir */
	     if code ^= 0 then go to unlock_err;

	     ndu = fixed (vtoce.records, 9);		/* Count dirs pages toward itself */
	     osu = vtoce.used (0);
	     odu = vtoce.used (1);			/* Read old totals at time T0 */
	end;

	else					/* There is active inferior quota */
	     call quotaw$rvq (astep, osu, odu, nsu, ndu); /* Get false (o) numbers and active
						   inferior totals (n) */

/* The time that quotaw$rvq reads these numbers is called "T0". The "false" numbers read out of the  ASTE  for
   this dir at T0 is (was) wrong by  a  finite  number,  "d(0:1)".   The   difference   between   the   active
   inferior totals  and   the   "right" number at time T0 is the sum of the non-active used for all VTOCEs not
   active  at  time  T0.  As long as the AST remains locked, the membership of this set cannot change. We have
   not  unlocked it  since  T0.  From this number, we can find "d". */

	begin;					/* * * * * START OF BEGIN BLOCK * * * * * * */

dcl  hshx fixed bin;
dcl  htbl (0:htblsize - 1) bit (36) aligned;
						/* Enter begin block to make hashtable */


	     unspec (htbl) = "0"b;			/* No stuff in table */
	     if astep ^= null then do;		/* AST still locked here */
		do astep = ptr (astep, aste.infp) repeat ptr (astep, aste.infl) while (rel (astep));
						/* Loop the AST to record activity at T0 */

		     if hash_search ((aste.uid)) then call syserr (1, "correct_qused: hash error");
		     else htbl (hshx) = aste.uid;
		end;
		call lock$unlock_ast;		/* I don't care what gets deactivated now */
	     end;

	     branches_passed = 0;			/* Don't loop */
	     nentries = nentries + dir.lcount;		/* Gotta count them too */

	     do ep = ptr (dp, dir.entryfrp) repeat ptr (dp, entry.efrp) while (rel (ep));
		branches_passed = branches_passed + 1;
		if branches_passed > nentries then signal bad_dir_;
		if entry.bs then do;		/* Skip them links */
		     if entry.owner ^= dir.uid
			| (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_;
		     if ^hash_search (entry.uid) then do; /* If not active at T0, get VTOC stuff */
			if ^correct_seg then
			     if ^entry.dirsw then go to next_entry; /* avoid asking for non-mounted vtoce */
			call internal_vtoc_man (entry.uid, (entry.pvid), entry.vtocx);
			if code ^= 0 then scode = code;
			else do;
			     if vtoce.dirsw then do;
				if vtoce.received (0) = 0 & ^vtoce.master_dir then nsu = nsu + vtoce.used (0);
				if vtoce.received (1) = 0 then ndu = ndu + vtoce.used (1); /* dirs pages already counted in used */
			     end;
			     else nsu = nsu + fixed (vtoce.records, 9);
			end;
		     end;
		end;
next_entry:    end;
	     if branches_passed < nentries then signal bad_dir_;

hash_search: proc (c_uid) returns (bit (1) aligned);	/* Internal to begin block */

dcl  c_uid bit (36) aligned parameter;

dcl  cuid bit (36) aligned;
dcl  hshi fixed bin;

	cuid = c_uid;
	if cuid = "0"b then signal bad_dir_;
	hshi = mod (fixed (cuid, 36), htblsize);
	do hshx = hshi to htblsize - 1, 0 to hshi - 1;
	     if htbl (hshx) = cuid then return ("1"b);
	     else if htbl (hshx) = "0"b then return ("0"b);
	end;
	signal bad_dir_;				/* dir header must have lied */
     end hash_search;
	end;					/* * * * * END OF BEGIN BLOCK * * * * * * * */
%page;

/* Now nsu and ndu are the correct used totals at time T0, while osu and odu are the erroneous totals at  time
   T0. Thus, we can find d(0:1), the difference.  This difference will not change, it is the fixed error. */


	sudelta = nsu - osu;
	dudelta = ndu - odu;

/* We are now free to change whatever we have at any time by these differences. */

	if scode ^= 0 then do;			/* if was problem check for lv demount window */
	     if correct_seg then do;
		call logical_volume_manager$lvtep (dir.sons_lvid, (null ()), scode1);
		if scode1 ^= 0 then do;
		     code = scode1;
		     sudelta, dudelta = 0;
		end;
	     end;
	end;

	if ^correct_seg then sudelta = 0;
	if ^correct_dir then dudelta = 0;

	if sudelta ^= 0 | dudelta ^= 0
	then call vtoc_attributes$correct_qused (duid, dir.pvid, (dir.vtocx), sudelta, dudelta, code);
	else code = 0;

	if code = 0 then did_anything = "1"b;
	else if code = error_table_$rqover then did_anything = "1"b; /* Avoid page fault */


unlock_err:
	call dc_find$finished (dp, "1"b);
err:	if code = 0 then code = scode;

	a_did_anything = did_anything;
	a_code = code;
	if correct_seg then do;
	     a_nsu = nsu;
	     a_osu = osu;
	end;
	if correct_dir then do;
	     a_ndu = ndu;
	     a_odu = odu;
	end;
	return;

%page;
internal_vtoc_man: proc (b_uid, b_pvid, b_vtocx);

/* Internal proc to get a whole bunch of vtoc info for a segment guaranteed not to be active */

dcl  b_pvid bit (36) aligned parameter;
dcl  b_uid bit (36) aligned parameter;
dcl  b_vtocx fixed bin (17) unal parameter;

dcl  pvtx fixed bin;

	pvtx = get_pvtx (b_pvid, code);
	if code ^= 0 then return;

	call vtoc_man$get_vtoce (b_pvid, pvtx, (b_vtocx), "100"b, vtocep, code);
	if code = 0 then if vtoce.uid ^= b_uid then code = error_table_$vtoce_connection_fail;
     end;

/* format: off */

%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include vtoce;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   correct_qused: hash error

   S: $crash

   T: $run

   M: Multiple entries within a directory undergoing quota correction have 
   the same UID.

   END MESSAGE DOCUMENTATION */

     end;




		    del_dir_tree.pl1                11/11/89  1132.4r w 11/11/89  0800.4       78552



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

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

del_dir_tree: proc (a_dirname, a_ename, a_code);

/*
   Del_dir_tree is used to delete all branches, whether directory or
   not with respect to some node. If the sub tree with respect to that
   node has directories in it then the branches they contain must be deleted befor
   the directory can be. Care is taken to protect against another user appending
   a new branch while deletion is being done by always recycling over the
   whole directory when we return from a lower node.

   The basic operation of the program is to perform its own star_ list as it 
   goes, calling delentry to delete each object.  It keeps rescanning the dir
   (actually just looking at the first object which it then deletes) until the
   dir is empty.

   USAGE:	call del_dir_tree(parent_path_name, entry_dir_name, error_code);


   1. parent_path_name char(*)		path name of the directory whose sub tree structure
   is to be deleted.
   2. entry_dir_name char(*)		entry name of the directory whose sub tree structure
   is to be deleted.
   3. error_code fixed bin(35)		file system error code (Output).


   NOTES:	1. User must have status (to perform the star_ list we simulate
      here) and modify (for later deltion) modes on directory structure.
   2. The directory entry_dir_name is not deleted.

   */

/* Modified 2/85 by Keith Loepere to look for new error codes. */
/* Modified 12/84 by Keith Loepere for relocking strategy. */
/* Modified 6/84 by Keith Loepere to use the new dc_find. */
/* Modified 1/80 by Mike Grady to fix bad error handling code in main loop */
/* Modified 4/77 by M. Weaver to call makeknown_ instead of makeknown */
/* Modified 11/76 by D.Vinograd to add entry retv for use by volume reloader */
/* Modified June 1, 1976 by R. Bratt to call find_$finished when done with ep */
/* Modified 760309 by L. Scheffler to use info-only entries in dire_control_error */
/* Modified July 74 by Kobziar to call new entry in access_mode */
/* Modified by E Stone to delete directories in the subtree without SM access 5/74 */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_retv			bit (1) parameter;

/* External */

dcl  error_table_$argerr		fixed bin (35) ext;
dcl  error_table_$copy_sw_on		fixed bin (35) ext;
dcl  error_table_$fulldir		fixed bin (35) ext;
dcl  error_table_$incorrect_access	fixed bin (35) ext;
dcl  error_table_$moderr		fixed bin (35) ext;
dcl  error_table_$mylock		fixed bin (35) ext;
dcl  error_table_$root		fixed bin (35) ext;
dcl  error_table_$safety_sw_on	fixed bin (35) ext;
dcl  error_table_$vtoce_connection_fail ext fixed bin (35);
dcl  pds$process_group_id		char (32) aligned ext;

/* Entries */

dcl  asd_$add_dentries		entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  delentry$dfile			entry (char (*), char (*), fixed bin (35));
dcl  delentry$retv			entry (char (*), char (*), fixed bin (35));
dcl  lock$dir_unlock		external entry (pointer);
dcl  set$copysw			entry (char (*), char (*), fixed bin (1), fixed bin (35));
dcl  set$safety_sw_path		entry (char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  sum$getbranch_root_my		entry (ptr, bit (36) aligned, ptr, fixed bin (35));

/* Misc */

dcl  (addr, length, ptr, rel, rtrim)	builtin;

dcl  bad_dir_			condition;
dcl  seg_fault_error		condition;

/* Variables */

dcl  code				fixed bin (35);
dcl  1 dir_acl			aligned,
       2 access_name		char (32),
       2 mode			bit (36),
       2 status_code		fixed bin (35);
dcl  dirl				bit (1) aligned;
dcl  dirname			char (168);
dcl  ename			char (32);
dcl  entries_in_dir			fixed bin;
dcl  entries_seen			fixed bin;
dcl  name				char (32);
dcl  nnp				ptr;
dcl  pname			char (168);
dcl  rep				bit (18) aligned;
dcl  retv				bit (1) init ("0"b);
%page;
	goto join;

retv: entry (a_dirname, a_ename, a_code);

	retv = "1"b;
	goto join;


recurse: entry (a_dirname, a_ename, a_retv, a_code);

	retv = a_retv;
join:
	dirl = "0"b;
	code = 0;					/* clear status code */
	dirname = a_dirname;			/* copy arguments */
	ename = a_ename;

	if dirname = ">" then pname = ">" || ename;
	else if ename = "" then pname = dirname;
	else if length (rtrim (dirname)) + 1 + length (rtrim (ename)) > length (pname) then do;
	     code = error_table_$argerr;
	     go to finale;
	end;
	else pname = rtrim (dirname) || ">" || ename;

	if retv then call dc_find$dir_read_priv (pname, dp, code);
	else call dc_find$dir_read (pname, dp, code);	/* get a pointer to dir, check for s (those requiring m check it itself) */
	if code ^= 0 then go to finale;
	dirl = "1"b;

	if ^retv then do;				/* safety switch of directory must be off */
	     call sum$getbranch_root_my (dp, "0"b, ep, code);
	     if code = 0 then do;
		if entry.safety_sw then code = error_table_$safety_sw_on;
		call lock$dir_unlock (ptr (ep, 0));
	     end;
	     else if code = error_table_$mylock then
		if entry.safety_sw then code = error_table_$safety_sw_on;
		else code = 0;
	     else if code = error_table_$root then code = 0;
	     if code ^= 0 then go to finale;
	end;

	on seg_fault_error begin;
		code = error_table_$vtoce_connection_fail;
		goto finale;
	     end;

rescan_dir:
	entries_in_dir = dp -> dir.seg_count + dp -> dir.dir_count + dp -> dir.lcount;
	entries_seen = 0;
	do rep = dp -> dir.entryfrp repeat entry.efrp while (rep);
	     ep = ptr (dp, rep);			/* pick up pointer to entry */
	     entries_seen = entries_seen + 1;
	     if entries_seen > entries_in_dir then signal bad_dir_;
	     if entry.uid = ""b then go to end_loop;
	     if entry.bs then
		if (entry.owner ^= dp -> dir.uid)
		     | (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_;
		else ;
	     else if (link.owner ^= dp -> dir.uid)
		     | (link.type ^= LINK_TYPE) then signal bad_dir_;
	     nnp = ptr (ep, entry.name_frp);
	     if nnp -> names.type ^= NAME_TYPE
		| nnp -> names.owner ^= entry.uid
		| nnp -> names.entry_rp ^= rel (ep) then signal bad_dir_;
	     name = nnp -> names.name;		/* get primary name of entry */
	     if name = "" then signal bad_dir_;
	     call dc_find$finished (dp, dirl);		/* unlock directory (delentry requires it) */
	     dirl = "0"b;
delent:	     if retv then call delentry$retv (pname, name, code);
	     else call delentry$dfile (pname, name, code);/* try to delete this entry */

	     if code = 0 then do;
		if retv then call dc_find$dir_read_priv (pname, dp, code);
		else call dc_find$dir_read (pname, dp, code);	/* get a pointer to dir, check for s (those requiring m check it itself) */
		if code ^= 0 then go to finale;
		dirl = "1"b;
		go to rescan_dir;
	     end;

	     if code = error_table_$safety_sw_on & ^retv then do; /* turn safety switch off */
		call set$safety_sw_path (pname, name, "0"b, code);
		if code = 0 then go to delent;
		else go to finale;			/* we can't continue */
	     end;

	     else if code = error_table_$copy_sw_on & ^retv then do; /* turn copy switch off */
		call set$copysw (pname, name, 0, code);
		if code = 0 then go to delent;
		else go to finale;
	     end;

	     else if code = error_table_$fulldir then do; /* directory has entries */
again:		call recurse (pname, name, retv, code); /* delete all entries in this dir */
		if code = 0 then goto delent;
		else if code = error_table_$incorrect_access | code = error_table_$moderr then do;
						/* try to give user proper access to delete sub-tree */
		     dir_acl.access_name = pds$process_group_id;
		     dir_acl.mode = "111"b;
		     call asd_$add_dentries (pname, name, addr (dir_acl), 1, code);
		     if code = 0 then goto again;
		     else goto finale;
		end;
		else go to finale;
	     end;
	     else go to finale;

end_loop: end;

finale:
	if dirl then call dc_find$finished (dp, DC_FIND_UNLOCK_DIR);
	a_code = code;
	return;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_link;
%page; %include dir_name;
%page; %include fs_types;
     end del_dir_tree;




		    delentry.pl1                    11/11/89  1132.4r w 11/11/89  0800.0      188163



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

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

delentry: proc;

/* modified by Kobziar on 11-15-73 not to require "w" on seg in order to delete */
/* last modified April 1975 by R. Bratt for new RNT/KST system             */
/* last modified Feb. 1976 by R. Bratt for pam flush     */
/* last modified April 20, 1976 by R. Bratt to check mountedness of volume */
/* modified 760324 by L. Scheffler to fix call to dir_control_error to call with dp, not ep */
/* last modified April 24, 1976 by R. Bratt to swallow known_in_other_rings code from makeunknown */
/* last modified June 1, 1976 by R. Bratt to call find_$finished when done   */
/* Modified by D.Vinograd 6/76 to add entry retv, used by volume retriever, which deletes without access checking */
/* Modified 4/77 by M. Weaver to replace makeknown by makeknown_ */
/* Modified April 1979 by D. Spector to remove logging of privileged deletions */
/* Modified June 1981 by J. Bongiovanni to call pathname_am$clear when deleting
      per-process directory */
/* Modified June 30 1981 by M. Pierret to remove access checking for priviledged entry.*/
/* Modified 2/82 BIM for new name of side-door dir unlocker. */
/* Modified 9/83 E. N. Kittlitz to handle makeknown_ returning connection_fail */
/* Modified 6/84 Keith Loepere to use the new dc_find. */
/* Modified 10/84 Keith Loepere for auditing of deletions. */
/* Modified 84-11-27 to change access_audit_ arg lists */
/* Modified 85-04-01 Keith Loepere for new access_audit_check_ep_. */
/* Modified 85-05-08 EJ Sharpe: renamed priv_duid to duid_mdir_priv, added duid_mdir entry */
/* Modified 85-05-15 EJ Sharpe: fix so hpdl can delete master dirs */

/*
   The delentry routine implements the user callable primitives for deleting
   an entry in a directory.

   Entry: delentry$dfile

   This entry deletes the entry designamed by the directory pathname, dirname,
   and the entry name, ename.

   Usage: call delentry$dfile (dirname, ename, code);

   1) dirname (character (168))		parent directory pathname (Input)

   2) ename (character(32)			entryname to be deleted (Input)

   3) code (fixed bin)			return error code (Output)


   Entry: delentry$dseg

   This entry deletes the entry designated by the pointer sp.

   Usage: call delentry$dseg (sp, code);

   1) sp (pointer)				pointer to segment to be deleted (Input)

   2) code (fixed bin)			error code (Output)

   Note:  If the entry is a segment, then the contents of the segment are deleted

   before the entry is deleted.  If it is a directory entry then  an error code is returned and
   del_dir_tree must be called.
   */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_ep				ptr parameter;
dcl  a_sp				ptr parameter;
dcl  a_trp			fixed bin (71) parameter; /* to return time-record product */
dcl  a_uidpath			(0:15) bit (36) aligned parameter;

/* Variables */

dcl  acl_count			fixed bin;
dcl  aclep			ptr;
dcl  areap			ptr;
dcl  asize			fixed bin;
dcl  audit_eventflags		bit (36) aligned;
dcl  code				fixed bin (35);
dcl  damaged			bit (1) init ("0"b);/* TRUE if dir uid is 0 */
dcl  dirl				bit (1) init ("0"b);
dcl  dirname			char (168);
dcl  e_sw				fixed bin;
dcl  ename			char (32);
dcl  ignore			fixed bin (35);
dcl  1 mk_info			aligned like makeknown_info;
dcl  mkunk_uid			bit (36) aligned init ("0"b);
dcl  ncnt				fixed bin;
dcl  nnames			fixed bin (18);
dcl  nrp				bit (18) aligned;
dcl  onp				ptr;
dcl  priv_entry			bit (1) init ("0"b);
dcl  pvid				bit (36) aligned;
dcl  1 qcell			like quota_cell aligned automatic;
dcl  ring				fixed bin;
dcl  seg_uid			bit (36) aligned;
dcl  segl				bit (1) init ("0"b);
dcl  segno			fixed bin;
dcl  segptr			ptr init (null);
dcl  sp				ptr;
dcl  trp				fixed bin (71);
dcl  type				fixed bin;
dcl  uidpath			(0:15) bit (36) aligned;
dcl  vtocx			fixed bin;

/* Constants */

dcl  directory			init (2) fixed bin static;
dcl  link_br			init (0) fixed bin static;
dcl  file				init (0) fixed bin static;
dcl  read_lock			bit (36) aligned init ("0"b);
dcl  retv				init (3) fixed bin static;
dcl  seg				init (1) fixed bin static;
dcl  segment			init (1) fixed bin static;
dcl  uid_mdir			init (2) fixed bin static;

/* External */

dcl  active_hardcore_data$ensize	fixed bin external;
dcl  active_hardcore_data$esize	fixed bin external;
dcl  error_table_$copy_sw_on		fixed bin (35) external;
dcl  error_table_$dirseg		fixed bin (35) external;
dcl  error_table_$fulldir		fixed bin (35) external;
dcl  error_table_$infcnt_non_zero	fixed bin (35) external;
dcl  error_table_$invalidsegno	fixed bin (35) external;
dcl  error_table_$known_in_other_rings	fixed bin (35) external;
dcl  error_table_$lower_ring		fixed bin (35) external;
dcl  error_table_$master_dir		fixed bin (35) external;
dcl  error_table_$safety_sw_on	fixed bin (35) external;
dcl  error_table_$seg_unknown		fixed bin (35) external;
dcl  error_table_$segknown		fixed bin (35) external;
dcl  error_table_$vtoce_connection_fail fixed bin (35) external; ;
dcl  pds$access_authorization		bit (72) aligned external;
dcl  pds$process_group_id		char (24) ext;
dcl  pds$processid			bit (36) aligned ext;

/* Entries */

dcl  acc_name_$delete		entry (ptr);
dcl  access_audit_check_ep_$self	entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1));
dcl  access_audit_$log_entry_ptr	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), char (*));
dcl  acl_$del_acl			entry (fixed bin, bit (36) aligned, ptr);
dcl  aim_check_$equal		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  delete_vtoce			entry (ptr, fixed bin (35));
dcl  fs_alloc$free			entry (ptr, fixed bin, ptr);
dcl  hash$out			entry (ptr, ptr, ptr, fixed bin (35));
dcl  level$get			entry returns (fixed bin);
dcl  lock$dir_lock_write		entry (ptr, fixed bin (35));
dcl  lock$dir_unlock		entry (ptr);
dcl  lock$dir_unlock_given_uid	entry (bit (36) aligned);
dcl  makeknown_			entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  makeunknown_			entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  mountedp			entry (bit (36) aligned) returns (fixed bin (35));
dcl  pathname_am$clear		entry (fixed bin (17));
dcl  pathname_am$flush		entry (bit (36) aligned);
dcl  sum$dirmod			entry (ptr);
dcl  syserr			entry options (variable);
dcl  syserr$error_code		entry options (variable);
dcl  terminate_$id			entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  vtoc_attributes$get_quota	entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin, fixed bin (35));

/* Misc */

dcl  (addr, fixed, ptr, rel, null, baseptr, unspec) builtin;

dcl  bad_dir_			condition;
dcl  seg_fault_error		condition;
%page;
salv_delete_branch: entry (a_ep, a_code);		/* Make branch go awayy */

	ep = a_ep;
	dp = ptr (ep, 0);
	dirl = "0"b;				/* Don't unlock dir */
	code = 0;
	damaged = "1"b;				/* Couldnt get inferior dir */
	segptr = null;				/* didn't touch inferior */
	segl = "0"b;				/* or lock it */
	if ^entry.bs then type = link_br;
	else if entry.dirsw then type = directory;
	else type = segment;
	go to remove;				/* Remove the branch */

retv: entry (a_dirname, a_ename, a_code);

	e_sw = retv;
	goto set_code;


priv_dfile: entry (a_dirname, a_ename, a_code);
	priv_entry = "1"b;

dfile: entry (a_dirname, a_ename, a_code);
	e_sw = file;				/* indicate through which entry point entered */

set_code: code = 0;					/* clear return status code */
	dirname = a_dirname;			/* copy arguments */
	ename = a_ename;

	if e_sw ^= retv & ^priv_entry then call dc_find$obj_delete (dirname, ename, DC_FIND_NO_CHASE, ep, code);
	else call dc_find$obj_delete_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code); /* get ptr to entry + lock dir for writing */
	if code ^= 0 then go to ret;
	go to common;


dseg: entry (a_sp, a_code);

	code = 0;					/* clear return status code */
	e_sw = seg;				/* indicate through entry point we entered */
	sp = a_sp;				/* copy arg */
	call dc_find$obj_delete_ptr (sp, ep, code);	/* get ptr to entry + lock for write */
	if code ^= 0 then go to ret;
	go to common;

duid_mdir_priv: entry (a_uidpath, a_trp, a_code);		/* entry to delete given uidpathname */

	e_sw = uid_mdir;				/* name type entry */
	uidpath = a_uidpath;			/* copy path */
	call dc_find$obj_delete_priv_uid (uidpath, dirname, ename, ep, code); /* find the thing */
	if code ^= 0 then go to ret;
	priv_entry = "1"b;
	trp = 0;
	goto common;

duid_mdir: entry (a_uidpath, a_trp, a_code);		/* entry to delete given uidpathname */

	e_sw = uid_mdir;				/* name type entry */
	uidpath = a_uidpath;			/* copy path */
	call dc_find$obj_delete_uid (uidpath, dirname, ename, ep, code); /* find the thing */
	if code ^= 0 then go to ret;
	trp = 0;

common:
	dp = ptr (ep, 0);
	dirl = "1"b;
	if ^ep -> entry.bs then do;			/* link case */
	     type = link_br;			/* set type of entry */
	     go to remove;
	end;
	else if ^ep -> entry.dirsw then type = segment;	/* non-directory branch */
	else type = directory;			/* directory branch */

	if e_sw ^= retv & ^priv_entry then do;
	     ring = level$get ();			/* get validation level */
	     if (type = segment & ring > fixed (ep -> entry.ring_brackets (1), 3)) |
		(type ^= segment & ring > fixed (ep -> entry.ex_ring_brackets (1), 3)) then do;
		code = error_table_$lower_ring;	/* ringbrackets must be consistent with validation level */
		go to finale;
	     end;

	     if entry.copysw then do;			/* branch cannot be deleted if copy on */
		code = error_table_$copy_sw_on;
		go to finale;
	     end;
	     if entry.safety_sw then do;		/* branch may not be deleted if safety switch on */
		code = error_table_$safety_sw_on;
		go to finale;
	     end;
	end;
						/* If ename is a directory branch, be sure there are */
	if type = directory then do;			/* no entries in that directory before deleting it */
	     if e_sw = seg then do;			/* Forbid use of ptr entry */
		code = error_table_$dirseg;
		go to finale;
	     end;
	     seg_uid = entry.uid;			/* Make sure nobody deletes it */
	     segptr = null;
	     on seg_fault_error begin;
		damaged = "1"b;
		goto dir_glop;
	     end;
	     unspec (mk_info) = "0"b;
	     mk_info.uid = seg_uid;
	     mk_info.entryp = ep;
	     mk_info.dirsw = "1"b;
	     mk_info.allow_write = "1"b;
	     mk_info.activate = "1"b;
	     call makeknown_ (addr (mk_info), segno, (0), code);
	     if code = 0 | code = error_table_$segknown then
		segptr = baseptr (segno);
	     else if code = error_table_$vtoce_connection_fail then damaged = "1"b;
	     else goto finale;
	     call dc_find$finished (dp, "1"b);		/* unlock and unreference (initiated dir will hold parent) - allows seg_fault to work */
	     dirl = "0"b;
	     if damaged then goto dir_glop;		/* skip segfault on next statement */

	     if segptr -> dir.uid = "0"b then do;	/* If the directory's UID is 0 we cant lock it */
		call syserr (4, "delentry: deleting damaged dir ^a>^a for ^a",
		     dirname, ename, pds$process_group_id);
		damaged = "1"b;			/* .. but then, nobody else can either */
	     end;
	     else do;
		call lock$dir_lock_write (segptr, code);/* Lock the dir to be deleted */
		if code ^= 0 then go to finale;
		segl = "1"b;
	     end;
dir_glop:	     revert seg_fault_error;
	     if e_sw = seg then call dc_find$obj_delete_ptr (sp, ep, code); /* refind dir */
	     else if e_sw = retv | priv_entry then call dc_find$obj_delete_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code);
	     else call dc_find$obj_delete (dirname, ename, DC_FIND_NO_CHASE, ep, code);
	     if code ^= 0 then do;
		if segptr ^= null then do;
		     call lock$dir_unlock (segptr);	/* Gack. How does this happen */
		     call makeunknown_ (segno, "0"b, ("0"b), ignore); /* .. ayway cleanup */
		end;
		go to ret;
	     end;
	     dp = ptr (ep, 0);			/* Regenerate dp just in case */
	     dirl = "1"b;
	     if seg_uid ^= entry.uid then do;		/* Check that our access check above .. */
		code = error_table_$invalidsegno;	/* .. hasn't been interfered with */
		go to finale;			/* nasty */
	     end;
	     if ^damaged then do;			/* Various validity checks. skip for bad dir */
		if segptr -> dir.master_dir then
		     if e_sw ^= uid_mdir & ^priv_entry then do;
			code = error_table_$master_dir; /* Do not delete master directory */
			go to finale;
		     end;
		if segptr -> dir.seg_count ^= 0	/* check if directory has any branches */
		     | segptr -> dir.dir_count ^= 0
		     | segptr -> dir.lcount ^= 0 then do;

		     code = error_table_$fulldir;
		     if /* tree */ ^aim_check_$equal (pds$access_authorization, segptr -> dir.access_class) then /* audit possible covert channel */
			if ^addr (pds$access_authorization) -> aim_template.privileges.dir then do;
			     audit_eventflags = "0"b;
			     addr (audit_eventflags) -> audit_event_flags.cc_10_100 = "1"b;
			     if access_audit_check_ep_$self (audit_eventflags, access_operations_$fs_obj_delete, ep) then
				call access_audit_$log_entry_ptr
				     ("delentry", level$get (), audit_eventflags, access_operations_$fs_obj_delete, ep, code, null, 0, "");
			end;
		     go to finale;
		end;
		if e_sw = uid_mdir then do;		/* caller wants a time record product */
		     pvid = entry.pvid;
		     vtocx = entry.vtocx;
		     qcp = addr (qcell);
		     call vtoc_attributes$get_quota (seg_uid, pvid, vtocx, qcp, 0, code);
		     if code = 0 then trp = quota_cell.trp; /* save it if i got it */
		end;
	     end;
	end;



/* Everything AOK. Remove segment and branch and go to finale. */

	if type ^= link_br then do;
	     if priv_entry | type = directory then code = 0; /* only check if unpriv or segment */
	     else code = mountedp (dir.sons_lvid);
	     if code = 0 then do;
		call delete_vtoce (ep, code);
		if code ^= 0 then call syserr$error_code (LOG, code, "delentry: failed to delete_vtoce for ^w ^o.", ep -> entry.pvid, ep -> entry.vtocx);
	     end;
	     if code ^= 0 then			/* error from delete_vtoce prob volume not up */
		if ^priv_entry | code = error_table_$infcnt_non_zero then /* unprivileged attempt or dir contains known inferior segments */
		     go to finale;			/* leave branch intact and return error code */
						/*		else call syserr$error_code (4, code,
						   "delentry: priv_dfile error deleting vtoce for ^a>^a for ^a",
						   dirname, ename, pds$process_group_id);
						   -- Priv deletions used to be logged */
	end;

remove:
	dir.modify = pds$processid;			/* mark dir unstable */
	nrp = entry.name_brp;			/* get rp to last name */
	areap = ptr (dp, dir.arearp);			/* get ptr to area */
	nnames = fixed (entry.nnames, 18);		/* pick up count of names */
	ncnt = 0;

name_loop:
	ncnt = ncnt + 1;				/* keep track of number of names deleted */
	if ncnt > nnames then signal bad_dir_;		/* too many times through the loop */
	np = ptr (dp, nrp);				/* get ptr to name entry to be removed */
	if np -> names.type ^= NAME_TYPE
	     | np -> names.owner ^= entry.uid
	     | np -> names.entry_rp ^= rel (ep) then signal bad_dir_;
	call hash$out (dp, addr (np -> names.name), onp, code); /* remove name from hash table */
	if code ^= 0 then call syserr$error_code (4, code, "delentry: error from hash$out on ""^a"" for ^a",
		np -> names.name, pds$process_group_id);

	if np ^= onp then signal bad_dir_;		/* check that hash table entry and name entry are consistent */

	nrp = np -> names.bp;			/* get rp to previous name on list */
	if nrp then do;				/* if not primary name stored in the entry */
	     entry.name_brp = nrp;			/* thread name list to entry */
	     call fs_alloc$free (areap, active_hardcore_data$ensize, np); /* free name entry */
	     go to name_loop;			/* continue removing names */
	end;
	entry.name_frp, entry.name_brp = "0"b;		/* clear name threads */
	entry.nnames = 0;				/* zero name count */

	if type ^= link_br then do;			/* in the branch case free the storage of the acl */
	     aclep = addr (entry.acl_frp);		/* get pointer to start of acl */
	     acl_count = fixed (entry.acle_count, 18);	/* get count of acls assoc with this entry */
	     call acl_$del_acl (acl_count, entry.uid, aclep); /* remove entire acl */

	     dir.acle_total =			/* decrease count of acl entries in dir header */
		dir.acle_total - acl_count;

	     entry.acl_frp, entry.acl_brp = "0"b;	/* zero out acl threads */
	     entry.acle_count = 0;			/* zero out acl count in entry */

	     asize = active_hardcore_data$esize;	/* size of area to be freed is entry size */
						/* delete bc author and update pers and proj name lists */
	     call acc_name_$delete (addr (entry.bc_author));

	     mkunk_uid = entry.uid;			/* get it unknown later */
	     segptr = null;
	end;
	else do;					/* in link case set pathname size to zero */
	     ep -> link.pathname_size = 0;
	     asize = ep -> link.size;			/* pick up number of words in link entry (for freeing) */
	end;

	call acc_name_$delete (addr (entry.author));	/* delete author and update pers and proj name lists */

	if entry.ebrp then ptr (ep, entry.ebrp) -> entry.efrp = entry.efrp; /* unthread the entry */
	if entry.efrp then ptr (ep, entry.efrp) -> entry.ebrp = entry.ebrp;
	if rel (ep) = dir.entrybrp then dir.entrybrp = entry.ebrp;
	if rel (ep) = dir.entryfrp then dir.entryfrp = entry.efrp;
	entry.ebrp, entry.efrp = "0"b;
	if type = link_br then dir.lcount = dir.lcount - 1; /* fix seg, dir, or link_br count in dir */
	else if type = segment then dir.seg_count = dir.seg_count - 1;
	else dir.dir_count = dir.dir_count - 1;
	entry.uid = "0"b;				/* clear uid */
	entry.pvid = "0"b;
	call fs_alloc$free (areap, asize, ep);		/* free the entry */
	if type = directory & ^damaged then do;
	     if ^entry.per_process_sw then call pathname_am$flush (mkunk_uid);
	     else call pathname_am$clear (segno);
	     call lock$dir_unlock_given_uid (seg_uid);
	     segl = "0"b;
	end;
	if dirl then dir.modify = "0"b;		/* If we locked dir, mark as ok now. */
	call sum$dirmod (dp);


finale:
	if segl then call lock$dir_unlock_given_uid (seg_uid); /* may not be all there */
	if dirl then do;
	     dir.modify = "0"b;
	     if e_sw ^= seg then call dc_find$finished (dp, "1"b);
	     else call lock$dir_unlock (dp);
						/* dont touch lot unless we locked dir */
	     if segptr ^= null then call makeunknown_ (segno, "0"b, ("0"b), ignore); /* implies dir */
	     else if mkunk_uid ^= "0"b then do;
		call terminate_$id (mkunk_uid, 0, code);
		if code ^= 0 then if code = error_table_$seg_unknown
			| code = error_table_$invalidsegno
			| code = error_table_$known_in_other_rings then code = 0;
		     else call syserr$error_code (4, code, "delentry: error from terminate_ for ^a", pds$process_group_id);
	     end;
	end;
	if e_sw = uid_mdir then a_trp = trp;
ret:
	a_code = code;
	return;

/* format: off */

%page; %include access_audit_eventflags;
%page; %include aim_template;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_link;
%page; %include dir_name;
%page; %include fs_obj_access_codes;
%page; %include fs_types;
%page; %include makeknown_info;
%page; %include quota_cell;
%page; %include syserr_constants;
%page;
/* format: on */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   delentry: deleting damaged dir PATH for USERID

   S:	$log

   T:	$run

   M:	An attempt to delete a directory
   found that the directory header had a zero UID.
   The directory was deleted anyway.

   A:	$ignore

   Message:
   delentry: priv_dfile error deleting vtoce for PATH for USERID. ERROR_CODE

   S:	$log

   T:	$run

   M:	A privileged call to delete a segment
   discovered a branch with not VTOC entry.
   This situation is called a "connection failure."
   The branch was deleted anyway.

   A:	$ignore

   Message:
   delentry: error from hash$out on "NAME" for USERID. ERROR_CODE

   S:	$log

   T:	$run

   M:	An attempt to delete the entry name NAME from the directory
   hash table failed.
   $err

   A:	$ignore

   Message:
   delentry: error from terminate_ for USERID. ERROR_CODE

   S:	$log

   T:	$run

   M:	An error code was returned while trying to
   make a directory unknown
   while deleting it.
   $err

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end delentry;




		    demand_deactivate.pl1           11/11/89  1132.4r w 11/11/89  0800.4       33534



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


/* format: style4 */
demand_deactivate: proc (a_segptr, a_code);

/* Written March 30, 1976 by R. Bratt

   This module allows priveleged users to deactivate a segment if certain
   conditions obtain. These conditions are:
   *	the segment must be known in the calling process
   *	the segment must be active
   *	all users who have connected to the aste must have specified explicit_deact_ok,
   *         or this is force entry
   *	the aste must be deactivateable

   Modified for external static SST, 04/19/81, W. Olin Sibert
   Modified for $force entrypoint, 04/21/81, WOS
   Modified for $force_given_segno entrypoint, 02/28/82, J. Bongiovanni
   Modified to lock ast on search, 05/30/83, E. N. Kittlitz
   Modified to respect threaded-out-ness, 84-01-08 BIM.
*/

dcl  a_segptr ptr parameter;
dcl  a_seg_uid bit (36) aligned parameter;
dcl  a_code fixed bin (35) parameter;

dcl  segno fixed bin (17);
dcl  code fixed bin (35);
dcl  uid bit (36) aligned;
dcl  force_sw bit (1) aligned;

dcl  sst$demand_deact_attempts fixed bin (35) external static;
dcl  sst$demand_deactivations fixed bin (35) external static;

dcl  deactivate entry (ptr, fixed bin (35));
dcl  get_kstep entry (fixed bin, pointer, fixed bin (35));
dcl  lock$lock_ast entry ();
dcl  lock$unlock_ast entry ();
dcl  search_ast entry (bit (36) aligned) returns (pointer);

dcl  error_table_$illegal_deactivation fixed bin(35) ext static;

dcl  (baseno, binary, null) builtin;

%page;

	force_sw = "0"b;				/* Don't, unless we're allowed to */
	goto FIND_UID;


demand_deactivate$force_given_segno:
     entry (a_segptr, a_code);

	force_sw = "1"b;

FIND_UID:
	segno = binary (baseno (a_segptr), 18);		/* Find the UID for the segment */

	call get_kstep (segno, kstep, code);
	if code ^= 0 then do;			/* Bad segno, or something */
	     a_code = code;
	     return;
	end;

	uid = kste.uid;
	goto COMMON;


demand_deactivate$force: entry (a_seg_uid, a_code);	/* Deactivate by UID, rather than segno, and force */

	uid = a_seg_uid;
	force_sw = "1"b;				/* Deactivate, if at all possible */


COMMON:	code = 0;					/* Assume success */
	sst$demand_deact_attempts = sst$demand_deact_attempts + 1;
	call lock$lock_ast ();

/* we don't go to the expense of deriving pvid, vtocx. If we have a double-uid,
   we'll either find the right segment active, or we'll harrass the other segment
   with the same uid.  In either case, the segment we want will end up inactive, if possible. */

	astep = search_ast (uid);
	if astep ^= null () then
	     if force_sw | aste.explicit_deact_ok then do;/* We're allowed to try it */
		if (astep -> aste.fp | astep -> aste.bp) = ""b
		then do;
		     code = error_table_$illegal_deactivation;
		     go to RETURN;
		end;
		call deactivate (astep, code);	/* See what happens */

		if code = 0 then sst$demand_deactivations = sst$demand_deactivations + 1;
	     end;					/* Record successes */
RETURN:
	call lock$unlock_ast ();
	a_code = code;
	return;

/*format: off */
%page; %include aste;
%page; %include kst;

     end demand_deactivate;




		    fs_get.pl1                      08/21/90  1511.9rew 08/21/90  1449.2      125451



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-08-08,GDixon), approve(86-08-08,MCR7388),
     audit(86-09-02,Farley), install(86-09-08,MR12.0-1150):
     Remove the include of kst.incl.pl1, since reference to variables in the
     program was removed in an early release.
  2) change(86-08-20,Lippard), approve(86-09-08,MCR7539),
     audit(86-10-15,Farley), install(86-10-20,MR12.0-1189):
     Modified by Jim Lippard to fix ref names allocation bug, fix supplied
     by Steve Harris (UNCA).
  3) change(90-07-26,WAAnderson), approve(90-07-26,MCR8182),
     audit(90-08-10,Schroth), install(90-08-21,MR12.4-1030):
     Replaced call to ref_name_$get_refnames with call to
     ref_name_$get_refname.  This change reduces stack space requirements
     and corrects the list_ref_names infinite loop bug.
                                                   END HISTORY COMMENTS */


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

fs_get: proc;

/*	Modified 03/05/85 by Melanie Weaver to remove entry label  $call_name */
/*	Modified 02/25/85 by Keith Loepere to use dc_find for name lookup check for path_name. */
/*	Modified 10/16/84 by Keith Loepere to use dc_find for access computations. */
/*	Modified 7/17/84 by Keith Loepere to use the new dc_find. */
/*	Modified 5/17/83 by E. N. Kittlitz to decrement ref on get_link_target.
/*	Modified 1/3/83 by Jay Pattin to add access_modes entry */
/*	Modified 01/15/79 by C. D. Tavares to compute access correctly w.r.t. dir extended ring brackets */
/* 	Modified March 1977 by M. Weaver to get rntp from stack */
/*	Modified March 1976 by R. Bratt for initiated_mode and to fix get_search_rules bug */
/*	Modified April 1975 by E. Stone to put access info in kst */
/*	Modified April 1975 by R. Bratt for new kst */
/*	Modified  Feb 1975 by R. Bratt to use get_pathname_ */
/* 	Modified by Kobziar July 74 to call appropriate entry point in access_mode */
/*
   -- ->  fs_get$brackets returns the mode and ring brackets of the current
   user for the segment specified by segptr.

   USAGE: call fs_get$brackets (segptr, mode, rings, code);

   1) segptr ptr - - - pointer to segment
   2) mode fixed bin(5) - - - mode of user (output)
   3) rings (3) fixed bin(6) - - - ring brackets of user (output)
   4) code fixed bin - - - error code (output)

   -- ->  fs_get$ex_mode_name returns the mode, brackets, extended access, and
   primary name of a segment for the current user.

   USAGE: call fs_get$ex_mode_name(segptr,mode,rings,ex_mode,name,code);

   4) ex_mode is the extended access mode.

   5) name is the primary name of the segment.

   All other arguments same as fs_get$brackets.

   -- ->  fs_get$mode returns the mode of the current user at the current
   validation level for the segment specified by segptr.

   USAGE: call fs_get$mode (segptr, mode, code);

   The arguments are the same as for fs_get$brackets.

   -- ->  fs_get$access_modes returns both mode and extended modes.

   USAGE:  call fs_get$access_modes (segptr, mode, exmodes, code);

   -- ->  fs_get$segptr returns a pointer to a segment given its reference name.

   USAGE: call fs_get$segptr (refname, segptr, code);

   1) refname char(*) - - - refernce name of segment
   2) segptr ptr - - - pointer to segment (output)
   3) code fixed bin - - - error code (output)

   -- ->  fs_get$search_rules  returns in a space provided by the user a list of
   of the search rules currently in use by the user for his validation level.

   USAGE:call fs_get$search_rules (search_rules_ptr);

   1) search_rules_ptr ptr - - - is a pointer to the space where the list of names will be stored.

   The names are stored in a structure of the form:

   dcl 1 ret_struc aligned,
   2 num fixed bin,	number of rules
   2 names(21) char(168) aligned;


   -- ->  fs_get$path_name returns the pathname of the directory immediately superior
   to, and the entry name of the segment specified by segptr.

   USAGE: call fs_get$path_name (segptr, dirname, lnd, ename, code);

   1) segptr ptr - - - pointer to the segment
   2) dirname char(168) - - - pathname of superior directory (output)
   3) lnd fixed bin - - - number of significant chars in pathname (output)
   4) ename char(32) - - - entry name of segment (output)
   5) code fixed bin - - - error code (output)

   -- ->  fs_get$dir_name returns the pathname of the directory immediatetly superior
   to the segment specified by segptr.

   USAGE: call fs_get$dir_name (segptr, dirname, lnd, code);

   The arguments are the same as fs_get$path_name.

   -- ->  fs_get$ref_name returns the reference name corresponding to namecnt for
   the segment specified by segptr.

   USAGE: call fs_get$ref_name (segptr, namecnt, refname, code);

   1) segptr ptr - - - pointer to the segment
   2) namecnt fixed bin(17) - - - number of the reference name desired
   3) refname char(*) - - - reference name (output)
   4) code fixed bin - - - error code (output)

   -- ->  fs_get$trans_sw returns the current value of the transparent usage/modification
   switch and sets it to a new value.

   USAGE: call fs_get$trans_sw (newsw, oldsw)

   1) newsw fixed bin - - - new value for switch, if > 3, don't set switch
   2) oldsw fixed bin - - - old value of switch (output)

   */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_ex_mode			bit (*) parameter;	/* extended access  bits EX ACC */
dcl  a_ex_modes			bit (36) aligned parameter;
dcl  a_ldir			char (*) parameter;
dcl  a_lentry			char (*) parameter;
dcl  a_lnd			fixed bin (17) parameter;
dcl  a_mode			fixed bin (5) parameter;
dcl  a_name			char (*) parameter; /* name of segment EX ACC */
dcl  a_namecnt			fixed bin (17) parameter;
dcl  a_new_mode			bit (36) aligned parameter;
dcl  a_newsw			fixed bin (17) parameter;
dcl  a_oldsw			fixed bin (17) parameter;
dcl  a_ptr			ptr parameter;
dcl  a_refname			char (*) parameter;
dcl  a_rings			(3) fixed bin (3) parameter;
dcl  a_rname			char (*) parameter;
dcl  a_segptr			ptr parameter;

/* Constants */

dcl  access_modes			fixed bin static options (constant) init (5);
dcl  brackets			fixed bin static options (constant) init (3);
dcl  ex_mode_name			fixed bin static options (constant) init (4);
dcl  just_mode			fixed bin static options (constant) init (0);

/* Variables */

dcl  aptr				ptr;
dcl  code				fixed bin (35);
dcl  dirsw			bit (1) aligned;
dcl  dlen				fixed bin (17);
dcl  end_rule			fixed bin (17);
dcl  entry_point			fixed bin;
dcl  extended_mode			bit (36) aligned;
dcl  i				fixed bin;
dcl  l				fixed bin;
dcl  ldir				char (168);
dcl  lentry			char (32);
dcl  mode				bit (36) aligned;
dcl  namecnt			fixed bin (17);
dcl  newsw			fixed bin (17);
dcl  oldsw			fixed bin (17);
dcl  pathname			char (201) varying;
dcl  rb				(3) fixed bin (3);
dcl  return_ename			bit (1) aligned;
dcl  ring				fixed bin;
dcl  rname			char (32) varying;
dcl  segnum			fixed bin (17);
dcl  segptr			ptr;
dcl  srpp				ptr;

/* Based */

dcl  1 ret_struc			based aligned,
       2 num			fixed bin,
       2 names			(21) char (168);

dcl  1 sr				(22) based aligned,
       2 segno			fixed bin (17) unaligned,
       2 offset			fixed bin (17) unaligned,
       2 uid			bit (36);

/* External */

dcl  error_table_$dirseg		fixed bin (35) external;
dcl  error_table_$noentry		fixed bin (35) external;
dcl  error_table_$root		fixed bin (35) external;
dcl  pds$stacks			(0:7) ptr external;
dcl  pds$transparent		bit (2) external aligned;

/* Entries */

dcl  get_pathname_			entry (fixed bin (17), char (*) varying, fixed bin (35));
dcl  level$get			entry returns (fixed bin);
dcl  ref_name_$get_refname		entry (fixed bin (17), fixed bin (17), char (*) varying, fixed bin (35));
dcl  ref_name_$get_segno		entry (char (32) varying, fixed bin (17), fixed bin (35));

/* Misc */

dcl  (baseno, baseptr, binary, fixed, hbound, index, lbound, length, max, null, reverse, segno, substr) builtin;
%page;
mode: entry (a_segptr, a_mode, a_code);

	entry_point = just_mode;			/* Set entry switch */
	go to join_mode;

brackets: entry (a_segptr, a_mode, a_rings, a_code);

	entry_point = brackets;			/* Set entry switch */
	go to join_mode;

access_modes:
     entry (a_segptr, a_new_mode, a_ex_modes, a_code);	/* new_mode because has correct dcl */

	entry_point = access_modes;			/* Set entry switch */
	go to join_mode;

ex_mode_name:
     entry (a_segptr, a_mode, a_rings, a_ex_mode, a_name, a_code); /* extended acess entry EX ACC */

	entry_point = ex_mode_name;			/* set entry switch EX ACC */
join_mode:
	segptr = a_segptr;				/* copy arg */

	call dc_find$obj_modes_ptr (segptr, mode, extended_mode, rb, code);
	if code ^= 0 then
	     if code = error_table_$dirseg then do;
		code = 0;
		dirsw = "1"b;
	     end;
	     else go to err0;
	else dirsw = "0"b;

	if (entry_point = brackets) | (entry_point = ex_mode_name) then do;
	     a_rings = rb;
	     if entry_point = ex_mode_name then do;
		a_ex_mode = extended_mode;
		a_name = "";
	     end;
	end;
	if entry_point = access_modes then do;
	     if dirsw then code = error_table_$dirseg;
	     else do;
		a_new_mode = mode;
		a_ex_modes = extended_mode;
	     end;
	end;
	else do;
	     if dirsw then mode = substr (mode, 1, 1) || "1"b || substr (mode, 2, 2);
	     a_mode = fixed (substr (mode, 1, 4), 5);
	end;

err0:
	a_code = code;
	return;
%page;

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

seg_ptr: entry (a_rname, a_segptr, a_code);

	call ref_name_$get_segno ((a_rname), segnum, code);
	if code = 0 then a_segptr = baseptr (segnum);
	else a_segptr = null ();
	a_code = code;
	return;

/* * * * * * * * * * * * * * * * * * * * */
search_rules: entry (a_ptr);

	aptr = a_ptr;				/* copy arg */
	ring = level$get ();
	rntp = pds$stacks (ring) -> stack_header.rnt_ptr;
	srpp = rntp -> rnt.srulep;
	end_rule = binary (END_RULE);			/* pull computation out of loop */
	do i = lbound (srpp -> sr, 1) to hbound (srpp -> sr, 1) while (srpp -> sr (i).offset ^= end_rule); /* now get the search rule names */
	     if srpp -> sr (i).offset ^= 0 then aptr -> ret_struc.names (i) = search_rule_names (srpp -> sr (i).offset);
	     else do;
		segnum = srpp -> sr (i).segno;
		segptr = baseptr (segnum);
		call dc_find$obj_existence_ptr (segptr, ep, code);
		if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer";
		else do;
		     call get_pathname_ (segnum, pathname, code);
		     if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer";
		     else aptr -> ret_struc.names (i) = pathname; /* copy name */
		     call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
		end;
	     end;
	end;
	aptr -> ret_struc.num = i - 1;
	return;

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

get_link_target:
     entry (a_ldir, a_lentry, a_dirname, a_ename, a_code);

	ldir = a_ldir;				/* copy input arguments */
	lentry = a_lentry;

	a_dirname = "";				/* set default values for return arguments */
	a_ename = "";

	call dc_find$link_target (ldir, lentry, code);

	if code = 0 | code = error_table_$noentry then do;
	     a_dirname = ldir;
	     a_ename = lentry;
	end;

	a_code = code;
	return;

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

path_name: entry (a_segptr, a_dirname, a_lnd, a_ename, a_code);
	return_ename = "1"b;
	goto name_join;

dir_name: entry (a_segptr, a_dirname, a_lnd, a_code);
	return_ename = "0"b;

name_join:
	code = 0;
	segptr = a_segptr;
	call dc_find$obj_existence_ptr (segptr, ep, code);
	if code = 0 then do;
	     call get_pathname_ (segno (segptr), pathname, code);
	     call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
	end;
	else if code = error_table_$root then do;
	     code = 0;
	     pathname = ">";
	end;
	else goto name_return;

	i = index (reverse (pathname), ">");
	l = length (pathname);
	dlen = max (l - i, 1);
	if return_ename then if dlen = 1 then dlen = 0;
	a_dirname = substr (pathname, 1, dlen);
	a_lnd = dlen;
	if return_ename then a_ename = substr (pathname, l + 2 - i, i - 1);
name_return:
	a_code = code;
	return;

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

ref_name: entry (a_segptr, a_namecnt, a_refname, a_code);

          namecnt = max(a_namecnt, 1);

          segnum = fixed (baseno (a_segptr), 17);
          call ref_name_$get_refname (segnum, namecnt, rname, code);
	if code = 0 then do;
	   a_refname = rname;
	   a_code = 0;
	end;
	else a_code = code;

	return;

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

trans_sw: entry (a_newsw, a_oldsw);

	newsw = a_newsw;
	oldsw = fixed (pds$transparent, 2);
	if newsw > 3 then go to fin2;			/* newsw > 3 means only go to fin2 oldsw, don't change newsw */
	if newsw < 0 then go to fin2;
	if newsw = 0 then pds$transparent = "0"b;
	else if newsw = 1 then pds$transparent = "01"b;
	else pds$transparent = "11"b;			/* can't have modified transparent without used */

fin2:	a_oldsw = oldsw;
	return;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_name;
%page; %include fs_types;
%page; %include rnt;
%page; %include sdw;
%page; %include search_rule_flags;
%page; %include stack_header;
     end fs_get;




		    fs_move.pl1                     11/11/89  1132.4rew 11/11/89  0800.4       76005



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


/* format: style4 */
fs_move: proc;

/* Modified by E. Stone 8/73  to convert to version 2 and to check the max length of the TO segment */
/* Modified January 1983 by Keith Loepere so as to truncate target AFTER
   all validations */
/* Modified February 1983 by E. N. Kittlitz for 256K segments */
/* Modified November 1984 by Keith Loepere to rename terminate to terminate_ */

ffile: entry (a_dirname_from, a_ename_from, a_sw, a_dirname_to, a_ename_to, a_code);

dcl  a_dirname_from char (*);
dcl  a_dirname_to char (*);
dcl  a_ename_from char (*);
dcl  a_ename_to char (*);
dcl  a_sw fixed bin (2);
dcl  a_code fixed bin (35);

dcl  created_seg bit (1) aligned;
dcl  dirname_from char (168);
dcl  dirname_to char (168);
dcl  ename_from char (32);
dcl  ename_to char (32);
dcl  curlen fixed bin;
dcl  ldirname_from fixed bin;
dcl  ldirname_to fixed bin;
dcl  target_len bit (12);
dcl  entry_point fixed bin;
dcl  options bit (2) unaligned;
dcl  append_sw bit (1) unaligned def (options) pos (1);
dcl  truncate_sw bit (1) unaligned def (options) pos (2);
dcl  max_length fixed bin (19);
dcl  words fixed bin (19);
dcl  tcode fixed bin (35);
dcl  code fixed bin (35);
dcl  ptr_from ptr;
dcl  ptr_to ptr;
dcl  dptr ptr;

dcl  copy (words) bit (36) aligned based;

dcl  file fixed bin static init (0) options (constant);
dcl  seg fixed bin static init (1) options (constant);

dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$segknown fixed bin (35) ext static;
dcl  error_table_$clnzero fixed bin (35) ext static;
dcl  error_table_$no_s_permission fixed bin (35) ext static;
dcl  error_table_$no_move fixed bin (35) external;

dcl  append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35));
dcl  fs_get$path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  status_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35));
dcl  initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  status_$long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  terminate_$noname entry (ptr, fixed bin (35));
dcl  truncate$trseg entry (ptr, fixed bin, fixed bin (35));
dcl  quota$check_file entry (char (*), char (*), fixed bin, fixed bin (35));
dcl  set$max_length_path entry (char (*), char (*), fixed bin (19), fixed bin (35));

dcl  (addr, bit, fixed, null) builtin;

dcl  1 lbranch aligned,				/* structure to return long branch status */
       (2 (type bit (2), nnames bit (16), nrp bit (18)),
       2 dtm bit (36),
       2 dtu bit (36),
       2 (mode bit (5), pad1 bit (13), records bit (18)),
       2 dtd bit (36),				/* date time file and branch dumped */
       2 dtem bit (36),				/* date time branch modified */
       2 acct bit (36),				/* account number to which storage is charged */
       2 (curlen bit (12), bitcnt bit (24)),		/* highest 1024-word block used, bit count */
       2 (did bit (4), mdid bit (4), copysw bit (1), pad3 bit (9), rbs (0:2) bit (6)),
       2 uid bit (36)) unaligned;

%page;
	entry_point = file;				/* indicate that entry was via pathname entry point */
	dirname_from = a_dirname_from;		/* copy arguments */
	ename_from = a_ename_from;
	dirname_to = a_dirname_to;
	ename_to = a_ename_to;
	options = bit (a_sw, 2);			/* get options user has requested */
	created_seg = "0"b;				/* we didn't make output segment */
	code, tcode = 0;				/* initialize status codes */

	call initiate (dirname_from, ename_from, "", 0, 0, ptr_from, code);
						/* get pointer to FROM segment */

	if code ^= 0 then if code ^= error_table_$segknown then go to fin0;

try2:	call initiate (dirname_to, ename_to, "", 0, 0, ptr_to, code);
						/* get pointer to TO segment */

	if code ^= 0 then if code ^= error_table_$segknown then do;
						/* if TO segment does not exist */
		if created_seg then do;
		     if code = 0 then code = error_table_$no_move;
		     go to fin1;
		end;
		if code = error_table_$noentry then do;
		     if append_sw then do;		/* if append option given, try to make new TO seg */
			created_seg = "1"b;		/* first try to create */
			call status_$get_max_length_ptr (ptr_from, max_length, code); /* get max length of FROM segment */
			if code ^= 0 then go to fin1;
			call append$branch (dirname_to, ename_to, 01011b, code);
			if code ^= 0 then go to fin1; /* boo hoo */
			call set$max_length_path (dirname_to, ename_to, max_length, code);
			if code = 0 then go to try2;
		     end;
		end;
		go to fin1;			/*  unable to initiate TO seg or unable to create it */
	     end;
	go to common;

fseg: entry (a_ptr_from, a_ptr_to, a_sw, a_code);

dcl  (a_ptr_from, a_ptr_to) ptr;

	entry_point = seg;				/* indicate that entry was via the pointer entry point */
	ptr_from = a_ptr_from;			/* copy arguments */
	ptr_to = a_ptr_to;
	options = bit (a_sw, 2);			/* get options user has requested */
	code, tcode = 0;				/* initialize status codes */

	call fs_get$path_name (ptr_from, dirname_from, ldirname_from, ename_from, code);
						/* get pathname of FROM segment */

	if code ^= 0 then go to fin0;

	call fs_get$path_name (ptr_to, dirname_to, ldirname_to, ename_to, code);
						/* get pathname of TO sement */

	if code ^= 0 then go to fin0;

common:
	dptr = addr (lbranch);			/* get pointer to storage for status_ info */

	call status_$long (dirname_to, ename_to, 1, dptr, null, code);
						/* get status info on TO segment */

	if code ^= 0 then
	     if code = error_table_$no_s_permission then code = 0; /* non fatal error */
	     else go to fin2;			/* serious error */
	target_len = lbranch.curlen;			/* save for later chec */

	if lbranch.type ^= "01"b then do;		/* make sure that entry is a segment */
badmove:	     code = error_table_$no_move;
	     go to fin2;
	end;

	if (lbranch.mode & "01010"b) ^= "01010"b then go to badmove; /* need RW on TO segment */

	call status_$long (dirname_from, ename_from, 1, dptr, null, code);
						/* get status info on FROM segment */

	if code ^= 0 then
	     if code = error_table_$no_s_permission then code = 0; /* non fatal error */
	     else go to fin2;			/* serious error */

	if lbranch.type ^= "01"b then go to badmove;	/* make sure that entry is a segment */

	if (lbranch.mode & "01000"b) = "0"b then go to badmove; /* need R on FROM segment */

	curlen = fixed (lbranch.curlen, 12);		/* save current length in pages of FROM segment */
	words = curlen * 1024;			/* get number of words of FROM segment */

	call status_$get_max_length_ptr (ptr_to, max_length, code); /* get max length of TO segment */
	if code ^= 0 then go to badmove;
	if words > max_length then go to badmove;	/* make sure that TO segment has big enough max length */

	call quota$check_file (dirname_to, ename_to, curlen, code);
						/* make sure that there is enough quota to perform the copy */

	if code ^= 0 then go to badmove;		/* it wont fit */

	if target_len then				/* if TO seg has non-zero length */
	     if truncate_sw then do;			/* and if truncate option given, truncate TO seg */
		call truncate$trseg (ptr_to, 0, code);
		if code ^= 0 then go to fin2;
	     end;
	     else do;				/* and if truncate option not given, return status code */
		code = error_table_$clnzero;
		go to fin2;
	     end;

	ptr_to -> copy = ptr_from -> copy;		/* copy FROM segment to TO segment */

	call truncate$trseg (ptr_from, 0, code);	/* truncate FROM segment */

fin2:	if entry_point = seg then go to fin0;		/* if entered via pointer entry, skip terminating segs */
	call terminate_$noname (ptr_to, tcode);		/* terminate TO seg */
	if tcode ^= 0 then go to fin0;
fin1:	if entry_point = seg then go to fin0;
	call terminate_$noname (ptr_from, tcode);	/* terminate FROM seg */

fin0:	if tcode ^= 0 then a_code = tcode;
	else a_code = code;

	return;

     end;




		    fs_search.pl1                   11/11/89  1132.4rew 11/11/89  0800.5      118395



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




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to add extra indirection when applying the referencing_dir rule
     if the referencing segment is an object MSF component, and to add the
     same_directory entrypoint for object MSF link snapping.
                                                   END HISTORY COMMENTS */


/* format: style2,indcomtxt */

fs_search:
     procedure (a_refptr, a_refname, a_MSF_sw, a_segptr, a_code);

/****
      Modified 85-04-09 by Keith Loepere to remove extraneous error codes from set_wdir.
      Modified 85-02-25 by Keith Loepere for name lookup error I missed last time.
      Modified 84-10-15 by Keith Loepere for auditing.  Also to not beep
      console on RNT damage.
      Modified 84-06-25 by Keith Loepere to use the new dc_find.
      Modified 83-12-08 BIM to protect against bad user ring pointers,
      flush get_rel_segment, and clean up pigsties.
      Modified 1/83 by Keith Loepere for object on unmounted logical volume.
      Modified 2/79 W. Olin Sibert to make fs_search return correct error code for error_table_$moderr
      Modified 3/77 by M. Weaver to use search rules in user ring and not zero lot entry
      Modified 8/76 by M. Weaver to initialize LOT entry directly
      Init search rules for ring 8/76 THVV
      Modified June 1976 by R. Bratt to dereference old wdirs
      Massively reorganized April 1975 by R. Bratt for new kst
      8/7/75	by S. Webber to remove get_seg_count, get_seg_ptr, and get_segment entries and
      to add fs_search entry

*/

/* Parameters */

	dcl     a_code		 fixed bin (35) parameter;
						/* returned status code */
	dcl     a_pathcnt		 fixed bin (17) parameter;
	dcl     a_pathptr		 ptr parameter;
	dcl     a_refname		 char (*) parameter;/* segment referenced */
	dcl     a_refptr		 ptr parameter;	/* pointer to segment attempting to link */
	dcl     a_segptr		 ptr parameter;	/* returned pointer to segment referenced */
	dcl     a_MSF_sw		 bit (1) aligned parameter;
						/* on if refp refers to an MSF */
	dcl     a_wdir		 char (*) parameter;/* path name of new working directory */

/* Variables */

	dcl     bc		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     dirname		 char (168);
	dcl     i			 fixed bin;
	dcl     old_ep		 ptr;
	dcl     pathname		 char (168) varying;
	dcl     refname		 char (32);
	dcl     refptr		 ptr;		/* temporary storage */
	dcl     ring		 fixed bin (3);	/* variable for validation level */
	dcl     segment_number	 fixed bin;
	dcl     segment_uid		 bit (36) aligned;
	dcl     segptr		 ptr;		/* temporary storage */
	dcl     srp		 ptr;		/* pointer to search rules in current use */
	dcl     test_stack_reference	 bit (36) aligned;
	dcl     type		 fixed bin (2);
	dcl     MSF_sw		 bit (1) aligned;
	dcl     wdir		 char (168);
	dcl     wdp		 ptr;		/* working directory pointer */

/* Based */

	dcl     based_reference	 bit (36) aligned based;
	dcl     dname		 char (168) based aligned;
	dcl     1 sr		 (22) based aligned,/* search rule declaration */
	        ( 2 base		 bit (18),	/* segment number */
		2 off		 bit (18),	/* offset or code */
		2 uid		 bit (36)
		)		 unaligned;	/* unique id */

/* External */
	dcl     error_table_$dirseg	 ext fixed bin (35);
	dcl     error_table_$inconsistent_rnt
				 ext fixed bin (35);
	dcl     error_table_$logical_volume_not_defined
				 ext fixed bin (35);
	dcl     error_table_$moderr	 ext fixed bin (35);
	dcl     error_table_$root	 ext fixed bin (35);
	dcl     error_table_$seg_not_found
				 ext fixed bin (35);
	dcl     error_table_$segknown	 ext fixed bin (35);
	dcl     pds$stacks		 (0:7) ptr ext;
	dcl     pds$process_group_id	 char (32) ext static;
	dcl     pds$wdir		 (0:7) ptr ext;	/* pointers to working directories (per ring) */
	dcl     pds$wdir_uid	 (0:7) ext bit (36);

/* Entries */

	dcl     get_kstep		 entry (fixed bin (17), ptr, fixed bin (35));
	dcl     get_pathname_	 entry (fixed bin (17), char (*) varying, fixed bin (35));
	dcl     initiate$initiate_count
				 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     initiate$initiate_seg_count
				 entry (ptr, char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     level$get		 entry returns (fixed bin);
	dcl     lock$dir_unlock	 entry (ptr);
	dcl     ref_name_$get_segno	 entry (char (32) varying, fixed bin (17), fixed bin (35));
	dcl     segno_usage$decrement	 entry (fixed bin (17), fixed bin (35));
	dcl     status_$minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     syserr		 entry options (variable);
	dcl     terminate_proc	 entry (fixed bin (35));

/* Misc */

	dcl     any_other		 condition;

	dcl     (addr, baseptr, hbound, length, null, ptr, rtrim, segno)
				 builtin;
%page;
	refptr = a_refptr;				/* copy arguments */
	refname = a_refname;
	MSF_sw = a_MSF_sw;
	segptr = null;

	code = 0;
	ring = level$get ();
	test_stack_reference = pds$stacks (ring) -> based_reference;
						/* in a new ring this will fault on stack which
						   will cause makestack to be invoked which
						   will init rnt and search rules */
	on any_other call USER_RING_DAMAGED ("stack_header.rnt_ptr", ring);
						/* now, however, a fault is evidence of a real problem */
	rntp = pds$stacks (ring) -> stack_header.rnt_ptr;
	on any_other call USER_RING_DAMAGED ("rnt.srulep", ring);
	srp = rnt.srulep;				/* get pointer to search rules */
	on any_other call USER_RING_DAMAGED ("the RNT", ring);

/* start the search */

	do i = 1 to hbound (srp -> sr, 1);

	     if srp -> sr (i).off
	     then do;				/* special code */

/* do this for special codes */

		     if srp -> sr (i).off = INITIATED_RULE
		     then do;			/* search RNT */
			     call ref_name_$get_segno ((refname), segment_number, code);
			     if code = 0
			     then do;
				     segptr = baseptr (segment_number);
				     addr (segptr) -> its_unsigned.ringno = 0;
						/* writearound for compiler bug to force ring num = ring of exec (i.e., 0) */
				     go to return;
				end;
			end;

		     else if srp -> sr (i).off = REFERENCING_DIR_RULE
		     then do;			/* search parent of referencing proceedure */
			     if refptr ^= null
			     then do;		/* must have pointer to referencing proceedure */
				     call get_kstep (segno (refptr), kstep, code);
				     if code = 0
				     then do;	/* see if we have to go up another level for an MSF */
					     if MSF_sw
						then call get_kstep (segno (kste.entryp), kstep, code);
					     dp = ptr (kste.entryp, 0);
					     go to init_seg;
					end;
				end;
			end;

		     else if srp -> sr (i).off = WDIR_RULE
		     then do;			/* search the working directory */
			     dp = pds$wdir (ring);	/* get the working directory for this ring */
			     if dp ^= null
			     then do;
				     call get_kstep (segno (dp), kstep, code);
				     if code = 0
				     then if pds$wdir_uid (ring) = kstep -> kste.uid
						/* check uid to make sure */
					then go to init_seg;
				end;
			end;

		     else if srp -> sr (i).off = END_RULE
		     then do;			/* not found */
			     code = error_table_$seg_not_found;
			     goto return;
			end;

		     else if srp -> sr (i).off = BAD_RULE
		     then ;			/* ignore bad rule */
		end;

/* come here for fixed directory search rules */

	     else do;
		     dp = baseptr (srp -> sr (i).base); /* set up pointer to directory */
		     call get_kstep (segno (dp), kstep, code);
		     if code = 0
		     then if srp -> sr (i).uid = kstep -> kste.uid
			then do;			/* check uid to make sure */
init_seg:
				call initiate$initiate_seg_count (dp, refname, refname, (0), 1b, segptr, code);
				if segptr ^= null
				then do;
					if code = error_table_$segknown
					then code = 0;
						/* Clear residual code */
					go to return;
				     end;
				else if code = error_table_$moderr
				     | code = error_table_$logical_volume_not_defined
				then go to return;
				else if code = error_table_$dirseg
				then do;
					call dc_find$obj_existence_ptr (dp, ep, code);
					if code = 0
					then do;
						call get_pathname_ (segno (dp), pathname, code);
						call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
					     end;
					if code = 0
					then do;
						dirname = pathname;
						call status_$minf (dirname, refname, 1, type, bc, code);
					     end;
					if code = 0 & bc > 0 & type = 2
					then do;
						dirname = rtrim (pathname) || ">" || refname;
						call initiate$initiate_count (dirname, "0", refname,
						     (0), 1, segptr, code);
						if segptr ^= null
						then do;
							if code = error_table_$segknown
							then code = 0;
						/* Clear residual code */
							go to return;
						     end;
						else if code = error_table_$moderr
						     | code = error_table_$logical_volume_not_defined
						then go to return;
					     end;
				     end;
			     end;
		end;
	end;

	code = error_table_$seg_not_found;		/* If fall through, indicate not found */

return:
	a_segptr = segptr;				/* return segptr to caller */
	a_code = code;
	return;					/* and return */
%page;
same_directory:
     entry (a_refptr, a_refname, a_segptr, a_code);

	refptr = a_refptr;
	refname = a_refname;

/* preset return values */

	segptr = null;
	code = 0;

	if refptr ^= null
	then do;
		call get_kstep (segno (refptr), kstep, code);
		if code = 0
		then do;
			dp = ptr (kste.entryp, 0);
			call initiate$initiate_seg_count (dp, refname, "", 0, 1b, segptr, code);
			if code = error_table_$segknown
			then code = 0;
		     end;
	     end;
	else code = error_table_$seg_not_found;

	a_segptr = segptr;
	a_code = code;

	return;
%page;
set_wdir:
     entry (a_wdir, a_code);

	wdir = a_wdir;				/* copy args */

	call dc_find$dir_initiate (wdir, dp, code);
	if code = 0				/* user has access to see object */
	then do;
		ring = level$get ();		/* which ring is this for */
		segment_number = segno (pds$wdir (ring));
		segment_uid = pds$wdir_uid (ring);

		pds$wdir (ring) = dp;		/* save the pointer */
		pds$wdir_uid (ring) = dp -> dir.uid;	/* and the uid */
		call lock$dir_unlock (dp);

		call get_kstep (segment_number, kstep, code);
		if code = 0
		then if segment_uid = kstep -> kste.uid
		     then do;			/* dereference old wdir */
			     call dc_find$obj_terminate_ptr (baseptr (segment_number), old_ep, code);
						/* audit termination */
			     if code = 0
			     then call lock$dir_unlock (ptr (old_ep, 0));
			     if code = error_table_$root
			     then code = 0;
			     if code = 0
			     then call segno_usage$decrement (segment_number, (0));
			end;
		code = 0;
	     end;
	a_code = code;
	return;
%page;
get_wdir:
     entry (a_pathptr, a_pathcnt);			/* to return the path name of the working directory */

	pathname = "";				/* in case of error */
	ring = level$get ();			/* which ring is this for */
	wdp = pds$wdir (ring);
	call get_kstep (segno (wdp), kstep, code);
	if code = 0
	then if pds$wdir_uid (ring) = kstep -> kste.uid
	     then do;
		     call dc_find$obj_existence_ptr (wdp, ep, code);
		     if code = 0
		     then do;
			     call get_pathname_ (segno (wdp), pathname, code);
			     call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
			end;
		     else if code = error_table_$root
		     then do;
			     code = 0;
			     pathname = ">";
			end;
		end;
	a_pathptr -> dname = pathname;
	a_pathcnt = length (pathname);
	return;
%page;
USER_RING_DAMAGED:
     procedure (Damaged_thing, Ring);

	dcl     Damaged_thing	 char (*) parameter;
	dcl     Ring		 fixed bin (3) parameter;

	call syserr (JUST_LOG, "fs_search: Fatal damage detected to ^a in ring ^d for ^a.", Damaged_thing, Ring,
	     pds$process_group_id);
	call terminate_proc (error_table_$inconsistent_rnt);
     end USER_RING_DAMAGED;
%page;
%include dc_find_dcls;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include its;
%page;
%include kst;
%page;
%include rnt;
%page;
%include search_rule_flags;
%page;
%include stack_header;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   fs_search: Fatal damage detected to WHAT in ring RING for USER.

   S:	$log

   T:	$run

   M:	Some object crucial to the operation of the dynamic linker in ring
   RING was detected damaged. Since the dynamic linker cannot operate
   in the process, it is terminated.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end fs_search;




		    get_defname_.pl1                11/11/89  1132.4r w 11/11/89  0800.5       65115



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

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

get_defname_: proc (a_linkptr, a_defptr, a_offset, a_section, a_ename, a_code);

/*  Get_defname is a routine which is given an entry offset
   .    and returns a pointer to the corresponding entry name in acc format.

   USAGE:	dcl get_defname ext entry (ptr, bit(18) aligned, ptr, fixed bin);

   call get_defname (linkptr, offset, acc_name_ptr, code);

   1) linkptr	a pointer to the linkage section for the entry (Input)

   2) defptr	a ptr to the def section or to the seg if seg is a gate

   3) offset	the offset of the entry (Input)

   4) section	the object section offset is relative to

   5) ename	the entry name from the defs

   6) code	a standard file system status code (Output)


   Converted for the follow-on 645 by Craig Jensen on 6/27/72.
   Recoded as get_def_name_ by M. Weaver 12 June 1973
   Modified 8/76 by M. Weaver to reference kst_info instead of unsnap_service
   Modified 10/84 by Keith Loepere to restructure so as to avoid access checks.

   */


/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_defptr			ptr parameter;
dcl  a_ename			char (*) parameter;
dcl  a_linkptr			ptr parameter;
dcl  a_offset			bit (18) aligned parameter;
dcl  a_section			fixed bin parameter;

/* Variables */

dcl  acc_name_ptr			ptr;
dcl  bitcnt			fixed bin (24);
dcl  class			fixed bin;
dcl  code				fixed bin (35);
dcl  def_count			fixed bin;
dcl  defptr			ptr;
dcl  first_defptr			ptr;
dcl  link_count			fixed bin;
dcl  linkptr			ptr;
dcl  offset			bit (18) aligned;
dcl  1 oi				aligned like object_info;
dcl  old_flag			fixed bin;
dcl  savering			fixed bin (3);
dcl  section			fixed bin;
dcl  type				fixed bin (2);

/* Entries */

dcl  level$get			entry () returns (fixed bin (3));
dcl  level$set			entry (fixed bin (3));
dcl  link_man$get_lp		entry (ptr, ptr);
dcl  object_info_$brief		entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  status_$mins			entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));

/* Misc */

dcl  (addr, addrel, bin, null, rel, unspec) builtin;

/* External */

dcl  error_table_$defs_loop		ext fixed bin (35);
dcl  error_table_$no_ext_sym		ext fixed bin (35);

/* Based */

dcl  1 acc			aligned based,	/* template for acc string */
       2 count			fixed bin (8) unaligned,
       2 string			char (0 refer (count)) unaligned;

/* OLD DEFINITION FORMAT */

dcl  1 ext_sym_definition		based aligned,	/* external symbol definition block */
       2 next_ext_ptr		bit (18) unal,	/* pointer to next definition */
       2 trap_ptr			bit (18) unal,	/* pointer to  trap information */
       2 value			bit (18) unal,	/* value of the defined symbol */
       2 class			bit (18) unal,	/* says what value is relative to */
       2 nchars			bit (9) unaligned,	/* number of characters in external def */
       2 char_string		bit (279) unaligned;/* external symbol */
%page;
	code = 0;					/* first do some initialization */
	link_count = 0;
	def_count = 0;
	linkptr = a_linkptr;
	defptr = a_defptr;
	offset = a_offset;
	section = a_section;
	savering = level$get ();

	if defptr ^= null then
	     if rel (defptr) ^= "0"b then ;		/* user could find definitions in user ring */
	     else do;

/* must find definitions given pointer to object */
/* This program used to handle cases where the segment was a
hardcore segment (segno < stack_0) in which the user's validation
level was within the call bracket.  However, the only two such
segments are return_to_ring_0_ and restart_fault, neither of which
has anything to look up. */

		call dc_find$obj_linkage_ring_ptr (defptr, code); /* let user read through call bracket */
		if code ^= 0 then go to no_name;

		call status_$mins (defptr, type, bitcnt, code);
		if code ^= 0 then go to no_name;

		oi.version_number = object_info_version_2;
		call object_info_$brief (defptr, bitcnt, addr (oi), code);
		if code = 0 then defptr = oi.defp;
		else if addr (defptr) -> its_unsigned.ringno ^= 0 then go to no_name;
		else do;

/* hardcore objects had their definitions removed - use get_lp to find them */

		     call level$set (0);		/* allow get_lp to work */
		     call link_man$get_lp (defptr, linkptr);
		     call level$set (savering);

		     if linkptr ^= null then		/* can still find defs from linakge */
			if unspec (linkptr -> header.def_ptr) = "0"b then go to no_name;
			else defptr = linkptr -> header.def_ptr; /* pointer to base of definition section */
		end;
	     end;
	else do;					/* must find definitions via linkage info */
	     if unspec (linkptr -> header.def_ptr) = "0"b then go to no_name;
	     defptr = linkptr -> header.def_ptr;	/* pointer to base of definition section */
	     call dc_find$obj_linkage_ring_ptr (defptr, code);
	     if code ^= 0 then do;
no_name:		code = error_table_$no_ext_sym;
		go to return;
	     end;
	end;

	first_defptr = defptr;
	if defptr -> definition.flags.new then do;	/* this is new format */
	     old_flag = 0;
	     if defptr -> definition.flags.ignore then	/* skip header in std obj segs */
		defptr = addrel (first_defptr, defptr -> definition.forward);
	end;
	else old_flag = 1;				/* this is old format */
	go to test;				/* got good def so skip next */

next:	defptr = addrel (first_defptr, defptr -> definition.forward);

next3:	if defptr -> definition.forward = "0"b then	/* no more definitions */
	     goto no_name;

	def_count = def_count + 1;			/* increment definition count */
	if def_count >= 4000 then do;			/* too many definitions */
	     code = error_table_$defs_loop;
	     go to return;
	end;

test:	if old_flag = 0 then do;			/* new_format */
	     if defptr -> definition.class = "011"b then do; /* check for class 3 */
		defptr = addrel (first_defptr, defptr -> definition.segname); /* get to first def quickly */
		go to next3;
	     end;
	end;

	if defptr -> definition.value ^= offset then go to next; /* no match */

	if section > -1 then do;			/* use only defs for proper section */
	     if old_flag = 0 then class = bin (defptr -> definition.class, 3);
	     else class = bin (defptr -> ext_sym_definition.class, 18);
	     if section ^= class then go to next;
	end;

	if old_flag = 0 then			/* new format */
	     acc_name_ptr = addrel (first_defptr, defptr -> definition.symbol);

	else acc_name_ptr = addrel (defptr, 2);		/* old format */

	a_ename = acc_name_ptr -> acc.string;		/* fill in name */

return:	a_code = code;
	return;
%page; %include dc_find_dcls;
%page; %include definition;
%page; %include its;
%page; %include linkdcl;
%page; %include object_info;
     end;




		    hc_page_trace.pl1               11/11/89  1132.4rew 11/11/89  0800.5       48771



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

/* format: style2,indcomtxt */

/**** hc_page_trace: user interface to pds trace buffer
      Written at an unknown time by an unknown party.
      Modified 83-12-03 BIM for pgt_ signal. */

/* Entries:

   declare hc_page_trace entry (pointer);
   call hc_page_trace (data_ptr);

   Where: data_ptr points to the structure "trace" in
   sys_trace.incl.pl1. The entry array is declared
   with a bound of 1024, and the last_available field
   is used to tell the size.


   declare hc_page_trace$get_signal entry (bit (1) aligned, fixed bin (17));
   call hc_page_trace$get_signal (ips_signal_enabled, threshold_percent);

   Where: ips_signal_enabled is "1"b is pgt_ is sent when the buffer
   is threshold_percent filled.
   threshold_percent (between 50 and 100) is the % threshold at
   which a pgt_ is sent.

   declare hc_page_trace$set_signal entry (bit (1) aligned, fixed bin (17), bit (1) aligned, fixed bin (35));
   call hc_page_trace$set_signal (ips_signal_enabled, threshold_percent, changed, old_enabled, old_threshold, code);

   Where:
   ips_signal_enabled (Input)  is as in get_signal
   threshold_percent (Input)   is as in get_signal
   if it is < 0, then threshold is not changed.
   changed (Output) is "1"b if either value was changed.
   old_enabled (Output) is the old value of signal_enabled
   old_threshold (Output) is the old value of threshold
   code (Output) is error_table_$bigarg or error_table_$smallarg
   if threshold_percent is not between 50 and 100.
*/


hc_page_trace$get_page_trace:
     procedure (Data_ptr);

	declare (
	        Data_ptr		 pointer,
	        Old_signal		 bit (1) aligned,
	        New_signal		 bit (1) aligned,
	        Old_threshold	 fixed bin (17),
	        New_threshold	 fixed bin (17),
	        Changed		 bit (1) aligned,
	        Code		 fixed bin (35)
	        )			 parameter;

	declare dp		 pointer;
	declare copy_data		 (copy_length) bit (36) aligned based;
	declare copy_length		 fixed bin (19);
	declare signal_enabled	 bit (1) aligned;
	declare threshold_percent	 fixed bin (17);
	declare threshold		 fixed bin (16);
	declare code		 fixed bin (35);

	declare error_table_$bigarg	 fixed bin (35) ext static;
	declare error_table_$smallarg	 fixed bin (35) ext static;
	declare pds$trace		 bit (36) aligned external static;
	declare pds$process_group_id   char (32) external static;

          declare syserr		 entry options (variable);

	declare (addr, decimal, fixed, float, round, wordno)
				 builtin;

%include sys_trace;


	dp = Data_ptr;				/* copy argument */
	trace_ptr = addr (pds$trace);
	copy_length = wordno (addr (trace.data)) + (2 * trace.last_available);
						/* entries are doublewords */

	/*** if user supplied insufficient space, tough! */

	dp -> copy_data = trace_ptr -> copy_data;	/* copy the trace data */
	return;


get_signal:
     entry (Old_signal, Old_threshold);

	call setup_get_old;
	return;

set_signal:
     entry (New_signal, New_threshold, Changed, Old_signal, Old_threshold, Code);

	code = 0;
	call setup_get_old;

	signal_enabled = New_signal;
	threshold_percent = New_threshold;

	if threshold_percent ^< 0			/* changing threshold */
	then do;
		if threshold_percent < 50
		then code = error_table_$smallarg;
		else if threshold_percent > 100
		then code = error_table_$bigarg;
		if code ^= 0
		then go to RETURN;
	     end;
	else threshold_percent = get_threshold_percent ();

	threshold =
	     round (fixed (float (decimal (threshold_percent)) / 1.0e2 * float (decimal (trace.last_available)), 17, 1),
	     0);					/* calculate in decimal to make 100 work right */
	Changed = (signal_enabled ^= trace.send_ips) | (threshold ^< 0 & threshold ^= trace.threshold);
	trace.send_ips = signal_enabled;
	trace.threshold = threshold;
RETURN:
	Code = code;
	return;

setup_get_old:
     procedure;
	trace_ptr = addr (pds$trace);
	Old_signal = trace.send_ips;
	Old_threshold = get_threshold_percent ();
	return;
     end setup_get_old;

get_threshold_percent:
     procedure returns (fixed bin (17));

	if trace.threshold = 0
	then call syserr (TERMINATE_PROCESS, "hc_page_trace: pds$trace.threshold found zero for ^a.",
		pds$process_group_id);
	else return (
		round (
		fixed (float (decimal (trace.threshold)) / float (decimal (trace.last_available)) * 1.00e2, 17, 1), 0)
		);
     end get_threshold_percent;

%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   hc_page_trace: pds$trace.threshold found zero for USER.

   M:  The signalling threshold for page tracing was found to be
   zero for USER. This indicates that the user's pds has been
   damaged.

   S:  $term

   T:  $run

   A:  Investigate the saved dead process.


   END MESSAGE DOCUMENTATION */

     end hc_page_trace$get_page_trace;




		    initiate_.pl1                   11/11/89  1132.4r w 11/11/89  0800.0      289224



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

/* format: off */  /* This program was formatted via emacs. */

initiate_:
initiate:
    procedure (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* History of earlier versions of the program:			       */
/* Modified on 05/74 by E Stone to call status_$long when copy made	       */
/*    (to get curlen and to cause a branch update)		       */
/* Modified by Kobziar July 74 to call new entry in access_mode	       */
/*    and to add privileged initate entries			       */
/* Modified on 03/76 by R. Bratt to check mountedness of LV before okaying   */
/*    makeknown						       */
/* Modified on 06/01/76 by R. Bratt to call find_$finished		       */
/* Modified on 06/02/76 by R. Bratt to cleanup a piece of trash!	       */
/* Modified 760317 by L. Scheffler to properly call dir_control_error	       */
/*    entries						       */
/* Modified on 03/29/77 by M. Weaver to set lot fault when segment is first  */
/*    initiated in ring					       */
/* Modified on 78/02/21 by M. Weaver to call link_man$grow_lot at proper     */
/*    boundary						       */
/* Modified on 79/08/29 by Mike Grady to fix bug handling reserved segno's   */
/*    and copy sw						       */
/* Modified on 81/04/06 by J. Bongiovanni to fix max lot size check	       */
/* Modified May 1981 by C. Hornig to remove references to the copy switch.   */
/* Modified 04/30/84 by S. Herbst to add $get_segment_ptr_path	       */
/* Modified 07/18/84 by Keith Loepere to use the new dc_find.	       */
/* Modified 10/19/84 by Keith Loepere to do the right thing for initiating   */
/*    directories.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/****^  HISTORY COMMENTS:
  1) change(85-12-10,GDixon), approve(86-08-09,MCR7388),
     audit(86-09-12,Farley), install(86-09-08,MR12.0-1150):
     Completely rewritten to:
      a) improve program structure and reduce number of switches used in code;
      b) keep directory locked while calling makeknown_, so that the pointer to
         dir entry remains valid;
      c) use dc_find$finished for most directory unlocking.
                                                   END HISTORY COMMENTS */


/* Parameters */

dcl  a_code fixed bin (35) parameter;
dcl  a_copysw fixed bin (2) parameter;
dcl  a_dname char (*) parameter;
dcl  a_dp ptr parameter;
dcl  a_ename char (*) parameter;
dcl  a_rname char (*) parameter;
dcl  a_count fixed bin (17);
dcl  a_segptr ptr parameter;
dcl  a_segsw fixed bin (1) parameter;
dcl  a_uid bit (36) parameter;

/* Variables */

dcl  1 in aligned,				/* copies of input parms.  */
       2 segp ptr,
       2 dirp ptr,
       2 dname char(168) unal,
       2 ename char(32) unal,
       2 rname char(32) varying;
dcl  1 entrypoint aligned,			/* per-entrypoint controls */
       2 dc_find entry (char(168), char(32), ptr, fixed bin(35)) variable,
       2 should_call_find_finished bit(1),
       2 should_unlock_dir bit(1),
       2 priv bit(1);
dcl  1 seg aligned,				/* intermediate data for   */
       2 dirp ptr,				/* segment being initiated.*/
       2 entp ptr,
       2 directory bit(1),
       2 hash_bucket fixed bin(17);
dcl  1 out aligned,				/* copies of output data.  */
       2 segp ptr,
       2 bc fixed bin(24),
       2 uid bit(36),
       2 code fixed bin(35);

/* External */

dcl  error_table_$dirseg external fixed bin (35);
dcl  error_table_$invalid_copy external fixed bin (35);
dcl  error_table_$seg_unknown external fixed bin (35);
dcl  error_table_$segknown external fixed bin (35);

/* Entries */

dcl  kstsrch entry (bit (36) aligned, fixed bin (17), ptr);

/* Misc */

dcl  (addr, baseno, baseptr, fixed, null, ptr, rtrim, unspec) builtin;
dcl  (FALSE init("0"b),
      TRUE  init("1"b)) bit(1) int static options(constant);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* NAME:	initiate						       */
/*							       */
/* This module is a primitive which calls other routines to make a segment   */
/* known, i.e., to assign a segment number to the segment or a copy of the   */
/* segment.						       */
/*							       */
/* ENTRY:	initiate						       */
/*							       */
/* This is the main entrypoint.  Besides making a segment identified by      */
/* pathname known (optionally by a given reference name), it allows the      */
/* caller to optionally specify the segment number by which the segment      */
/* will be known.  The copysw argument is obsolete; a value of 2 (always     */
/* make a copy of the segment in the pdir) is diagnosed as an error;	       */
/* otherwise the switch is ignored.				       */
/*							       */
/* USAGE: call initiate (a_dname, a_ename, a_rname, a_segsw, a_copysw,       */
/*	  a_segptr, a_code);				       */
/*							       */
/* a_dname (char(*))					       */
/*    pathname of parent directory of the segment to be initiated (Input)    */
/* a_ename (char(*))					       */
/*    entryname of the segment to be initiated (Input)		       */
/* a_rname (char(*))					       */
/*    reference name by which the segment is to be made known if this	       */
/*    argument is of zero length, then the segment is made known by a null   */
/*    name (Input)						       */
/* a_segsw (fixed bin (1))					       */
/*    reserve segment switch  (Input)				       */
/*    (= 0 if no segment number reserved,			       */
/*     = 1 if segment number reserved)				       */
/* a_copysw (fixed bin (2))					       */
/*    formerly copy switch (Input)				       */
/*    (= 0 if default setting of copy switch to be used,		       */
/*     = 1 if segment never to be copied,			       */
/*     = 2 if segment always to be copied into process dir prior to	       */
/*	 initiation. This alternative is no longer implemented.  It	       */
/*	 produces an error.)				       */
/* a_segptr (pointer)					       */
/*    normally output.  If segsw = 1 then input pointer to previously known  */
/*    segment (used to input reserve segment number) .		       */
/* a_code (fixed bin (35))					       */
/*    status code (Output)					       */
/*							       */
/* ENTRY: priv_init						       */
/*							       */
/* This entry is identical to the initiate entrypoint, except that it	       */
/* ignores the impact of AIM and ring brackets when determining whether the  */
/* user has access to initiate the segment.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* The real procedure statement is up above.  This one is useful documentation.

initiate_:
initiate:
    proc (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code); */

    call setup_args$initiate();
    entrypoint.dc_find = dc_find$obj_initiate;
    go to INITIATE_COMMON;

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


priv_init:
    entry (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code);

    call setup_args$initiate();
    entrypoint.dc_find = dc_find$obj_initiate_raw;
    entrypoint.priv = TRUE;

INITIATE_COMMON:
    if out.code = 0 then do;
       call entrypoint.dc_find (in.dname, in.ename, seg.entp, out.code);
       if out.code = 0 then do;
	entrypoint.should_call_find_finished = TRUE;
	entrypoint.should_unlock_dir = FALSE;
	call check_entry();
	call make_entry_known_and_unlock_dir();
	end;
       end;
    a_segptr = out.segp;
    a_code = out.code;
    return;

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





setup_args$initiate:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* a_dname, a_ename, a_rname,					       */
/* a_segsw, a_copysw, a_seg_ptr				       */
/*    input parameters, to be copied and tested.  Meanings of these parms    */
/*    are given in entrypoint descriptions above.			       */
/*							       */
/* Function:						       */
/* 1) copy a_dname, a_ename, a_rname.				       */
/* 2) copy, test and apply a_segsw to initial value of in.segp.	       */
/* 3) initialize out.segp, out.bc out.uid & entrypoint.priv.	       */
/* 4) copy and test a_copysw.  Set out.code according to test results.       */
/*							       */

/* Output Args:						       */
/* in.dname, in.ename, in.rname				       */
/*    copies of input parameters.				       */
/* in.segp						       */
/*    copy of a_segptr if a_segsw is on; otherwise set to null.	       */
/* out.segp						       */
/*    initialized to null (default output value if error occurs).	       */
/* out.bc							       */
/*    set to 0 (unused return argument).			       */
/* out.uid						       */
/*    set to "0"b (unused return argument).			       */
/* out.code						       */
/*    result of test of a_copysw.				       */
/* entrypoint.priv						       */
/*    set to off, assuming not entered at privileged		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  copysw fixed bin (2);
dcl  segsw fixed bin (1);

    copysw = a_copysw;
    segsw = a_segsw;
    in.dname = a_dname;
    in.ename = a_ename;
    in.rname = rtrim(a_rname);

    if segsw = 0 then			/* a_segptr can only be    */
       in.segp = null;			/* copied if segsw ^= 0.   */
    else					/* Otherwise, it must not  */
       in.segp = a_segptr;			/* be touched, since its   */
					/* storage may not be in   */
					/* ptr format.	       */
    out.segp = null;
    out.bc = 0;
    out.uid = "0"b;
    if copysw = 2 then 
       out.code = error_table_$invalid_copy;
    else 
       out.code = 0;
    entrypoint.priv = FALSE;

    end setup_args$initiate;

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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ENTRY:	initiate_count					       */
/*							       */
/* This entry is the same as initiate except that a bit count parameter      */
/* replaces the a_segsw parm.					       */
/*							       */
/* USAGE:	call initiate$initiate_count				       */
/*	  (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);*/
/*							       */
/* a_count (fixed bin(24))					       */
/*    bit count of initiated segment (Output)			       */
/*							       */
/* ENTRY: priv_init_count					       */
/*							       */
/* This entry is like initiate_count, except that it ignores the impact of   */
/* AIM and ring brackets when determining whether the user has access to     */
/* initiate the segment.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

initiate_count:
    entry (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);

    call setup_args$initiate_count();
    entrypoint.dc_find = dc_find$obj_initiate;
    go to INITIATE_COUNT_COMMON;

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


priv_init_count:
    entry (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);

    call setup_args$initiate_count();
    entrypoint.dc_find = dc_find$obj_initiate_raw;
    entrypoint.priv = TRUE;

INITIATE_COUNT_COMMON:
    if out.code = 0 then do;
       call entrypoint.dc_find (in.dname, in.ename, seg.entp, out.code);
       if out.code = 0 then do;
	entrypoint.should_call_find_finished = TRUE;
	entrypoint.should_unlock_dir = FALSE;
	call check_entry();
	call make_entry_known_and_unlock_dir();
	end;
       end;
    a_count = out.bc;
    a_segptr = out.segp;
    a_code = out.code;
    return;

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

setup_args$initiate_count:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* a_dname, a_ename, a_rname, a_copysw				       */
/*    input parameters, to be copied and tested.  Meanings of these parms    */
/*    are given in entrypoint descriptions above.			       */
/*							       */
/* Function:						       */
/* 1) copy a_dname, a_ename, a_rname.				       */
/* 2) initialize in.segp, out.segp, out.bc, out.uid & entrypoint.priv.       */
/* 3) copy and test a_copysw.  Set out.code according to test results.       */
/*							       */
/* Output Args:						       */
/* in.dname, in.ename, in.rname				       */
/*    copies of input parameters.				       */
/* in.segp						       */
/*    set to null (no reserved segment number specified).		       */
/* out.segp						       */
/*    set to null (default output value if error occurs).		       */
/* out.bc							       */
/*    set to value for bit count to be output if error occurs (0).	       */
/* out.uid						       */
/*    set to "0"b (unused output value).			       */
/* out.code						       */
/*    result of test of a_copysw.				       */
/* entrypoint.priv						       */
/*    set to off, assuming not entered at privileged entrypoint.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  copysw fixed bin (2);

    copysw = a_copysw;
    in.dname = a_dname;
    in.ename = a_ename;
    in.rname = rtrim(a_rname);
    in.segp = null;

    out.segp = null;
    out.bc = 0;
    out.uid = "0"b;
    if copysw = 2 then 
       out.code = error_table_$invalid_copy;
    else 
       out.code = 0;
    entrypoint.priv = FALSE;

    end setup_args$initiate_count;

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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ENTRY:	initiate_seg_count					       */
/*							       */
/* This entry is the same as initiate_count except that it takes a	       */
/* directory pointer instead of a directory path name.  It is used solely    */
/* by fs_search.						       */
/*							       */
/* NOTE: a contract has been made that this entry can only be called by      */
/* fs_search.  dc_find knows this.  As such, dc_find does not do its normal  */
/* name lookup access check for this routine, and merely returns no_info     */
/* if the name doesn't exist or if the user doesn't have access.	       */
/*							       */
/* USAGE:	call initiate$initiate_seg_count			       */
/*	  (a_dp, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);   */
/*							       */
/* a_dp (ptr)						       */
/*    pointer to directory of entry ename. (Input)		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

initiate_seg_count:
    entry (a_dp, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);

    call setup_args$initiate_seg_count();
    if out.code = 0 then do;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Note that dc_find$obj_initiate_for_linker_dp, knowing it is called only   */
/* for fs_search, does not perform its normal name lookup access checks.     */
/* If the entry is not found, dc_find will return no_info, as it will (for   */
/* this one entry only) if the user lacks access to see the object.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

       call dc_find$obj_initiate_for_linker_dp (in.dirp, in.ename, seg.entp, out.code);
       if out.code = 0 then do;
	if in.dirp = null then do;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This means ename was a link to an object in another directory besides     */
/* that pointed to by in.dirp.  Therefore, we cannot unlock the dir but      */
/* must instead tell dc_find to do it.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   entrypoint.should_unlock_dir = FALSE;
	   entrypoint.should_call_find_finished = TRUE;
	   end;

	else do;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This is the normal case, in which we can unlock in.dirp directly without  */
/* having to call dc_find.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   entrypoint.should_call_find_finished = FALSE;
	   entrypoint.should_unlock_dir = TRUE;
	   end;

	call check_entry();
	call make_entry_known_and_unlock_dir();
	end;
       end;
    a_count = out.bc;
    a_segptr = out.segp;
    a_code = out.code;
    return;

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

setup_args$initiate_seg_count:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* a_dp, a_ename, a_rname,					       */
/* a_copysw						       */
/*    input parameters, to be copied and tested.  Meanings of these parms    */
/*    are given in entrypoint descriptions above.			       */
/*							       */
/* Function:						       */
/* 1) copy a_dp, a_ename, a_rname.				       */
/* 2) initialize in.segp, out.segp, out.bc, out.uid & entrypoint.priv.       */
/* 3) copy and test a_copysw.  Set out.code according to test results.       */
/*							       */
/* Output Args:						       */
/* in.dirp, in.ename, in.rname				       */
/*    copies of input parameters.				       */
/* in.segp						       */
/*    set to null (no reserved segment number specified).		       */
/* out.segp						       */
/*    set to null (default output value if error occurs).		       */
/* out.bc							       */
/*    set to value for bit count to be output if error occurs (0).	       */
/* out.uid						       */
/*    set to "0"b (unused output value).			       */
/* out.code						       */
/*    result of test of a_copysw.				       */
/* entrypoint.priv						       */
/*    set to off, not a privileged entrypoint.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  copysw fixed bin (2);

    in.dirp = a_dp;
    in.ename = a_ename;
    in.rname = rtrim(a_rname);
    in.segp = null;

    out.segp = null;
    out.bc = 0;
    out.uid = "0"b;
    copysw = a_copysw;
    if copysw = 2 then 
       out.code = error_table_$invalid_copy;
    else 
       out.code = 0;
    entrypoint.priv = FALSE;

    end setup_args$initiate_seg_count;

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

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ENTRY: get_segment_ptr_path				       */
/*							       */
/* This entry point returns a ptr and uid if the segment is already	       */
/* initiated; it returns an error if the segment is not already initiated.   */
/*							       */
/* USAGE: call initiate_$get_segment_ptr_path (a_dname, a_ename, a_segptr,   */
/*	   a_uid, a_code);					       */
/*							       */
/* a_dname (char(*))					       */
/*    parent directory. (Input)				       */
/* a_ename (char(*))					       */
/*    entry name. (Input)					       */
/* a_segptr (ptr)						       */
/*    pointer to the segment, or null. (Output)			       */
/* a_uid (bit(36))						       */
/*    file system uid. (Output)				       */
/* a_code (fixed(35))					       */
/*    zero or error_table_$seg_unknown. (Output)			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_segment_ptr_path:
    entry (a_dname, a_ename, a_segptr, a_uid, a_code);

    call setup_args$get_segment_ptr_path();
    call dc_find$obj_initiate (in.dname, in.ename, seg.entp, out.code);
    if out.code = 0 then do;
       entrypoint.should_call_find_finished = TRUE;
       entrypoint.should_unlock_dir = FALSE;
       call check_entry();
       if seg.directory then do;
	out.code = error_table_$dirseg;
	out.uid = "0"b;
	end;
       else do;
	call kstsrch (out.uid, seg.hash_bucket, kstep);
	if kstep = null then do;
	   out.code = error_table_$seg_unknown;
	   out.uid = "0"b;
	   end;
	else 
	   out.segp = baseptr (kste.segno);
	end;
       call unlock_dir();
       end;
    a_uid = out.uid;
    a_segptr = out.segp;
    a_code = out.code;
    return;

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


setup_args$get_segment_ptr_path:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* a_dname, a_ename						       */
/*    input parameters, to be copied.  Meanings of these parms are given in  */
/*    entrypoint descriptions above.				       */
/*							       */
/* Function:						       */
/* 1) copy a_dname and a_ename				       */
/* 2) initialize in.segp, out.segp, out.bc, out.uid, out.code and	       */
/*    entrypoint.priv.					       */
/*							       */
/* Output Args:						       */
/* in.dname, in.ename					       */
/*    copies of input parameters.				       */
/* in.segp						       */
/*    set to null (no reserved segment number specified).		       */
/* out.segp						       */
/*    set to null (default output value if segment not known).	       */
/* out.bc							       */
/*    set to 0 (unused return argument).			       */
/* out.uid						       */
/*    set to uid value to output if error occurs (0).		       */
/* out.code						       */
/*    set to 0.						       */
/* entrypoint.priv						       */
/*    set to off, not a privileged entrypoint.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    in.dname = a_dname;
    in.ename = a_ename;
    in.segp = null;

    out.segp = null;
    out.bc = 0;
    out.uid = "0"b;
    out.code = 0;
    entrypoint.priv = FALSE;

    end setup_args$get_segment_ptr_path;

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

check_entry:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* seg.entp						       */
/*    pointer to the dir branch for the entry to be initiated.	       */
/*							       */
/* Function:						       */
/* 1) Check if target entry being initiated is the root dir.  If so	       */
/*    fabricate information.					       */
/* 2) Otherwise, extract output information from dir branch for the entry.   */
/*							       */
/* Output Args:						       */
/* seg.dirp						       */
/*    pointer to the containing dir.				       */
/* seg.directory						       */
/*    on if entry being initiated is a directory.			       */
/* out.uid						       */
/*    entry's unique ID					       */
/* out.bc							       */
/*    entry's bit count					       */
/* entrypoint.should_call_find_finished,		       	       */
/* entrypoint.should_unlock_dir				       */
/*    switches controlling whether/how directory is unlocked.  These are     */
/*    turned off if the entry is the root dir.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if seg.entp = null then do;		/* root		       */
       seg.dirp = null;
       seg.directory = TRUE;
       out.uid = "777777777777"b3;
       out.bc = 0;
       entrypoint.should_call_find_finished,	/* didn't lock anything    */
	entrypoint.should_unlock_dir = FALSE;
       end;
    else do;
       seg.dirp = ptr (seg.entp, 0);
       seg.directory = seg.entp -> entry.dirsw;
       out.uid = seg.entp -> entry.uid;
       out.bc = seg.entp -> entry.bc;
       end;
    end check_entry;

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

make_entry_known_and_unlock_dir:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* in.segp						       */
/*    reserved segment number to use for initiate_ entrypoint	       */
/* in.rname						       */
/*    name by which segment is to be referenced (for ref_name_$insert)       */
/* seg.dirp						       */
/*    pointer to dir containing entry.				       */
/* seg.entp						       */
/*    pointer to entry's dir branch.				       */
/* seg.directory						       */
/*    on if entry being initiated is a directory.			       */
/* entrypoint.priv						       */
/*    on if calling entrypoint is privileged (for call to makeknown_)	       */
/* out.uid						       */
/*    entry's unique ID (for call to makeknown_)			       */
/*							       */
/* Function:						       */
/* 1) Ensures disk holding target entry is mounted.		       */
/* 2) Makes target entry known to process.			       */
/* 3) Unlocks containing directory.				       */
/* 4) Adds reference name table (RNT) entry for the known segment.	       */
/* 5) Sets LOT entry for the segment (in target ring) to lot_fault value.    */
/*							       */
/* Output Args:						       */
/* out.segp						       */
/*    pointer to initiated segment (remains unchanged if makeknown_ fails).  */
/* out.bc							       */
/*    bit count (set to 0 if makeknown_ fails).			       */
/* out.code						       */
/*    results from call to mountedp, makeknown_ and ref_name_$insert.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* Variables */
dcl  ecode fixed bin (35);
dcl  1 mk_info aligned like makeknown_info;
dcl  ring fixed bin (3);
dcl  segno fixed bin;
dcl  use_count fixed bin (17);

/* External */
dcl  pds$stacks (0:7) ptr ext;
dcl  1 pds$useable_lot aligned ext,
       2 flags (0:7) bit (1) unal;

/* Entries */
dcl  level$get entry returns (fixed bin (3));
dcl  link_man$grow_lot entry (fixed bin (3));
dcl  makeknown_ entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  mountedp entry (bit (36) aligned, fixed bin (35));
dcl  ref_name_$insert entry (char (32) varying, fixed bin, fixed bin (35));

    if ^seg.directory then do;		/* ensure LV is mounted    */
       call mountedp (seg.dirp -> dir.sons_lvid, out.code);
       if out.code ^= 0 then do;
	call unlock_dir();
	out.bc = 0;			/* Don't return bit count  */
	return;				/* if errors occur.	       */
	end;
       end;

    unspec (mk_info) = FALSE;
    mk_info.uid = out.uid;
    mk_info.entryp = seg.entp;		/* dir locked, seg.entp    */
					/* has been validated by   */
					/*  dc_find.	       */
    mk_info.dirsw = seg.directory;
    mk_info.priv_init = entrypoint.priv;
    mk_info.allow_write = TRUE;

    if in.segp ^= null then do;
       mk_info.rsw = TRUE;
       segno = fixed (baseno (in.segp), 17);
       end;
    else mk_info.rsw = FALSE;

    call makeknown_ (addr (mk_info), segno, use_count, out.code);
    call unlock_dir();			/* The dir must stay       */
					/* locked until after      */
    if out.code = 0 then;			/* makeknown_ returns, as  */
    else if out.code = error_table_$segknown then;/* per interface specs.    */
    else do;
       out.bc = 0;				/* Don't return bit count  */
       return;				/* if errors occur.	       */
       end;
    out.segp = baseptr (segno);		/* From this point on,     */
					/* makeknown_ has succeeded*/

    if in.rname ^= "" then do;		/* Add ref name to segment.*/
       call ref_name_$insert (in.rname, segno, ecode);
       if ecode ^= 0 then out.code = ecode;	/* Be careful not to zero  */
       end;				/* segknown code needlessly*/

    if use_count = 1 then do;			/* Made known for first    */
       ring = level$get ();			/* time in a ring?	       */
       if pds$useable_lot.flags (ring) then do;	/* diddle user ring lot    */
	if segno >= pds$stacks (ring) -> stack_header.cur_lot_size then
	   if segno < pds$stacks (ring) -> stack_header.max_lot_size then do;
	      call link_man$grow_lot (ring);
	      unspec (pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segno)) = lot_fault;
					/* flag lot entry to tell  */
	      end;			/* run unit seg is known.  */
	   else;				/* high segno might be OK  */
					/* if seg not linked to.   */
	else  unspec (pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segno)) = lot_fault;
	end;
       end;
    end make_entry_known_and_unlock_dir;

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

unlock_dir:
    proc;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Input Args:						       */
/* seg.dirp						       */
/*    pointer to dir containing entry.				       */
/* seg.entp						       */
/*    pointer to entry's dir branch.				       */
/* entrypoint.should_call_find_finished				       */
/*    on to call dc_find$finished to unlock and unhold dir.		       */
/* entrypoint.should_unlock_dir				       */
/*    on to call lock$unlock_dir to unlock dir.			       */
/*							       */
/* Function: unlock dir containing target entry.  Normally, it was locked    */
/* by dc_find$obj_initiate, which also holds the directory (by incrementing  */
/* its usage count) to keep it from being KST-garbage-collected.  So	       */
/* dc_find$finished must be called to undo this dir holding.	       */
/*							       */
/* However, the linker calls $initiate_seg_count, which uses	       */
/* dc_find$obj_initiate_for_linker_dp, which does NOT hold the containing    */
/* dir unless ename matches a link in the containing dir and the link gets   */
/* chased.  If no links were chased, then the dir is NOT held and	       */
/* lock$dir_unlock can be called directly.  If links were chased, then       */
/* dc_find$finished must be called to unhold the dir containing the chased   */
/* link target.						       */
/*							       */
/* Finally, if the entry being initiated is the root, then there is no       */
/* containing directory to unlock.  The input flags are set appropriately    */
/* by callers to cause the correct operation to occur.		       */
/*							       */
/* Output Args:						       */
/* entrypoint.should_call_find_finished,			       */
/* entrypoint.should_unlock_dir				       */
/*    turned off on output.					       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* Entries */

dcl  lock$dir_unlock entry (pointer);

    if entrypoint.should_call_find_finished then
       call dc_find$finished (seg.entp, DC_FIND_UNLOCK_DIR);
    else if entrypoint.should_unlock_dir then
       call lock$dir_unlock(seg.dirp);
    entrypoint.should_call_find_finished, entrypoint.should_unlock_dir = FALSE;

    end unlock_dir;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

%include dc_find_dcls;

%include dir_entry;

%include dir_header;

%include kst;

%include lot;

%include makeknown_info;

%include stack_header;
     end initiate_;




		    initiate_search_rules.pl1       11/11/89  1132.4r w 11/11/89  0800.5      109233



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

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

initiate_search_rules: proc (a_ptr, a_code);

/* Last Modified: (Date and Reason)
   10/15/84 by Keith Loepere for auditing info.
   06/22/84 by Keith Loepere to use the new dc_find (including access checks).
   03/77 by M. Weaver to put search rules in user ring
   07/76 by THVV for Bicentennial
   04/03/75 by R. Bratt for new kst / rnt system
   08/11/71 by Richard H. Gumpertz to make length of pds$process_dir_name = 32 instead of 52
   08/04/71 by Mosley Meer for new KST format
   originally coded by Mosley Meer
*/

/* This routine is called to initiate and insert the search rules
   passed to it through the pointer argument
   USAGE:
   call initiate_search_rules(ptr, code);

   1) ptr		pointer to a data array. (Input)
   2) code	return status code. (Output)

   NOTE: the data array is of the form
   dcl 1 input_arg based aligned,
   2 number fixed bin,
   2 name (22) char (168) unal;

   All search rules are checked to be directories. */

/* Parameters */

dcl  a_code			fixed bin (35) parameter; /* return status code */
dcl  a_ptr			ptr parameter;	/* pointer to input search rule array */
dcl  syscode			fixed bin (35) parameter;
dcl  sysptr			ptr parameter;

/* Based */

dcl  based_area			area based;
dcl  1 input_arg			based (ap) aligned, /* form of input name structure array */
       2 number			fixed bin,
       2 name			(22) char (168) unal;
dcl  1 search_rules			(22) based (srp) aligned,
     ( 2 base			bit (18),
       2 offset			bit (18),
       2 uid			bit (36)) unaligned;

/* Variables */

dcl  ap				ptr;		/* input array pointer */
dcl  1 arg			aligned like input_arg;
dcl  code				fixed bin (35);
dcl  count			fixed bin;	/* count of rules in pointer array */
dcl  firstarg			fixed bin;	/* first arg to scan (2 for ssd, else 1) */
dcl  i				fixed bin;
dcl  new_ring			bit (1);
dcl  old_ep			ptr;
dcl  ring				fixed bin;
dcl  1 search_rule_temp		(22) aligned like search_rules; /* Stack copy */
dcl  segnum			fixed bin (15);	/* segment number from pointer */
dcl  srp				ptr;		/* pointer to a single search rule in KST */
dcl  1 ssd_dft_rules		(22) aligned like search_rules;
dcl  ssd_wdir_index			fixed bin;	/* location of rule after WDIR rule */
dcl  xcode			fixed bin (35);

/* Entries */

dcl  get_kstep			entry (fixed bin (15), ptr, fixed bin (35));
dcl  level$get			entry returns (fixed bin);
dcl  lock$dir_unlock		entry (ptr);
dcl  lock$lock_fast			entry (ptr);
dcl  lock$unlock_fast		entry (ptr);
dcl  segno_usage$decrement		entry (fixed bin (15), fixed bin (35));

/* External */

dcl  ahd$n_sr_tags			fixed bin ext;
dcl  ahd$n_sys_rules		fixed bin ext;
dcl  1 ahd$search_rule		(50) aligned ext,
       2 name			char (168) unal,
       2 flag			bit (36);
dcl  1 ahd$sr_tag			(10) aligned ext,
       2 name			char (32),
       2 flag			bit (36);
dcl  ahd$search_rules_lock		ext;
dcl  error_table_$bad_arg		ext fixed bin (35);
dcl  error_table_$bad_string		ext fixed bin (35);
dcl  error_table_$root		ext fixed bin (35);
dcl  error_table_$too_many_sr		ext fixed bin (35);
dcl  pds$home_dir			ext char (168) aligned;
dcl  pds$process_dir_name		ext char (32) aligned;
dcl  pds$stacks			(0:7) ptr ext;

/* Misc */

dcl  (addr, baseptr, binary, bit, hbound, null, segno, substr) builtin;
%page;
	new_ring = "0"b;				/* entry used by ssr command */
	goto join;


init_ring: entry (a_ptr, a_code);

	new_ring = "1"b;				/* called by makestack */

join:	ap = a_ptr;				/* copy the array pointer */
	arg = input_arg;				/* Copy whole input structure */
	code = 0;
	ring = level$get ();			/* get ring for this search rule set */
	rntp = pds$stacks (ring) -> stack_header.rnt_ptr;
	count = 1;				/* count of elements in pointer array */
	firstarg = 1;
	if arg.number < 1 | arg.number >= hbound (search_rules, 1) then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	call lock$lock_fast (addr (ahd$search_rules_lock));
	if arg.name (1) = "default" then do;
	     call process_rule ("default", 0, code);	/* Get all rules tagged "default" */
	     if code ^= 0 then go to fin;		/* .. might have changed since proc created */
	     count = count + 1;
	     go to thru;
	end;

	if arg.name (1) = "set_search_directories" then do; /* Set default rules but with extras after wdir */
	     call process_rule ("default", 0, code);	/* Expand default rules */
	     if code ^= 0 then go to fin;
	     search_rule_temp (count + 1).offset = END_RULE; /* Flag end of list */
	     do count = 1 to hbound (search_rules, 1) while (search_rule_temp (count).offset ^= WDIR_RULE); end;
	     if count > hbound (search_rules, 1) then go to too_many_err;
	     ssd_wdir_index, count = count + 1;		/* Note pos of wdir */
	     ssd_dft_rules = search_rule_temp;		/* Save spare copy of defaults */
	     firstarg = 2;				/* Scan from rule 2 on */
	end;

	do i = firstarg to arg.number;		/* Scan strings in user input */
	     call process_rule (arg.name (i), 0, code);	/* Expand each rule */
	     if code = 1 then i = arg.number;		/* Force end of loop */
	     else if code ^= 0 then go to fin;

	     count = count + 1;
	     if count > hbound (search_rules, 1) then go to too_many_err; /* too many search rules */
	end;

	if arg.name (1) = "set_search_directories" then do; /* Did user rules, now finish sandwich */
	     do i = ssd_wdir_index to hbound (search_rules, 1); /* Finish copy of default search rules */
		if count > hbound (search_rules, 1) then go to too_many_err;
		search_rule_temp (count) = ssd_dft_rules (i);
		if search_rule_temp (count).offset = END_RULE then go to thru;
		count = count + 1;
	     end;
	     go to too_many_err;			/* shouldn't get here */
	end;

/* Insert search termination code */

thru:	search_rule_temp (count).uid = "0"b;		/* Put in an end marker */
	search_rule_temp (count).base = "0"b;
	search_rule_temp (count).offset = END_RULE;	/* insert the code */

/* check if space allocated for these search rules (this ring) */

	srp = rnt.srulep;				/* ptr to list for current ring */
	if srp = null then do;			/* First time in a virgin ring */
	     allocate search_rules in (rnt.areap -> based_area) set (srp);
	     rnt.srulep = srp;			/* put it in pointer list */
	end;
	else do i = 1 to hbound (search_rules, 1) while (search_rules (i).offset ^= END_RULE);
	     if search_rules (i).uid ^= "0"b then do;	/* Must decrement usage counts of old rules */
		segnum = binary (search_rules (i).base, 18);
		call get_kstep (segnum, kstep, xcode);
		if xcode = 0
		     then if search_rules (i).uid = kste.uid
		     then do;
			call dc_find$obj_terminate_ptr (baseptr (segnum), old_ep, xcode); /* audit termination */
			if xcode = 0 then  call lock$dir_unlock (ptr (old_ep, 0));
			if xcode = error_table_$root then xcode = 0;
			if xcode = 0 then call segno_usage$decrement (segnum, (0));
		     end;
	     end;
	end;

	search_rules = search_rule_temp;		/* Copy search rules into KST */

fin:	call lock$unlock_fast (addr (ahd$search_rules_lock));
	a_code = code;
	return;

too_many_err: code = error_table_$too_many_sr;
	go to fin;
%page;

/* This entry is called from the initializer to set the system default search rules */

set_system_rules: entry (sysptr, syscode);
	xsp = sysptr;
	syscode = 0;
	i = dft_sr_arg.ntags;
	if i > hbound (dft_sr_arg.tags, 1) then do;
	     syscode = error_table_$bad_arg;
	     return;
	end;
	count = dft_sr_arg.nrules;
	if count > hbound (dft_sr_arg.rules, 1) then do;
	     syscode = error_table_$bad_arg;
	     return;
	end;
	call lock$lock_fast (addr (ahd$search_rules_lock)); /* Nobody use whilst i am changing */
	ahd$n_sys_rules = count;
	ahd$n_sr_tags = i;
	ahd$n_sys_rules = dft_sr_arg.nrules;
	do i = 1 to ahd$n_sr_tags;
	     ahd$sr_tag (i).name = dft_sr_arg.tags (i).name;
	     ahd$sr_tag (i).flag = dft_sr_arg.tags (i).flag;
	end;
	do i = 1 to ahd$n_sys_rules;
	     ahd$search_rule (i).name = dft_sr_arg.rules (i).name;
	     ahd$search_rule (i).flag = dft_sr_arg.rules (i).flag;
	end;
	call lock$unlock_fast (addr (ahd$search_rules_lock));
	return;

/* This entry returns them to the user */

get_system_rules: entry (sysptr, syscode);

	syscode = 0;
	xsp = sysptr;
	call lock$lock_fast (addr (ahd$search_rules_lock));
	do i = 1 to ahd$n_sr_tags;
	     dft_sr_arg.tags (i).name = ahd$sr_tag (i).name;
	     dft_sr_arg.tags (i).flag = ahd$sr_tag (i).flag;
	end;
	do i = 1 to ahd$n_sys_rules;
	     dft_sr_arg.rules (i).name = ahd$search_rule (i).name;
	     dft_sr_arg.rules (i).flag = ahd$search_rule (i).flag;
	end;
	dft_sr_arg.ntags = ahd$n_sr_tags;
	dft_sr_arg.nrules = ahd$n_sys_rules;
	call lock$unlock_fast (addr (ahd$search_rules_lock));
	return;
%page;
process_rule: proc (dn, depth, code);

dcl  code				fixed bin (35) parameter;
dcl  depth			fixed bin parameter;
dcl  dn				char (168) parameter;

dcl  j				fixed bin;
dcl  jj				fixed bin;
dcl  nfound			fixed bin;

	code, nfound = 0;
	search_rule_temp (count).base = "0"b;
	search_rule_temp (count).offset = "0"b;
	search_rule_temp (count).uid = "0"b;

	if substr (dn, 1, 1) = ">" then do;
	     call initiate_name;
	end;

	else if dn = search_rule_names (1) then do;	/* "initiated_segments" */
	     search_rule_temp (count).offset = INITIATED_RULE; /* search KST code */
	end;

	else if dn = search_rule_names (2) then do;	/* "referencing_dir" */
	     search_rule_temp (count).offset = REFERENCING_DIR_RULE; /* parent of referencing proceedure search */
	end;

	else if dn = search_rule_names (3) then do;	/* "working_dir" */
	     search_rule_temp (count).offset = WDIR_RULE; /* search working directory code */
	end;

	else if dn = "process_dir" then do;		/* process directory */
	     dn = pds$process_dir_name;
	     call initiate_name;
	end;

	else if dn = "home_dir" then do;		/* home or login directory */
	     dn = pds$home_dir;
	     call initiate_name;
	end;

	else if dn = search_rule_names (4) then do;	/* End of rules */
	     code = 1;				/* Force end of loop */
	end;

	else do;					/* Unrecognized. */
	     if depth = 0 then do;			/* Keyword ok? */
		do j = 1 to ahd$n_sr_tags while (dn ^= ahd$sr_tag (j).name); end;
		if j <= ahd$n_sr_tags then do;
		     do jj = 1 to ahd$n_sys_rules;
			if (ahd$search_rule (jj).flag & ahd$sr_tag (j).flag) ^= "0"b then do;
			     call process_rule (ahd$search_rule (jj).name, 1, code);
			     if code ^= 0 then return;
			     nfound = nfound + 1;
			     count = count + 1;
			end;
		     end;
		     if nfound = 0 then code = 2;
		     else count = count - 1;		/* count incr by loop above once more than req'd */
		     return;
		end;
	     end;
	     code = error_table_$bad_string;
	end;

	return;

initiate_name: proc;

	     call dc_find$dir_initiate (dn, dp, code);
	     if code = 0 then do;
		segnum = segno (dp);
		search_rule_temp (count).base = bit (binary (segnum, 18), 18); /* put away base of pointer */
		search_rule_temp (count).uid = dp -> dir.uid; /* store uid */
		call lock$dir_unlock (dp);		/* don't dereference dir */
	     end;
	     else if new_ring then do;		/* new ring so do best we can */
		code = 0;
		search_rule_temp (count).offset = BAD_RULE; /* special code for bad entry during proc init */
	     end;
	     return;
	end initiate_name;

     end process_rule;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include kst;
%page; %include rnt;
%page; %include search_rule_flags;
%page; %include stack_header;
%page; %include system_dft_sr;
     end initiate_search_rules;




		    ips_.alm                        11/11/89  1132.4rew 11/11/89  0800.5       92349



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

" HISTORY COMMENTS:
"  1) change(87-09-03,GDixon), approve(87-09-10,MECR0006),
"     audit(87-09-30,Farley), install(87-09-10,MR12.1-1104):
"      A) Change $reset_ips_mask to only reset the mask if the control bit
"         is on in the incoming mask.  Otherwise, it will only return the
"         current mask value.
"  2) change(87-10-07,GDixon), approve(87-10-07,MCR7770),
"     audit(87-11-02,Farley), install(87-11-30,MR12.2-1004):
"      A) Formally install changes covered by MECR0006 (change 1 above).
"                                                      END HISTORY COMMENTS

" Name:  ips_
" 
"      The procedure "ips_" controls the enabling and disabling of
" interprocess signal (IPS) interrupts.  Each ring of each process
" has an IPS mask and an automatic IPS mask stored in the "pds".
" Individual bits of the mask words correspond to specific IPS
" interrupts.  The correspondence is defined by the procedure
" "create_ips_mask_".  The following "ips_" entries inspect or
" modify the IPS mask or the automatic IPS mask of the calling
" process's current validation level.  Entries that change a mask
" return the former value of the mask.  The entries are all
" accessible via the hardcore gate "hcs_".
" 
"      The last (thirty-sixth) bit of an IPS mask does not
" correspond to an interrupt, but is instead a control bit.  The
" control bit of each IPS mask and each automatic IPS mask stored
" in the "pds" is always zero.  On mask values input to procedure
" "ips_", the control bit is ignored.  On masks returned from
" "ips_", the control bit is set to either "0"b or "1"b, as
" specified in the individual entry descriptions below, to notify
" the user that the requested action has been performed.  No
" process interrupts can occur in the time interval between the
" requested mask modification and the return of the old mask and
" control bit.  Hence, each call on an "ips_" entry behaves as an
" atomic operation.
" 
" 
" 
" Entry:  ips_$get_ips_mask
" 
"      This entry returns the value of the current IPS mask without
" modifying it.  The control bit is returned as "0"b.
" 
" Usage:
" 
" dcl ips_$get_ips_mask entry(bit(36)aligned);
" 
" call ips_$get_ips_mask(oldmask);
" 
" 1) oldmask          is the current value of the IPS mask, with a
"                     control bit of "0"b (output).
" 
" 
" 
" Entry:  ips_$set_ips_mask
" 
"      This entry replaces the entire IPS mask with a supplied
" value and returns the previous value of the mask with a control
" bit of "1"b.
" 
" Usage:
" 
" dcl ips_$set_ips_mask entry(bit(36)aligned,bit(36)aligned);
" 
" call ips_$set_ips_mask(mask,oldmask);
" 
" 1) mask             is the new value to replace the IPS mask
"                     (input).
" 
" 2) oldmask          is the former value of the IPS mask, with a
"                     control bit of "1"b (output).
" 
" 
" 
" Entry:  ips_$reset_ips_mask
" 
"      This entry is exactly the same as "ips_$set_ips_mask" except
" that the control bit in the returned former mask is "0"b.  These
" two entries can be used to bracket sections of critical code
" during which interrupts must be masked.  The control bit then
" serves as rigorous identification of whether control is in a
" critical section.
" 
" Usage:
" 
" dcl ips_$reset_ips_mask entry(bit(36)aligned,bit(36)aligned);
" 
" call ips_$reset_ips_mask(mask,oldmask);
" 
" 1) mask             is the new value to replace the IPS mask
"                     (input).
" 
" 2) oldmask          is the former value of the IPS mask, with a
"                     control bit of "0"b (output).
" 
" 
" 
" Entry:  ips_$unmask_ips
" 
"      This entry disables specified IPS interrupts.  Bits in the
" supplied mask value cause corresponding bits of the IPS mask to
" be reset.  The former value of the IPS mask is returned with a
" control bit of "1"b.  Warning: for historical reasons, this entry
" is misnamed (it masks rather than unmasks).
" 
" Usage:
" 
" dcl ips_$unmask_ips entry(bit(36)aligned,bit(36)aligned);
" 
" call ips_$unmask_ips(mask,oldmask);
" 
" 1) mask             for each bit on in this word, the
"                     corresponding bit in the IPS mask is turned
"                     off--i.e., the corresponding IPS interrupt is
"                     disabled (input).
" 
" 2) oldmask          is the former value of the IPS mask, with a
"                     control bit of "1"b (output).
" 
" 
" 
" Entry:  ips_$mask_ips
" 
"      This entry enables specified IPS interrupts.  Bits in the
" supplied mask value cause corresponding bits of the IPS mask to
" be set.  The former value of the IPS mask is returned with a
" control bit of "0"b.  Entry "ips_$unmask_ips" and this entry can
" be used to bracket sections of critical code during with certain
" interrupts must be masked.  The control bit then serves as
" rigorous identification of whether control is in a critical
" section.  Warning: for historical reasons, this entry is misnamed
" (it unmasks rather than masks).
" 
" Usage:
" 
" dcl ips_$mask_ips entry(bit(36)aligned,bit(36)aligned);
" 
" call ips_$mask_ips(mask,oldmask);
" 
" 1) mask             for each bit on in this word, the
"                     corresponding bit in the IPS mask is turned
"                     on--i.e., the corresponding IPS interrupt is
"                     enabled (input).
" 
" 2) oldmask          is the former value of the IPS mask, with a
"                     control bit of "0"b (output).
" 
" 
" 
" Entry:  ips_$set_automatic_ips_mask
" 
"      This entry replaces the entire automatic IPS mask with a
" supplied value and returns the previous value of the mask with a
" control bit of "1"b.
" 
" Usage:
" 
" dcl ips_$set_automatic_ips_mask
" entry(bit(36)aligned,bit(36)aligned);
" 
" call ips_$set_automatic_ips_mask(mask,oldmask);
" 
" 1) mask             is the new value to replace the automatic IPS
"                     mask (input).
" 
" 2) oldmask          is the former value of the automatic IPS
"                     mask, with a control bit of "1"b (output).
"
"
"
"
"	Modified August 1981 by J. Bongiovanni for IPS signals to take
"		immediately when unmasked (or shortly thereafter)
"

	entry	get_ips_mask		Inspect IPS mask without changing it.
	entry	set_ips_mask		Replace entire IPS mask.
	entry	reset_ips_mask		Replace entire IPS mask.
	entry	unmask_ips		Disable specific IPS interrupts.
	entry	mask_ips			Enable specific IPS interrupts.
	entry	set_automatic_ips_mask	Replace entire auto IPS mask.
"
"
"
" Entry:  ips_$get_ips_mask(oldmask)
"
get_ips_mask:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$ips_mask,7		Save old IPS mask in the Q.
	anq	=o777777777776		Make sure control bit is 0.
	stq	ap|2,*			Pass it back to caller.
	short_return			Return to caller.
"
"
"
" Entry:  ips_$set_ips_mask(mask,oldmask)
"
set_ips_mask:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$ips_mask,7		Save old IPS mask in the Q.
	lda	ap|2,*			Caller's desired new mask.
	ana	=o777777777776		Control bit must be off.
	sta	pds$ips_mask,7		Set new IPS mask.
ret1:	orq	=o1,dl			Set control bit 1 in old mask.
	stq	ap|4,*			Pass it back to caller.
	tra	check_ips_pending		Make pending, unmasked IPS take
"					And return to caller.
"
"
"
" Entry:  ips_$reset_ips_mask(mask,oldmask)
"
reset_ips_mask:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$ips_mask,7		Save old IPS mask in the Q.
	lda	ap|2,*			Caller's desired new mask.
	cana	1,dl			Check if control bit is on.
	tze	ret0			No, don't reset mask.
	ana	=o777777777776		Control bit must be off.
	sta	pds$ips_mask,7		Set new IPS mask.
ret0:	anq	=o777777777776		Set control bit 0 in old mask.
	stq	ap|4,*			Pass it back to caller.
	tra	check_ips_pending		Make pending, unmasked IPS take
"					And return to caller.
"
"
"
" Entry:  ips_$unmask_ips(mask,oldmask)
"
unmask_ips:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$ips_mask,7		Save old IPS mask in the Q.
	lda	ap|2,*			Get bits to be cleared.
	era	=o777777777776		Change bits to zeros for logical AND.
	ansa	pds$ips_mask,7		Clear selected bits of IPS mask.
	tra	ret1			Return old mask with control bit 1.
"
"
"
" Entry:  ips_$mask_ips(mask,oldmask)
"
mask_ips:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$ips_mask,7		Save old IPS mask in the Q.
	lda	ap|2,*			Get bits to be set.
	ana	=o777777777776		Control bit must remain off.
	orsa	pds$ips_mask,7		Set selected bits of IPS mask.
	tra	ret0			Return old mask with control bit 0.
"
"
"
" Entry:  ips_$set_automatic_ips_mask(mask,oldmask)
"
set_automatic_ips_mask:
	lxl7	pds$validation_level	Validation level to X7.
	ldq	pds$auto_mask,7		Save old auto IPS mask in the Q.
	lda	ap|2,*			Caller's desired new mask.
	ana	=o777777777776		Control bit must be off.
	sta	pds$auto_mask,7		Set new auto IPS mask.
	tra	ret1			Return old auto mask with control bit 1.
"
"
"
"
"	Internal procedure to check for pending IPS signals which are unmasked
"	as a result of this call.  If any are found, ring_alarm is called
"	to determine and set an appropriate value of the ring_alarm register
"	so that the recently unmasked IPS signal will take within a short
"	amount of time.
"
"	On entry, x7 = current validation level
"
"	This routine will exit to the caller of ips_
"

check_ips_pending:
	eppbp	pds$apt_ptr,*		bp -> APTE for this process
	lda	bp|apte.ips_message		Get pending IPS signals
	ana	pds$ips_mask,7		Check for unmasked in ring of validation
	tnz	set_ring_alarm		Pending IPS found
	short_return			None found -- return to caller
set_ring_alarm:
	push			        "	For call out
	call	ring_alarm$reset
	return				Return to caller
"
	include	apte

	end




		    kst_info.pl1                    11/11/89  1132.4r w 11/11/89  0800.5       20313



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

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

kst_info: proc;

/*

   Written July 7, 1976 by Richard Bratt

   Last Modified:
   8/26/76 by M. Weaver  to add high_low_seg_count entry
   11/1/84 by K. Loepere to remove hdr.

   This module contains entries to extract information from a process' KST.
   These entries may be called by hardcore gates

   --->  get_uid (segptr, uid, code)

   This entry translates a segment number (represented as a segptr) into the unique identifier
   of the object to which the segment number is bound.

*/


get_uid: entry (a_segptr, a_uid, a_code);

/* Parameters */

dcl  a_code			fixed bin (35, 0) parameter;
dcl  a_hcsc			fixed bin (17) parameter;
dcl  a_high_seg			fixed bin (17) parameter;
dcl  a_segptr			ptr parameter;
dcl  a_uid			bit (36) aligned parameter;

/* Variables */

dcl  code				fixed bin (35, 0);
dcl  segptr			ptr;

/* Entries */

dcl  get_kstep			entry (fixed bin (17), ptr, fixed bin (35));

/* Misc */

dcl  segno			builtin;
%page;
	segptr = a_segptr;
	a_uid = "0"b;
	call get_kstep (segno (segptr), kstep, code);
	if code ^= 0 then do;
	     a_code = code;
	     return;
	end;

	a_uid = kste.uid;
	a_code = 0;
	return;
%page;
high_low_seg_count: entry (a_high_seg, a_hcsc);


/* 1) high_seg	the number to add to hcsc to get the highest segment number being used.

   2) hcsc	is the lowest non-hardcore segment number.
*/

	kstp = pds$kstp;

	a_hcsc = kstp -> kst.lowseg;

	a_high_seg = kstp -> kst.highest_used_segno - kstp -> kst.lowseg;

	return;
%page; %include kst;
     end kst_info;




		    level_0_.pl1                    11/11/89  1132.4rew 11/11/89  0800.6       36666



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


level_0_: proc;

/* This a program to set the level to 0 before call the access primitives. */
/* Last modified 01/11/79 by C. D. Tavares to add dir_ring_brackets code */
/* Modified 04/26/82 by S Krupp to change declaration of dname and
   ename to char(*). */

dcl  dname char (*),
     ename char (*),
     aptr ptr,
     acount fixed bin,
     dbit bit (1) aligned,				/* daemon bit */
     code fixed bin (35),
     dir_ring_brackets (2) fixed bin (5),
     ring_brackets (3) fixed bin (5),
     esw fixed bin,
     save_level fixed bin;

dcl  level$get entry (fixed bin),
     level$set entry (fixed bin),
     asd_$add_sentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)),
     asd_$add_dentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)),
     asd_$replace_sall entry (char (*), char (*), ptr, fixed bin (17), bit (1) aligned, fixed bin (35)),
     asd_$replace_dall entry (char (*), char (*), ptr, fixed bin (17), bit (1) aligned, fixed bin (35)),
     asd_$del_sentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)),
     asd_$del_dentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)),
     ringbr_$set entry (char (*), char (*), (3) fixed bin (5), fixed bin (35)),
     ringbr_$set_dir entry (char (*), char (*), (2) fixed bin (5), fixed bin (35)),
     delentry$priv_dfile entry (char (*), char (*), fixed bin (35));


add_acl_entries: entry (dname, ename, aptr, acount, code);

	esw = 0;					/* add name or names to acl */
	go to start;

add_dir_acl_entries: entry (dname, ename, aptr, acount, code);

	esw = 1;					/* add name or names to dir acl */
	go to start;

replace_acl: entry (dname, ename, aptr, acount, dbit, code);

	esw = 2;					/* replace acls */
	go to start;

replace_dir_acl: entry (dname, ename, aptr, acount, dbit, code);

	esw = 3;					/* replace for a dir */
	go to start;

delete_acl_entries: entry (dname, ename, aptr, acount, code);

	esw = 4;					/* delete acls */
	go to start;

delete_dir_acl_entries: entry (dname, ename, aptr, acount, code);

	esw = 5;					/* delete for a dir */
	go to start;

set_ring_brackets: entry (dname, ename, ring_brackets, code);

	esw = 6;					/* modify the ring brackets */
	go to start;

set_dir_ring_brackets: entry (dname, ename, dir_ring_brackets, code);

	esw = 7;					/* modify the dir ring brackets */
	go to start;

delentry_file: entry (dname, ename, code);

	esw = 8;					/* delete a segment */
	goto start;

start:
	call level$get (save_level);			/* save the current level */
	call level$set (0);				/* set it to zero */

	if esw = 0 then call asd_$add_sentries (dname, ename, aptr, acount, code);
	else if esw = 1 then call asd_$add_dentries (dname, ename, aptr, acount, code);
	else if esw = 2 then call asd_$replace_sall (dname, ename, aptr, acount, dbit, code);
	else if esw = 3 then call asd_$replace_dall (dname, ename, aptr, acount, dbit, code);
	else if esw = 4 then call asd_$del_sentries (dname, ename, aptr, acount, code);
	else if esw = 5 then call asd_$del_dentries (dname, ename, aptr, acount, code);
	else if esw = 6 then call ringbr_$set (dname, ename, ring_brackets, code);
	else if esw = 7 then call ringbr_$set_dir (dname, ename, dir_ring_brackets, code);
	else if esw = 8 then call delentry$priv_dfile (dname, ename, code);

	call level$set (save_level);			/* restore the proper level */

	return;

     end;




		    link_man.pl1                    11/11/89  1132.4rew 11/11/89  0800.0      151875



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



/****^  HISTORY COMMENTS:
  1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
     audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222):	
     initialize the heap_header_ptr to null in get_initial_linkage.
  2) change(86-10-01,Fawcett), approve(86-10-01,MCR7473),
     audit(86-10-22,Farley), install(86-11-03,MR12.0-1206):
     Changed to eliminate stack_header.old_lot_ptr, this obsolete ptr was
     replaced by stack_header.cpm_data_ptr for Control Point Management.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
link_man$other_linkage:
     proc (atxp, alp, astp, asymbp, acode);

/* LINK_MAN
   "

   This program is the utility program used by the Multics ring 0 linker.


   Last modified (date and reason):

   9/20/74 by S.Webber Complete rewrite from an earlier version as part
   of combining stacks, lots, and clr's.

   rewritten 8/76 by M. Weaver to turn linkage regions into areas.
   modified 4/77 by M. Weaver to add entry combine_linkage for lot_fault_handler_
   modified 5/77 by M. Weaver to process perprocess_static bit
   modified 9/77 by M. Weaver to change assign_linkage to use assign_linkage_ptr
   modified 2/78 by M. Weaver to grow lot at correct boundary
   Modified April 1981 by J. Bongiovanni to fix recursive grow_lot bug
   Modified May, 1981, Charlie Hornig, to convert for ADP SDW formats
   Modified August 1981, E. N. Kittlitz per S. Harris (UNCA), check lot size in getlp
   Modified 83-12-08 BIM to flush support for .link segments, once and for all.
   Modified April 10, 1984 by M. Weaver to check ring arg in $combine_linkage
   Modified 84-07-02 BIM to check ring arg in grow_lot.
   Modified 85-01-22 Keith Loepere to increment usage count for segment in
   target ring when its linkage is combined.
*/

/* Parameters */

dcl  acode fixed bin (35);
dcl  alp ptr;
dcl  aring fixed bin;
dcl  astp ptr;
dcl  asymbp ptr;
dcl  atxp ptr;

/* Automatic */

dcl  1 ainfo aligned like area_info;
dcl  cl fixed bin (14);
dcl  cl_sw bit (1) aligned;
dcl  code fixed bin (35);
dcl  count fixed bin (24);
dcl  dummy bit (36) aligned;
dcl  lp ptr;
dcl  nwords fixed bin (18);
dcl  1 oi like object_info;
dcl  ring fixed bin;
dcl  rings (3) fixed bin;
dcl  1 sdwi aligned like sdw_info;
dcl  sp ptr;
dcl  stack_end fixed bin (18);
dcl  stp ptr;
dcl  target fixed bin;
dcl  target_sp ptr;
dcl  tcode fixed bin (35);
dcl  txp ptr;
dcl  type fixed bin (2);

/* Entries */

dcl  define_area_ entry (ptr, fixed bin (35));
dcl  level$get entry returns (fixed bin);
dcl  makestack entry (fixed bin);
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  sdw_util_$dissect entry (ptr, ptr);
dcl  segno_usage$increment_other_ring entry (fixed bin, fixed bin, fixed bin (35));
dcl  status_$mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  terminate_proc entry (fixed bin (35));

/* External */

dcl  dseg$ (0:1) fixed bin (71) ext;
dcl  error_table_$bad_segment fixed bin (35) ext;
dcl  error_table_$badringno fixed bin (35) ext;
dcl  error_table_$invalidsegno fixed bin (35) ext;
dcl  error_table_$no_linkage fixed bin (35) ext;
dcl  error_table_$noalloc fixed bin (35) ext;
dcl  error_table_$nrmkst fixed bin (35) ext;
dcl  error_table_$termination_requested fixed bin (35) ext;
dcl  pds$clr_stack_size (0:7) fixed bin (18) ext;
dcl  pds$lot_stack_size (0:7) fixed bin (17) ext;
dcl  pds$max_lot_size (0:7) fixed bin (17) ext;
dcl  pds$stacks (0:7) ptr ext;
dcl  sys_info$max_seg_size ext fixed bin (19);

/* Builtins */

dcl  (addr, addrel, baseno, bin, bit, divide, max, mod, null, ptr, size, segno, string, substr, wordno) builtin;

/* Conditions */

dcl  area condition;
dcl  cleanup condition;

/* Based */

dcl  based_area area (100) based;
dcl  based_array (nwords) bit (36) aligned based;
dcl  based_ptr ptr based;
dcl  based_word fixed bin based;
dcl  linkage_section (oi.llng) bit (36) aligned based;
dcl  static_section (oi.ilng) bit (36) aligned based;
%page;
/* EXECUTION OF LINK_MAN$OTHER_LINKAGE BEGINS HERE */

	cl_sw = "0"b;
	acode = 0;
	txp = atxp;
	alp = null;
	astp = null;
	asymbp = null;

	ring = level$get ();

/* Now get the target ring of the linkage fault, i.e. the ring in which
   the snapped link will be relevant */

/* The following  sequence of code (through the reference to sdw.r3) should be
   replaced by a call to fs_get$brackets when that entry becomes efficient */

retry:
	code = txp -> based_word;			/* touch the segment to make SDW valid */
	call sdw_util_$dissect (addr (dseg$ (segno (txp))), addr (sdwi));
	if sdwi.faulted
	then					/* try again */
	     goto retry;

	cl = sdwi.gate_entry_bound + 1;		/* get offset of linkage pointer in ring zero gates */
	rings (1) = bin (sdwi.r1, 3);			/* copy ring numbers */
	rings (2) = bin (sdwi.r2, 3);
	rings (3) = bin (sdwi.r3, 3);

	if ring < rings (1)
	then target = rings (1);			/* calculate target ring ... */
	else if ring > rings (2)
	     then target = rings (2);
	     else target = ring;

	if target = 0 then do;			/* snapping a link to hardcore gate */
	     alp = ptr (txp, cl + mod (cl, 2)) -> based_ptr;
						/* fetch linkage pointer from text */
	     return;				/* that's all for hardcore gates */
	     end;

	target_sp = get_sp (target);

	lp = null;
	call getlp (target_sp, txp, lp, stp);
	if lp ^= null then do;			/* yes, just return */
ret:
	     alp = lp;
	     astp = stp;
	     asymbp = lp -> header.symbol_ptr;
	     addr (alp) -> its_unsigned.ringno = target;	/* So we can link to gates */
	     return;
	     end;
cl_join:
	call status_$mins (txp, type, count, code);	/* get bit count for object info call */
	if code ^= 0 then goto error;

	code = error_table_$bad_segment;
	oi.version_number = object_info_version_2;	/* set version number of structure */
	oi.symbp = null;				/* in case object_info_ doesn't fill it in */
	if count > 0 then call object_info_$brief (txp, count, addr (oi), code);
	if code = error_table_$bad_segment then do;	/* all format flags are turned off */
	     acode = error_table_$no_linkage;
	     return;
	     end;
	else if code ^= 0 then do;
error:
		acode = code;
		return;
		end;

	tcode = 1;

	if oi.linkp -> its.its_mod = "100011"b
	then lp, stp = oi.linkp;			/* .link segment; pre-initialized when created */

	else do;
	     on area call terminate_proc (error_table_$noalloc);
	     allocate linkage_section in (target_sp -> stack_header.clr_ptr -> based_area) set (lp);
	     dummy = lp -> linkage_section (oi.llng);	/* avoid bounds fault during EIS copy */
	     lp -> linkage_section = oi.linkp -> linkage_section;
	     lp -> header.original_linkage_ptr = oi.linkp;

	     if lp -> virgin_linkage_header.first_ref_relp
	     then lp -> virgin_linkage_header.first_ref_relp = "000000000001000000"b;
						/* replace offset with flag */

	     if oi.separate_static then do;		/* must copy static separately */
		lp -> header.stats.static_length = bit (bin (oi.ilng, 18), 18);
		allocate static_section in (target_sp -> stack_header.combined_stat_ptr -> based_area) set (stp);
		dummy = stp -> static_section (oi.ilng);/* avoid bounds fault during EIS copy */
		stp -> static_section = oi.statp -> static_section;
		end;
	     else do;				/* combined static already copied */
		lp -> header.stats.static_length =
		     bit (bin (bin (lp -> header.stats.begin_links, 18) - size (header), 18), 18);
						/* static section is between header & first link */
		stp = lp;
		end;
	     lp -> header.stats.segment_number = baseno (txp);
	     lp -> header.symbol_ptr = oi.symbp;
	     end;

	call setlp (txp, lp, stp, target);
	substr (lp -> its.pad2, 9, 1) = oi.perprocess_static;
						/* set flag in 1st word of def_ptr for run unit manager */
	if cl_sw then return;			/* no output arguments for this entry */
	goto ret;
%page;
combine_linkage:
     entry (atxp, aring, acode);

/* This entry is available through hcs_ and is intended for the lot_fault handler */

	cl_sw = "1"b;
	txp = atxp;
	target = aring;
	if target ^= level$get () then do;		/* caller must set level to correct ring */
	     acode = error_table_$badringno;
	     return;
	     end;
	target_sp = get_sp (target);
	acode = 0;
	lp = null;

	goto cl_join;
%page;
own_linkage:
     entry (atxp, alp, astp, asymbp, acode);

/* Entry to return information about a segment and its linkage which has
   been set up earlier in the process */

	acode = 0;
	txp = atxp;
	alp, astp, asymbp = null;

	ring = level$get ();
	sb = get_sp (ring);
	call getlp (sb, txp, lp, stp);
	if lp = null then do;
	     acode = error_table_$no_linkage;
	     return;
	     end;
	;
	alp = lp;
	astp = stp;
	asymbp = lp -> header.symbol_ptr;
	return;
%page;
/* SET_LP
   "
*/

set_lp:
     entry (atxp, alp);

/* This entry is obsolete. It is used by the trap-before-link stuff, however, and must be supported.
   The callers of the entry must assume that no separate static will be allocated, hence, the
   static pointer passed to setlp is the same as the linkage pointer. */

	ring = level$get ();
	call setlp (atxp, alp, alp, ring);
	return;
%page;
/* GET_LP
   "
*/

get_lp:
     entry (atxp, alp);				/* OBSOLETE */

	ring = level$get ();			/* get caller's validation level */
	sb = get_sp (ring);
	call getlp (sb, atxp, alp, (null));
	return;
%page;
/* ASSIGN_LINKAGE
   "
*/

assign_linkage:
     entry (aamount, rp, rcode);

dcl  aamount fixed bin (18);
dcl  rcode fixed bin (35);
dcl  rp ptr;

	rcode = 0;
	rp = null;

	on area go to a_l_error;

	sb = get_sp ((level$get ()));
	nwords = aamount;
	allocate based_array in (sb -> stack_header.assign_linkage_ptr -> based_area) set (rp);
						/* must go in same seg as ipc static */

	return;

a_l_error:
	rcode = error_table_$noalloc;
	return;
%page;
/* GET_INITIAL_LINKAGE
   "
*/

get_initial_linkage:
     entry (aring);

/* This entry is called only by makestack when a new ring is being created. The program makestack
   may have been called by link_man. */

	sp = pds$stacks (aring);
	stack_end = wordno (sp -> stack_header.stack_end_ptr);

/* allocate space for lot in stack */

	nwords = pds$lot_stack_size (aring);
	if nwords = 0 then nwords = 512;		/* force 512 word lot in stack */
	lotp = sp;				/* unused part of lot overlays stack header */
	sp -> stack_header.cur_lot_size = nwords;
	stack_end = max (stack_end, nwords * 2);	/* the "2"  is for isot as well as lot */
	stack_end = divide (stack_end + 15, 16, 17, 0) * 16;
						/* round up */

/* set up linkage section area */

	if pds$clr_stack_size (aring) > 0 then do;	/* initial area is in stack */
	     ainfo.size = pds$clr_stack_size (aring);
	     ainfo.areap = ptr (sp, stack_end);
	     stack_end = stack_end + ainfo.size;	/* update length of stack */
	     stack_end = divide (stack_end + 15, 16, 17, 0) * 16;
						/* round up */
	     end;
	else do;					/* clr is to go into separate seg */
	     ainfo.size = sys_info$max_seg_size;
	     ainfo.areap = null;
	     end;

	ainfo.version = area_info_version_1;
	string (ainfo.control) = "0"b;
	ainfo.control.extend = "1"b;
	ainfo.control.zero_on_free = "1"b;
	ainfo.control.system = "1"b;
	ainfo.owner = "linker";
	call define_area_ (addr (ainfo), code);
	if code ^= 0 then call terminate_proc (error_table_$termination_requested);

	sp -> stack_header.max_lot_size = pds$max_lot_size (aring);
	sp -> stack_header.stack_end_ptr = ptr (sp, stack_end);
	sp -> stack_header.stack_begin_ptr = ptr (sp, stack_end);
	sp -> stack_header.lot_ptr = lotp;
	sp -> stack_header.isot_ptr = addrel (lotp, sp -> stack_header.cur_lot_size);
	sp -> stack_header.sct_ptr = addrel (lotp, sp -> stack_header.cur_lot_size);
	sp -> stack_header.system_free_ptr, sp -> stack_header.user_free_ptr, sp -> stack_header.assign_linkage_ptr,
	     sp -> stack_header.clr_ptr, sp -> stack_header.combined_stat_ptr = ainfo.areap;
	sp -> stack_header.heap_header_ptr = null;
	sp -> stack_header.sys_link_info_ptr = null;
	return;
%page;
grow_lot:
     entry (a_ring);

/* This entry is for initiate to call if it needs to before setting a lot_fault */

dcl  a_ring fixed bin (3);

dcl  grow_lot_invalid_ring_ condition;

	ring = a_ring;
	if ring ^= level$get () then signal grow_lot_invalid_ring_;
	call make_lot (ring);
	return;
%page;
setlp:
     proc (txp, lp, stp, ring);

dcl  lp ptr;
dcl  ring fixed bin;
dcl  stp ptr;
dcl  txp ptr;

dcl  segnum fixed bin;
dcl  shp ptr;

	shp = get_sp (ring);
	segnum = segno (txp);
	if segnum >= shp -> stack_header.cur_lot_size then do;
	     if segnum > shp -> stack_header.max_lot_size then do;
		code = error_table_$invalidsegno;
		go to error;
		end;
	     call make_lot (ring);			/* new lot will be max lot size */
	     end;

	call segno_usage$increment_other_ring (segnum, ring, code);
						/* setting linkage for segment in target ring is a good
						   reason to hold segment - prevents termination of lower ring gates */

	shp -> stack_header.lot_ptr -> lot.lp (segnum) = lp;
	shp -> stack_header.isot_ptr -> isot.isp (segnum) = stp;
	if baseno (lp) = "0"b then return;		/* just zeroing slot */

/* don't disturb flags in lower half of 2nd word in linkage header */

	if lp -> its.its_mod = "100011"b
	then return;				/*  def ptr already set */
	else if lp -> its.its_mod = "0"b
	     then lp -> its_unsigned.segno = segno (txp); /* defs in text */
	     else do;				/* defs in linkage after links */
		lp -> its_unsigned.segno = segno (lp);
		lp -> its_unsigned.offset = lp -> its_unsigned.offset + wordno (lp);
		end;
	lp -> its.its_mod = "100011"b;		/* turn it into a pointer */
	return;

     end setlp;
%page;
getlp:
     proc (gsp, gtxp, glp, gstp);

dcl  (glp, gsp, gstp, gtxp) ptr;
dcl  segnum fixed bin;

	glp, gstp = null;				/* assume the worst */
	segnum = segno (gtxp);
	if segnum >= gsp -> stack_header.cur_lot_size then return;
						/* lot isn't that big in this ring */
	if baseno (gsp -> stack_header.lot_ptr -> lot.lp (segnum))
						/* non-zero lot entry? */
	then glp = gsp -> stack_header.lot_ptr -> lot.lp (segnum);
	else return;				/* no linkage for this segno */

	if baseno (gsp -> stack_header.isot_ptr -> isot.isp (segnum)) ^= "0"b
	then gstp = gsp -> stack_header.isot_ptr -> isot.isp (segnum);

	return;
     end;
%page;
make_lot:
     proc (ring);

dcl  ring fixed bin;

dcl  lotp ptr;
dcl  newisotp ptr;
dcl  newlotp ptr;
dcl  save_max_lot_size fixed bin;
dcl  sp ptr;


/* This procedure is called to make a larger LOT than the initial lot given a process.
   It assumes the stack, lot, and clr are already there and makes a new lot
   by allocating one in the current linkage region.
*/


	sp = pds$stacks (ring);
	lotp = sp -> stack_header.lot_ptr;

	if sp -> stack_header.cur_lot_size >= sp -> stack_header.max_lot_size
	then call terminate_proc (error_table_$nrmkst);

	nwords = 2 * sp -> stack_header.max_lot_size;

/* Set stack_header.max_lot_size temporarily so that we won't be called
   recursively.  Otherwise, this could happen if a segment is
   created to satisfy the allocate								*/

	save_max_lot_size = sp -> stack_header.max_lot_size;
	sp -> stack_header.max_lot_size = sp -> stack_header.cur_lot_size;
	on cleanup
	     begin;				/* in case of crawlout			*/
	     sp -> stack_header.max_lot_size = save_max_lot_size;
	end;

	allocate based_array in (sp -> stack_header.clr_ptr -> based_area) set (newlotp);

	sp -> stack_header.max_lot_size = save_max_lot_size;
	revert cleanup;

	newisotp = addrel (newlotp, sp -> stack_header.max_lot_size);
	nwords = sp -> stack_header.cur_lot_size;
	newlotp -> based_array = lotp -> based_array;
	newisotp -> based_array = sp -> stack_header.isot_ptr -> based_array;
	sp -> stack_header.cur_lot_size = sp -> stack_header.max_lot_size;

	sp -> stack_header.lot_ptr = newlotp;
	sp -> stack_header.isot_ptr = newisotp;

	return;
     end make_lot;
%page;
get_sp:
     proc (ring) returns (ptr);

/* This procedure returns a pointer to the initial stack in a ring */

dcl  ring fixed bin;

	if pds$stacks (ring) = null then call makestack (ring);

	return (pds$stacks (ring));

     end;
%page;
%include area_info;
%include its;
%include linkdcl;
%include lot;
%include object_info;
%include sdw_info;
%include stack_header;
     end;




		    link_snap.pl1                   11/11/89  1132.4rew 11/11/89  0800.0      613602



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




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Rewritten to support object multisegment files.  In particular, support
     of indirect definitions, deferred initialization, partial links, and
     preliminary support for *heap links.
  2) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
     audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
     added a check for heap links and a call to set_ext_variable_$star_heap
     when a heap link is found.
  3) change(86-06-24,DGHowe), approve(86-06-24,MCR7420),
     audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
     added a segment pointer to the calling sequences of for_linker and
     star_heap for ext pointer initialization.
  4) change(87-06-10,Elhard), approve(87-07-17,MCR7739),
     audit(87-06-10,RWaters), install(87-07-17,MR12.1-1043):
     Critical fix to correct snapping of CREATE_IF_NOT_FOUND (type 6) links to
     targets with no offset name, or nonexistent targets.
                                                   END HISTORY COMMENTS */


/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll79,initcol0,dclind4,idind24,struclvlind1,comcol41 */

link_snap:
  proc;

  /*** ****************************************************************/
  /***							*/
  /***	Name:	link_snap					*/
  /***	Input:	none					*/
  /***	Function:	This procedure implements the Multics dynamic	*/
  /***		linking mechanism.  Four entries exist in this	*/
  /***		procedure:				*/
  /***		  link_snap$link_fault - This entry is called as	*/
  /***				     due to a fault_tag_2	*/
  /***				     (linkage) fault.	*/
  /***		  link_snap$link_force - This entry corresponds	*/
  /***				     to the hcs_$link_force	*/
  /***				     gate entry.  It basicly	*/
  /***				     duplicates the action of	*/
  /***				     a link_fault without	*/
  /***				     taking a fault.	*/
  /***		  link_snap$make_ptr   - This entry corresponds	*/
  /***				     to the hcs_$make_ptr	*/
  /***				     gate entry. It simulates	*/
  /***				     a type-3 or type-4 link	*/
  /***				     fault and returns the	*/
  /***				     target as a pointer.	*/
  /***		  link_snap$make_entry - This entry corresponds	*/
  /***				     to the hcs_$make_entry	*/
  /***				     gate entry. It simulates	*/
  /***				     a type-3 or type-4 link	*/
  /***				     fault and returns the	*/
  /***				     target as an entry value	*/
  /***							*/
  /*** ****************************************************************/

  /* constants */

  dcl true		bit (1) static options (constant) init ("1"b);
  dcl false		bit (1) static options (constant) init ("0"b);

  dcl indirect		bit (6) static options (constant) init ("20"b3);

  dcl Link_fault		fixed bin static options (constant) init (1);
  dcl Link_force		fixed bin static options (constant) init (2);
  dcl Make_ptr		fixed bin static options (constant) init (3);
  dcl Make_entry		fixed bin static options (constant) init (4);

  dcl No_retry		bit (1) static options (constant) init ("0"b);
  dcl Will_retry		bit (1) static options (constant) init ("1"b);

  dcl zero_word		bit (36) static options (constant) init (""b);

  dcl None		fixed bin (18) unsigned unaligned
			static options (constant) init (0);

  /* parameters */

  dcl a_mcp		ptr parameter;
  dcl a_link_pairp		ptr parameter;
  dcl a_dummy		fixed bin parameter;
  dcl a_code		fixed bin (35) parameter;
  dcl a_refp		ptr parameter;
  dcl a_seg_name		char (*) parameter;
  dcl a_offset_name		char (*) parameter;
  dcl a_targetp		ptr parameter;
  dcl a_targete		entry parameter;

  /* procedures */

  dcl condition_		entry (char (*), entry);
  dcl fs_search		entry (ptr, char (*), bit (1) aligned, ptr,
			fixed bin (35));
  dcl fs_search$same_directory
			entry (ptr, char (*), ptr, fixed bin (35));
  dcl get_defptr_		entry (ptr, ptr, ptr, ptr, fixed bin (35));
  dcl level$get		entry () returns (fixed bin (3));
  dcl level$set		entry (fixed bin (3));
  dcl link_man$other_linkage	entry (ptr, ptr, ptr, ptr, fixed bin (35));
  dcl link_man$own_linkage	entry (ptr, ptr, ptr, ptr, fixed bin (35));
  dcl page$enter_data	entry (ptr unal, fixed bin);
  dcl set_ext_variable_$for_linker
			entry (char (*), ptr, ptr, ptr, bit (1) aligned,
			ptr, fixed bin (35), ptr, ptr, ptr, ptr);
  dcl set_ext_variable_$star_heap
			entry (char (*), ptr, ptr, ptr, bit (1) aligned,
			ptr, fixed bin (35));
  dcl trap_caller_caller_	entry (ptr, ptr, ptr, ptr, ptr, ptr,
			fixed bin (35));
  dcl usage_values		entry (fixed bin (30) aligned,
			fixed bin (71) aligned);

  /* external */

  dcl 01 ahd$link_meters	(4) aligned external like link_meters;
  dcl error_table_$bad_class_def
			external fixed bin (35);
  dcl error_table_$bad_deferred_init
			external fixed bin (35);
  dcl error_table_$bad_indirect_def
			external fixed bin (35);
  dcl error_table_$bad_link_type
			external fixed bin (35);
  dcl error_table_$bad_self_ref
			external fixed bin (35);
  dcl error_table_$first_reference_trap
			external fixed bin (35);
  dcl error_table_$illegal_ft2
			external fixed bin (35);
  dcl error_table_$no_defs	external fixed bin (35);
  dcl error_table_$no_ext_sym external fixed bin (35);
  dcl error_table_$no_linkage external fixed bin (35);
  dcl error_table_$unexpected_ft2
			external fixed bin (35);
  dcl pds$link_meters_bins	(4) external fixed bin (30);
  dcl pds$link_meters_pgwaits (4) external fixed bin (30);
  dcl pds$link_meters_times	(4) external fixed bin (35);
  dcl pds$stacks		(0:7) external ptr;

  /* based */

  dcl 01 based_entry	aligned based,
       02 code_ptr		ptr,
       02 env_ptr		ptr;
  dcl 01 expr		aligned like exp_word based (exprp);
  dcl 01 link_pair		aligned like object_link based (link_pairp);
  dcl 01 offsetname		aligned based (offsetnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (offsetname.count) unaligned;
  dcl 01 segname		aligned based (segnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (segname.count) unaligned;
  dcl 01 type_pr		aligned like type_pair based (type_prp);
  dcl 01 usage		aligned based,
       02 time		fixed bin (71),
       02 pf		fixed bin (30);

  /* automatic */

  dcl 01 automatic_offsetname aligned automatic,
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (256) unaligned;
  dcl 01 automatic_segname	aligned automatic,
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (32) unaligned;
  dcl 01 call_info		aligned automatic,
       02 type		fixed bin,
       02 save_ring		fixed bin,
       02 mcp		ptr,
       02 codep		ptr,
       02 start		aligned like usage,
       02 finish		aligned like usage,
       02 search		aligned like usage,
       02 get_linkage	aligned like usage,
       02 def_search	aligned like usage;
  dcl call_infop		ptr automatic;
  dcl code		fixed bin (35) automatic;
  dcl connect_fail_code	fixed bin (35) automatic;
  dcl defp		ptr automatic;
  dcl exprp		ptr automatic;
  dcl init_infop		ptr automatic;
  dcl instrp		ptr automatic;
  dcl link_pairp		ptr automatic;
  dcl linkp		ptr automatic;
  dcl nchars		fixed bin automatic;
  dcl offset_name		char (256) automatic;
  dcl offsetnamep		ptr automatic;
  dcl refp		ptr automatic;
  dcl retry_sw		bit (1) automatic;
  dcl seg_name		char (32) automatic;
  dcl segnamep		ptr automatic;
  dcl segp		ptr automatic;
  dcl star_system_sw	bit (1) automatic;
  dcl target_linkagep	ptr automatic;
  dcl targetp		ptr automatic;
  dcl textp		ptr automatic;
  dcl type_prp		ptr automatic;
  dcl MSF_sw		bit (1) aligned automatic;

  /* builtin */

  dcl addr		builtin;
  dcl addrel		builtin;
  dcl baseno		builtin;
  dcl baseptr		builtin;
  dcl bin			builtin;
  dcl char		builtin;
  dcl divide		builtin;
  dcl index		builtin;
  dcl length		builtin;
  dcl ltrim		builtin;
  dcl max			builtin;
  dcl min			builtin;
  dcl null		builtin;
  dcl ptr			builtin;
  dcl rtrim		builtin;
  dcl substr		builtin;
  dcl unspec		builtin;

  return;

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


link_fault:
  entry (a_mcp);			/** machine conditions  (i/o)	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	link_snap$link_fault			*/
  /***	Input:	mcp					*/
  /***	Function:	handles a fault_tag_2 (linkage) fault.  The mcp	*/
  /***		pointer points to the machine conditions at the	*/
  /***		time of the fault.  If the link snapping is	*/
  /***		successfull, the machine conditions will be	*/
  /***		adjusted to allow the fault to be restarted.	*/
  /***	Output:	mcp					*/
  /***							*/
  /*** ****************************************************************/

  /* copy the parameters into automatic storage */

  mcp = a_mcp;

  call_infop = addr (call_info);
  call_info.type = Link_fault;
  call_info.mcp = mcp;
  call_info.save_ring = level$get ();

  /* since this is a fault, the trap routines can't set a return code	*/

  call_info.codep = null;

  /* set validation level to the level that the fault occurred at */

  scup = addr (mc.scu (0));
  call level$set (bin (scu.ppr.prr, 3));

  /* get a pointer to the faulting link pair and instruction */

  link_pairp = ptr (baseptr (bin (scu.tpr.tsr, 15)), scu.ca);
  instrp = ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc);

  /* trace the fault */

  call page$enter_data ((instrp), linkage_fault_start);

  /* make sure the fault_tag_2 wasn't in an instruction */

  if instrp -> its.its_mod = FAULT_TAG_2
    then call exit (call_infop, error_table_$unexpected_ft2, null);

  goto link_join;

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


link_force:
  entry (a_link_pairp,		/** ptr to link to snap (in )	*/
       a_dummy,			/** unused	    (---) */
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	link_snap$link_force			*/
  /***	Input:	link_pairp				*/
  /***	Function:	given a pointer to a link, snap it without taking	*/
  /***		a fault.  This entry is functionally the same as	*/
  /***		link_snap$link_fault except that it is entered	*/
  /***		via gate call rather than fault entry.		*/
  /***	Output:	code					*/
  /***							*/
  /*** ****************************************************************/

  /* not a fault entry */

  mcp = null;

  /* copy parameters into automatic storage */

  link_pairp = a_link_pairp;

  /* set up call info */

  call_infop = addr (call_info);
  call_info.type = Link_force;
  call_info.mcp = null;
  call_info.save_ring = -1;

  /* save error code address in case we trap out to the user ring and	*/
  /* the trap procedure needs to set the error code.		*/

  call_info.codep = addr (a_code);

  /* for a link_force call, we use the link itself as the start point	*/
  /* for tracing purposes.					*/

  call page$enter_data ((link_pairp), linkage_fault_start);

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


link_join:

  /* clear out the metering information */

  call_info.search.time = 0;
  call_info.search.pf = 0;
  call_info.get_linkage.time = 0;
  call_info.get_linkage.pf = 0;
  call_info.def_search.time = 0;
  call_info.def_search.pf = 0;

  /* meter the fault time etc. */

  call usage_values (call_info.start.pf, call_info.start.time);

  if link_pair.tag ^= FAULT_TAG_2
    then if call_info.type = Link_force
	 then call exit (call_infop, 0, baseptr (0));
	 else call exit (call_infop, error_table_$illegal_ft2, null);

  /* get the linkage section and text pointers */

  linkp = addrel (link_pairp, link_pair.header_relp);
  textp = baseptr (linkp -> linkage_header.stats.segment_number);
  target_linkagep = null;

  /* validate the definition pointer */

  if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= ITS_MODIFIER
    then call exit (call_infop, error_table_$no_defs, null);
    else defp = linkp -> linkage_header.def_ptr;

  /* validate that all first reference traps have been run */

  if linkp -> virgin_linkage_header.first_ref_relp ^= 0
    then call exit (call_infop, error_table_$first_reference_trap, null);

  /* now that things look reasonably valid, we start decoding the link */

  exprp = addrel (defp, link_pair.expression_relp);
  type_prp = addrel (defp, expr.type_relp);

  /* first we check the link to see if it should be converted into a	*/
  /* *system link.  Trap-before links to datmk_ and certain type-6	*/
  /* links are converted to *system links.			*/

  call convert_trap_link (call_infop, linkp, defp, type_prp, offset_name,
       init_infop, star_system_sw);

  if star_system_sw
    then do;

      /* the link either was a *system link, or has become one */

      call star_system (call_infop, link_pairp, defp, linkp, type_prp,
	 offset_name, init_infop, targetp);
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call exit (call_infop, 0, targetp);
    end;

  /* see if we have a C *heap link */

  if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_HEAP
    then do;

      /* C *heap links are similar to *system links except that they	*/
      /* are allocated separately, and have a level associated with	*/
      /* them so that recursive invocations get new copies and they	*/
      /* can be released when the invocation returns.		*/

      call star_heap (call_infop, defp, linkp, type_prp, targetp);
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call exit (call_infop, 0, targetp);
    end;

  /* now see if there is a trap pointer.  Anything with a trap	*/
  /* pointer that wasn't converted to a *system link, and isn't a	*/
  /* create link, we now treat as a trap-before link, and try to run	*/
  /* the trap.						*/

  if type_pr.type ^= LINK_CREATE_IF_NOT_FOUND & type_pr.trap_relp ^= None
    then do;

      /* actually is a trap-before link, trap out to the user	*/
      /* ring to execute the trap procedure.			*/

      /* NB.  We don't try to complete tracing or metering in this	*/
      /*	    case since it would be rather meaningless anyway. . .	*/

      call adjust_mc (mcp);
      call trap_caller_caller_ (mcp, linkp, defp, type_prp, link_pairp,
	 call_info.codep, code);

      /* usually we don't return, but. . . */

      call exit (call_infop, code, baseptr (0));
    end;

  /* at this point we assume we have a reasonably standard link and	*/
  /* can just snap it according to type.			*/

  if /* case */ type_pr.type = LINK_SELF_BASE
    then do;
      call self_reference (call_infop, (type_pr.segname_relp), textp,
	 targetp);
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call exit (call_infop, 0, targetp);
    end;

  else if type_pr.type = LINK_OBSOLETE_2
    then call exit (call_infop, error_table_$bad_link_type, null);

  else if type_pr.type = LINK_REFNAME_BASE
    then do;
      segnamep = addrel (defp, type_pr.segname_relp);
      if defp -> definition_header.msf_map_relp ^= None
        then MSF_sw = true;
        else MSF_sw = false;
      call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
	 code);
      if segp = null
        then call exit (call_infop, code, null);
      call snap (segp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call exit (call_infop, 0, segp);
    end;

  else if type_pr.type = LINK_REFNAME_OFFSETNAME
    then do;
      segnamep = addrel (defp, type_pr.segname_relp);
      if defp -> definition_header.msf_map_relp ^= None
        then MSF_sw = true;
        else MSF_sw = false;
      call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
	 code);
      if segp = null
        then call exit (call_infop, code, null);
      call condition_ ("seg_fault_error", connect_fail_handler_);
      call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
      call get_definition (call_infop, segnamep, offsetnamep, segp,
	 No_retry, target_linkagep, targetp);
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call trap (call_infop, target_linkagep, targetp);
      call exit (call_infop, 0, targetp);
    end;

  else if type_pr.type = LINK_SELF_OFFSETNAME
    then do;
      call self_reference (call_infop, (type_pr.segname_relp), textp,
	 targetp);

      /* insure that segname won't be found */

      segnamep = addr (zero_word);
      call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
      call get_definition (call_infop, segnamep, offsetnamep, textp,
	 No_retry, (null), targetp);
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call exit (call_infop, 0, targetp);
    end;

  else if type_pr.type = LINK_CREATE_IF_NOT_FOUND
    then do;

      /* NB.  since we have already processed the trap case, we will	*/
      /*	    assume that this link can be treated as a type-4 until	*/
      /*	    something breaks.				*/

      segnamep = addrel (defp, type_pr.segname_relp);
      if defp -> definition_header.msf_map_relp ^= None
        then MSF_sw = true;
        else MSF_sw = false;
      call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
	 code);
      if segp = null
        then do;

	/* OK.  something broke.  now we try to treat this as a	*/
	/* *system link so that the caller will get something.	*/

	call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
	if offsetnamep = null
	  then offset_name = segname.string || "$";
	  else offset_name = segname.string || "$" || offsetname.string;
	if type_pr.trap_relp = 0
	  then init_infop = null;
	  else init_infop = addrel (defp, type_pr.trap_relp);
	call star_system (call_infop, link_pairp, defp, linkp, type_prp,
	     offset_name, init_infop, targetp);
	call snap (targetp, (expr.expression), link_pairp);
	call meter (call_infop, (type_pr.type));
	call exit (call_infop, 0, targetp);
        end;

      call condition_ ("seg_fault_error", connect_fail_handler_);
      call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);

      /* dont try to do a definition search if no entrypoint name was given */

      if offsetnamep ^= null
        then call get_definition (call_infop, segnamep, offsetnamep, segp,
	        No_retry, target_linkagep, targetp);
        else targetp = segp;
      call snap (targetp, (expr.expression), link_pairp);
      call meter (call_infop, (type_pr.type));
      call trap (call_infop, target_linkagep, targetp);
      call exit (call_infop, 0, targetp);
    end;

  else call exit (call_infop, error_table_$bad_link_type, null);

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


make_ptr:
  entry (a_refp,			/** referencing dir ptr (in )	*/
       a_seg_name,			/** segname to find	    (in ) */
       a_offset_name,		/** entrypoint to find  (in ) */
       a_targetp,			/** target ptr returned (out) */
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	link_snap$make_ptr				*/
  /***	Input:	refp, seg_name, offset_name			*/
  /***	Function:	Using the segname and optional offsetname given,	*/
  /***		snap a simulated type-3 (if a null offsetname)	*/
  /***		or type-4 (if non-null) link and return a pointer	*/
  /***		to the target.  The reference pointer is passed	*/
  /***		to fs_search in order to evaluate the referencing	*/
  /***		dir search rule.  If it is null, the referencing	*/
  /***		dir rule is skipped.			*/
  /***	Output:	targetp, code				*/
  /***							*/
  /*** ****************************************************************/

  /* preset the return values */

  a_targetp = null;

  /* set up the call info */

  call_info.type = Make_ptr;

  goto make_join;

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


make_entry:
  entry (a_refp,			/** referencing dir ptr (in )	*/
       a_seg_name,			/** segname to find	    (in ) */
       a_offset_name,		/** entrypoint to find  (in ) */
       a_targete,			/** entry returned	    (out) */
       a_code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	link_snap$make_entry			*/
  /***	Input:	refp, seg_name, offset_name			*/
  /***	Function:	performs the same function as link_snap$make_ptr	*/
  /***		except that an entry value is returned instead of	*/
  /***		a pointer value.  The other difference between	*/
  /***		calling make_entry and make_ptr is that if the	*/
  /***		offsetname value is null on a call to make_entry	*/
  /***		the target linkage section is combined and any	*/
  /***		first reference traps run.  This is because it is	*/
  /***		assumed that if you want an entry returned, you	*/
  /***		plan on calling it, and to call it the linkage	*/
  /***		section should be combined.			*/
  /***	Output:	targete, code				*/
  /***							*/
  /*** ****************************************************************/

  call_info.type = Make_entry;

  /* preset the returned entry */

  addr (a_targete) -> based_entry.code_ptr = null;
  addr (a_targete) -> based_entry.env_ptr = null;

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


make_join:

  /* meter and trace the make_ptr/make_entry call */

  call usage_values (call_info.start.pf, call_info.start.time);
  call page$enter_data (baseptr (0), linkage_fault_start);

  /* clear out the metering information */

  call_info.search.time = 0;
  call_info.search.pf = 0;
  call_info.get_linkage.time = 0;
  call_info.get_linkage.pf = 0;
  call_info.def_search.time = 0;
  call_info.def_search.pf = 0;

  /* set up the common call_info stuff */

  call_infop = addr (call_info);
  call_info.codep = addr (a_code);
  call_info.mcp, mcp = null;
  call_info.save_ring = -1;

  /* copy the args into automatic storage */

  refp = a_refp;
  seg_name = a_seg_name;
  offset_name = a_offset_name;

  /* preset the return code */

  a_code = 0;

  /* try to determine whether the ref pointer refers to an MSF */

  if refp = null
    then MSF_sw = false;
    else do;
      call link_man$own_linkage (ptr (refp, 0), linkp, null, null, code);
      if code ^= 0
        then MSF_sw = false;
      else if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= 
	      ITS_MODIFIER
        then MSF_sw = false;
      else do;
        defp = linkp -> linkage_header.def_ptr;
        if defp -> definition_header.msf_map_relp ^= None
	then MSF_sw = true;
	else MSF_sw = false;
      end;
    end;

  /* search for the segment */

  call fs_search (refp, seg_name, MSF_sw, segp, code);
  if code ^= 0
    then call exit (call_infop, code, null);

  /* set up to handle connection failure gracefully */

  call condition_ ("seg_fault_error", connect_fail_handler_);

  nchars = length (rtrim (offset_name));

  if nchars = 0
    then do;

      /* no offsetname, so just meter, finish tracing and return */

      if call_info.type = Make_ptr
        then call meter (call_infop, (LINK_REFNAME_BASE));
        else do;

	/* if we are returning an entry, we must combine the	*/
	/* target linkage section first.  If we combine the linkage	*/
	/* section we should run any first reference traps.	*/

	call combine_linkage (call_infop, segp, (null), target_linkagep,
	     (null), (null));
	call meter (call_infop, (LINK_REFNAME_BASE));
	call trap (call_infop, target_linkagep, segp);
        end;
      call exit (call_infop, 0, segp);
    end;

  /* set up the segname/offsetname pointers */

  segnamep = addr (automatic_segname);
  offsetnamep = addr (automatic_offsetname);

  /* clear them out */

  unspec (automatic_segname) = ""b;
  unspec (automatic_offsetname) = ""b;

  /* save the passed segname/offsetname values */

  automatic_segname.count = length (rtrim (seg_name));
  substr (automatic_segname.string, 1, automatic_segname.count) =
       substr (seg_name, 1, automatic_segname.count);

  automatic_offsetname.count = length (rtrim (offset_name));
  substr (automatic_offsetname.string, 1, automatic_offsetname.count) =
       substr (offset_name, 1, automatic_offsetname.count);

  /* if the offsetname and segname are the same, we want	*/
  /* get_definition to retry using the offsetname "main_"	*/
  /* if this attempt fails				*/

  if seg_name = offset_name
    then retry_sw = Will_retry;
    else retry_sw = No_retry;

  call get_definition (call_infop, segnamep, offsetnamep, segp, retry_sw,
       target_linkagep, targetp);

  call meter (call_infop, (LINK_REFNAME_OFFSETNAME));
  call trap (call_infop, target_linkagep, targetp);
  call exit (call_infop, 0, targetp);

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


convert_trap_link:
  proc (infop,			/** call info pointer   (in )	*/
       linkp,			/** linkage pointer	    (in )	*/
       defp,			/** definition pointer  (in ) */
       type_prp,			/** type_pair pointer   (in ) */
       offset_name,			/** entrypoint name	    (out) */
       init_infop,			/** init_info pointer   (out) */
       star_system_sw);		/** *system or mapped   (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	convert_trap_link				*/
  /***	Input:	infop, linkp, defp, type_prp			*/
  /***	Function:	determines whether the link in question has a	*/
  /***		trap_relp value.  If it does, then the link is	*/
  /***		a probably a *system link (type-5, class-5) or	*/
  /***		should should be treated as one.  If it is not	*/
  /***		not a *system link, and should be, we determine	*/
  /***		what the offset_name to be found is and what the	*/
  /***		init_info pointer should be and then set the flag	*/
  /***		to indicate that this is to be snapped as a	*/
  /***		*system link.				*/
  /***	Output:	offset_name, init_infop, star_system_sw		*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl linkp		ptr parameter;
  dcl defp		ptr parameter;
  dcl type_prp		ptr parameter;
  dcl offset_name		char (256) parameter;
  dcl init_infop		ptr parameter;
  dcl star_system_sw	bit (1) parameter;

  /* based */

  dcl based_ptr		ptr based;
  dcl 01 offsetname		aligned based (offsetnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (offsetname.count) unaligned;
  dcl 01 segname		aligned based (segnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (segname.count) unaligned;
  dcl 01 trap		aligned like link_trap_pair based (trapp);
  dcl 01 type_pr		aligned like type_pair based (type_prp);

  /* automatic */

  dcl code		fixed bin (35) automatic;
  dcl init_linkp		ptr automatic;
  dcl offsetnamep		ptr automatic;
  dcl segnamep		ptr automatic;
  dcl trapp		ptr automatic;

  segnamep = addrel (defp, type_pr.segname_relp);
  offsetnamep = addrel (defp, type_pr.offsetname_relp);

  /* preset output variables */

  star_system_sw = false;
  offset_name = offsetname.string;
  if type_pr.trap_relp = None
    then init_infop = null;
    else init_infop = addrel (defp, type_pr.trap_relp);

  /* first see if it is actually a *system link */

  if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_SYSTEM
    then do;
      star_system_sw = true;
      return;
    end;

  /* now check the conditions for converting a type 6 link */

  if type_pr.type = LINK_CREATE_IF_NOT_FOUND
    then do;

      /* check for pl1 ext static */

      if segname.string = "stat_"
        then do;
	star_system_sw = true;
	return;
        end;

      /* check for fortran common blocks */

      if offsetname.count = 0
        then if index (segname.string, ".com") = segname.count - 3
	     then do;
	       star_system_sw = true;
	       offset_name = substr (segname.string, 1, segname.count - 4);
	       if offset_name = "b_"	/* blank common */
	         then offset_name = "blnk*com";
	       return;
	     end;
	     else ;

      /* check for cobol FSB link */

      else if segname.string = "cobol_fsb_"
        then do;
	offset_name = "cobol_fsb_" || offsetname.string;
	star_system_sw = true;
	return;
        end;
    end;

  if type_pr.type = LINK_REFNAME_OFFSETNAME & type_pr.trap_relp ^= None
    then do;

      /* if we have a type 4 link with a trap-before link to datmk_	*/
      /* we force-snap the info-link of the trap, use that as the	*/
      /* init_info pointer and use the offsetname from the original	*/
      /* link as the name and then treat as a *system link.		*/

      trapp = addrel (defp, type_pr.trap_relp);
      if segname.string = "stat_"
        then if addrel (defp,
	        addrel (defp,
	        addrel (defp, addrel (linkp, trap.call_relp)
	        -> object_link.expression_relp)
	        -> exp_word.type_relp)
	        -> type_pair.segname_relp) -> acc_string.string = "datmk_"
	     then do;
	       init_linkp = addrel (linkp, trap.info_relp);

	       /* snap the info link */

	       call link_force (init_linkp, 0, code);
	       if code ^= 0
	         then call exit (call_infop, code, null);

	       init_infop = init_linkp -> based_ptr;
	       star_system_sw = true;
	     end;
    end;

  end convert_trap_link;

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


star_system:
  proc (infop,			/** call_info pointer   (in )	*/
       link_pairp,			/** pointer to link	    (in ) */
       defp,			/** definition pointer  (in ) */
       linkp,			/** linkage pointer	    (in ) */
       type_prp,			/** type_pair pointer   (in ) */
       offset_name,			/** ext var name string (in ) */
       init_infop,			/** init_info pointer   (in ) */
       targetp);			/** target variable	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	star_system				*/
  /***	Input:	infop, link_pairp, defp, linkp, type_prp,	*/
  /***		offset_name, init_infop			*/
  /***	Function:	determines the target of a *system link.  This	*/
  /***		procedure calls set_ext_variable_ to return the	*/
  /***		variable_node which defines the named external	*/
  /***		variable, and then returns a pointer to the var	*/
  /***		itself.					*/
  /***	Output:	targetp					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl link_pairp		ptr parameter;
  dcl defp		ptr parameter;
  dcl linkp		ptr parameter;
  dcl type_prp		ptr parameter;
  dcl offset_name		char (256) parameter;
  dcl init_infop		ptr parameter;
  dcl targetp		ptr parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);

  /* automatic */

  dcl code		fixed bin (35) automatic;
  dcl sb			ptr automatic;

  /* set the stack base pointer */

  if info.mcp = null
    then sb = pds$stacks (level$get ());
    else sb = ptr (info.mcp -> mc.prs (6), 0);

  /* check to see if this variable has a deferred initialization type	*/

  call deferred_init (infop, init_infop, linkp);

  /* now call set_ext_variable_ to get the variable node.  Note that	*/
  /* this call may not return if the target is an uninitialized VLA,	*/
  /* since this requires a call to fortran_storage_manager_. We cant	*/
  /* call this in ring 0 so we trap out to the user ring to call out	*/
  /* to set up the VLA.  The fortran_storage_manager_ is responsible	*/
  /* for completing the link snap.				*/

  call set_ext_variable_$for_linker (offset_name, init_infop, sb,
       ptr (init_infop, 0), ("0"b), targetp, code, info.mcp, def_ptr,
       type_prp, link_pairp);
  if code ^= 0
    then call exit (infop, code, null);

  /* get a pointer to the actual variable instead of the node */

  targetp = targetp -> variable_node.vbl_ptr;

  end star_system;

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


star_heap:
  proc (infop,			/** call_info pointer   (in )	*/
       defp,			/** def section ptr	    (in ) */
       linkp,			/** linkage section ptr (in ) */
       type_prp,			/** type_pair pointer   (in ) */
       targetp);			/** target pointer	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	star_heap					*/
  /***	Input:	infop, defp, linkp, type_prp			*/
  /***	Function:	given a pointer to the type_pair and definition	*/
  /***		section for a link, get the offsetname and init	*/
  /***		info pointer and call set_ext_variable_$star_heap	*/
  /***		to find or create the variable.		*/
  /***	Output:	targetp					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl defp		ptr parameter;
  dcl linkp		ptr parameter;
  dcl type_prp		ptr parameter;
  dcl targetp		ptr parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);
  dcl 01 offsetname		aligned based (offsetnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (offsetname.count) unaligned;
  dcl 01 type_pr		aligned like type_pair based (type_prp);

  /* automatic */

  dcl init_infop		ptr automatic;
  dcl offsetnamep		ptr automatic;
  dcl sb			ptr automatic;
  dcl offset_name		char (256) automatic;

  /* extract the variable name and init_info pointer */

  offsetnamep = addrel (defp, type_pr.offsetname_relp);
  offset_name = offsetname.string;

  if type_pr.trap_relp = None
    then init_infop = null;
    else init_infop = addrel (defp, type_pr.trap_relp);

  /* get the stack base pointer */

  if info.mcp = null
    then sb = pds$stacks (level$get ());
    else sb = ptr (info.mcp -> mc.prs (6), 0);

  /* get new init_info pointer if initialization type = INIT_DEFERRED */

  call deferred_init (infop, init_infop, linkp);

  /* call set_ext_variable_$star_heap to allocate the variable and	*/
  /* return a node ptr					*/

  call set_ext_variable_$star_heap (offset_name, init_infop, sb,
       ptr (init_infop, 0), ("0"b), targetp, code);
  if code ^= 0
    then call exit (infop, code, null);

  /* set the target to point to the variable itself */

  targetp = targetp -> variable_node.vbl_ptr;

  end star_heap;

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


deferred_init:
  proc (infop,			/** call_info pointer   (in )	*/
       init_infop,			/** init_info pointer   (i/o) */
       linkp);			/** linkage section ptr (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	deferred_init				*/
  /***	Input:	infop, init_infop, linkp			*/
  /***	Function:	locates the initialization info for deferred init	*/
  /***		external or heap initialization.  The procedure	*/
  /***		for deferred initialization is as follows:	*/
  /***		  - check to see if the init type is deferred.	*/
  /***		  - if so, extract the target_relp and link_relp	*/
  /***		    from the init_info.			*/
  /***		  - make sure the link referenced by target_relp	*/
  /***		    has been snapped.			*/
  /***		  - chase the link to find the target segments	*/
  /***		    linkage header.				*/
  /***		  - extract the def_ptr and original_linkage_ptr	*/
  /***		    from the linkage_header.			*/
  /***		  - apply the link_relp to the original_linkage	*/
  /***		    pointer to find the unsnapped link.		*/
  /***		  - extract a pointer to the init_info from the	*/
  /***		    def_ptr and type_pair.			*/
  /***		  - return the actual init_info pointer.	*/
  /***	Output:	init_infop				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl init_infop		ptr parameter;
  dcl linkp		ptr parameter;

  /* based */

  dcl 01 lh		aligned like linkage_header based (lhp);
  dcl based_ptr		ptr based;
  dcl 01 type_pr		aligned like type_pair based (type_prp);
  dcl 01 expr		aligned like exp_word based (exprp);
  dcl 01 link_pair		aligned like object_link based (link_pairp);
  dcl 01 init_info		aligned like link_init_deferred
			based (init_infop);

  /* automatic */

  dcl target_ptr_ptr	ptr automatic;
  dcl lhp			ptr automatic;
  dcl exprp		ptr automatic;
  dcl type_prp		ptr automatic;
  dcl link_pairp		ptr automatic;

  /* if no init_info, or init_info is not deferred, just return */

  if init_infop = null
    then return;

  if init_info.header.type ^= INIT_DEFERRED
    then return;

  /* get the target partial link and make sure it is snapped */

  target_ptr_ptr = addrel (linkp, init_info.target_relp);
  if target_ptr_ptr -> its.its_mod ^= ITS_MODIFIER
    then call exit (infop, error_table_$bad_deferred_init, null);

  /* make sure the target of the link looks somewhat like a linkage	*/
  /* header and that the definition pointer is a pointer		*/

  lhp = target_ptr_ptr -> based_ptr;
  if addr (lh.def_ptr) -> its.its_mod ^= ITS_MODIFIER
    then call exit (infop, error_table_$no_defs, null);
    else defp = lh.def_ptr;

  /* get a pointer to the link specified in the original linkage	*/
  /* section and make sure it looks like an unsnapped link.		*/

  link_pairp = addrel (lh.original_linkage_ptr, init_info.link_relp);
  if link_pair.tag ^= FAULT_TAG_2
    then call exit (infop, error_table_$bad_deferred_init, null);

  /* now decode the link and get a pointer to the init_info */

  exprp = addrel (defp, link_pair.expression_relp);
  type_prp = addrel (defp, expr.type_relp);
  if type_pr.trap_relp = None
    then init_infop = null;
    else init_infop = addrel (defp, type_pr.trap_relp);

  end deferred_init;

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


self_reference:
  proc (infop,			/** call_info pointer   (in )	*/
       class,			/** link class	    (in ) */
       textp,			/** segment pointer	    (in ) */
       targetp);			/** section pointer	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	self_reference				*/
  /***	Input:	infop, class, textp				*/
  /***	Function:	given a link class and a pointer to the owners	*/
  /***		text_section, get the other section pointers and	*/
  /***		return a pointer to the section specified by the	*/
  /***		class of the link.				*/
  /***	Output:	targetp					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl class		fixed bin (18) unsigned parameter;
  dcl textp		ptr parameter;
  dcl targetp		ptr parameter;

  /* automatic */

  dcl code		fixed bin (35) automatic;
  dcl linkp		ptr automatic;
  dcl staticp		ptr automatic;
  dcl symbolp		ptr automatic;

  /* get pointers to the various sections */

  call link_man$own_linkage (textp, linkp, staticp, symbolp, code);
  if code ^= 0
    then call exit (infop, code, null);

  /* return the section pointer based on the link class */

  if /* case */ class = CLASS_TEXT
    then targetp = textp;
  else if class = CLASS_LINKAGE
    then targetp = linkp;
  else if class = CLASS_STATIC
    then targetp = staticp;
  else if class = CLASS_SYMBOL
    then targetp = symbolp;
  else call exit (infop, error_table_$bad_self_ref, null);

  end self_reference;

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


search_for_segment:
  proc (infop,			/** call_info pointer   (in )	*/
       segnamep,			/** segname acc pointer (in ) */
       refp,			/** referencing pointer (in ) */
       MSF_sw,			/** is caller an MSF    (in ) */
       segp,			/** found segment ptr   (out) */
       code);			/** error code	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	search_for_segment				*/
  /***	Input:	infop, segnamep, refp			*/
  /***	Function:	calls fs_search to search for the refname given	*/
  /***		by the acc_string pointer to by segnamep, and	*/
  /***		meters the call.				*/
  /***	Output:	segp, code				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl segnamep		ptr parameter;
  dcl refp		ptr parameter;
  dcl MSF_sw		bit (1) aligned parameter;
  dcl segp		ptr parameter;
  dcl code		fixed bin (35) parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);
  dcl 01 segname		aligned based (segnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (segname.count) unaligned;

  /* automatic */

  dcl 01 finish		aligned like usage automatic;
  dcl 01 start		aligned like usage automatic;

  /* do the search and meter the time an pagewaits */

  call usage_values (start.pf, start.time);

  call fs_search (refp, segname.string, MSF_sw, segp, code);

  call usage_values (finish.pf, finish.time);

  /* calculate the metering info and add it to the search metering */

  info.search.pf = info.search.pf + (finish.pf - start.pf);
  info.search.time = info.search.time + (finish.time - start.time);

  end search_for_segment;

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


get_offsetnamep:
  proc (infop,			/** call_info pointer   (in )	*/
       defp,			/** definition pointer  (in ) */
       type_prp,			/** type_pair pointer   (in ) */
       offsetnamep);		/** offsetname pointer (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	get_offsetnamep				*/
  /***	Input:	infop, defp, type_prp			*/
  /***	Function:	extract a pointer to the offsetname for the link	*/
  /***		from the type_pair.  If there is no offsetname	*/
  /***		or the type is 6 and the offset name length is 0,	*/
  /***		the null pointer is returned.			*/
  /***	Output:	offsetnamep				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl defp		ptr parameter;
  dcl type_prp		ptr parameter;
  dcl offsetnamep		ptr parameter;

  /* based */

  dcl 01 offsetname		aligned based (offsetnamep),
       02 count		fixed bin (9) unsigned unaligned,
       02 string		char (offsetname.count) unaligned;
  dcl 01 type_pr		aligned like type_pair based (type_prp);

  if type_pr.offsetname_relp = None
    then offsetnamep = null;
    else do;

      /* type-6 links use a valid acc_string with a zero length instead. */

      offsetnamep = addrel (defp, type_pr.offsetname_relp);
      if type_pr.type = LINK_CREATE_IF_NOT_FOUND & offsetname.count = 0
        then offsetnamep = null;
    end;

  end get_offsetnamep;

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


combine_linkage:
  proc (infop,			/** call_info pointer   (in )	*/
       segp,			/** target segment ptr  (in ) */
       textp,			/** text section ptr    (out) */
       linkp,			/** linkage section ptr (out) */
       statp,			/** static section ptr  (out) */
       symbp);			/** symbol section ptr  (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	combine_linkage				*/
  /***	Input:	infop, segp				*/
  /***	Function:	given a pointer to a segment (segp), combine the	*/
  /***		linkage section (if necessary) and return the	*/
  /***		pointers to the various sections.  This routine	*/
  /***		also meters the call.			*/
  /***	Output:	textp, linkp, statp, symbp			*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl segp		ptr parameter;
  dcl textp		ptr parameter;
  dcl linkp		ptr parameter;
  dcl statp		ptr parameter;
  dcl symbp		ptr parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);

  /* automatic */

  dcl 01 finish		aligned like usage automatic;
  dcl 01 start		aligned like usage automatic;

  /* combine the linkage section and meter the time and pagewaits */

  call usage_values (start.pf, start.time);

  textp = ptr (segp, 0);
  call link_man$other_linkage (textp, linkp, statp, symbp, code);

  call usage_values (finish.pf, finish.time);

  /* add in to metering info */

  info.get_linkage.pf = info.get_linkage.pf + (finish.pf - start.pf);
  info.get_linkage.time = info.get_linkage.time + (finish.time - start.time);

  if code ^= 0
    then call exit (infop, code, null);

  if linkp = null
    then call exit (infop, error_table_$no_linkage, null);

  end combine_linkage;

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


get_definition:
  proc (infop,			/** call_info pointer   (in )	*/
       segnamep,			/** segname acc ptr	    (in ) */
       offsetnamep,			/** offsetname acc ptr  (in ) */
       segp,			/** segment to search   (in ) */
       retry,			/** will retry "main_"  (in ) */
       target_linkagep,		/** linkp of target seg (out) */
       targetp);			/** target pointer	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	get_definition				*/
  /***	Input:	infop, segnamep, offsetnamep, segp, retry	*/
  /***	Function:	combines the linkage section for the segment	*/
  /***		specified, and then searches the definition	*/
  /***		section for a definition matching the segname	*/
  /***		and offsetname given and meters the search.	*/
  /***		A pointer to the definition target is then	*/
  /***		generated based on the definition class, the	*/
  /***		section pointers returned by combining the	*/
  /***		linkage, and the definition offset.  If the	*/
  /***		search fails and the retry flag is set, we	*/
  /***		try another search for the entrypoint "main_".	*/
  /***	Output:	targetp					*/
  /***							*/
  /*** ****************************************************************/

  /* constant */

  dcl 01 main_acc		aligned static options (constant),
       02 count		fixed bin (9) unsigned unaligned init (5),
       02 string		char (5) unaligned init ("main_");

  /* parameters */

  dcl infop		ptr parameter;
  dcl segnamep		ptr parameter;
  dcl offsetnamep		ptr parameter;
  dcl retry		bit (1) parameter;
  dcl target_linkagep	ptr parameter;
  dcl segp		ptr parameter;
  dcl targetp		ptr parameter;

  /* based */

  dcl based_ptr		ptr based;
  dcl 01 def		aligned like definition based (defp);
  dcl 01 info		aligned like call_info based (infop);

  /* automatic */

  dcl code		fixed bin (35) automatic;
  dcl defp		ptr automatic;
  dcl 01 finish		aligned like usage automatic;
  dcl linkp		ptr automatic;
  dcl 01 start		aligned like usage automatic;
  dcl statp		ptr automatic;
  dcl symbp		ptr automatic;
  dcl textp		ptr automatic;

  /* if we have no name to search for, don't bother trying */

  if offsetnamep = null
    then return;

  /* combine the linkage section and get the section pointers */

  call combine_linkage (infop, segp, textp, linkp, statp, symbp);

  /* save the linkage pointer in case we have first reference traps to run */

  target_linkagep = linkp;

  call usage_values (start.pf, start.time);
  call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep, offsetnamep,
       defp, code);
  call usage_values (finish.pf, finish.time);

  /* update the metering info */

  info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
  info.def_search.time = info.def_search.time + (finish.time - start.time);

  if retry & code = error_table_$no_ext_sym
    then do;

      /* retry the search with an offsetname of "main_" */

      call usage_values (start.pf, start.time);
      call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep,
	 addr (main_acc), defp, code);
      call usage_values (finish.pf, finish.time);

      /* add to the metering info */

      info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
      info.def_search.time = info.def_search.time + (finish.time - start.time);

    end;

  if code ^= 0
    then call exit (infop, code, null);

  /* check for an indirect definition */

  if def.indirect
    then do;

      /* an indirect definition (used only in component 0 of an	*/
      /* object MSF) is used to refer to something in another	*/
      /* component by adding another indirection through a partial	*/
      /* link. In this case the thing_relp is the offset in the	*/
      /* linkage section of a partial link to the actual definition	*/
      /* target.  In some cases this link will have been snapped	*/
      /* already by the msf_prelink_ first reference trap, if not, we	*/
      /* snap the link, and then use the indirection to give us our	*/
      /* definition target.					*/

      if def.class ^= CLASS_LINKAGE
        then call exit (infop, error_table_$bad_indirect_def, null);

      /* if the link is snapped, just get the value and return */

      targetp = addrel (linkp, def.thing_relp);
      if targetp -> its.its_mod = ITS_MODIFIER
        then do;
	targetp = targetp -> based_ptr;
	return;
        end;

      /* if not make sure it is a partial link */

      if targetp -> its.its_mod ^= FAULT_TAG_3
        then call exit (infop, error_table_$bad_indirect_def, null);

      /* then snap it, get the value and return */

      call snap_partial_link (infop, targetp, textp);
      targetp = targetp -> based_ptr;
      return;
    end;

  /* calculate the target based on the definition class and offset */

  if /* case */ def.class = CLASS_TEXT
    then targetp = addrel (textp, def.thing_relp);
  else if def.class = CLASS_LINKAGE
    then targetp = addrel (linkp, def.thing_relp);
  else if def.class = CLASS_STATIC
    then targetp = addrel (statp, def.thing_relp);
  else if def.class = CLASS_SYMBOL
    then targetp = addrel (symbp, def.thing_relp);
  else call exit (infop, error_table_$bad_class_def, null);

  end get_definition;

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


snap_partial_link:
  proc (infop,			/** call_info pointer   (in )	*/
       link_pairp,			/** link pair to snap   (i/o) */
       refp);			/** ref ptr for search  (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	snap_partial_link				*/
  /***	Input:	infop, link_pairp, refp			*/
  /***	Function:	snaps a partial link to another component in	*/
  /***		the same directory.				*/
  /***	Output:	link_pairp				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl link_pairp		ptr parameter;
  dcl refp		ptr parameter;

  /* based */

  dcl based_ptr		ptr based;
  dcl 01 info		aligned like call_info based (infop);
  dcl 01 link_pair		aligned like partial_link based (link_pairp);

  /* automatic */

  dcl 01 finish		aligned like usage automatic;
  dcl linkp		ptr automatic;
  dcl refname		char (32) automatic;
  dcl 01 start		aligned like usage automatic;
  dcl statp		ptr automatic;
  dcl symbp		ptr automatic;
  dcl textp		ptr automatic;

  /* get the name of the other component */

  refname = ltrim (char (link_pair.component));

  /* perform the search and meter the time and pagewaits */

  call usage_values (start.pf, start.time);
  call fs_search$same_directory (refp, refname, segp, code);
  call usage_values (finish.pf, finish.time);

  /* update the metering info */

  info.search.pf = info.search.pf + (finish.pf - start.pf);
  info.search.time = info.search.time + (finish.time - start.time);

  /* if we didn't find it, something is broken . . . */

  if code ^= 0
    then call exit (infop, code, null);

  /* combine the target linkage section */

  call combine_linkage (infop, segp, textp, linkp, statp, symbp);

  /* now snap the link based on the type and offset in the link */

  if /* case */ link_pair.type = CLASS_TEXT
    then link_pairp -> based_ptr = addrel (textp, link_pair.offset);
  else if link_pair.type = CLASS_LINKAGE
    then link_pairp -> based_ptr = addrel (linkp, link_pair.offset);
  else if link_pair.type = CLASS_STATIC
    then link_pairp -> based_ptr = addrel (statp, link_pair.offset);
  else if link_pair.type = CLASS_SYMBOL
    then link_pairp -> based_ptr = addrel (symbp, link_pair.offset);
  else call exit (infop, error_table_$bad_indirect_def, null);

  end snap_partial_link;

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


snap:
  proc (targetp,			/** value to snap to    (in )	*/
       expression,			/** offset to add	    (in ) */
       link_pairp);			/** link pair to snap   (i/o) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	snap					*/
  /***	Input:	targetp, expression, link_pairp		*/
  /***	Function:	completes the snapping of the link and sets	*/
  /***		targetp to point to the same value as the snapped	*/
  /***		link;					*/
  /***	Output:	targetp, link_pairp				*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl targetp		ptr parameter;
  dcl expression		fixed bin (17) parameter;
  dcl link_pairp		ptr parameter;

  /* based */

  dcl 01 link_as_its	aligned like its based (link_pairp);
  dcl 01 link_pair		aligned like object_link based (link_pairp);
  dcl link_ptr		ptr based (link_pairp);

  /* automatic */

  dcl modifier		bit (6) automatic;
  dcl sb			ptr automatic;

  /* add in the expression value */

  targetp = addrel (targetp, expression);

  /* get the original modifier from the link */

  modifier = link_pair.modifier;

  /* store the new pointer back into the link */

  link_ptr = targetp;

  /* put the link modifier back in */

  link_as_its.mod = modifier;

  /* put the run-depth into the pointer */

  sb = pds$stacks (level$get ());
  link_pair.run_depth = sb -> stack_header.run_unit_depth;

  end snap;

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


meter:
  proc (infop,			/** call_info pointer   (in )	*/
       type);			/** link type	    (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	meter					*/
  /***	Input:	infop, type				*/
  /***	Function:	given the call_info structure containing the	*/
  /***		metering info for the last call, and the type of	*/
  /***		link snapped, update the perprocess link meters	*/
  /***		in pds and the system_wide meters in ahd.	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl type		fixed bin (18) unsigned parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);
  dcl 01 lm		aligned like link_meters based (lmp);

  /* automatic */

  dcl elapsed_time		fixed bin (35) automatic;
  dcl elapsed_pf		fixed bin (30) automatic;
  dcl bin_no		fixed bin automatic;
  dcl lmp			ptr automatic;

  /* get the final metering values */

  call usage_values (info.finish.pf, info.finish.time);

  /* calculate the elapsed time and pagewaits */

  elapsed_time = bin (info.finish.time - info.start.time, 35);
  elapsed_pf = bin (info.finish.pf - info.start.pf, 30);

  /* determine which bin this fault goes into */

  bin_no = max (1, min (4, divide (elapsed_time, 25000, 17, 0) + 1));

  /* update the counts in pds */

  pds$link_meters_bins (bin_no) = pds$link_meters_bins (bin_no) + 1;
  pds$link_meters_pgwaits (bin_no) = pds$link_meters_pgwaits (bin_no) +
       elapsed_pf;
  pds$link_meters_times (bin_no) = pds$link_meters_times (bin_no) +
       elapsed_time;

  /* update the ahd link meters */

  lmp = addr (ahd$link_meters (bin_no));

  lm.total = lm.total + 1;
  lm.pf = lm.pf + elapsed_pf;
  lm.time = lm.time + elapsed_time;

  if /* case */ (info.type = Link_fault | info.type = Link_force) &
       (type = LINK_REFNAME_BASE | type = LINK_REFNAME_OFFSETNAME)
    then do;
      lm.search_pf = lm.search_pf + info.search.pf;
      lm.search_time = lm.search_time + info.search.time;
      lm.get_linkage_pf = lm.get_linkage_pf + info.get_linkage.pf;
      lm.get_linkage_time = lm.get_linkage_time + info.get_linkage.time;
      lm.defsearch_pf = lm.defsearch_pf + info.def_search.pf;
      lm.defsearch_time = lm.defsearch_time + info.def_search.time;
    end;
  else if type = LINK_CREATE_IF_NOT_FOUND
    then do;
      lm.total_type_6 = lm.total_type_6 + 1;
      lm.type_6_pf = lm.type_6_pf + elapsed_pf;
      lm.type_6_time = lm.type_6_time + elapsed_time;
    end;
  else do;
    if info.type = Make_entry | info.type = Make_ptr
      then lm.tot_make_ptr = lm.tot_make_ptr + 1;
    lm.total_others = lm.total_others + 1;
    lm.others_pf = lm.others_pf + elapsed_pf;
    lm.others_time = lm.others_time + elapsed_time;
  end;

  end meter;

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


trap:
  proc (infop,			/** call_info pointer   (in )	*/
       target_linkagep,		/** target linkage scn  (in ) */
       targetp);			/** return value	    (in ) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	trap					*/
  /***	Input:	infop, target_linkagep, targetp		*/
  /***	Function:	executes first reference traps in the target of	*/
  /***		the link snapped.  Since this operation involves	*/
  /***		calling back out to the user ring, we set fix up	*/
  /***		the maching conditions, error codes, and return	*/
  /***		values prior to calling trap_caller_caller_.	*/
  /***		If there are no traps, we return and exit through	*/
  /***		the normal mechanism.			*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl target_linkagep	ptr parameter;
  dcl targetp		ptr parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);

  /* now we see if we have first reference traps to run in the target	*/
  /* of the link we just finished snapping.			*/

  if target_linkagep ^= null
    then do;
      if target_linkagep -> virgin_linkage_header.first_ref_relp ^= None
        then do;

	/* we adjust the machine conditions now, since we won't	*/
	/* return from trap_caller_caller_ . . .		*/

	call adjust_mc (mcp);

	/* set the return values */

	if info.type ^= Link_fault
	  then a_code = 0;

	if /* case */ info.type = Make_ptr
	  then a_targetp = targetp;
	else if info.type = Make_entry
	  then addr (a_targete) -> based_entry.code_ptr = targetp;

	/* now we complete tracing of the fault, since the trap	*/
	/* should not return.				*/

	call page$enter_data ((targetp), linkage_fault_end);

	/* trap back to the user ring and execute the firstref traps */

	call trap_caller_caller_ (info.mcp, target_linkagep, null,
	     null, null, info.codep, code);

	/* just in case we returned. . . */

	if info.mcp ^= null
	  then call exit (infop, code, null);
        end;

    end;

  end trap;

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


adjust_mc:
  proc (mcp);			/** machine conditions  (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	adjust_mc					*/
  /***	Input:	mcp					*/
  /***	Function:	adjusts the fault machine conditions so that the	*/
  /***		fault can be restarted.			*/
  /***	Output:	none.					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl mcp			ptr parameter;

  /* based */

  dcl 01 instr		aligned based (instrp),
       02 address		bit (18) unaligned,
       02 op_code		bit (12) unaligned,
       02 modifier		bit (6) unaligned;

  /* automatic */

  dcl scup		ptr automatic;
  dcl instrp		ptr automatic;

  /* don't try fixing machine conditions that aren't there. . . */

  if mcp = null
    then return;

  scup = addr (mcp -> mc.scu);
  instrp = addr (scup -> scu.even_inst);
  instr.address = scup -> scu.ca;
  instr.modifier = indirect;

  end adjust_mc;

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

connect_fail_handler_:
  proc (a_mcp,			/** machine conditions  (in )	*/
       a_condition_name,		/** condition name	    (in ) */
       a_wcp,			/** crawlout info	    (in ) */
       a_infop,			/** condition info	    (in ) */
       a_continue_flag);		/** continue flag	    (out) */

  /*** ****************************************************************/
  /***							*/
  /***	Name:	connect_fail_handler_			*/
  /***	Input:	mcp, condition_name, wcp, infop, continue_flag	*/
  /***	Function:	handles the seg_fault condition.  This handler	*/
  /***		in enabled prior to the definition search in	*/
  /***		type-4 and type-6 links.  When invoked, the	*/
  /***		faulting segment is compared with the global	*/
  /***		variable segp, it the segments are not the same,	*/
  /***		this means we have faulted somewhere unexpected,	*/
  /***		so we continue to signal.  If the fault occurred	*/
  /***		on the expected segment, we assume it is because	*/
  /***		of a connection failure and simply return abort	*/
  /***		the link fault returning the appropriate code.	*/
  /***							*/
  /***		NB.  Because of the machanism involved, this	*/
  /***		     procedure assumes that the global variables	*/
  /***		     segp and call_infop are set prior to the	*/
  /***		     establishment of the condition handler.	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl a_mcp		ptr parameter;
  dcl a_condition_name	char (*) parameter;
  dcl a_wcp		ptr parameter;
  dcl a_infop		ptr parameter;
  dcl a_continue_flag	bit (1) parameter;

  /* automatic */

  dcl faulted_segno		fixed bin (18) automatic;
  dcl segno		fixed bin (18) automatic;
  dcl scup		ptr automatic;

  /* get the segment numbers of the faulting segment and the target	*/
  /* segment of the current link snapping operation		*/

  a_continue_flag = false;
  scup = addr (a_mcp -> mc.scu);
  faulted_segno = bin (scup -> scu.tpr.tsr, 18);
  segno = bin (baseno (segp), 18);

  /* if they are different, continue to signal */

  if faulted_segno ^= segno
    then do;
      a_continue_flag = true;
      return;
    end;

  /* otherwise assume a connection failure, and return the code */

  connect_fail_code = a_mcp -> mc.errcode;

  /* NB.  here we set a global code and do a non-local goto which	*/
  /*	then calls the exit procedure rather than calling exit	*/
  /*	directly in order to keep the exit and adjust_mc procedures	*/
  /*	as quick procedures.				*/

  goto CONNECT_FAIL_EXIT;

  end connect_fail_handler_;

CONNECT_FAIL_EXIT:
  call exit (call_infop, connect_fail_code, null);

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


exit:
  proc (infop,			/** call_info pointer   (in )	*/
       code,			/** code to return	    (in ) */
       targetp);			/** target (for trace)  (in )	*/

  /*** ****************************************************************/
  /***							*/
  /***	Name:	exit					*/
  /***	Input:	info, code, targetp				*/
  /***	Function:	returns from the fault or gate entry and cleans	*/
  /***		up.  This procedure differs depending on where	*/
  /***		we entered from:				*/
  /***		  link_fault - save the code in the machine	*/
  /***			     conditions, adjust the machine	*/
  /***			     conditions to allow restart, reset	*/
  /***			     the validation level back,	*/
  /***			     complete the fault trace, and exit	*/
  /***		  link_force - set the code to be returned,	*/
  /***			     complete the fault trace, and exit	*/
  /***		  make_ptr   - set the return pointer and code,	*/
  /***			     complete the fault trace, and exit	*/
  /***		  make_entry - set the return entry and code,	*/
  /***			     complete the fault trace, and exit	*/
  /***							*/
  /***		NB.  When completing the fault trace, the code to	*/
  /***		     be returned is examined.  If it it nonzero,	*/
  /***		     the info_ptr for the call to page$enter_data	*/
  /***		     is 0|0.  If the code is zero, the targetp	*/
  /***		     value is passed to page$enter_data.	*/
  /***	Output:	none					*/
  /***							*/
  /*** ****************************************************************/

  /* parameters */

  dcl infop		ptr parameter;
  dcl code		fixed bin (35) parameter;
  dcl targetp		ptr parameter;

  /* based */

  dcl 01 info		aligned like call_info based (infop);
  dcl 01 exit_mc		aligned like mc based (info.mcp);

  /* if we had a make_ptr or make_entry call, set the return value */

  if /* case */ info.type = Make_ptr
    then a_targetp = targetp;
  else if info.type = Make_entry
    then addr (a_targete) -> based_entry.code_ptr = targetp;

  /* return the code */

  if info.type = Link_fault
    then do;
      call level$set ((info.save_ring));
      exit_mc.errcode = code;
      call adjust_mc (info.mcp);
    end;
    else a_code = code;

  /* complete fault tracing */

  if code = 0
    then call page$enter_data ((targetp), linkage_fault_end);
    else call page$enter_data (baseptr (0), linkage_fault_end);

  /* non-local goto to outer level and return */

  goto EXIT;

  end exit;

EXIT:
  return;

/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
%page;
/****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


%include definition_dcls;
%page;
%include its;
%page;
%include link_meters;
%page;
%include mc;
%page;
%include object_link_dcls;
%page;
%include stack_header;
%page;
%include system_link_names;
%page;
%include trace_types;

  end link_snap;




		    list_inacl_all.pl1              11/11/89  1132.4r w 11/11/89  0800.6       77373



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


/* format: style2 */

list_inacl_all:
     proc (a_dirname, a_area_ptr, a_acl_ptr, a_info_ptr, a_code);

/* Modified 06/11/84 by Keith Loepere to use the new dc_find. */
/* Modified 05/10/79 by B Margulies to remove xmode check */
/* Modified 07/77 by THVV for bad_dir_ check */
/* modified by R. Bratt 06/01/76 to call find_$finished */
/* modified by Kobziar 1/24/75 to accept a null area ptr and return only counts */
/* coded RE Mullen: 4/13/74 */

	dcl     a_acl_ptr		 ptr parameter;
	dcl     a_area_ptr		 ptr parameter;
	dcl     a_code		 fixed bin (35) parameter;
	dcl     a_dirname		 char (*) parameter;
	dcl     a_info_ptr		 ptr parameter;

	dcl     1 acl_arrays	 aligned based (acl_ptr),
		2 seg_aclsa	 (alloc_seg_acl_count) aligned like segment_acl_entry,
		2 dir_aclsa	 (alloc_dir_acl_count) aligned like directory_acl_entry;
	dcl     1 dir_acls		 (dir_acl_count) aligned like directory_acl_entry based (da_ptr);
	dcl     1 inacl_info	 aligned based (info_ptr) like list_inacl_all_info;
						/* Our structure */
	dcl     1 list		 aligned based,
		2 frp		 bit (18) unal,
		2 brp		 bit (18) unal;
	dcl     1 seg_acls		 (seg_acl_count) aligned like segment_acl_entry based (sa_ptr);
	dcl     user_area		 area based (area_ptr);

	dcl     1 a_n		 aligned,
		2 ac_name,
		  3 person	 char (32),
		  3 project	 char (32),
		  3 tag		 char (1),
		2 mode		 bit (36),
		2 ex_mode		 bit (36);
	dcl     acls_listed		 fixed bin (17);
	dcl     alloc_dir_acl_count	 fixed bin;
	dcl     alloc_seg_acl_count	 fixed bin;
	dcl     area_ptr		 pointer;
	dcl     called_find		 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     d_s		 bit (1) aligned;
	dcl     da_ptr		 pointer;
	dcl     dir_acl_count	 fixed bin;
	dcl     dir_aclx		 fixed bin;
	dcl     dirname		 char (168);
	dcl     i			 fixed bin (17);
	dcl     info_ptr		 pointer;
	dcl     lev		 fixed bin (17);
	dcl     list_ptr		 pointer;
	dcl     locked		 bit (1) aligned;
	dcl     return_the_acls	 bit (1) aligned;
	dcl     sa_ptr		 pointer;
	dcl     saved_dir_change_pclock
				 fixed bin (35);
	dcl     seg_acl_count	 fixed bin;
	dcl     seg_aclx		 fixed bin;

	dcl     (area, bad_dir_, cleanup, seg_fault_error)
				 condition;

	dcl     acl_$list_entry	 entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (17), fixed bin (35));
	dcl     lock$dir_lock_read	 entry (ptr, fixed bin (35));
	dcl     lock$dir_unlock	 entry (ptr);

	dcl     error_table_$noalloc	 ext fixed bin (35);
	dcl     error_table_$null_info_ptr
				 ext fixed bin (35);

	dcl     (addr, bin, bit, max, rtrim, null, ptr, rel, sum, unspec)
				 builtin;
%page;
	dirname = a_dirname;			/* copy args  befor locking dir */
	area_ptr = a_area_ptr;
	info_ptr = a_info_ptr;

RESTART:
	acl_ptr = null;
	locked, called_find = "0"b;
	sa_ptr, da_ptr = null;
	on cleanup call cleanup_;

	if info_ptr = null
	then call fatal_error (error_table_$null_info_ptr);

	return_the_acls = (area_ptr ^= null);

/* Find the directory and lock it. */

	call dc_find$dir_read (dirname, dp, code);
	if code ^= 0
	then call fatal_error (code);
	called_find = "1"b;
	locked = "1"b;

/* See how much info to return */

	seg_acl_count = sum (dir.iacl_count.seg);
	dir_acl_count = sum (dir.iacl_count.dir);

	if seg_acl_count + dir_acl_count = 0
	then do;
		unspec (inacl_info) = ""b;
		call unlock_dir;
		a_acl_ptr = null;
		a_code = 0;
		go to RETURN;
	     end;


	if return_the_acls
	then do;

		saved_dir_change_pclock = dir.change_pclock;

		call lock$dir_unlock (dp);
		locked = "0"b;

		on area call fatal_error (error_table_$noalloc);

		alloc_seg_acl_count = max (1, seg_acl_count);
		alloc_dir_acl_count = max (1, dir_acl_count);

		allocate acl_arrays in (user_area) set (acl_ptr);

		revert area;

		sa_ptr = addr (seg_aclsa);		/* avoid expensive runtime adress preparation */
		da_ptr = addr (dir_aclsa);

		on seg_fault_error signal bad_dir_;
		call lock$dir_lock_read (dp, code);
		revert seg_fault_error;
		locked = "1"b;

		if code ^= 0
		then call fatal_error (code);

		if dir.change_pclock ^= saved_dir_change_pclock
		then do;
			call unlock_dir;
			call free_storage;
			go to RESTART;
		     end;
	     end;

/* Call internal proc for seg and dir iacls per ring */

	seg_aclx, dir_aclx = 1;
	acls_listed = 0;

	d_s = "0"b;				/* set switch for internal proc */

	do lev = 0 to 7;				/* do all rings */

	     call do_one_list (addr (dp -> dir.iacl (lev).seg_frp), dir.iacl_count (lev).seg);
	end;

	d_s = "1"b;
	do lev = 0 to 7;
	     call do_one_list (addr (dp -> dir.iacl (lev).dir_frp), dir.iacl_count (lev).dir);
	end;

	if acls_listed < (seg_acl_count + dir_acl_count)
	then signal bad_dir_;			/* make sure we found all we were supposed to */

	call unlock_dir;

	a_code = 0;
	a_acl_ptr = acl_ptr;
	return;
%page;
do_one_list:
     proc (acl_start_ptr, a_n_iacls);

	dcl     a_n_iacls		 fixed bin unal parameter;
	dcl     acl_start_ptr	 pointer parameter;

	dcl     access_name		 character (32);
	dcl     n_iacls		 fixed bin;

	n_iacls = a_n_iacls;
	i = 0;
	list_ptr = acl_start_ptr;
	if n_iacls = 0
	then do;
		if list_ptr -> list.frp ^= ""b
		then signal bad_dir_;
		else if d_s
		then do;
			inacl_info.dia_relp (lev) = ""b;
			inacl_info.dia_count (lev) = 0;
		     end;
		else do;
			inacl_info.sia_relp (lev) = ""b;
			inacl_info.sia_count (lev) = 0;
		     end;
		return;
	     end;

	if d_s
	then do;
		inacl_info.dia_relp (lev) = rel_to_acl_ptr (addr (dir_acls (dir_aclx)));
		inacl_info.dia_count (lev) = n_iacls;
	     end;
	else do;
		inacl_info.sia_relp (lev) = rel_to_acl_ptr (addr (seg_acls (dir_aclx)));
		inacl_info.sia_count (lev) = n_iacls;
	     end;

	do while (list_ptr -> list.frp ^= ""b);
	     list_ptr = ptr (list_ptr, list_ptr -> list.frp);
	     i = i + 1;
	     if i > n_iacls
	     then signal bad_dir_;

	     if return_the_acls
	     then do;				/* want all the info */

		     call acl_$list_entry (n_iacls, dir.uid, acl_start_ptr, addr (a_n), i, code);
		     if code ^= 0
		     then call fatal_error (code);

		     acls_listed = acls_listed + 1;

		     access_name =
			rtrim (a_n.ac_name.person) || "." || rtrim (a_n.ac_name.project) || "." || a_n.ac_name.tag;

		     if d_s
		     then do;
			     if dir_aclx > dir_acl_count
			     then signal bad_dir_;
			     dir_acls (dir_aclx).access_name = access_name;
			     dir_acls (dir_aclx).mode = a_n.ex_mode;
			     dir_acls (dir_aclx).status_code = 0;
						/* no per user errors on list */
			     dir_aclx = dir_aclx + 1;
			end;
		     else do;
			     if seg_aclx > seg_acl_count
			     then signal bad_dir_;
			     seg_acls (seg_aclx).access_name = access_name;
			     seg_acls (seg_aclx).mode = a_n.mode;
			     seg_acls (seg_aclx).extended_mode = a_n.ex_mode;
			     seg_acls (seg_aclx).status_code = 0;
			     seg_aclx = seg_aclx + 1;
			end;
		end;
	     else acls_listed = acls_listed + 1;	/* just count */
	end;
	if i < n_iacls
	then signal bad_dir_;

rel_to_acl_ptr:
     procedure (aptr) returns (bit (18)) reducible;

	dcl     aptr		 pointer parameter;

	dcl     relf		 fixed bin (18) uns;

	relf = bin (rel (aptr), 18) - bin (rel (acl_ptr), 18);
	return (bit (relf, 18));
     end rel_to_acl_ptr;

     end do_one_list;

fatal_error:
     procedure (c);
	dcl     c			 fixed bin (35);

	call unlock_dir;
	call free_storage;
	a_code = c;
	go to ERR_RETURN;
     end fatal_error;
RETURN:
ERR_RETURN:
	return;

unlock_dir:
     procedure;
	if called_find
	then call dc_find$finished (dp, locked);
	else if locked
	then call lock$dir_unlock (dp);
     end unlock_dir;

free_storage:
     procedure;
	if acl_ptr ^= null
	then free acl_arrays;
     end free_storage;

cleanup_:
     procedure;
	call free_storage;
	if called_find
	then call dc_find$finished (dp, "0"b);		/* leave locked for verify lock */
     end cleanup_;
%page;
%include acl_structures;
%page;
%include dc_find_dcls;
%page;
%include dir_header;
%page;
%include list_inacl_all_info;
     end list_inacl_all;




		    make_seg.pl1                    11/11/89  1132.4rew 11/11/89  0800.6       29115



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


/* The make_seg procedure creates a branch in a
   specified directory with a specified entry name.  Once
   the branch is created, the segment is made known to the
   process by a call to "initiate" and a pointer to the
   segment is returned to the caller. */

make_seg: procedure (adirname, aentry, arefname, amode, asegptr, acode);

/* Modified by R. Bratt 04/76 to make "" and " " equivalent arguments for dname/ename */
/* Modified by E. Stone 10/73 to remove the $stack entry point */

dcl  adirname char (*),				/* is the directory in which to create "entry". */
     aentry char (*),				/* is the entry name in question. */
     arefname char (*),				/* is the desired reference name, or "". */
     amode fixed bin (5),				/* specifies the mode for this user. */
     asegptr ptr,					/* is an ITS pointer to the created segment.
						   (Output) */
     acode fixed bin;				/* is a standard File System status code.
						   (Output) */

dcl  dirname char (168),				/* copy of directory name */
     entry char (32),				/* copy of entry name */
    (code1, code2) fixed bin (35);			/* error codes */

dcl  pds$process_dir_name char (32) ext,		/* name of process directory */
     error_table_$namedup fixed bin (35) ext;		/* error code for name duplication */

dcl (null, length) builtin;

dcl  unique_chars_ ext entry (bit (*) aligned) returns (char (15)),
     append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)),
     initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));


/*  */

	asegptr = null;				/* Initialize pointer. */

	dirname = adirname;
	if dirname = ""				/* If supplied directory name is null ... */
	then dirname = pds$process_dir_name;		/* Use process directory name. */

	entry = aentry;
	if entry = ""				/* If supplied entry name is null ... */
	then entry = unique_chars_ ("0"b);		/* Use unique name. */

	call append$branch (dirname, entry, amode, code1); /* Now create segment branch in hierarchy. */
	if code1 ^= 0 then				/* If error ... */
	     if code1 ^= error_table_$namedup then	/* If not a name duplication ... */
		go to make_rtn;			/* Return the error code2. */

	call initiate (dirname, entry, arefname, 0, 0, asegptr, code2);
						/* Initiate the segment. */

	if code2 ^= 0 then				/* If error in initiate ... */
	     acode = code2;				/* Return error code from initiate. */
	else					/* Otherwise ... */
make_rtn:
	acode = code1;				/* Return error code from append. */
	return;					/* Return to caller. */




     end make_seg;




		    makestack.pl1                   11/11/89  1132.4r w 11/11/89  0800.6      123669



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


/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/*			MAKESTACK
   *
   *	This is a  ring (0)  procedure which is called to make a stack for a ring.
   *	The number of the ring for which the stack is being made is passed as an argument to
   *	makestack.    All of the operations performed by  makestack  will be in behalf of this
   *	 ring.
   *
   * Last modified (date and reason):
   *		3/85 by Keith Loepere to not append stacks through links.
   *		6/79 by C. Hornig to do less for prelinked rings
   *		11/77 by M. Weaver to set aside a special area for ref names
   *		6/77 by M. Weaver to set static handlers for isot_fault and lot_fault
   *		3/77 by M. Weaver to add initialize_rnt code and to initialize ect_ptr
   *		11/76 by M. Weaver to extend stack header
   *		10/75 by R. Bratt for prelinking and to cleanup
   *		9/74    by S.Webber as part of combining stacks, lots, and clrs
   *		Modified 12/73 by E. Stone to remove assumption that pl1_operators_ is the same in all rings
   *		,i.e. the placing of pointers to the alm operators in the stack header.
   *		Modified 10/73 by E. Stone to set the max_length of the stack less than 256K
   *		and to terminate the process if the stack exists or if the segment number has been used
   *		and to place a pointer to operator_pointers_ in the stack header for B. Wolman
   *		Recoded to include new stack format  -  3/72  by  Bill Silver
   *		Recoded in  PL/I  -  8/70  by  N. I. Morris
   */


makestack: procedure (a_ring_num);


dcl  a_ring_num fixed bin (3);			/* ring number for stack */

dcl 1 instruction based aligned,
    2 tra_offset bit (18) unaligned,			/* References  offset  portion of  tra  instruction
						   *  in transfer vector table in pl1_operators_.   These
						   *  tra   instructions transfer to  ALM linkage operators. */
    2 rest bit (18) unaligned;


dcl  ring_num fixed bin (3),				/* Work variable where the   ring number argument
						   is  copied.  */
     save_val fixed bin (3),				/* Used to save the current validation level when the
						   procedure is entered.  */
     segno fixed bin,				/* segment number of new stack */
     dirname char (168),
     stack_name char (8),				/* The reference name  ( and entry name ) of the new
						   stack  segment.  */
     pl1_op_ptr ptr,				/* A pointer to the pl1 operators table. */
     workptr ptr,					/* A work pointer used in calls to  link_snap$make_ptr */
						/* And to construct ptrs to operators in the stack header. */
     sctp (0:1) ptr unaligned based,
     1 local_create_branch_info aligned like create_branch_info,
     code fixed bin (35);				/* An internal  error  code.  */


/*	The following declarations are made in order to reference data in the
   *	process  data  segment.
   */

dcl  pds$stacks (0:7) pointer external;			/* An array of stack pointers for all possible rings. */
dcl  pds$prelinked_ring (7) bit (1) unaligned ext;
dcl  active_all_rings_data$stack_base_segno fixed bin (18) ext; /* Segment number of ring 0 stack. */
dcl  pds$process_dir_name char (32) ext;
dcl  pds$process_group_id char (32) ext;
dcl 1 pds$useable_lot aligned ext,
    2 flags (0:7) bit (1) unal;



/*	MAKESTACK uses the following external  entry points.
   */

dcl  level$get ext entry (fixed bin (3)),
     level$set ext entry (fixed bin (3)),
     link_man$get_initial_linkage entry (fixed bin (3)),
     link_snap$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin (35)),
     append$create_branch_ ext entry (char (*), char (*), ptr, fixed bin (35)),
     initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     ref_name_$insert entry (char (32) varying, fixed bin, fixed bin (35)),
     set$max_length_ptr ext entry (ptr, fixed bin (19), fixed bin (35)),
     syserr$error_code ext entry options (variable),
     terminate_proc ext entry (fixed bin (35));

dcl  sys_info$default_stack_length fixed bin (19) ext;
dcl  error_table_$invalid_stack_creation ext fixed bin (35);

dcl (addr,
     addrel,
     baseno,
     baseptr,
     fixed,
     null,
     ptr,
     rel,
     size,
     string,
     substr,
     unspec) builtin;
%page;
	ring_num = a_ring_num;
	sb, pds$stacks (ring_num)
	     = baseptr (ring_num + active_all_rings_data$stack_base_segno); /* Compute expected stack pointer. */
	segno = fixed (baseno (sb), 17);

	if pds$prelinked_ring (ring_num)
	then do;
	     stack_header.null_ptr = null ();		/* force the stack to be copied */
	     pds$useable_lot.flags (ring_num) = "1"b;	/* this saves trouble later */
	     return;
	end;

	call level$get (save_val);
	call level$set (ring_num);
	dirname = pds$process_dir_name;
	stack_name = "stack_" || substr ("1234567", ring_num, 1);

	unspec (local_create_branch_info) = "0"b;	/* describe new stack, no chasing allowed */
	local_create_branch_info.version = create_branch_version_2;
	local_create_branch_info.parent_ac_sw = "1"b;
	local_create_branch_info.mode = REW_ACCESS;
	local_create_branch_info.rings (*) = ring_num;
	local_create_branch_info.userid = pds$process_group_id;

	call append$create_branch_ (dirname, stack_name, addr (local_create_branch_info), code);
	if code ^= 0 then do;			/* User cannot make his own stack */
	     call syserr$error_code (4, code, "makestack: error appending ^a", stack_name);
	     call terminate_proc (error_table_$invalid_stack_creation);
	end;
	call initiate (dirname, stack_name, "", 1, 1, sb, code);
						/* can't use reference names yet */
	if code ^= 0 then do;			/* Prevent user from using reserved segment number */
	     call syserr$error_code (4, code, "makestack: error initiating ^a", stack_name);
	     call terminate_proc (error_table_$invalid_stack_creation);
	end;
	call set$max_length_ptr (sb, sys_info$default_stack_length, code);
	if code ^= 0
	then call syserr$error_code (2, code, "makestack: error from set$max_length_ptr on ^a.", stack_name);

	stack_header.null_ptr,
	     stack_header.ect_ptr = null ();
	stack_header.stack_begin_ptr,
	     stack_header.stack_end_ptr = ptr (sb, size (stack_header));
	call link_man$get_initial_linkage (ring_num);
	pds$useable_lot.flags (ring_num) = "1"b;
	unspec (stack_header.lot_ptr -> lot.lp (segno)) = lot_fault;
	call initialize_rnt;			/* allocate RNT and set search rules */
	call ref_name_$insert ((stack_name), segno, code); /* now we can add reference name */

/*	Now fill in the fields in the  header  of the  new  stack.  */

	stack_header.signal_ptr = get_ptr ("signal_", "signal_");
	stack_header.unwinder_ptr = get_ptr ("unwinder_", "unwinder_");
	stack_header.trans_op_tv_ptr = get_ptr ("operator_pointers_", "operator_pointers_");
	pl1_op_ptr = get_ptr ("pl1_operators_", "operator_table");



/*	Get the following pl1 operator pointers from offsets within the pl1 operator table transfer vector */

	workptr = addrel (pl1_op_ptr, tv_offset);

	stack_header.pl1_operators_ptr = pl1_op_ptr;
	stack_header.call_op_ptr =
	     ptr (workptr, addrel (workptr, call_offset) -> instruction.tra_offset);
	stack_header.push_op_ptr =
	     ptr (workptr, addrel (workptr, push_offset) -> instruction.tra_offset);
	stack_header.return_op_ptr =
	     ptr (workptr, addrel (workptr, return_offset) -> instruction.tra_offset);
	stack_header.return_no_pop_op_ptr =
	     ptr (workptr, addrel (workptr, return_no_pop_offset) -> instruction.tra_offset);
	stack_header.entry_op_ptr =
	     ptr (workptr, addrel (workptr, entry_offset) -> instruction.tra_offset);

/*	set up essential static handlers */

	call link_snap$make_ptr (null (), "copy_on_write_handler_", "copy_on_write_handler_", workptr, code);
	ptr (sb, rel (stack_header.sct_ptr)) -> sctp (no_write_permission_sct_index) = workptr;
	ptr (sb, rel (stack_header.sct_ptr)) -> sctp (not_in_write_bracket_sct_index) = workptr;
	call link_snap$make_ptr (null (), "isot_fault_handler_", "isot_fault_handler_", workptr, code);
	ptr (sb, rel (stack_header.sct_ptr)) -> sctp (isot_fault_sct_index) = workptr;
	call link_snap$make_ptr (null (), "lot_fault_handler_", "lot_fault_handler_", workptr, code);
	ptr (sb, rel (stack_header.sct_ptr)) -> sctp (lot_fault_sct_index) = workptr;

/*	We have finished setting up the header of the new  stack.   There are no more calls to be
   *	made  so we will reset the validation level of this procedure to what it was when the procedure
   *	was  called.    Then we will set up the two thread pointers in the first stack frame of the
   *	new  stack.   Note the previous frame pointer is null since there is no previous frame.
   *	The pointer to the first stack frame has been set up above in the stack_begin_ptr.
   */

	call level$set (save_val);
	sp = stack_header.stack_end_ptr;
	sp -> stack_frame.prev_sp = null;
	sp -> stack_frame.next_sp = addrel (stack_header.stack_end_ptr, stack_frame_min_length);


get_ptr:	proc (refname, defname) returns (ptr);
dcl (refname, defname) char (*);
	     call link_snap$make_ptr (null (), refname, defname, workptr, code);
	     if code ^= 0 then do;
		call syserr$error_code (0, code, "makestack: error finding ^a$^a for ^a.", refname, defname, stack_name);
		call terminate_proc (error_table_$invalid_stack_creation);
	     end;
	     return (workptr);
	end get_ptr;
%page;
initialize_rnt: proc;

dcl  rnt_space (2048) bit (36) aligned based;
dcl 1 ainfo aligned like area_info;

dcl  size builtin;

dcl  error_table_$termination_requested ext fixed bin (35);
dcl  terminate_proc entry (fixed bin (35));
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  pds$processid bit (36) aligned ext;
dcl  initiate_search_rules$init_ring entry (ptr, fixed bin (35));
dcl  syserr$error_code entry options (variable);

%include rnt;

%include area_info;

dcl 1 default_rules static options (constant) aligned,
    2 number fixed bin init (1),
    2 name char (168) init ("default");
%page;
/* obtain an rnt area */

	     ainfo.version = area_info_version_1;
	     string (ainfo.control) = "0"b;
	     ainfo.control.zero_on_free = "1"b;
	     ainfo.control.system = "1"b;
	     ainfo.owner = "rnt";
	     ainfo.size = size (rnt_space);
	     allocate rnt_space in (stack_header.clr_ptr -> based_rnt_area) set (ainfo.areap);
	     call define_area_ (addr (ainfo), code);
	     if code ^= 0 then call terminate_proc (error_table_$termination_requested);


/*	initialize the RNT itself */

	     allocate rnt in (ainfo.areap -> based_rnt_area) set (rntp);
	     unspec (rnt) = "0"b;
	     rnt.areap = ainfo.areap;
	     rnt.rnt_area_size = ainfo.size;
	     rnt.name_hash_table (*) = null ();
	     rnt.segno_hash_table (*) = null ();
	     rnt.srulep = null;
	     stack_header.rnt_ptr = rntp;

/*	initialize the search rules */

	     call initiate_search_rules$init_ring (addr (default_rules), code);
	     if code ^= 0 then do;
		call syserr$error_code (0, code, "makestack: error from initiate_search_rules.");
		call terminate_proc (error_table_$termination_requested);
		end;

	     return;
	end initialize_rnt;
%page;
% include access_mode_values;
% include create_branch_info;
% include lot;
% include stack_frame;
% include stack_header;
% include static_handlers;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   makestack: error from set$max_length_ptr on STACKNAME.

   S:	$term

   T:	$init
   Process/ring initialization.  Just prior to using a new ring.

   M:	The process directory is probably messed up.

   A:	Ignore unless it's the initializer, in which case bring the system back up.
   If problem persists, contact the system administrator.

   Message:
   makestack: error appending STACKNAME

   S:	$term

   T:	$init
   Process/ring initialization.  Just prior to using a new ring.

   M:	The process directory is probably messed up.

   A:	Ignore unless it's the initializer, in which case bring the system back up.
   If problem persists, contact the system administrator.

   Message:
   makestack: error getting bit count for original prelinked STACK_NAME

   S:	$term

   T:	$init
   Process/ring initialization.  Just prior to using a new ring.

   M:	A directory containing a prelinked subsystem is probably messed up.

   A:	The directory should be prelinked again.

   Message:
   makestack: error initiating STACKNAME

   S:	$term

   T:	$init
   Process/ring initialization.  Just prior to using a new ring.

   A:	Ignore unless it's the initializer, in which case bring the system back up.
   If problem persists, contact the system administrator.

   Message:
   makestack: error finding DIRNAME>ENAME for STACKNAME.

   S:	$term

   T:	$init
   Process/ring initialization.

   A:	Ignore unless it's the initializer, in which case bring the system back up.
   If problem persists, contact the system administrator.

   Message:
   makestack: error from initiate_search_rules.

   S:	$term

   T:	Process/ring initialization.  Just prior to using new ring.

   M:	The default search rules are missing from ahd (active hardcore data).
   These are usually loaded by the command set_system_search_rules.

   A:	$contact_sa

   END MESSAGE DOCUMENTATION */

     end makestack;




		    other_process_info.pl1          11/11/89  1132.4rew 11/11/89  0800.6       22509



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

/* format: style4 */

/* other_process_info - find out things about another process, typically
   by snooping in its pds */

/* 83-05-09 coded	E. N. Kittlitz */
/* 83-12-05 modified to lock AST while peeking at other guy's PDS */

other_process_info: proc;

dcl  a_code fixed bin (35);
dcl  a_processid bit (36) aligned;
dcl  a_privs bit (36) aligned;

dcl  abs_seg_ptr ptr;
dcl  pds_sdw bit (72) aligned;
dcl  pds_sdw_ptr ptr;
dcl  processid bit (36) aligned;

dcl  1 process_auth aligned like aim_template;

dcl  error_table_$process_unknown fixed bin (35) ext static;
dcl  initializer_abs_seg$ fixed bin ext static;
dcl  sst$ fixed bin ext static;

dcl  1 pds$access_authorization aligned like aim_template ext static;

dcl  get_ptrs_$given_astep entry (ptr) returns (bit (72) aligned);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  privileged_mode_ut$swap_sdw entry (ptr, ptr);
dcl  tc_util$get_aptep entry (bit (36) aligned, bit (1) aligned) returns (ptr);

dcl  (addr, null, ptr, rel) builtin;

	return;
%page;

get_privileges: entry (a_processid, a_privs, a_code);

	processid = a_processid;
	aptep = tc_util$get_aptep (processid, "1"b);
	if aptep = null then go to foo_process;
	abs_seg_ptr = addr (initializer_abs_seg$);
	pds_sdw_ptr = addr (pds_sdw);

	call lock$lock_ast;				/* AST LOCKED */

	pds_sdw = get_ptrs_$given_astep (ptr (addr (sst$), aptep -> apte.pds));
	call privileged_mode_ut$swap_sdw (abs_seg_ptr, pds_sdw_ptr);
	process_auth = ptr (abs_seg_ptr, rel (addr (pds$access_authorization))) -> aim_template;

	call lock$unlock_ast;			/* AST UNLOCKED */

	pds_sdw = ""b;
	call privileged_mode_ut$swap_sdw (abs_seg_ptr, pds_sdw_ptr);
	if apte.processid ^= processid then		/* something changed behind our backs */
	     go to foo_process;
	a_privs = unspec (addr (process_auth) -> aim_template.privileges);
	a_code = 0;
	return;

foo_process: a_code = error_table_$process_unknown;
	a_privs = ""b;
	return;

%page; %include aim_template;
%page; %include apte;

     end other_process_info;




		    proc_info.pl1                   11/11/89  1132.4rew 11/11/89  0800.6       18342



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


/* 	Procedure to return certain per-process info previously in process_info */
/*	Initially coded by R. J. Feiertag, Dec. 10,1969 */
/* 	Last modified by Kobziar July 74 to add authorization entry */

proc_info:	proc(process_id,process_group_id,process_dir_name,lock_id_);

	declare process_id bit(36) aligned,
		process_group_id char(32) aligned,
		process_dir_name char(32) aligned,
		lock_id_ bit(36) aligned,
		((pds$processid, pds$lock_id, tc_data$initializer_id) bit(36),
		 (pds$process_group_id, pds$process_dir_name) char(32)) aligned ext;


	process_id = pds$processid;		/* pick up process id */
	lock_id_ = pds$lock_id;		/* pick up lock id */
	process_group_id = pds$process_group_id;
	process_dir_name = pds$process_dir_name;
	return;

get_initial_ring: entry(iring);

dcl (pds$initial_ring ext, iring) fixed bin;

	iring = pds$initial_ring;

	return;			/* That was rather difficult! */

set_mask_ring: entry;			/* hphcs_ entry */

	if pds$processid = tc_data$initializer_id
	then pds$initial_ring = 4;		/* Initializer now wants to be masked in lower rings */
	return;

authorization: entry(auth, max_auth);

	declare (auth, max_auth) bit(72) aligned,
		(pds$access_authorization, pds$max_access_authorization) ext static aligned bit(72);

	auth = pds$access_authorization;
	max_auth = pds$max_access_authorization;
	return;

end proc_info;




		    quota.pl1                       11/11/89  1132.4r w 11/11/89  0800.0      234657



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

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

quota: proc;

/* QUOTA - directory control interface for managing quotas.

   Quotas live in the VTOC entry; or in the ASTE when the seg is active.
   There are two "quota cells" for each directory: one for pages of segments and one for directory pages.
   Each quota cell contains
   .	quota
   .	used
   .	clock
   .	time-page product
   .	received count (quota + all inferior quotas)
   .	inferior quota count

   The current program does not handle directory quota at all.

   Quota cell is protected by the directory lock.
   But used can only be satisfactorily protected by the PTL.
   So quotaw is called to look at or manipulate used, and he must be called
   with the AST locked since his inputs are asteps.

   vtoc_attributes is used to  read and write quota cells in VTOC.
   It may be called with or without AST locked */

/* Last change: */
/* Modified May 1985 by EJ Sharpe to use dc_find$mdir_set_quota_uid and to
     enforce AIM restriction on removing quota from upgraded master dirs */
/* Modified January 1985 by Keith Loepere to set tup at append_mdir_set. */
/* Modified November 1984 by Keith Loepere for auditing info. */
/* Modified July 1984 by Keith Loepere to use the new dc_find. */
/* Modified BIM 84-05 for sst reformat. */
/* Modified BIM 83-12-06 to correctly check dir privilege and upgradedness, TR 16411 */
/* Modified BIM 3/82 to only hold read locks when appropriate */
/* Modified 05/05/82 by S. Krupp to change error code invalid_move_quota to
   invalid_move_qmax and return ai_not_restricted in case of no privilege */
/* Modified November 1979 by C. Hornig for privileged quota reading */
/* Modified 19 Feb 79 by D. Spector for 18-bit quota values */
/* Modified June 1, 1976 by R. Bratt to call find_$finished */
/* Modified March 1976 by Larry Johnson for master directory quota */
/* Extensive changes for NSS by TVV 6/75 */
/* Modified by Kobziar 10-21-74 to add qmove_mylock entry */
/* Modified by Kobziar July 74 to call new entry in access_mode and to check authorization */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dp1			ptr parameter;
dcl  a_ename			char (*) parameter;
dcl  a_ep				ptr parameter;
dcl  a_ignore			fixed bin (17) parameter;
dcl  a_ltrp			fixed bin (71) parameter;
dcl  a_parent			char (*) parameter;
dcl  a_qchange			fixed bin (17) parameter;
dcl  a_quota			fixed bin (18) parameter;
dcl  a_seg_or_dir			bit (1) parameter;
dcl  a_segptr			ptr parameter;
dcl  a_slvid			bit (36) parameter;
dcl  a_taccsw			fixed bin (1) parameter;
dcl  a_trp			fixed bin (35) parameter;
dcl  a_trpc			fixed bin (35) parameter;
dcl  a_tup			bit (36) aligned parameter;
dcl  a_uchange			fixed bin (17) parameter;
dcl  a_uidpath			(0:15) bit (36) aligned parameter;
dcl  a_used			fixed bin (17) parameter;

/* Variables */

dcl  CHECK_ONLY			fixed bin (1) init (1) static options (constant);
dcl  LOTS				fixed bin (71) static options (constant) init (11111111111111111111111111111111111b); /* 35 1-bits */
dcl  ROOT_UID			bit (36) static options (constant) init ((36)"1"b);
dcl  SEC_PER_TICK			float bin static options (constant) init (.65536e-1); /* Convert fs time to seconds */

dcl  called_find			bit (1) aligned init ("0"b);
dcl  check_access			bit (1);
dcl  code				fixed bin (35);
dcl  curtime			bit (36) aligned;
dcl  dep				ptr;
dcl  dir_privilege			bit (1);
dcl  dir_quota_sw			bit (1) init ("0"b);/* TRUE only if doing dir quota */
dcl  dt				fixed bin (35);
dcl  ename			char (32);
dcl  len				fixed bin;
dcl  locked			bit (1) aligned init ("0"b);
dcl  ltrp				fixed bin (71);
dcl  moved_down			fixed bin (35);
dcl  mylock_entry			bit (1) aligned;
dcl  new_entry			bit (1) aligned init ("0"b);
dcl  not_root			bit (1) aligned init ("1"b);
dcl  now_terminal			bit (1);
dcl  parent			char (168);
dcl  parent_astep			ptr;
dcl  parent_dp			ptr;
dcl  parent_pvid			bit (36) aligned;
dcl  1 parent_qcell			like quota_cell aligned;
dcl  parent_uid			bit (36) aligned;
dcl  parent_vtocx			fixed bin;
dcl  pathname			char (168);
dcl  pvid				bit (36) aligned;
dcl  1 qcell			like quota_cell aligned;
dcl  qchange			fixed bin (18);
dcl  qt				fixed bin (18) init (0); /* default assumption is segs (=0) */
dcl  quota			fixed bin (18);
dcl  read_lock			bit (36) aligned init ("0"b);
dcl  segptr			ptr;
dcl  setquota_entry			bit (1) init ("0"b);
dcl  slvid			bit (36);
dcl  sstp				pointer;
dcl  taccsw			bit (1) aligned;
dcl  trp				fixed bin (35);
dcl  tup				bit (36) aligned;
dcl  uchange			fixed bin (18);
dcl  uid				bit (36) aligned;
dcl  uidpath			(0:15) bit (36) aligned;
dcl  unlock_son			bit (1);
dcl  used				fixed bin (18);
dcl  vtocx			fixed bin;
dcl  was_terminal			bit (1);
dcl  write_lock			bit (36) aligned init ("1"b);

/* External */

dcl  error_table_$ai_restricted	fixed bin (35) ext;
dcl  error_table_$argerr		fixed bin (35) ext;
dcl  error_table_$bad_ring_brackets	fixed bin (35) ext;
dcl  error_table_$invalid_move_qmax	fixed bin (35) ext;
dcl  error_table_$master_dir		fixed bin (35) ext;
dcl  error_table_$mdc_not_mdir	fixed bin (35) ext;
dcl  error_table_$rqover		fixed bin (35) ext;
dcl  pds$access_authorization		bit (72) aligned ext static;
dcl  sst_seg$			external static;
dcl  sst$root_astep			pointer external static;

/* Entries */

dcl  activate			entry (ptr, fixed bin (35)) returns (ptr);
dcl  aim_check_$greater		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  level$get			entry returns (fixed bin (17));
dcl  lock$dir_unlock		entry (ptr);
dcl  lock$unlock_ast		entry;
dcl  quotaw$cu			entry (ptr, fixed bin (18), bit (1), fixed bin (1), fixed bin (35));
dcl  quotaw$mq			entry (ptr, ptr, fixed bin (18), bit (1), fixed bin (35));
dcl  quotaw$sq			entry (ptr, fixed bin (18), bit (1), fixed bin (1));
dcl  sum$getbranch			entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  sum$dirmod			entry (ptr);
dcl  vtoc_attributes$get_quota	entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin (18), fixed bin (35));
dcl  vtoc_attributes$set_quota	entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin (18), fixed bin (35));

/* Misc */

dcl  (addr, bin, bit, clock, fixed, length, min, null, ptr, rtrim, substr, unspec) builtin;
%page;

/* ========================================================== */

/* qlong_reset, reset - entries which modify the trp of the directory only */
/* these are called by accounting to reduce the trp once a month. */
/* qreset is very probably obsolete */

dqlong_reset: entry (a_parent, a_ltrp, a_code);

	dir_quota_sw = "1"b;
	qt = 1;

qlong_reset: entry (a_parent, a_ltrp, a_code);

	ltrp = a_ltrp;				/* Copy arguments */
	go to reset1;

qreset: entry (a_parent, a_trpc, a_code);

	ltrp = a_trpc;				/* .. old style */
reset1:
	parent = a_parent;

	code = 0;					/* Clear return code */
	call dc_find$dir_write_priv (parent, FS_OBJ_TRP_MOD, dp, code); /* get pointer to directory */
	if code ^= 0 then go to errxit;
	called_find, locked = "1"b;

	call get_quota_cell;			/* read VTOC */
	qcell.trp = qcell.trp - ltrp;			/* Perform subtraction */
	call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), qt, code);
	call sum$dirmod (dp);			/* Make sure dir mod noted */
	goto done;

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

/* qset, qset_mylock, qreload, qrestor - support for entries which set the quota cell */
/* all four are highly-privileged entrypoints */

dqset: entry (a_parent, a_quota, a_code);

	dir_quota_sw = "1"b;
	qt = 1;

qset: entry (a_parent, a_quota, a_code);

	setquota_entry = "1"b;
	taccsw = "1"b;				/* Default */
	quota = a_quota;				/* Copy arg */
	parent = a_parent;				/* copy into char(168) aligned */

	code = 0;					/* Clear return code */
	call dc_find$dir_write_priv (parent, FS_OBJ_QUOTA_MOD, dp, code); /* get pointer to directory */
	if code ^= 0 then go to errxit;
	called_find, locked = "1"b;

	call get_quota_cell;			/* Read VTOCE */
	go to common;

dqrestor: entry (a_parent, a_quota, a_ltrp, a_tup, a_ignore, a_taccsw, a_code);

	dir_quota_sw = "1"b;
	qt = 1;

qrestor: entry (a_parent, a_quota, a_ltrp, a_tup, a_ignore, a_taccsw, a_code);
	ltrp = a_ltrp;				/* Privileged entry for SysAdmin */
	go to qreload_common;			/* .. and daemon */

qreload: entry (a_parent, a_quota, a_trp, a_tup, a_ignore, a_taccsw, a_code);

	ltrp = a_trp;
qreload_common:

	tup = a_tup;				/* Copy args */
	taccsw = bit (a_taccsw, 1);
	quota = a_quota;
	parent = a_parent;				/* copy into char(168) aligned */

	code = 0;					/* Clear return code */
	call dc_find$dir_write_priv (parent, FS_OBJ_QUOTA_RELOAD, dp, code); /* get pointer to directory */
	if code ^= 0 then go to errxit;
	called_find, locked = "1"b;

	call get_quota_cell;			/* read in quota info */
	qcell.trp = ltrp;
	qcell.tup = tup;

common:
	sstp = addr (sst_seg$);			/* Make segment active */
	astep = make_seg_active (dp);
	if aste.tqsw (qt) = taccsw then		/* if no change to terminal status */
	     aste.quota (qt) = quota;			/* just change quota in AST entry */
	else do;					/* for non-term quota, used must be subtracted from parent */
	     call quotaw$sq (astep, quota, dir_quota_sw, fixed (taccsw, 1));
						/* sets quota, adds or subs used from sup accts */
	     if setquota_entry then qcell.tup = bit (bin (clock (), 52), 52); /* on first qset set tup */
	end;
	qcell.received = qcell.received + quota - qcell.quota;
	qcell.quota = quota;			/* set quota in VTOC */
	qcell.terminal_quota_sw = aste.tqsw (qt);
	if not_root then call lock$unlock_ast;

	call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), qt, code);
	if not_root then do;			/* Unlock parent dir */
	     parent_dp = ptr (dep, 0);
	     call lock$dir_unlock (parent_dp);		/* unlock sup dir */
	end;
	call sum$dirmod (dp);			/* Make sure dir mod noted */
	goto done;

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

/* mdir_set: entry to set quota on a master directory */

mdir_set: entry (a_uidpath, a_quota, a_code);

	uidpath = a_uidpath;
	quota = a_quota;

	call dc_find$mdir_set_quota_uid (uidpath, parent, FS_OBJ_MDIR_QUOTA_MOD, ep, dp, code); /* finds directory */
	if code ^= 0 then go to errxit;
	locked, called_find = "1"b;
	parent_dp = ptr (ep, 0);

	if ^entry.master_dir then do;
	     code = error_table_$mdc_not_mdir;
	     go to unlock2;
	end;

	if level$get () > fixed (entry.ex_ring_brackets (1), 3) then do;
	     code = error_table_$bad_ring_brackets;
	     go to unlock2;
	end;

	uid = dir.uid;				/* setup to read vtoce */
	pvid = dir.pvid;
	vtocx = dir.vtocx;
	call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code);
	if code ^= 0 then go to unlock2;

	dir_privilege = addr (pds$access_authorization) -> aim_template.privileges.dir;
	qchange = quota - qcell.quota;
	if qchange < 0 then				/* If reducing quota */
	     if aim_check_$greater (entry.access_class, parent_dp -> dir.access_class) then /* its an upgraded dir */
		if ^dir_privilege then do;		/* If not privileged, forget it. */
						/* Could publish info if he did this */
		     code = error_table_$ai_restricted;
		     go to unlock2;
		end;
		else if qcell.quota + qchange <= 0 then do; /* if would make it zero, forget it too. */
		     code = error_table_$invalid_move_qmax;
		     go to unlock2;
		end;
	call lock$dir_unlock (parent_dp);		/* done with parent */

	astep = activate (ep, code);
	qcell.used = aste.used (0);			/*  aste is more up to date */
	moved_down = qcell.received - qcell.quota;	/* quota on lower directorys */
	qcell.received = quota;
	qcell.quota = quota - moved_down;
	if qcell.received < qcell.used + moved_down then do; /* not enough */
	     code = error_table_$rqover;
	     call lock$unlock_ast;
	     go to unlock1;
	end;
	aste.quota (0) = quota;
	call lock$unlock_ast;

	call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), 0, code);
	call sum$dirmod (dp);
	go to done;

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

/* append_mdir_set: special entry called by append to set initial master directory quota */

append_mdir_set: entry (a_ep, a_quota, a_code);

	ep = a_ep;
	quota = a_quota;
	uid = entry.uid;				/* set up for vtoc_attributes call */
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	unspec (qcell) = "0"b;
	qcell.received, qcell.quota = quota;
	qcell.terminal_quota_sw = "1"b;
	curtime = bit (bin (clock (), 52), 52);
	qcell.tup = curtime;			/* trp clock starts NOW */

	astep = activate (ep, code);			/* must also update aste */
	aste.quota (0) = quota;
	aste.tqsw (0) = "1"b;
	call lock$unlock_ast;
	call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), 0, code);
	a_code = code;
	return;



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

/* qread, qget - entries to read the quota information */

dqread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code);

	dir_quota_sw = "1"b;
	qt = 1;
	check_access = "1"b;
	new_entry = "1"b;
	goto get_common;

qread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code);
	new_entry = "1"b;
	check_access = "1"b;
	goto get_common;

qget: entry (a_parent, a_quota, a_trp, a_tup, a_slvid, a_taccsw, a_used, a_code);

	check_access = "1"b;
	goto get_common;

priv_qread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code);

	new_entry = "1"b;
	check_access = "0"b;
	goto get_common;

priv_dqread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code);

	new_entry = "1"b;
	dir_quota_sw = "1"b;
	qt = 1;
	check_access = "0"b;

get_common:
	quota, trp, ltrp, used = 0;			/* zero return variables */
	tup = "0"b;
	taccsw = "0"b;
	parent = a_parent;				/* copy into char(168) aligned */

	code = 0;					/* Clear return code */
	if check_access then call dc_find$dir_read (parent, dp, code); /* get pointer to directory */
	else call dc_find$dir_read_priv (parent, dp, code);
	if code ^= 0 then go to errxit;
	called_find, locked = "1"b;

	call get_quota_cell;			/* get quota info */

	slvid = dir.sons_lvid;			/* Save sons LVID for later */
	sstp = addr (sst_seg$);
	astep = make_seg_active (dp);			/* To check used, must have active acct */
	qcell.used = aste.used (qt);			/* update from ast entry to temp */
	if not_root then do;			/* ok, now unlock */
	     parent_dp = ptr (dep, 0);
	     call lock$unlock_ast;
	     call lock$dir_unlock (parent_dp);		/* unlock parent dir */
	end;
	if qcell.terminal_quota_sw then do;		/* this is a terminal account, do full update */
	     curtime = bit (bin (clock (), 52), 52);	/* get time as bit string - high order bits */
						/* calc and add to the time-page product which is in page-secs */
	     dt = fixed (curtime, 36) - fixed (qcell.tup, 36); /* time since last update */
	     qcell.trp = qcell.trp + fixed ((dt * qcell.used) * SEC_PER_TICK + .5e0, 71);
	     qcell.tup = curtime;			/* .. */
	end;
	quota = qcell.quota;			/* copy info from dir header */
	ltrp = qcell.trp;				/* .. into return args */
	trp = min (ltrp, LOTS);			/* return max value if  overflow 35 bits */
	tup = qcell.tup;
	used = qcell.used;
	taccsw = qcell.terminal_quota_sw;

unlock:	call dc_find$finished (dp, "1"b);		/* Unlock directory */
	a_quota = quota;				/* .. and give args back to caller */
	if new_entry then a_ltrp = ltrp;
	else a_trp = trp;
	a_tup = tup;
	a_slvid = slvid;
	a_taccsw = fixed (taccsw, 1);
	a_used = used;
	a_code = code;
	return;

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

/* entry called by append to see if can move quota */

check: entry (a_ep, a_uchange, a_code);

	ep = a_ep;				/* dir is not locked */
	unlock_son = "0"b;
	go to join;

check_file: entry (a_parent, a_ename, a_uchange, a_code);	/* Called by fs_move */

	parent = a_parent;
	ename = a_ename;
	code = 0;
	unlock_son = "1"b;				/* will lock the dir */
	call dc_find$obj_status_read (parent, ename, DC_FIND_CHASE, ep, code);
	dp = ptr (ep, 0);				/* Get ptr to parent */
	if code ^= 0 then go to errxit;		/* see if find it */
	called_find = "1"b;
	go to join;

check_seg: entry (a_segptr, a_uchange, a_code);		/* (not used currently) */

	segptr = a_segptr;
	code = 0;
	unlock_son = "1"b;
	call dc_find$obj_status_read_ptr (segptr, ep, code);
	if code ^= 0 then go to errxit;
	dp = ptr (ep, 0);

join:
	uchange = a_uchange;			/* What's the change in quota */
	dp = ptr (ep, 0);				/* get pointer to base of directory */

	sstp = addr (sst_seg$);
	astep = make_seg_active (dp);			/* Force active so look at used */
	call quotaw$cu (astep, uchange, dir_quota_sw, CHECK_ONLY, code); /* checks act acct with ptl set */
	if not_root then do;
	     parent_dp = ptr (dep, 0);
	     call lock$unlock_ast;
	     call lock$dir_unlock (parent_dp);		/* unlock parent dir */
	end;

unlock3:	if unlock_son then
	     if called_find then call dc_find$finished (dp, "1"b);
	     else call lock$dir_unlock (dp);
	a_code = code;
	return;

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

/* This entry moves quota between a dir and its parent */

dqmove: entry (a_parent, a_ename, a_qchange, a_code);

	dir_quota_sw = "1"b;
	qt = 1;

qmove: entry (a_parent, a_ename, a_qchange, a_code);

	code = 0;
	qchange = a_qchange;			/* Copy arg */
	parent = a_parent;				/* copy into char(168) aligned */
	ename = a_ename;				/* copy into char(32) aligned */
	mylock_entry = "0"b;

	len = length (rtrim (parent));		/* Get dirname into pathname */
	if ename ^= "" then do;
	     if len + length (rtrim (ename)) + 1 > length (pathname) then do; /* too long */
bad_path:		code = error_table_$argerr;
		goto errxit;
	     end;
	     if len = 1 then pathname = substr (parent, 1, 1) || ename; /* dir is then root */
	     else pathname = substr (parent, 1, len) || ">" || ename;
	end;
	else do;
	     if len > length (pathname) then goto bad_path;
	     if len = 1 then goto bad_path;		/* don't bother with a single directory (root) */
	     pathname = parent;
	end;

	dir_privilege = addr (pds$access_authorization) -> aim_template.privileges.dir;

/* this is going to be useful later... */

	call dc_find$dir_move_quota (pathname, ep, dp, code);
	if code ^= 0 then goto errxit;
	called_find, locked = "1"b;
	parent_dp = ptr (ep, 0);			/* Locate parent */

	if level$get () > fixed (entry.ex_ring_brackets (1), 3) then do;
	     code = error_table_$bad_ring_brackets;	/* ringbrackets must be consistent with validation level */
	     go to unlock2;
	end;

	uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars for son */
	call vtoc_attributes$get_quota (uid, pvid, vtocx, /* .. and read VTOC */
	     addr (qcell), qt, code);
	if code ^= 0 then go to unlock2;
	parent_uid = parent_dp -> dir.uid; parent_pvid = parent_dp -> dir.pvid; parent_vtocx = parent_dp -> dir.vtocx;
	call vtoc_attributes$get_quota (parent_uid, parent_pvid, parent_vtocx,
	     addr (parent_qcell), qt, code);
	if code ^= 0 then go to unlock2;

	if qcell.terminal_quota_sw then		/* if inferior dir has terminal acct */
	     if qcell.received > qcell.quota then	/* and it has inferior quotas */
		if qcell.quota + qchange <= 0 then do;	/* and the.change would make it non-terminal */
		     code = error_table_$invalid_move_qmax; /* don't allow change to be made */
		     go to unlock2;
		end;

	if qchange < 0 then				/* If moving quota up */
	     if aim_check_$greater (entry.access_class, parent_dp -> dir.access_class) then /* its an upgraded dir */
		if ^dir_privilege then do;		/* If not privileged, forget it. */
						/* Could publish info if he did this */
		     code = error_table_$ai_restricted;
		     go to unlock2;
		end;
		else if qcell.quota + qchange <= 0 then do; /* if would make non-term, forget it too. */
		     code = error_table_$invalid_move_qmax;
		     go to unlock2;
		end;

	go to skip_del_entry;

/* This entry is called from inside append, when creating an upgraded directory.
   Parent and new dir are both locked at this point */

qmove_mylock: entry (a_ep, a_dp1, a_qchange, a_seg_or_dir, a_code);

	dir_quota_sw = a_seg_or_dir;			/* Copy switch */
	qt = fixed (dir_quota_sw, 1);
	mylock_entry = "1"b;
	ep = a_ep;
	parent_dp = ptr (ep, 0);
	dp = a_dp1;				/* are already locked */
	qchange = a_qchange;

	uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars */
	call vtoc_attributes$get_quota (uid, pvid, vtocx,
	     addr (qcell), qt, code);
	if code ^= 0 then go to errxit;
	parent_uid = parent_dp -> dir.uid; parent_pvid = parent_dp -> dir.pvid; parent_vtocx = parent_dp -> dir.vtocx;
	call vtoc_attributes$get_quota (parent_uid, parent_pvid, parent_vtocx,
	     addr (parent_qcell), qt, code);
	if code ^= 0 then go to errxit;
	if qchange = 0 then				/* If quota change arg is zero, */
	     qchange = -qcell.quota;			/* ..take the whole thing */

skip_del_entry:
	if ^dir_quota_sw & dir.master_dir then do;
	     code = error_table_$master_dir;		/* Apples an oranges */
	     if mylock_entry then go to errxit;
	     go to unlock2;
	end;
	if qchange = 0 then do;			/* If useless call */
	     code = 0;
	     if mylock_entry then go to errxit;
	     go to unlock2;
	end;

	if ^parent_qcell.terminal_quota_sw then do;	/* None to move */
	     code = error_table_$invalid_move_qmax;
	     if mylock_entry then go to errxit;
	     go to unlock2;
	end;

/* get pointers to AST entries for both directories */

	sstp = addr (sst_seg$);			/* Get SST */
	astep = activate (ep, code);			/* Activate son */

	parent_astep = ptr (sstp, aste.par_astep);	/* this is active because son is active */

/* update trp for both directories, since we may cause a sudden change to used */

	qcell.used = aste.used (qt);			/* Copy from AST */
	parent_qcell.used = parent_astep -> aste.used (qt);
	curtime = bit (bin (clock (), 52), 52);		/* same as above */
						/* calc & add the time-page product which is in page-seconds */
	dt = fixed (curtime, 36) - fixed (parent_qcell.tup, 36); /* time since trp was last updated */
	parent_qcell.trp = parent_qcell.trp + fixed ((dt * parent_qcell.used) * SEC_PER_TICK + .5e0, 71);
	parent_qcell.tup = curtime;
	was_terminal = qcell.terminal_quota_sw;		/* indicator if directory currently has terminal quota */
	if was_terminal then do;			/* only update son if it is terminal */
	     dt = fixed (curtime, 36) - fixed (qcell.tup, 36); /* time since trp was last updated */
	     qcell.trp = qcell.trp + fixed ((dt * qcell.used) * SEC_PER_TICK + .5e0, 71);
	     qcell.tup = curtime;
	end;

	call quotaw$mq (parent_astep, astep, qchange, dir_quota_sw, code);
						/* change quotas and maybe used with ptl locked */
	if code ^= 0 then do;			/* one if the quotas didn't cover the used */
	     call lock$unlock_ast;
	     if mylock_entry then go to errxit;		/* don't unlock */
	     else go to unlock2;
	end;
	qcell.quota = aste.quota (qt);		/* change quotas in the VTOCEs */
	parent_qcell.quota = parent_astep -> aste.quota (qt);
	now_terminal, qcell.terminal_quota_sw = aste.tqsw (qt); /* terminal status of directory may have changed */

/* clean up trps in case terminal status of directory has changed */

	if was_terminal ^= now_terminal then do;	/* Did status of inferior change? */
	     if was_terminal then do;
		parent_qcell.trp = parent_qcell.trp + qcell.trp; /* carry total trp up to parent */
	     end;
	     else do;
		qcell.tup = curtime;
	     end;
	     qcell.trp = 0;				/* just so it doesn't get charged twice */
	end;

	qcell.received = qcell.received + qchange;	/* Adjust total quota at this node */

	call lock$unlock_ast;			/* Unlock AST */

	call vtoc_attributes$set_quota (uid, pvid, vtocx, /* Write back */
	     addr (qcell), qt, code);
	call vtoc_attributes$set_quota (parent_uid, parent_pvid, parent_vtocx,
	     addr (parent_qcell), qt, code);

	if ^mylock_entry then do;			/* usually must unlock */
	     call sum$dirmod (dp);			/* indicate directory and parent modified */
	     if called_find then call dc_find$finished (dp, "1"b);
	     else call lock$dir_unlock (dp);
	     call lock$dir_unlock (parent_dp);
	end;
	a_code = code;
	return;

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

/* Error handlers */

unlock2:	if not_root then call lock$dir_unlock (parent_dp);

done:
unlock1:	if called_find then call dc_find$finished (dp, locked);
	else call lock$dir_unlock (dp);

errxit:	a_code = code;				/* set return error code */
	return;

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

/* Internal procedure to get directory's quota cell */

get_quota_cell: proc;

	uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars */
	call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), qt, code);
	if code ^= 0 then go to unlock1;

     end get_quota_cell;

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

/* Internal procedure to make segment be active */

make_seg_active: proc (dpt) returns (ptr);		/* Returns astep */

dcl  dpt				ptr parameter;	/* .. given entry ptr */

dcl  ASTep			ptr;

	if dpt -> dir.uid = ROOT_UID then do;		/* root's active already */
	     not_root = "0"b;
	     return (sst$root_astep);
	end;
	else do;					/* no root */
	     call sum$getbranch (dpt, read_lock, dep, code); /* get branch (lock parent) */
	     if code ^= 0 then return (null);
	     ASTep = activate (dep, code);		/* Activate thing */
	end;
	return (ASTep);

     end make_seg_active;
%page; %include aim_template;
%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include fs_obj_access_codes;
%page; %include quota_cell;
     end quota;




		    quota_util.pl1                  11/11/89  1132.4rew 11/11/89  0800.6       16272



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


quota_util$suspend_quota: proc;	/* Set switch for this process' PDS */

dcl switch_val fixed bin(17),
    pdsp ptr,
    (pds$quota_inhib ext, pdsval based(pdsp)) fixed bin(17);

	switch_val = 1;		/* Suspend quota checking for this process */

	go to this_process_common;

restore_quota: entry;		/* clear switch */

	switch_val = 0;

this_process_common:
	pds$quota_inhib = switch_val;

	return;

/* Following code is commented out, may be completed and de-commented if
   it is ever desired to suspend the quota for any process other than
   one which may call hphcs_$(suspend/restore)_quota in its own right.
suspend_proc_quota: entry(pid, code);

dcl pid fixed bin(35),
    code fixed bin(17);

	switch_val = 1;
	go to find_pdir;

restore_proc_quota: entry(pid, code);

	switch_val = 0;

find_pdir:
	uc = unique_chars(addr(pid) -> bit36b);
	...

	call initiate(pdir, "pds", "", 1, 0, pdsp, code);

	if pdsp = null
	then return;

	pdsp = ptr(pdsp, rel(addr(pds$quota_inhib));

	code = 0;
	pdsp -> pdsval = switch_val;

	call terminate_noname(pdsp, ignore_code);

   End of commented code */

end quota_util$suspend_quota;




		    reclassify.pl1                  11/11/89  1132.4r w 11/11/89  0800.0      180252



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


/* Initial coding by Kobziar July 74 */
/* Modified 750523 by LJS to add protection auditing */
/* Modified June 1, 1976 by R. Bratt to call find_$finished */
/* Modified Nov 30 76 by B. Greenberg for setting dtem */
/* Modified September 1981 by J. Bongiovanni for better error codes */
/* Modified March 1983 by E. N. Kittlitz to not set dtem back */
/* Modified August 1983 by E. N. Kittlitz for setfaults$if_active pvid, vtocx args */
/* Modified 83-10-10 by E. N. Kittlitz to fix locking problems */
/* Modified 83-12-07 by E. N. Kittlitz to audit setting node oos */
/* Modified July 1984 by Keith Loepere to use the new dc_find.  Also to flush
   PAM on dir reclassify. */
/* Modified November 1984 by Keith Loepere for access_audit_ and for PAM using
   uid's. */
/* Modified 84-12-05 by EJ Sharpe to actually use access_audit_ (also new sys_seg_priv entry) */
/* Modified 85-04-01 by Keith Loepere for access_audit_check_ep_. */

/* format: style4 */
reclassify: proc;

/* Parameters */

dcl  a_access_class bit (72) aligned;
dcl  a_code fixed bin (35);
dcl  a_dirname char (*);
dcl  a_ename char (*);

/* Variables */

dcl  access_class bit (72) aligned;
dcl  branch_name char (32);
dcl  branchp ptr;
dcl  code fixed bin (35);
dcl  dep ptr;
dcl  dep_locked bit (1) aligned;
dcl  dirname char (168);
dcl  dirpath char (168);
dcl  ename char (32);
dcl  ep_locked bit (1) aligned;
dcl  1 event_flags aligned like audit_event_flags;
dcl  has_zero_quota bit (1);
dcl  1 local_vtoce like vtoce aligned;
dcl  oosw_err bit (1) aligned;
dcl  parent_access_class bit (72) aligned;
dcl  pvtx fixed bin (17);
dcl  1 qcell like quota_cell aligned;
dcl  quota_err bit (1) aligned;
dcl  relp bit (18);
dcl  set_soos bit (1) aligned;
dcl  targp ptr;
dcl  targp_locked bit (1) aligned;
dcl  whoami char (24) aligned;

/* Entries */

dcl  access_audit_check_ep_$self entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1));
dcl  access_audit_$log_entry_ptr entry options (variable);
dcl  access_audit_$log_obj_class entry options (variable);
dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  change_dtem entry (ptr);
dcl  display_access_class_ entry (bit (72) aligned) returns (char (32) aligned);
dcl  get_pvtx entry (bit (36) unaligned, fixed bin (35)) returns (fixed bin (17));
dcl  level$get entry () returns (fixed bin);
dcl  lock$dir_unlock entry (ptr);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  logical_volume_manager$lvtep entry (bit (36) aligned, ptr, fixed bin (35));
dcl  pathname_am$flush entry (bit (36) aligned);
dcl  setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
dcl  sum$dirmod entry (ptr);
dcl  sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35));
dcl  syserr$error_code entry options (variable);
dcl  vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin, fixed bin (35));
dcl  vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin (17), fixed bin (17), bit (3) aligned, ptr, fixed bin (35));
dcl  vtoc_man$put_vtoce entry (bit (36) aligned, fixed bin (17), fixed bin (17), bit (3) aligned, ptr, fixed bin (35));

/* External */

dcl  access_operations_$fs_obj_reclassify bit (36) aligned ext static;
dcl  access_operations_$fs_obj_set_soos bit (36) aligned ext static;
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$ai_out_range fixed bin (35) ext static;
dcl  error_table_$ai_parent_greater fixed bin (35) ext static;
dcl  error_table_$ai_son_less fixed bin (35) ext static;
dcl  error_table_$argerr fixed bin (35) ext static;
dcl  error_table_$bad_ring_brackets fixed bin (35) ext static;
dcl  error_table_$dirseg fixed bin (35) ext static;
dcl  error_table_$no_terminal_quota fixed bin (35) ext static;
dcl  error_table_$nondirseg fixed bin (35) ext static;
dcl  error_table_$not_a_branch fixed bin (35) ext static;
dcl  error_table_$rqover fixed bin (35) ext static;
dcl  error_table_$soos_set fixed bin (35) ext static;
dcl  error_table_$vtoce_connection_fail fixed bin (35) ext static;
dcl  pds$processid bit (36) aligned ext;
dcl  sys_info$access_class_ceiling bit (72) aligned ext static;

/* Misc */

dcl  (addr, fixed, null, ptr, rtrim, string) builtin;
%page;
/* change branch's access_class to value of parent, called through system_privilege_ gate */

branch: entry (a_dirname, a_ename, a_access_class, a_code);

	whoami = "reclassify$branch";
	call setup;				/* process args and get ptrs */
	if ep -> entry.dirsw then do;
	     code = error_table_$dirseg;
	     go to unlock_all;
	end;
	dir.modify = pds$processid;
	call set_access_class (ep, parent_access_class, dirname, ename); /* Set the access class */
	if code = 0 then				/* Force ring 1 multiclass bit off */
	     call set_r1mc (ep -> entry.multiple_class, "0"b, dirname, ename);
	go to finish_seg;
%page;
/* change seg to be multi class, called through system_privilege_ gate */

sys_seg_priv: entry (a_dirname, a_ename, a_access_class, a_code);

	whoami = "reclassify$sys_seg_priv";
	goto sys_seg_join;


/* change seg to be multi class, called through admin_gate_ from ring 1 */

sys_seg: entry (a_dirname, a_ename, a_access_class, a_code);

	whoami = "reclassify$sys_seg";
sys_seg_join:
	call setup;
	if ^aim_check_$greater (access_class, parent_access_class) then do; /* must be higher */
	     code = error_table_$action_not_performed;
	     go to unlock_all;
	end;
	if ep -> entry.dirsw then do;
	     code = error_table_$dirseg;
	     go to unlock_all;
	end;
	if ep -> entry.ring_brackets (3) ^= "001"b then do; /* must be ring 1 */
	     code = error_table_$bad_ring_brackets;
	     go to unlock_all;
	end;
	dir.modify = pds$processid;
	call set_access_class (ep, access_class, dirname, ename); /* Set the access class */
	if code = 0 then				/* Force ring 1 multiclass bit on */
	     call set_r1mc (ep -> entry.multiple_class, "1"b, dirname, ename);
finish_seg:
	call setfaults$if_active ((ep -> entry.uid),	/* be conservative, call even if code ^= 0 */
	     (ep -> entry.pvid), (ep -> entry.vtocx), "1"b);
	dir.modify = "0"b;
	if code = 0 then
	     call sum$dirmod (dp);			/* reflect modification up for backup to find */
						/* note: we don't soos parent if this failed */
	call dc_find$finished (dp, "1"b);		/* unlock and unuse */
	go to ret;
%page;
/* change access class of directory and contents */

node: entry (a_dirname, a_ename, a_access_class, a_code);

	whoami = "reclassify$node";
	call setup;
	if ^ep -> entry.dirsw then do;
	     code = error_table_$nondirseg;
	     go to unlock_all;
	end;

	call vtoc_attributes$get_quota (ep -> entry.uid, (ep -> entry.pvid), (ep -> entry.vtocx),
	     addr (qcell), 0, code);
	if code ^= 0 then go to unlock_all;
	has_zero_quota = ^qcell.terminal_quota_sw;

	call lock$dir_unlock (dp);			/* all done with dp for now (will re-get via sum when done with node) */
						/* see if dir will be upgraded */
	ep_locked = "0"b;

	if aim_check_$greater (access_class, parent_access_class) then
	     if has_zero_quota then do;		/* refuse to do operation */
		code = error_table_$no_terminal_quota;
		go to unlock_all;
	     end;
	     else ;				/* ok upgraded dir */
	else if ^aim_check_$equal (access_class, parent_access_class) then do; /* don't accept lower than parent */
	     code = error_table_$action_not_performed;
	     go to unlock_all;
	end;
%page;
/* now reset access class and check multi class bit */
/* must go to completion in the following loop for a consistent directory */

	targp -> dir.modify = pds$processid;
	relp = targp -> dir.entryfrp;
	do while (relp ^= "0"b);			/* reset access_class if necessary */
	     branchp = ptr (targp, relp);
	     branch_name = ptr (targp, branchp -> entry.name_frp) -> names.name;
	     if ^branchp -> entry.dirsw then if branchp -> entry.bs then do; /* a segment */
		     if aim_check_$greater (branchp -> entry.access_class, access_class) then
			if branchp -> entry.multiple_class then go to fine;
						/* all other segments get access class reset (or corrected) */
		     call set_access_class (branchp, access_class, dirpath, branch_name);
		     call set_r1mc (branchp -> entry.multiple_class, "0"b, dirpath, branch_name);
		     call setfaults$if_active ((branchp -> entry.uid), (branchp -> entry.pvid),
			(branchp -> entry.vtocx), "1"b);
		end;
						/* now for directories */
	     if branchp -> entry.dirsw then if aim_check_$equal (branchp -> entry.access_class, access_class)
		then call set_r1mc (branchp -> entry.multiple_class, "0"b, dirpath, branch_name);
		else if aim_check_$greater (branchp -> entry.access_class, access_class)
		then call set_r1mc (branchp -> entry.multiple_class, "1"b, dirpath, branch_name);
		else do;				/* this directory doesn't fit */
		     if ^branchp -> entry.security_oosw then do;
			if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, branchp) then
			     call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags),
			     access_operations_$fs_obj_set_soos, branchp, error_table_$ai_parent_greater, null (), 0,
			     "Parent class: ^a", display_access_class_ (access_class));
		     end;
		     branchp -> entry.security_oosw = "1"b;
		     oosw_err = "1"b;
		end;
fine:
	     relp = branchp -> entry.efrp;
	end;

	if set_soos then go to finish_node;
	targp -> dir.access_class = access_class;
%page;
/* now check all upgraded directories for quota */
/* this loop seperate from above since locking failure not critical */

	relp = targp -> dir.entryfrp;
	do while (relp ^= "0"b);
	     branchp = ptr (targp, relp);
	     if branchp -> entry.dirsw then
		if aim_check_$greater (branchp -> entry.access_class, access_class) then do;
		     call vtoc_attributes$get_quota (branchp -> entry.uid, (branchp -> entry.pvid),
			(branchp -> entry.vtocx), addr (qcell), 0, code);
		     if code ^= 0 then go to q_err;
		     if ^qcell.terminal_quota_sw then do;
q_err:			if ^branchp -> entry.security_oosw then
			     if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, branchp) then
				call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags),
				access_operations_$fs_obj_set_soos, branchp, error_table_$no_terminal_quota,
				null (), 0);
			branchp -> entry.security_oosw = "1"b;
			quota_err = "1"b;
		     end;
		end;
	     relp = branchp -> entry.efrp;
	end;
%page;
/* fix branch in parent */

finish_node:
	call sum$getbranch (targp, "1"b, ep, code);	/* get ep again (could change via on-line salvage) */
	if code ^= 0 then do;			/* stop the world, I want to get off */
	     call syserr$error_code (CRASH, code, "reclassify: err locking parent");
	     go to unlock_all;			/* just in case we come back... */
	end;
	ep_locked = "1"b;
	dp = ptr (ep, 0);				/* reaffirm dp */
	dir.modify = pds$processid;
	if set_soos then do;
	     if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, ep) then
		call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags),
		access_operations_$fs_obj_set_soos, ep, error_table_$ai_son_less, null (), 0);
	     entry.security_oosw = "1"b;		/* zap main dir */
	end;
	call set_access_class (ep, access_class, dirname, ename);
	if code = 0 then
	     call set_r1mc (ep -> entry.multiple_class, aim_check_$greater (access_class, parent_access_class), dirname, ename); /* Set multi-class bit */
	if code = 0 then if quota_err then code = error_table_$rqover;
	     else if oosw_err | set_soos then code = error_table_$soos_set; /* signal oosw problem */
	targp -> dir.modify = "0"b;
	call sum$dirmod (targp);
	call pathname_am$flush (ep -> entry.uid);
	dir.modify = "0"b;
	call sum$dirmod (dp);
	call lock$dir_unlock (dp);
	call dc_find$finished (targp, "1"b);		/* unlock and unuse */

ret:
	a_code = code;
	return;

unlock_all:
						/* we come here only if the operation is denied due
						   to some aim restriction or improper operation */
	event_flags.grant = "0"b;
	call access_audit_$log_obj_class (whoami, level$get (), string (event_flags),
	     access_operations_$fs_obj_reclassify, access_class, target (dirname, ename), code, null (), 0);

	if targp_locked then do;			/* dirs held by targp */
	     if dep_locked then
		call lock$dir_unlock (ptr (dep, 0));
	     if ep_locked then do;
		dp -> dir.modify = "0"b;
		call lock$dir_unlock (ptr (ep, 0));
	     end;
	     targp -> dir.modify = "0"b;
	     call dc_find$finished (targp, "1"b);
	end;
	else do;
	     if dep_locked then call lock$dir_unlock (ptr (dep, 0));
	     dir.modify = "0"b;
	     call dc_find$finished (dp, "1"b);		/* unlock and unuse */
	end;
	go to ret;
%page;
/* get entry and check access */

setup: proc;

dcl  lvid bit (36) aligned;

	string (event_flags) = ""b;
	event_flags.special_op = "1"b;
	event_flags.grant = "1"b;			/* for now */

	if whoami ^= "reclassify$sys_seg"		/* this one's refed through admin_gate_ */
	then event_flags.priv_op = "1"b;

	pvt_arrayp = addr (pvt$array);
	dep_locked, ep_locked, oosw_err, quota_err, set_soos, targp_locked = "0"b;
	access_class = a_access_class;		/* copy args */
	if aim_check_$greater_or_equal (sys_info$access_class_ceiling, access_class) then code = 0;
	else do;					/* check arg */
	     code = error_table_$argerr;
	     go to ret;
	end;
	dirname = a_dirname;
	ename = a_ename;

/* the calls to dc_find below may generate an audit message
   thus, it's OK to simply return without additional auditing
   if either fails. */
	if whoami = "reclassify$node" then do;
	     if dirname = ">" then dirpath = ">" || ename;/* now check out the directory */
	     else dirpath = rtrim (dirname) || ">" || ename;
	     call dc_find$dir_reclassify (dirpath, dep, ep, targp, code);
	     if code ^= 0 then go to ret;
	     targp_locked = "1"b;
	end;
	else do;
	     call dc_find$obj_reclassify (dirname, ename, dep, ep, code);
	     if code ^= 0 then go to ret;
	end;
	ep_locked = "1"b;
	dp = ptr (ep, 0);
	if dep ^= null then dep_locked = "1"b;

	if ^ep -> entry.bs then do;			/* this is a link */
	     code = error_table_$not_a_branch;
	     go to unlock_all;
	end;
	if whoami = "reclassify$node" then lvid = entry.sons_lvid; /* check AIM for volume */
	else do;
	     pvtx = get_pvtx (entry.pvid, code);
	     if code ^= 0 then go to unlock_all;
	     lvid = pvt_array (pvtx).lvid;
	end;
	call logical_volume_manager$lvtep (lvid, lvtep, code); /* check lv mounted, AIM range */
	if code ^= 0 then go to unlock_all;		/* oh well */
	if ^aim_check_$greater_or_equal (access_class, lvte.access_class.min) |
	     ^aim_check_$greater_or_equal (lvte.access_class.max, access_class) then do;
	     code = error_table_$ai_out_range;
	     go to unlock_all;
	end;
	if dep_locked then do;
	     parent_access_class = dep -> entry.access_class;
	     call lock$dir_unlock (ptr (dep, 0));
	     dep_locked = "0"b;			/* remember not to do this again when finishing */
	end;
	else parent_access_class = "0"b;

     end setup;


%page;
set_access_class: proc (set_ep, to_this, dirname, ename);

dcl  dirname char (168) parameter;
dcl  ename char (32) parameter;
dcl  set_ep ptr parameter;
dcl  to_this bit (72) aligned parameter;

dcl  pvid bit (36);
dcl  uid bit (36) aligned;
dcl  vtocx fixed bin (17);



/* reclassify$(branch sys_seg sys_seg_priv) call this to
   set the new access class of the segment in its entry and
   vtoce.  reclassify$node calls this once for each segment
   in the dir being reclassified, and finally once for the
   directory itself.  "set_soos" is set if the operation
   failed so reclassify$node will set security-out-of-service
   on the containing dir that is being reclassified. */

	if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_reclassify, set_ep) then
	     call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags),
	     access_operations_$fs_obj_reclassify, set_ep, 0, null (), 0, "New class: ^a",
	     display_access_class_ (to_this));

	pvid = set_ep -> entry.pvid;			/* do vtoce first */
	uid = set_ep -> entry.uid;
	vtocx = set_ep -> entry.vtocx;		/* copy args before ASTlocking */
	call lock$lock_ast;
	pvtx = get_pvtx (pvid, code);
	if code ^= 0 then go to bust;
	call vtoc_man$get_vtoce ((pvid), pvtx, vtocx, "101"b, addr (local_vtoce), code);
						/* read activation + part 3 */
	if code ^= 0 then go to bust;
	if local_vtoce.uid ^= uid then do;
	     code = error_table_$vtoce_connection_fail;
	     go to bust;
	end;
	addr (local_vtoce) -> vtoce.access_class = to_this;
	call vtoc_man$put_vtoce ((pvid), pvtx, vtocx, "001"b, addr (local_vtoce), code);
						/* but only write part 3 */

bust:	call lock$unlock_ast;
	if code = 0 then do;
	     set_ep -> entry.access_class = to_this;
	     call change_dtem (set_ep);		/* Cause access recomputation */
	end;
	else set_soos = "1"b;
	return;
     end set_access_class;
%page;

set_r1mc: proc (set_this, to_this, dirname, ename);

dcl  dirname char (168) parameter;
dcl  ename char (32) parameter;
dcl  set_this bit (1) parameter;
dcl  to_this bit (1) parameter;

dcl  type (0:1) char (12) aligned static options (constant) init ("single-class", "upgraded");

	if set_this ^= to_this
	then do;
						/* we'll already have logged with entry data by reclassifying,
						   so here we'll just log a text message, no binary */
	     call access_audit_$log_obj_class (whoami, level$get (), string (event_flags),
		access_operations_$fs_obj_reclassify, access_class, target (dirname, ename),
		0, null (), 0, "Changed to ^a", type (fixed (to_this, 1)));
	end;

	set_this = to_this;

	return;
     end set_r1mc;
%page;
target: proc (dir, ent) returns (char (*));

dcl  dir char (*) parameter;
dcl  ent char (*) parameter;

	if dir = ">"
	then return (">" || ent);
	else return (rtrim (dir) || ">" || ent);

     end target;

/* format: off */
%page; %include access_audit_eventflags;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_name;
%page; %include lvt;
%page; %include pvte;
%page; %include quota_cell;
%page; %include vtoce;
%page; %include syserr_constants;
%page;
/* format: on */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   reclassify: err locking parent. ERROR_CODE

   S:	$crash

   T:	$run

   M:	$err
   $crashes

   A:	$recover


   Message:
   AUDIT (reclassify$ENTRY): GRANTED modification of security out-of-service ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	An AIM error was found in respect to the specified directory.
   There was a disagreement in access class between the directory
   and one of it's sons, or there was an upgraded directory with
   non-terminal quota.

   A:	$ignore


   Message:
   AUDIT (reclassify$ENTRY): GRANTED|DENIED modification of fs_obj access class ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	Indicates whether an attempt to reclassify the specified file
   system object was granted or denied.  In the case of
   reclassify$node, a message will be generated for each
   entry in the directory being reclassified.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end reclassify;




		    ring0_init.pl1                  11/11/89  1132.4rew 11/11/89  0800.6       21492



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


ring0_init: proc ;

/* last modified by Kobziar 1/25/75 to call priv_init entries */
/* last modified by Greenberg 05/27/76 who changed it back again, and added terminate entries. */
/* last modified by Loepere 11/05/84 to rename terminate to terminate_. */

dcl (level$get, level$set) ext entry (fixed bin) ;

dcl  initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)) ;
dcl  initiate$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)) ;
dcl  terminate_$noname entry (ptr, fixed bin (35));
dcl  terminate_$teseg entry (ptr, fixed bin (1), fixed bin (35));

dcl (dirname, ename, rname) char (*) ;
dcl  tcode fixed bin (35);
dcl  tsptr ptr;
dcl  tsw fixed bin (1);
dcl  segsw fixed bin (1) ;
dcl  copysw fixed bin (2) ;
dcl  count fixed bin (24) ;
dcl  segptr ptr ;
dcl  code fixed bin (35) ;

dcl  save_level fixed bin ;
dcl  esw fixed bin ;

initiate:	entry (dirname, ename, rname, segsw, copysw, segptr, code) ;

	esw = 1 ;
	goto start ;

initiate_count: entry (dirname, ename, rname, count, copysw, segptr, code) ;

	esw = 2 ;
	go to start;

terminate_noname: entry (tsptr, tcode);

	esw = 3;
	go to start;

terminate_seg: entry (tsptr, tsw, tcode);

	esw = 4;

start:
	call level$get (save_level) ;

	call level$set (0) ;

	if esw = 1 then call initiate (dirname, ename, rname, segsw, copysw, segptr, code) ;
	else if esw = 2 then call initiate$initiate_count (dirname, ename, rname, count, copysw, segptr, code);
	else if esw = 3 then call terminate_$noname (tsptr, tcode);
	else if esw = 4 then call terminate_$teseg (tsptr, tsw, tcode);

	call level$set (save_level) ;

	return ;

     end ;




		    ring_0_peek.pl1                 11/11/89  1132.4r w 11/11/89  0800.6       45432



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

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

/* RING-0-PEEK --- Procedure to return to a user in arbitrary ring
   the contents of arbitrary supervisor segments.

   Converted from EPL to PL/I by C Garman, December 1970
   VTOCE dumping by BSG 4/20/76
   New PVTE include file by J. Bongiovanni, March 1982
   Support 256K segments, E. N. Kittlitz, March 1983
   Removed access check (let hardware do it), Keith Loepere, October 1984.

   */

ring_0_peek: proc (a_from_ptr, a_to_ptr, a_num_words);

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_from_ptr			ptr parameter;
dcl  a_message			char (*) parameter;
dcl  a_num_words			fixed bin (19) parameter;
dcl  a_pvtx			fixed bin parameter;
dcl  a_to_ptr			ptr parameter;
dcl  a_vtocx			fixed bin parameter;
dcl  a_vtocep			ptr parameter;

/* Variables */

dcl  code				fixed bin (35);
dcl  from_ptr			ptr;
dcl  i				fixed bin (18);
dcl  1 local_vtoce			like vtoce aligned;
dcl  num_words			fixed bin (19);
dcl  patch_mem			bit (1) aligned;
dcl  pvid				bit (36) aligned;
dcl  pvtx				fixed bin;
dcl  rel_from_ptr			fixed bin (18);
dcl  rel_to_ptr			fixed bin (18);
dcl  vtocx			fixed bin;
dcl  to_ptr			ptr;

/* Entries */

dcl  pmut$cam			entry;
dcl  syserr			entry options (variable);
dcl  vtoc_man$get_vtoce		entry (bit (36) aligned, fixed bin, fixed bin, bit (3) aligned, ptr, fixed bin (35));

/* External */

dcl  error_table_$invalid_pvtx	fixed bin (35) ext;
dcl  pds$process_group_id		char (32) aligned ext;
dcl  pvt$n_entries			fixed bin ext;
dcl  sys_info$seg_size_256K		fixed bin (19) ext static;

/* Based */

dcl  move_array			(num_words) fixed bin (35) based;

/* Misc */

dcl  (addr, fixed, max, rel, size)	builtin;
%page;
	patch_mem = "0"b;
	go to common;

patch: entry (a_from_ptr, a_to_ptr, a_num_words);		/* Explicit patch, inhibit mode checking */

	patch_mem = "1"b;

common:	from_ptr = a_from_ptr;			/* Copy arguments */
	to_ptr = a_to_ptr;
	if patch_mem then addr (to_ptr) -> its.ringno = ""b;
	else addr (from_ptr) -> its.ringno = ""b;	/* force ringno of from ptr to 0 */
	num_words = a_num_words;

	if num_words <= 0 then return;		/* A few gullibility tests */

	rel_from_ptr = fixed (rel (from_ptr), 18);
	rel_to_ptr = fixed (rel (to_ptr), 18);

	if (max (rel_to_ptr, rel_from_ptr) + num_words) > sys_info$seg_size_256K then return; /* Protect the guy from himself */

	if patch_mem then do;

	     call syserr (0, "^a:  ^d words @ ^p", pds$process_group_id, num_words, to_ptr);
						/* Print header on console */

	     do i = 1 to num_words;

		call syserr (0, "^6o^14w to ^w", i - 1, (to_ptr -> move_array (i)), (from_ptr -> move_array (i)));
						/* Print before & after, take fault here if no access */

	     end;
	     call pmut$cam;				/* clear caches */
	end;

	to_ptr -> move_array (*) = from_ptr -> move_array (*); /* Use PL/I array copy */

	return;					/* All paths use this return */
%page;
message: entry (a_message);				/* Print message from user */

	call syserr (3, "^a:  ^a", pds$process_group_id, (a_message)); /* Print message, turning on bleeper */

	return;					/* Return to caller */
%page;
vtoce_peek: entry (a_pvtx, a_vtocx, a_vtocep, a_code);

	num_words = size (vtoce);
	vtocep = a_vtocep;				/* Set up for copy */

	pvtx = a_pvtx;
	vtocx = a_vtocx;

	if pvtx <= 0 | pvtx > pvt$n_entries then go to bad_pvtx;

	pvt_arrayp = addr (pvt$array);
	pvtep = addr (pvt_array (pvtx));

	if ^pvte.storage_system | ^pvte.used then do;
bad_pvtx:	     a_code = error_table_$invalid_pvtx;
	     return;
	end;

	pvid = pvte.pvid;
	call vtoc_man$get_vtoce (pvid, pvtx, vtocx, "111"b, addr (local_vtoce), code); /* vtoc_man will validate vtocx */
	if code = 0 then
	     vtocep -> move_array = addr (local_vtoce) -> move_array;
	a_code = code;
	return;
%page; %include disk_pack;
%page; %include its;
%page; %include pvte;
%page; %include vtoce;
%page;

/* BEGIN MESSAGE DOCUMENTATION

Message:
PERSON.PROJ.T:  NN words @ SSS|XXX
.br
  XXX  WWWWWWWWWWWW to YYYYYYYYYYYY
.br
  XXX  WWWWWWWWWWWW to YYYYYYYYYYYY

S:	$beep

T:	$run

M:	A privileged user has patched the hardcore supervisor.

A:	$ignore


Message:
PERSON.PROJ.T:  MESSAGE

S:	$beep

T:	$run

M:	A privileged user has sent a message to be printed on the SYSERR console.

A:	Read the message and take appropriate action.


END MESSAGE DOCUMENTATION */

     end ring_0_peek;




		    ringbr_.pl1                     11/11/89  1132.4r w 11/11/89  0800.6       92592



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


/* format: style4 */
ringbr_: proc;					/* list or set ring brackets */

/*        Modified by E. Swenson 02/21/85 to add get_ring_brackets_seg entry */
/*	Modified by Keith Loepere 10/22/84 to audit operation as an access change. */
/*	Modified by Keith Loepere 6/12/84 to call the new dc_find. */
/*	Modified by Lindsey Spratt 2/22/84 to change DM ringno check from the read bracket to the write bracket */
/*	Modified by E. N. Kittlitz 8/8/83 for setfaults$if_active pvid, vtocx args */
/*	Modified by Jay Pattin 6/9/83 to not require status permission if you have non-null on the branch
   for get_ring_brackets */
/*        Modified by J. Bongiovanni, September 1982, for Data Management */
/*	Modified by C. D. Tavares on 16 March 1979 to correct error codes */
/* 	Modified by R. Bratt on 06/01/76 to call find_$finished */
/*	Modified by BSG, 4/28/75 */
/* 	Modified by E. Stone 06/74 to convert to version 2 */

/* The entries to this routine are:
   name
   ringbr_$get
   $set
   $get_dir
   $set_dir

   arguments:
   1) a_dirname char(*)		a directory pathname (Input)
   2) a_ename char(*)		an entry name (Input)
   3) a_rb(3) fixed bin(3)		are seg ring brackets (Input for set, Output for get)
   3) a_drb(2) fixed bin(3)		are dir ringbrackets ( Input for dir_set, Output for dir_get)
   4) a_code fixed bin(35)		a standard error code (Output)
*/
dcl  a_code fixed bin (35) parameter;
dcl  a_dirname char (*) parameter;
dcl  a_drb (2) fixed bin (3) parameter;
dcl  a_ename char (*) parameter;
dcl  a_rb (3) fixed bin (3) parameter;
dcl  a_segptr ptr parameter;

dcl  directory fixed bin static options (constant) init (2);
dcl  get fixed bin static options (constant) init (1);
dcl  segment fixed bin static options (constant) init (1);
dcl  set fixed bin static options (constant) init (2);

dcl  code fixed bin (35);
dcl  d_s bit (1) aligned;
dcl  drbr (2) fixed bin (3);
dcl  dirname char (168);
dcl  entryname char (32);
dcl  function fixed bin;
dcl  i fixed bin;
dcl  lev fixed bin;
dcl  1 local_sc_info aligned like sc_info;
dcl  pathname_supplied bit (1) aligned;
dcl  pvid bit (36) aligned;
dcl  rbr (3) fixed bin (3);
dcl  segptr ptr;
dcl  type fixed bin;
dcl  uid bit (36) aligned;
dcl  username char (32) aligned;
dcl  vtocx fixed bin;

dcl  change_dtem ext entry (ptr);
dcl  check_gate_acl_ ext entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35));
dcl  level$get ext entry (fixed bin);
dcl  lock$dir_unlock ext entry (ptr);
dcl  setfaults$if_active ext entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
dcl  sum$dirmod ext entry (ptr);
dcl  vtoc_attributes$get_info ext entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin (35));

dcl  error_table_$ai_restricted ext fixed bin (35);
dcl  error_table_$dirseg ext fixed bin (35);
dcl  error_table_$invalid_ring_brackets ext fixed bin (35);
dcl  error_table_$lower_ring ext fixed bin (35);
dcl  error_table_$not_dm_ring ext fixed bin (35);
dcl  error_table_$notadir ext fixed bin (35);
dcl  error_table_$null_info_ptr ext fixed bin (35);
dcl  pds$processid bit (36) aligned ext;
dcl  sys_info$data_management_ringno fixed bin ext;

dcl  (addr, bit, fixed, null, ptr) builtin;
%page;

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

get: entry (a_dirname, a_ename, a_rb, a_code);		/* return segment ring brackets */

	function = get;
	type = segment;
	pathname_supplied = "1"b;
	go to start_proc;

get_ring_brackets_seg:
     entry (a_segptr, a_rb, a_code);

	function = get;
	type = segment;
	pathname_supplied = "0"b;
	go to start_proc;

get_dir: entry (a_dirname, a_ename, a_drb, a_code);	/* return directory ring brackets */

	function = get;
	type = directory;
	pathname_supplied = "1"b;
	go to start_proc;

set: entry (a_dirname, a_ename, a_rb, a_code);		/* set segment ring brackets  */

	function = set;
	type = segment;
	pathname_supplied = "1"b;
	go to start_proc;

set_dir: entry (a_dirname, a_ename, a_drb, a_code);	/* set directory ring brackets  */

	function = set;
	type = directory;
	pathname_supplied = "1"b;
	go to start_proc;

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

start_proc:					/* initialization and argument copying */

	dp, ep = null ();

	if pathname_supplied then
	     do;
	     dirname = a_dirname;
	     entryname = a_ename;
	end;
	else do;
	     segptr = a_segptr;
	     if segptr = null then
		go to segptr_null_err;
	end;

	code = 0;
	call level$get (lev);

	if function = set then do;			/* copy input rb & perform consistency checks on them */
	     if type = segment then do;
		rbr = a_rb;
		do i = 1 to 3;
		     if rbr (i) < lev then go to low_ring_err;
		     if rbr (i) > 7 then go to brack_err;
		end;
		if rbr (1) > rbr (2) then go to brack_err;
		if rbr (2) > rbr (3) then go to brack_err;
	     end;

	     else do;
		drbr = a_drb;
		do i = 1 to 2;
		     if drbr (i) < lev then go to low_ring_err;
		     if drbr (i) > 7 then go to brack_err;
		end;
		if drbr (1) > drbr (2) then go to brack_err;
	     end;
	end;

	if pathname_supplied then
	     do;
	     if function = set then
		call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_RING_MOD, ep, code);
	     else call dc_find$obj_attributes_read (dirname, entryname, 1, ep, code); /* chase */
	end;

/**** Note that we do not handle set_ring_brackets_ptr-type entrypoints
      in the following code.  It is assumed that if these entrypoints are
      ever added, that the appropriate changes will be made below.  There
      is currently no dc_find$obj_access_write_ptr entrypoint, which, of
      course, would be necessary if a ringbr_$set_ring_brackets_ptr entry
      were added. */

	else					/* can only get here if the entry is get_ring_brackets_ptr */
	     call dc_find$obj_attributes_read_ptr (segptr, ep, code);

	if code ^= 0 then go to error_return;

	dp = ptr (ep, 0);				/* get pointer to directory */

	d_s = ep -> entry.dirsw;			/* pick up directory switch from branch */

	if type = directory then			/* make sure correct entry (seg or dir) called */
	     if ^d_s then do;
		code = error_table_$notadir;		/* already checked access, ok to return this code */
		go to error_return;
	     end;

	if type = segment then
	     if d_s then do;
		code = error_table_$dirseg;		/* already checked access, ok to return this code */
		go to error_return;
	     end;

	if function = get then do;			/* copy rb from branch into stack array */
	     if type = segment then rbr = fixed (ep -> entry.ring_brackets, 3);
	     else do;
		drbr (1) = fixed (ep -> entry.ex_ring_brackets (1), 3);
		drbr (2) = fixed (ep -> entry.ex_ring_brackets (2), 3);
	     end;
	end;

	else do;					/* setting rb */
	     if type = segment then do;		/* check level with write bracket */
		if lev > fixed (ep -> entry.ring_brackets (1), 3) then go to low_ring_err;

		if (rbr (2) ^= rbr (3))		/* if turning this into a gate check projects on acl */
		     & lev > 1
		     & ep -> entry.acl_frp ^= "0"b then do;
		     call check_gate_acl_ (addr (ep -> entry.acl_frp), "1"b, (ep -> entry.acle_count), username, code);
		     if code ^= 0 then go to error_return;
		end;

		if ep -> entry.multiple_class		/* see if multiclass AIM seg */
		     & rbr (3) > 1 then go to aim_err;

		if (fixed (ep -> entry.ring_brackets (1), 3) <= sys_info$data_management_ringno)
		     & (rbr (1) > sys_info$data_management_ringno)
		then do;
		     uid = ep -> entry.uid;
		     pvid = ep -> entry.pvid;
		     vtocx = ep -> entry.vtocx;
		     call vtoc_attributes$get_info (uid, pvid, vtocx, addr (local_sc_info), code);
		     if code ^= 0 then goto error_return;
		     if local_sc_info.flags.synchronized
		     then goto dm_ring_error;
		end;

	     end;

/* for dir rb's, check level with modify bracket of directory */
	     else if lev > fixed (ep -> entry.ex_ring_brackets (1), 3) then go to low_ring_err;

	     dir.modify = pds$processid;		/* About to mod directory */
	     call change_dtem (ep);
						/* set segment rb */
	     if type = segment then ep -> entry.ring_brackets = bit (rbr, 3);
	     else do;
		ep -> entry.ex_ring_brackets (1) = bit (drbr (1), 3);
		ep -> entry.ex_ring_brackets (2) = bit (drbr (2), 3);
	     end;

	     call setfaults$if_active ((ep -> entry.uid), (ep -> entry.pvid), (ep -> entry.vtocx), "1"b);
						/* set the dates for backup */
	     dir.modify = "0"b;
	     call sum$dirmod (dp);
	end;					/* all done setting rb */

	if pathname_supplied then
	     call dc_find$finished (dp, DC_FIND_UNLOCK_DIR); /* unlock and unuse directory */
	else call lock$dir_unlock (dp);		/* unlock directory */

	if function = get then do;			/* copy rb into caller's space after unlocking dir */
	     if type = segment then a_rb = rbr;
	     else a_drb = drbr;
	end;

	a_code = code;				/* copy status code to caller */
	return;
%page;
brack_err:					/* input ring brackets were in error */
	code = error_table_$invalid_ring_brackets;
	go to error_common;

low_ring_err:
	code = error_table_$lower_ring;
	go to error_common;

aim_err:
	code = error_table_$ai_restricted;
	goto error_common;

dm_ring_error:
	code = error_table_$not_dm_ring;
	goto error_common;

segptr_null_err:
	code = error_table_$null_info_ptr;
	goto error_common;

error_return:
error_common:
	if dp ^= null then do;
	     if function = set then dir.modify = "0"b;
	     call lock$dir_unlock (dp);
	     if pathname_supplied then
		call dc_find$finished (dp, "0"b);
	end;

	a_code = code;
	return;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include fs_obj_access_codes;
%page; %include quota_cell;
%page; %include sc_info;
     end;




		    set.pl1                         11/11/89  1132.4rew 11/11/89  0800.0      287253



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



/****^  HISTORY COMMENTS:
  1) change(85-07-01,CLJones), approve(86-08-05,MCR7458),
     audit(86-06-30,EJSharpe), install(86-08-19,MR12.0-1120):
     Made damaged and dnzp switch setting respect ring brackets.
  2) change(88-03-14,Lippard), approve(88-05-02,MCR7881),
     audit(88-06-09,Fawcett), install(88-08-02,MR12.2-1074):
     Added audit_flag_path, for setting entry audit switch
     (to cause generation of audit messages for all accesses to the
     object.
                                                   END HISTORY COMMENTS */


/* format: style4 */
set:
     proc;

/* Modified October 1984, Keith Loepere, for auditing info;
also to not allow the setting of bc for upgraded dirs. */
/* Modified June 1984, Keith Loepere, to use the new dc_find. */
/* Modified February 1984, Lindsey Spratt, changed the dm_gino check to be against the write bracket instead of the read bracket. */
/* Modified August 1983, E. N. Kittlitz, setfaults$if_active pvid, vtocx args */
/* Modified March 1983, E. N. Kittlitz, never set dtem back, delete tpd */
/* Modified February 1983, E. N. Kittlitz, 256K max length. */
/* Modified 30 July, 1981, W. Olin Sibert, to change the rules for damaged switch setting */
/* Modified 800409 by PG to add change_bc entries for WOS */
/* Modified 800314 by PG to add entries to set dnzp switch */
/* Modified 07/18/79 by Steve Webber to disallow setting bit count on directories given a pointer */
/* Modified by D.Vinograd 6/76 to add entry to set volume dump control switches */
/* Modified 05/31/76 by R. Bratt to call find_$finished when done */
/* Modified 04/20/76 by R. Bratt to check mountedness of LV */
/* Modified by R. Bratt for setting branch tpd */
/* Modified for NSS 4/75 by THVV: remove actind, use vtoc/aste */
/* Modified by Kobziar 9/74 to call appropriate entry in access_mode */
/* Modified by E. Stone to add entries to change the entry point bound - Aug 1974 */
/* Modified on 12-4-73 by Kobziar to not check for append perm. to set bc */

/* parameters */

dcl  a_audit_flag bit (1) aligned parameter;
dcl  a_auth char (*) parameter;
dcl  a_bitct fixed bin (24) parameter;
dcl  1 a_btimes aligned like based_btimes;
dcl  a_chasesw fixed bin (1) parameter;
dcl  a_code fixed bin (35) parameter;
dcl  a_copy fixed bin (1) parameter;
dcl  a_damaged_sw bit (1) parameter;
dcl  a_date bit (36) parameter;
dcl  a_datep ptr parameter;
dcl  a_delta_bc fixed bin (24) parameter;
dcl  a_dirname char (*) parameter;
dcl  a_dtime fixed bin (52) parameter;			/* time dumped */
dcl  a_ename char (*) parameter;
dcl  a_entry_bound fixed bin (14) parameter;
dcl  a_max_length fixed bin (19) parameter;
dcl  a_new_bc fixed bin (24) parameter;
dcl  a_ncd fixed bin parameter;
dcl  a_nid fixed bin parameter;
dcl  a_old_bc fixed bin (24) parameter;
dcl  a_safety_sw bit (1) parameter;
dcl  a_segptr ptr parameter;
dcl  a_setp ptr parameter;
dcl  a_synchronized_sw bit (1) aligned parameter;

/* based */

dcl  1 a_reload_set_info aligned based like reload_set_info;
dcl  1 based_time based aligned,
       2 dtem bit (36),
       2 dtd bit (36),
       2 dtu bit (36),
       2 dtm bit (36);

dcl  1 based_btimes based aligned,			/* times from backup */
       2 dtem fixed bin (52),
       2 dtd fixed bin (52),
       2 dtu fixed bin (52),
       2 dtm fixed bin (52);

/* automatic */

dcl  1 access_name aligned,				/* 3 part access name - used for author and bc_author */
       2 person char (32),
       2 project char (32),
       2 tag char (1);
dcl  audit_flag bit (1) aligned;
dcl  auth char (32) aligned;
dcl  authp ptr;
dcl  bitct fixed bin (24);
dcl  bs bit (1) aligned;
dcl  1 btimes aligned like based_btimes;
dcl  chasesw fixed bin (1);
dcl  check_rb bit (1) aligned;
dcl  code fixed bin (35);
dcl  copy fixed bin (1);
dcl  damaged_sw bit (1) aligned;
dcl  date bit (36);
dcl  delta_bc fixed bin (24);
dcl  detailed_operation fixed bin (18) uns;
dcl  dirname char (168);
dcl  dirsw bit (1) aligned;
dcl  dtm bit (36) aligned;
dcl  dtu bit (36) aligned;
dcl  ename char (32);
dcl  entry_bound fixed bin (14);
dcl  entry_type fixed bin;
dcl  find_was_called bit (1) aligned;
dcl  max_length fixed bin (19);
dcl  mxl fixed bin (9);
dcl  ncd fixed bin;
dcl  new_bc fixed bin (24);
dcl  nid fixed bin;
dcl  old_bc fixed bin (24);
dcl  1 pc_msk like vtoce_pc_sws aligned;
dcl  1 pc_val like vtoce_pc_sws aligned;
dcl  priv_ml bit (1) aligned init ("0"b);
dcl  pvid bit (36) aligned;
dcl  safety_sw bit (1) aligned;
dcl  segptr ptr;
dcl  setp ptr;
dcl  setting_for_reloader fixed bin init (0);
dcl  synchronized_sw bit (1) aligned;
dcl  1 time aligned like based_time;
dcl  uid bit (36) aligned;
dcl  val fixed bin (17);
dcl  vtocx fixed bin;

/* constants */

dcl  Normal_entry fixed bin init (1) static options (constant);
dcl  Set_bc_entry fixed bin init (2) static options (constant);
dcl  Change_bc_entry fixed bin init (3) static options (constant);
dcl  Dsw_entry fixed bin init (4) static options (constant);
dcl  Set_bc_entry_priv fixed bin init (5) static options (constant);
dcl  Normal_priv_entry fixed bin init (6) static options (constant);

/* external static */

dcl  error_table_$ai_restricted external fixed bin (35);
dcl  error_table_$argerr external fixed bin (35);
dcl  error_table_$bad_ring_brackets external fixed bin (35);
dcl  error_table_$dirseg external fixed bin (35);
dcl  error_table_$link external fixed bin (35);
dcl  error_table_$not_a_branch external fixed bin (35);
dcl  error_table_$not_dm_ring external fixed bin (35);
dcl  pds$access_name fixed bin (35) external;
dcl  1 pds$transparent ext aligned,
       2 m bit (1) unaligned,
       2 u bit (1) unaligned;
dcl  sys_info$data_management_ringno fixed bin external;
dcl  sys_info$seg_size_256K fixed bin (19) external;

/* entries */

dcl  acc_name_$delete entry (ptr);
dcl  acc_name_$elements entry (ptr, ptr, fixed bin (35));
dcl  acc_name_$encode entry (ptr, ptr, fixed bin (35));
dcl  change_dtem entry (ptr);
dcl  level$get returns (fixed bin (17));
dcl  lock$dir_unlock entry (pointer);
dcl  mountedp entry (bit (36) aligned) returns (fixed bin (35));
dcl  setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
dcl  sum$dirmod entry (pointer);
dcl  vtoc_attributes$reloading entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (9), fixed bin (35));
dcl  vtoc_attributes$set_dates entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  vtoc_attributes$set_dump_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  vtoc_attributes$set_max_lth entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (9), bit (1) aligned, fixed bin (35));
dcl  vtoc_attributes$set_pc_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));

/* builtins */

dcl  (addr, binary, bit, clock, fixed, divide, length, ptr, string, substr, unspec) builtin;
%page;
/* SET$COPYSW changes the setting of the copy switch in the branch effectively pointed to by
   "entry" in the directory with path name "dirname" to "copy" if caller has
   write permit in the directory. */

copysw:
     entry (a_dirname, a_ename, a_copy, a_code);

	detailed_operation = FS_OBJ_COPY_SW_MOD;
	copy = a_copy;				/* must copy input arguments into stack before locking */
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;
	entry.copysw = bit (copy, 1);
	go to finish;
%page;
/* SET$AUTH changes the auth variable in the entry "ename" in the directory pointed to by
   the pathname "dirname" . The entry is "chased" if the chase switch is on. The caller must
   have write permit on the directory. */

auth:
     entry (a_dirname, a_ename, a_chasesw, a_auth, a_code);

	detailed_operation = FS_OBJ_AUTHOR_MOD;
	chasesw = a_chasesw;
	auth = a_auth;
	check_rb = "0"b;
	entry_type = Normal_entry;
	call find_entry;
	authp = addr (entry.author);			/* Get pointer to author. */

set_auth:
	call acc_name_$elements (addr (auth), addr (access_name), code);
	if code ^= 0
	then go to unlock;				/* Break up author into 3 part access name. */
	call acc_name_$delete (authp);		/* Delete previous author if any */
	call acc_name_$encode (authp, addr (access_name), code);
	go to unlock;
%page;
/* SET$BC changes the setting of the bit count item in the branch effectively pointed
   to by "entry" in the directory with path name "dirname" to "bitct"
   if caller has execute permit in the directory and write
   or append permit in the branch. */

/* SET$BC_SEG is the same as set$bc except that it takes a pointer to a segment rather than
   "dirname" and "entry" as input arguments.  */

bc_seg_priv:
     entry (a_segptr, a_bitct, a_code);			/* privileged bitcount setting - no access check */

	entry_type = Set_bc_entry_priv;
	go to bc_set_ptr_join;

bc_seg:
     entry (a_segptr, a_bitct, a_code);

	entry_type = Set_bc_entry;

bc_set_ptr_join:
	detailed_operation = FS_OBJ_BC_MOD;
	bitct = a_bitct;				/* copy input args */
	check_rb = "0"b;
	call get_entry_ptr;
	if dirsw
	then					/* disallow setting bc on directory given pointer */
	     goto dirseg;

	go to set_bc;				/* Join common code. */

bc:
     entry (a_dirname, a_ename, a_bitct, a_code);

	detailed_operation = FS_OBJ_BC_MOD;
	bitct = a_bitct;				/* must copy input arguments into stack before locking */
	chasesw = 1;
	check_rb = "0"b;
	entry_type = Set_bc_entry;
	call find_entry;

set_bc:
	if entry.dirsw then
	     if binary (entry.ring_brackets (1), 3) > 1 then
		if entry.multiple_class then		/* implies upgraded */
		     go to ai_error;

	entry.bc = bitct;				/* actually set the bit count in the entry */

	call acc_name_$delete (addr (entry.bc_author));	/* set the bc author */
	call acc_name_$encode (addr (entry.bc_author), addr (pds$access_name), code);

	go to finish;
%page;
/* SET$CHANGE_BC_PATH adds a specified amount to the bitcount, and returns the
   old and new bitcount to the caller. It can be used by multiple processes
   to synchronize their writing to an unstructured segment without any other
   locking protocol. */

change_bc_path:
     entry (a_dirname, a_ename, a_delta_bc, a_old_bc, a_new_bc, a_code);

	detailed_operation = FS_OBJ_BC_MOD;
	delta_bc = a_delta_bc;
	chasesw = 1;
	check_rb = "0"b;
	entry_type = Change_bc_entry;
	call find_entry;
	go to change_bc;

/* SET$CHANGE_BC_PTR is the same as set$change_bc_path except that it takes
   a pointer to a segment. */

change_bc_ptr:
     entry (a_segptr, a_delta_bc, a_old_bc, a_new_bc, a_code);

	detailed_operation = FS_OBJ_BC_MOD;
	delta_bc = a_delta_bc;
	check_rb = "0"b;
	entry_type = Change_bc_entry;
	call get_entry_ptr;
	if dirsw
	then go to dirseg;

change_bc:
	old_bc = entry.bc;
	new_bc, bitct = old_bc + delta_bc;
	go to set_bc;
%page;
/* SET$DTD changes the setting of the date time dumped item in the branch effectively pointed to
   by "entry" in the directory with path name "dirname" to "date"
   if caller has write permit in the directory . */

/* SET$BACKUP_DUMP_TIME is the same as set$dtd except that it takes a fixed bin (52)
   time instead of a bit (36) file system time.  */

dtd:
     entry (a_dirname, a_ename, a_date, a_code);

	date = a_date;				/* must copy input argument into stack before locking */
	entry_type = Normal_entry;
	go to set_dtd;				/* Join common code. */

backup_dump_time:
     entry (a_dirname, a_ename, a_dtime, a_code);

	date = substr (bit (a_dtime, 52), 1, length (date)); /* copy and convert input argument */
	entry_type = Normal_priv_entry;

set_dtd:
	detailed_operation = FS_OBJ_DT_DUMPED_MOD;
	chasesw = 0;
	check_rb = "0"b;
	call find_entry;
	if bs
	then entry.dtd = date;
	else link.dtd = date;
	go to unlock;
%page;
/* SET$DATES changes the setting of the date time used, date time modified and date time entry modified
   items in the branch effectively pointed to by "entry" in the directory with path name "dirname" to
   "date" if caller has write permit in the directory. */

dates:
     entry (a_dirname, a_ename, a_datep, a_code);

	detailed_operation = FS_OBJ_DATES_MOD;
	time = a_datep -> based_time;			/* must copy input into stack before locking */
	chasesw = 0;
	check_rb = "0"b;
	entry_type = Normal_entry;
	call find_entry;
	if bs then do;
	     uid = entry.uid;			/* Extract unique ID */
	     pvid = entry.pvid;
	     vtocx = entry.vtocx;
	     dtu = time.dtu;
	     dtm = time.dtm;
	     if dirsw
	     then code = 0;				/* assume RLV is always mounted */
	     else code = mountedp (dir.sons_lvid);	/* only if mounted! */
	     if code = 0
	     then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code);
	     if code ^= 0
	     then go to unlock;
	     entry.dtem = time.dtem;
	     entry.dtd = time.dtd;
	end;
	else do;
	     link.dtem = time.dtem;
	     link.dtd = time.dtd;
	end;
	go to unlock;
%page;
/* SET$DUMP_SWITCHES is used to set/reset the dump control switches  in the vtoce of
   a branch. The two switches, no_complete_dump and no incremental dump are set on
   if the input is positive, off if negative and not set if zero. */

volume_dump_switches:
     entry (a_dirname, a_ename, a_nid, a_ncd, a_code);

	detailed_operation = FS_OBJ_VOL_DUMP_SW_MOD;
	chasesw = 1;
	check_rb = "1"b;
	ncd = a_ncd;
	nid = a_nid;
	entry_type = Normal_entry;
	call find_entry;
	if bs then do;
	     uid = entry.uid;
	     pvid = entry.pvid;
	     vtocx = entry.vtocx;
	     if dirsw
	     then code = error_table_$dirseg;
	     else code = mountedp (dir.sons_lvid);
	     if code = 0
	     then call vtoc_attributes$set_dump_switches (uid, pvid, vtocx, nid, ncd, code);
	end;
	else code = error_table_$link;
	goto unlock;
%page;
/* SET$BACKUP_TIMES is used by the reloading process to set the following
   items in a directory branch: date-time entry modified,
   date-time dumped, date-time used, date-time modified.  */

backup_times:
     entry (a_dirname, a_ename, a_btimes, a_code);

	detailed_operation = FS_OBJ_BACKUP_TIMES_MOD;
	btimes = a_btimes;				/* copy structure argument */
	chasesw = 0;
	check_rb = "0"b;
	entry_type = Normal_entry;
	call find_entry;
	if bs then do;
	     uid = entry.uid;			/* Extract unique ID */
	     pvid = entry.pvid;
	     vtocx = entry.vtocx;
	     dtu = substr (bit (btimes.dtu, 52), 1, length (dtu));
	     dtm = substr (bit (btimes.dtm, 52), 1, length (dtm));
	     if dirsw
	     then code = 0;				/* assume RLV always mounted */
	     else code = mountedp (dir.sons_lvid);	/* only if mounted! */
	     if code = 0
	     then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code);
	     if code ^= 0
	     then go to unlock;
	     entry.dtem = substr (bit (btimes.dtem, 52), 1, length (entry.dtem));
	     entry.dtd = substr (bit (btimes.dtd, 52), 1, length (entry.dtd));
	end;
	else do;
	     link.dtem = substr (bit (btimes.dtem, 52), 1, length (link.dtem));
	     link.dtd = substr (bit (btimes.dtd, 36), 1, length (link.dtd));
	end;
	go to unlock;
%page;
/* SET$SAFETY_SWITCH_PTR changes the safety switch in the directory entry corresponding
   to the pointer "segptr".  */

/* SET$_SAFETY_SWITCH_PATH is identical to set$safety_switch pointer except that
   the "ename" and "dirname" are specified instead of a segment pointer.  */

safety_sw_ptr:
     entry (a_segptr, a_safety_sw, a_code);

	detailed_operation = FS_OBJ_SAFETY_SW_MOD;
	safety_sw = a_safety_sw;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call get_entry_ptr;
	go to set_safety;				/* Join common code. */

safety_sw_path:
     entry (a_dirname, a_ename, a_safety_sw, a_code);

	detailed_operation = FS_OBJ_SAFETY_SW_MOD;
	safety_sw = a_safety_sw;
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;

set_safety:
	entry.safety_sw = safety_sw;
	go to finish;
%page;
/* SET$AUDIT_FLAG_PATH changes the audit switch in the directory entry for
   the specified path. */

audit_flag_path:
     entry (a_dirname, a_ename, a_audit_flag, a_code);

	detailed_operation = FS_OBJ_AUDIT_FLAG_MOD;
	audit_flag = a_audit_flag;
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;

set_audit_flag:
	entry.audit_flag = audit_flag;
	go to finish;
%page;
/* SET$DAMAGED_SW_PTR changes the damaged switch in the directory entry corresponding
   to the pointer "segptr".  */

/* SET$DAMAGED_SW_PATH is identical to set$damaged_sw_ptr except that
   the "ename" and "dirname" are specified instead of a segment pointer.  */

damaged_sw_ptr:
     entry (a_segptr, a_damaged_sw, a_code);

	detailed_operation = FS_OBJ_DAMAGED_SW_MOD;
	damaged_sw = a_damaged_sw;
	check_rb = "1"b;
	entry_type = Dsw_entry;
	call get_entry_ptr;
	go to set_damaged;				/* Join common code. */

damaged_sw_path:
     entry (a_dirname, a_ename, a_damaged_sw, a_code);

	detailed_operation = FS_OBJ_DAMAGED_SW_MOD;
	damaged_sw = a_damaged_sw;
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Dsw_entry;
	call find_entry;

set_damaged:
	unspec (pc_val) = ""b;
	unspec (pc_msk) = ""b;
	pc_val.damaged = damaged_sw;
	pc_msk.damaged = "1"b;
	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	if dirsw
	then code = 0;
	else code = mountedp (dir.sons_lvid);
	if code = 0
	then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
	if code ^= 0
	then go to unlock;
	go to finish;
%page;
/* SET$DNZP_SW_PTR changes the dnzp switch in the directory entry corresponding
   to the pointer "segptr".  */

/* SET$DNZP_SW_PATH is identical to set$dnzp_sw_ptr except that
   the "ename" and "dirname" are specified instead of a segment pointer.  */

/* parameters */

declare  a_dnzp_sw bit (1) aligned parameter;

/* automatic */

declare  dnzp_sw bit (1) aligned;

/* program */

dnzp_sw_ptr:
     entry (a_segptr, a_dnzp_sw, a_code);

	detailed_operation = FS_OBJ_DNZP_MOD;
	dnzp_sw = a_dnzp_sw;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call get_entry_ptr;
	go to set_dnzp;				/* Join common code. */

dnzp_sw_path:
     entry (a_dirname, a_ename, a_dnzp_sw, a_code);

	detailed_operation = FS_OBJ_DNZP_MOD;
	dnzp_sw = a_dnzp_sw;
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;

set_dnzp:
	if dirsw
	then go to dirseg;				/* Oh no you don't */

	unspec (pc_val) = ""b;
	unspec (pc_msk) = ""b;
	pc_val.dnzp = dnzp_sw;
	pc_msk.dnzp = "1"b;
	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	if dirsw
	then code = 0;
	else code = mountedp (dir.sons_lvid);
	if code = 0
	then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
	if code ^= 0
	then go to unlock;
	go to finish;
%page;
/* SET$SYNCHRONIZED_SW changes the synchronized switch in the VTOCE
   corresponding to the path supplied. This is used by Data Management
   to order writes done by Page Control. */

synchronized_sw:
     entry (a_dirname, a_ename, a_synchronized_sw, a_code);

	detailed_operation = FS_OBJ_SYNC_SW_MOD;
	synchronized_sw = a_synchronized_sw;
	chasesw = 0;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;

	if dirsw
	then goto dirseg;

	if fixed (entry.ring_brackets (1), 3) > sys_info$data_management_ringno
	then do;
	     code = error_table_$not_dm_ring;
	     goto unlock;
	end;

	unspec (pc_val) = ""b;
	unspec (pc_msk) = ""b;
	pc_val.synchronized = synchronized_sw;
	pc_msk.synchronized = "1"b;
	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	code = mountedp (dir.sons_lvid);
	if code = 0
	then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
	if code ^= 0 then goto unlock;
	goto finish;
%page;
/* SET$MAX_LENGTH_PTR resets the maximum length of the segment pointed to
   by "segptr" to the "max_length" specified in words.  */

/* SET$MAX_LENGTH_PATH is identical to set$max_length_ptr except that the
   "ename" and "dirname" of the segment are sepcified instead of the "segptr".  */

max_length_ptr:
     entry (a_segptr, a_max_length, a_code);

	detailed_operation = FS_OBJ_MAX_LEN_MOD;
	max_length = a_max_length;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call get_entry_ptr;
	go to set_max_length;

max_length_priv:
     entry (a_dirname, a_ename, a_max_length, a_code);

	priv_ml = "1"b;
	check_rb = "0"b;
	goto cp_ml_args;

max_length_path:
     entry (a_dirname, a_ename, a_max_length, a_code);
	check_rb = "1"b;

cp_ml_args:
	detailed_operation = FS_OBJ_MAX_LEN_MOD;
	max_length = a_max_length;
	chasesw = 1;
	entry_type = Normal_entry;
	call find_entry;

set_max_length:
	if dirsw
	then go to dirseg;
	if max_length < 0
	then go to argerr;
	if max_length > sys_info$seg_size_256K
	then go to argerr;
	uid = entry.uid;				/* Extract unique ID */
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	mxl = divide (max_length + 1023, 1024, 9, 0);	/* Correct units */
	code = mountedp (dir.sons_lvid);
	if code = 0
	then call vtoc_attributes$set_max_lth (uid, pvid, vtocx, mxl, priv_ml, code);
	if code ^= 0
	then go to unlock;
	go to finish;
%page;
/* SET$BC_AUTH_PATH is used by the reloader to set the bitcount author of the
   directory entry corresponding to the segment indicated by "ename" and
   "dirname". */

bc_auth_path:
     entry (a_dirname, a_ename, a_auth, a_code);

	detailed_operation = FS_OBJ_BC_AUTHOR_MOD;
	auth = a_auth;
	chasesw = 1;
	check_rb = "0"b;
	entry_type = Normal_entry;
	call find_entry;				/* no AIM check since privileged entry */

	authp = addr (entry.bc_author);		/* Get pointer to bit count author. */
	go to set_auth;				/* Join common author-setting code. */
%page;
/* SET$ENTRY_BOUND_PTR sets the entry point bound switch and changes the
   entry point bound of the segment pointed to by "segptr" to the "entry_bound"
   specified in words if "entry_bound" is greater than 0.
   If "entry_bound" equals 0, then the entry point bound switch is reset and
   the entry point bound is changed to 0. */

/* SET$ENTRY_BOUND_PATH is identical to set$entry_point_ptr except that
   then "dirname" and "ename" of the segment are specified instead of the "segptr". */

entry_bound_ptr:
     entry (a_segptr, a_entry_bound, a_code);

	detailed_operation = FS_OBJ_ENTRY_BOUND_MOD;
	entry_bound = a_entry_bound;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call get_entry_ptr;
	go to set_call_limiter;

entry_bound_path:
     entry (a_dirname, a_ename, a_entry_bound, a_code);

	detailed_operation = FS_OBJ_ENTRY_BOUND_MOD;
	entry_bound = a_entry_bound;
	chasesw = 1;
	check_rb = "1"b;
	entry_type = Normal_entry;
	call find_entry;

set_call_limiter:
	if dirsw
	then go to dirseg;
	if entry_bound < 0
	then go to argerr;				/* Limited to 14 bits in sdw */
	if entry_bound > 16383
	then go to argerr;
	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	call setfaults$if_active (uid, pvid, vtocx, "0"b);
	if entry_bound = 0 then do;
	     entry.entrypt_sw = "0"b;
	     entry.entrypt_bound = "0"b;
	end;
	else do;
	     entry.entrypt_sw = "1"b;
	     entry.entrypt_bound = bit (entry_bound, 14);
	end;
	go to finish;
%page;
/* SET$SET_FOR_RELOADER  changes a number of variables in the entry "ename" in
   the directory pointed to by the pathname "dirname".
   It also makes one call to set appropriate items in the VTOC.
   The entry is not chased.    The caller must have write permit
   on the directory.  It is intended that that this entry in set
   provide the sum of the functionality of a number of other entries:
   that is the usual checks are made and status codes are returned.
   Because this entry can only be reached through a priviliged gate,
   the max_length is not checked against the current length ---
   this is not only consistent with the privileged set_max_length entry,
   but also with the fact that the dumper will never write more
   meaningfull data than "max_length" to tape */

set_for_reloader:
     entry (a_dirname, a_ename, a_setp, a_code);

	detailed_operation = FS_OBJ_FOR_RELOADER_MOD;
	setp = a_setp;
	reload_set_info = setp -> a_reload_set_info;	/* copy input before locking */
	if reload_set_info.version ^= reload_set_version_2 then do;
						/* called with bad structure */
	     a_code = error_table_$argerr;
	     return;
	end;
	setting_for_reloader = 1;			/* remember to return info */
	chasesw = 0;
	check_rb = "0"b;
	entry_type = Normal_priv_entry;
	call find_entry;
	uid = entry.uid;				/* Extract unique ID */
	pvid = entry.pvid;
	vtocx = entry.vtocx;

	if ^bs then do;
	     code = error_table_$not_a_branch;
	     go to unlock;
	end;

	if reload_set_info.should_set.safety_sw
	then					/* set the safety_sw? */
	     entry.safety_sw = reload_set_info.safety_sw;

	if reload_set_info.should_set.audit_flag
	then					/* set the audit_flag? */
	     entry.audit_flag = reload_set_info.audit_flag;



	if reload_set_info.should_set.author then do;	/* author? */
	     authp = addr (entry.author);
	     call acc_name_$elements (addr (reload_set_info.author), addr (access_name), reload_set_info.author_code);
	     if reload_set_info.author_code = 0 then do;	/* if no errs proceed */
		call acc_name_$delete (authp);
		call acc_name_$encode (authp, addr (access_name), reload_set_info.author_code);
	     end;
	end;

	if reload_set_info.should_set.bc_author then do;	/* no AIM check since privileged entry */
	     authp = addr (entry.bc_author);
	     call acc_name_$elements (addr (reload_set_info.bc_author), addr (access_name),
		reload_set_info.bc_author_code);
	     if reload_set_info.bc_author_code = 0 then do;
		call acc_name_$delete (authp);
		call acc_name_$encode (authp, addr (access_name), reload_set_info.bc_author_code);
	     end;
	end;

/* Now for the tricky part */
/* go to vtoc to set dtm,dtu,mxl */
/* if go to vtoc for mxl,  need not do setfaults here */
/* even if setting entry_bound */

	if reload_set_info.should_set.dtu
	then dtu = reload_set_info.dtu;		/* dtu = 0 means va$ wont set */
	else dtu = "0"b;

	if reload_set_info.should_set.dtm
	then dtm = reload_set_info.dtm;		/* dtm = 0 means va$ wont set */
	else dtm = "0"b;

	mxl = -1;					/* mxl = -1 means va$ wont set, dont setfaults */
	if reload_set_info.should_set.max_length then do;
	     if dirsw
	     then reload_set_info.max_length_code = error_table_$dirseg;
						/* make some checks */
	     else if reload_set_info.max_length < 0
	     then reload_set_info.max_length_code = error_table_$argerr;
	     else mxl = divide (reload_set_info.max_length + 1023, 1024, 9, 0);
	end;

	if dtm | dtu | mxl >= 0 then do;		/* something to set in vtoc */
	     if dirsw
	     then code = 0;				/* RLV always mounted */
	     else code = mountedp (dir.sons_lvid);	/* check mountedness */
	     if code = 0
	     then call vtoc_attributes$reloading (uid, pvid, vtocx, dtu, dtm, mxl, code);
						/*  NOTE: for  now we are punting the no mounted case */
	end;					/* vtoc_attr has done setfaults if mxl >= 0 */

	if reload_set_info.should_set.entry_bound then do;/* see about epb */
	     if dirsw
	     then reload_set_info.entry_bound_code = error_table_$dirseg;
	     else if reload_set_info.entry_bound < 0
	     then reload_set_info.entry_bound_code = error_table_$argerr;
	     else if reload_set_info.entry_bound > 16383
	     then reload_set_info.entry_bound_code = error_table_$argerr;
	     else do;				/* we are willing to set it */
		if mxl < 0 | code ^= 0
		then				/* do setfault now, if not already done */
		     call setfaults$if_active (uid, pvid, vtocx, "0"b);
		if reload_set_info.entry_bound = 0 then do;
						/* clear relevant fields */
		     entry.entrypt_sw = "0"b;
		     entry.entrypt_bound = "0"b;
		end;
		else do;
		     entry.entrypt_sw = "1"b;
		     entry.entrypt_bound = bit (reload_set_info.entry_bound, 14);
		end;
	     end;
	end;

	if reload_set_info.should_set.dtem
	then					/* date time entry modified? */
	     entry.dtem = reload_set_info.dtem;

	if reload_set_info.should_set.dtd
	then					/* date time dumped? */
	     entry.dtd = reload_set_info.dtd;

	go to finish;
%page;
/* Update dtem, unlock entry, notify segment control that directory containing
   entry has been modified and return */

finish:
	if pds$transparent.m = "0"b
	then if entry.dtem ^= bit (binary (clock (), 52), 36)
	     then call change_dtem (ep);

unlock:
	call sum$dirmod (dp);
	if find_was_called
	then call dc_find$finished (dp, "1"b);
	else call lock$dir_unlock (dp);

	if setting_for_reloader ^= 0
	then setp -> a_reload_set_info = reload_set_info;
	else if entry_type = Change_bc_entry then do;
	     a_old_bc = old_bc;
	     a_new_bc = new_bc;
	end;

finale:
	a_code = code;
	return;

/* Error Handling */

ai_error: 
	code = error_table_$ai_restricted;
	go to unlock;

argerr:
	code = error_table_$argerr;
	go to unlock;

dirseg:
	code = error_table_$dirseg;
	go to unlock;

bracket_error:
	code = error_table_$bad_ring_brackets;
	goto unlock;
%page;
/* internal procedures */

find_entry:
     proc;					/* get a pointer to the entry and lock the directory */

	code = 0;
	dirname = a_dirname;
	ename = a_ename;
	if entry_type = Normal_entry then
	     call dc_find$obj_status_write (dirname, ename, chasesw, detailed_operation, ep, code);
	else if entry_type = Set_bc_entry then
	     call dc_find$obj_bc_write (dirname, ename, bitct, ep, code);
	else if entry_type = Change_bc_entry then
	     call dc_find$obj_bc_delta_write (dirname, ename, delta_bc, ep, code);
	else if entry_type = Dsw_entry then		/* allow no m on parent */
	     call dc_find$obj_attributes_write (dirname, ename, chasesw, detailed_operation, ep, code);
	else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then
	     call dc_find$obj_status_write_priv (dirname, ename, chasesw, detailed_operation, ep, code);
	dp = ptr (ep, 0);
	if code ^= 0
	then go to finale;
	find_was_called = "1"b;
	go to check;

get_entry_ptr:
     entry;					/* get a pointer to the entry and lock the directory */

	code = 0;
	segptr = a_segptr;
	find_was_called = "0"b;
	if entry_type = Normal_entry then
	     call dc_find$obj_status_write_ptr (segptr, detailed_operation, ep, code);
	else if entry_type = Set_bc_entry then
	     call dc_find$obj_bc_write_ptr (segptr, bitct, ep, code);
	else if entry_type = Change_bc_entry then
	     call dc_find$obj_bc_delta_write_ptr (segptr, delta_bc, ep, code);
	else if entry_type = Dsw_entry then		/* allow no m on parent */
	     call dc_find$obj_attributes_write_ptr (segptr, detailed_operation, ep, code);
	else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then
	     call dc_find$obj_status_write_priv_ptr (segptr, detailed_operation, ep, code);
	dp = ptr (ep, 0);
	if code ^= 0
	then go to finale;

check:
	bs = entry.bs;
	dirsw = entry.dirsw;
	if check_rb then do;			/* also need to check ring brackets */
	     val = level$get ();
	     if dirsw then do;
		if val > fixed (entry.ex_ring_brackets (1), 3)
		then go to bracket_error;
	     end;
	     else do;
		if val > fixed (entry.ring_brackets (1), 3)
		then go to bracket_error;
	     end;
	end;

     end find_entry;
%page;
/* include files */

%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_link;
%page; %include fs_obj_access_codes;
%page; %include reload_set_info;
%page; %include vtoce_pc_sws;
     end set;




		    set_disk_table_loc.pl1          11/11/89  1132.4r w 11/11/89  0800.6       21249



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

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

set_disk_table_loc: proc (a_segptr, a_code);

/* set_disk_table_loc: this procedure is called by system startup
   to assert the VTOC index of the disk table on the
   root physical volume.

   Bernard Greenberg, Oct. 18, 1975. 
   Modified February, 1982, J. Bongiovanni to eliminate FSDCT 
   Modified October 1984, Keith Loepere to use dc_find.
*/

/* Entries */

dcl  fsout_vol			external entry (fixed bin);
dcl  lock$dir_unlock		entry (ptr);

/* External */

dcl  error_table_$action_not_performed	fixed bin (35) external;
dcl  pvt$disk_table_uid		bit (36) aligned external;
dcl  pvt$disk_table_vtocx		fixed bin external;
dcl  pvt$root_pvtx			fixed bin external;

/* Misc */

dcl  (addr, ptr)			builtin;

/* Parameters */

dcl  a_code			fixed bin (35);
dcl  a_segptr			ptr;		/* pointer to supposed disk table */

/* Variables */

dcl  code				fixed bin (35);
dcl  segptr			ptr;
%page;
	segptr = a_segptr;				/* copy param, we are a gate. */

	pvt_arrayp = addr (pvt$array);

	call dc_find$obj_status_read_priv_ptr (segptr, ep, code);
	if code ^= 0 then do;
	     a_code = code;
	     return;
	end;

	if entry.pvid ^= pvt_array (pvt$root_pvtx).pvid then do;

	     call lock$dir_unlock (ptr (ep, 0));	/* unlock the dir */
	     a_code = error_table_$action_not_performed;	/* Must be on rpv */
	     return;
	end;

	pvt$disk_table_uid = entry.uid;		/* Set the info */
	pvt$disk_table_vtocx = entry.vtocx;
	call lock$dir_unlock (ptr (ep, 0));
	call fsout_vol (pvt$root_pvtx);		/* fsout the RPV */
	a_code = 0;
	return;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include pvte;
     end;




		    set_kst_attributes.pl1          11/11/89  1132.4r w 11/11/89  0800.6       22572



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


set_kst_attributes: proc (a_segno, a_kstap, a_code);

	priv = "0"b;

highly_privileged: entry (a_segno, a_kstap, a_code);

/*

   Written 03/26/76 by R. Bratt

   This procedure allows a sufficiently privileged user to change the segment use attributes
   stored in his kst.

   Privileged users may set: allow_write, explicit_deact_ok, tpd, and audit.
   Highly privileged users may also set: tms, and tus.

*/

dcl  a_segno fixed bin (17),
     a_kstap ptr,
     a_code fixed bin (35);

dcl  segno fixed bin (17),
     code fixed bin (35),
     1 ksta aligned like kst_attributes,
     priv bit (1) aligned init ("1"b);

dcl  dseg$ ext,
     error_table_$action_not_performed ext fixed bin (35);

dcl  get_kstep entry (fixed bin (17), ptr, fixed bin (35)),
     setfaults$disconnect entry (fixed bin (17));

	segno = a_segno;
	unspec (ksta) = unspec (a_kstap -> kst_attributes);
	call get_kstep (segno, kstep, code);
	if code ^= 0
	then do;
	     a_code = code;
	     return;
	end;
	if ^priv & (ksta.set.tms | ksta.set.tus)
	then do;
	     a_code = error_table_$action_not_performed;
	     return;
	end;
	if ksta.set.allow_write
	then do;
	     kste.allow_write = ksta.value.allow_write;
	     sdwp = addr (addr (dseg$) -> sdwa (segno));	/* Get ptr to SDW */
	     string (sdw.access) = kste.access & ("11"b || kste.allow_write);
	     call setfaults$disconnect (segno);
	end;
	if ksta.set.tms
	then kste.tms = ksta.value.tms;
	if ksta.set.tus
	then kste.tus = ksta.value.tus;
	if ksta.set.tpd
	then kste.tpd = ksta.value.tpd;
	if ksta.set.audit
	then kste.audit = ksta.value.audit;
	if ksta.set.explicit_deactivate_ok
	then kste.explicit_deact_ok = ksta.value.explicit_deactivate_ok;
	a_code = 0;
	return;

/*  */

% include kst;

/*  */

%include kst_attributes;

/*  */

%include sdw;

     end set_kst_attributes;




		    set_privileges.pl1              11/11/89  1132.4r   11/11/89  0800.6      133740



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

/* format: style2,indcomtxt */
set_privileges:
     procedure;

/* Modified 1985-03-04, EJ Sharpe: remove special_op event flags and auditing for ring-1 TCB calls */
/* Modified 1985-01-21, BIM: ring 1 (admin) privilege manipulation. */
/* Modified 84-12-05 by EJ Sharpe to use access_audit_ instead of protection_audit_ */
/* Modified 84-11 BIM, changed to set all privs in apte */
/* Modified May 1983 by E. N. Kittlitz to add communication privilege */
/* Modified 760309 by L.Scheffler to fix excessive auditing calls */
/* Modified by E. Stone on Sept 1975 to change kst when setting directory privileges */
/* Coded 16 Oct. 1974 by D. H. Hunt */

/* This ring 0 procedure is expected to be invoked only by the */
/* system security administrator and by certain SysDaemon processes */
/* which need to bypass the access isolation mechanism (AIM) checks */

/* A process grants itself a particular privilege to bypass AIM checks */
/* by calling one of the "---priv_on" entry points.  This sets the */
/* corresponding privilege bit on (="1"b) */

/* A process rescinds a particular privilege for bypassing AIM checks */
/* by calling one of the "---priv_off" entry points.  This sets the */
/* corresponding privilege bit off (="0"b) */


	declare access_audit_$log_general
				 entry external options (variable);
	declare access_operations_$system_privilege_modify
				 bit (36) aligned external;
	declare 1 pds$access_authorization
				 aligned like aim_template external;
	declare pds$admin_privileges	 bit (36) aligned external;
	declare pds$apt_ptr		 pointer external;
	declare 1 event_flags	 aligned like audit_event_flags;
	declare level$get		 entry returns (fixed bin (3));
	declare ring_alarm$reset	 entry;
	declare setfaults$disconnect	 entry (fixed bin);
	declare ME		 char (14) aligned internal static initial ("set_privileges") options (constant);
	declare P_code		 fixed bin (35) parameter;
	declare P_set_privs		 bit (36) aligned parameter;
	declare P_old_privs		 bit (36) aligned parameter;

	declare changed		 bit (1) aligned;
	declare set_privs		 bit (36) aligned;
	declare old_privs		 bit (36) aligned;

	declare (addr, bit, bool, hbound, length, null, rtrim, string, substr)
				 builtin;
%page;

admin_set:
     entry (P_set_privs, P_old_privs);

	set_privs = P_set_privs;
	call set_admin_privileges (set_privs, old_privs); /* fixes the KST */
	P_old_privs = old_privs;
	return;

admin_reset:
     entry (P_set_privs);

	set_privs = P_set_privs;
	call reset_admin_privileges (set_privs);	/* fixes the KST */
	P_set_privs = set_privs;
	return;


admin_ring_alarm:					/* Called on a ring alarm to get rid of these */
     entry;

	set_privs = bit (string (pds$access_authorization.privileges), 36) & ^pds$admin_privileges;
						/* construct appropriate priv set */
	substr (set_privs, 36, 1) = "1"b;		/* Give it something to do */
	call reset_admin_privileges (set_privs);
	pds$admin_privileges = ""b;			/* double sure */
	return;
%page;

/* In managing its log buffers, syserr may send a wakeup to the initializer */
/* process.  Everything will work OK, since if the wakeup is sent from the */
/* initializer to itself, the wakeup will be allowed regardless of the state */
/* of the IPC privilege bits.  If another process sends the wakeup to the */
/* initializer, it will be allowed since the initializer will have IPC privilege */
/* on before other processes are allowed to log in. */

ipc_priv_on:					/* disables the AIM check for interprocess communication */
     entry (P_code);

	call set_one_privilege (IPC_PRIVILEGE_X, IPC_PRIVILEGE, changed);

	if changed
	then P_code = 0;
	else P_code = 1;
	return;


ipc_priv_off:					/* enables the AIM check for interprocess communication */
     entry (P_code);

	call clear_one_privilege (IPC_PRIVILEGE_X, ^IPC_PRIVILEGE, changed);

	if changed
	then P_code = 0;
	else P_code = 1;
	return;

dir_priv_on:					/* disables the AIM checks for directories */
     entry (P_code);

	call set_one_privilege (DIR_PRIVILEGE_X, DIR_PRIVILEGE, changed);
	if changed
	then do;
		call fix_kst;			/* cause access to directories to be recalculated */
		P_code = 0;
	     end;
	else P_code = 1;
	return;

dir_priv_off:					/* enables the AIM checks for directories */
     entry (P_code);

	call clear_one_privilege (DIR_PRIVILEGE_X, ^DIR_PRIVILEGE, changed);

	if changed
	then do;
		call fix_kst;			/* cause access to directories to be recalculated */
		P_code = 0;
	     end;
	else P_code = 1;
	return;

seg_priv_on:					/* disables the AIM checks for segments */
     entry (P_code);

	call set_one_privilege (SEG_PRIVILEGE_X, SEG_PRIVILEGE, changed);

	if changed
	then do;
		P_code = 0;
		call fix_kst_seg;
	     end;
	else P_code = 1;
	return;

seg_priv_off:					/* enables the AIM checks for segments */
     entry (P_code);

	call clear_one_privilege (SEG_PRIVILEGE_X, ^SEG_PRIVILEGE, changed);
	if changed
	then do;
		P_code = 0;
		call fix_kst_seg;
	     end;
	else P_code = 1;

	return;

soos_priv_on:					/* prevents access to directories which have the */
     entry (P_code);				/* security out of service attribute turned on */

	call set_one_privilege (SOOS_PRIVILEGE_X, SOOS_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

soos_priv_off:					/* allows access to directories which have the */
     entry (P_code);				/* security out of service attribute turned on */
	call clear_one_privilege (SOOS_PRIVILEGE_X, ^SOOS_PRIVILEGE, changed);

	if changed
	then P_code = 0;
	else P_code = 1;
	return;

ring1_priv_on:					/* disables the interpretive AIM */
     entry (P_code);				/* checks in ring one */
	call set_one_privilege (RING1_PRIVILEGE_X, RING1_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

ring1_priv_off:					/* enables the interpretive AIM */
     entry (P_code);				/* checks in ring one */

	call clear_one_privilege (RING1_PRIVILEGE_X, ^RING1_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

rcp_priv_on:					/* disables the interpretive AIM */
     entry (P_code);				/* checks in RCP */

	call set_one_privilege (RCP_PRIVILEGE_X, RCP_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

rcp_priv_off:					/* enables the interpretive AIM */
     entry (P_code);				/* checks in RCP */
	call clear_one_privilege (RCP_PRIVILEGE_X, ^RCP_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

comm_priv_on:					/* disables the interpretive AIM */
     entry (P_code);				/* checks in TCP and dial_ctl_ */

	call set_one_privilege (COMM_PRIVILEGE_X, COMM_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;

comm_priv_off:					/* enables the interpretive AIM */
     entry (P_code);				/* checks in comm */
	call clear_one_privilege (COMM_PRIVILEGE_X, ^COMM_PRIVILEGE, changed);
	if changed
	then P_code = 0;
	else P_code = 1;
	return;
%page;

fix_kst:
     procedure;

	dcl     segno		 fixed bin;
	dcl     seg_flag		 bit (1) aligned;
	dcl     faulted_one		 bit (1) aligned;

	seg_flag = "0"b;
	go to COMMON;

fix_kst_seg:
     entry;

	seg_flag = "1"b;

COMMON:
	kstp = pds$kstp;				/* get pointer to kst  */
	faulted_one = "0"b;
	do segno = kstp -> kst.lowseg to kstp -> kst.highest_used_segno;
						/* whip thru kst looking for dirs */
	     kstep = addr (kstp -> kst.kst_entry (segno));
	     if kste.uid ^= ""b
	     then if (kste.dirsw & ^seg_flag) | (^kste.dirsw & ^kste.priv_init & seg_flag)
		then do;
			kstep -> kste.dtbm = (36)"1"b;/* set dtbm so that access will be recalculated as needed */
			if seg_flag
			then call setfaults$disconnect (segno);
		     end;

	end;

     end fix_kst;
%page;

set_one_privilege:
     procedure (privilege_index, privilege_mask, changed);

	declare changed		 bit (1) aligned;
	declare privilege_index	 fixed bin;
	declare privilege_mask	 bit (36) aligned;
	declare new_privs		 bit (18) aligned;
	declare old_privs		 bit (18) aligned;
	declare apte_auth_ptr	 pointer;
	declare 1 apte_auth		 aligned like aim_template based (apte_auth_ptr);
	declare turn_on		 bit (1) aligned;

	turn_on = "1"b;
	go to COMMON;

clear_one_privilege:
     entry (privilege_index, privilege_mask, changed);

	turn_on = "0"b;

COMMON:
	changed = "0"b;
	old_privs = string (pds$access_authorization.privileges);
						/* starts same as old */
	if turn_on
	then new_privs = old_privs | privilege_mask;
	else new_privs = old_privs & privilege_mask;	/* caller ^'s to get ^'ed form in as text constant */

	if new_privs = old_privs
	then return;				/* with changed = "0"b */

	changed = "1"b;
	apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization);
	string (apte_auth.privileges), string (pds$access_authorization.privileges) = new_privs;
	string (event_flags) = ""b;
	event_flags.grant = "1"b;
	event_flags.priv_op = "1"b;
	call access_audit_$log_general (ME, level$get (), string (event_flags),
	     access_operations_$system_privilege_modify, "", 0, null (), 0, "^a turned ^[on^;off^]",
	     system_privilege_names (privilege_index).long, turn_on);
	return;

     end set_one_privilege;

set_admin_privileges:
     procedure (new_privileges, old_privileges);

	declare (new_privileges, old_privileges)
				 bit (36) aligned;
	declare apte_auth_ptr	 pointer;
	declare 1 apte_auth		 aligned like aim_template based (apte_auth_ptr);
	declare priv_value		 bit (18);
	declare name_string		 char (100) varying;
	declare x			 fixed bin;
	declare privs_before_set	 bit (18) aligned;
	declare different_privs_mask	 bit (18) aligned;

	old_privileges = string (pds$access_authorization.privileges);
	substr (old_privileges, 36, 1) = "1"b;		/* Mark the setting */
	priv_value = substr (old_privileges, 1, 18) | substr (new_privileges, 1, 18);
						/* Turn on the new ones */
	name_string = "";
	do x = 1 to hbound (system_privilege_names, 1);
	     if substr (new_privileges, x, 1)
	     then do;
		     if length (name_string) > 0
		     then name_string = name_string || ",";
		     name_string = name_string || rtrim (system_privilege_names.short (x));
		end;
	end;

	apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization);
	privs_before_set = string (pds$access_authorization.privileges);

	different_privs_mask = bool (privs_before_set, new_privileges, "0110"b);
						/* XOR */
	pds$admin_privileges = pds$admin_privileges | (new_privileges & different_privs_mask);
						/* mark */
	call ring_alarm$reset;

	string (apte_auth.privileges), string (pds$access_authorization.privileges) = priv_value;

	if ((priv_value & DIR_PRIVILEGE) ^= ""b) /* We only turn ON here */ & ((privs_before_set & DIR_PRIVILEGE) = ""b)
	then call fix_kst;
	if ((priv_value & SEG_PRIVILEGE) ^= ""b) & ((privs_before_set & SEG_PRIVILEGE) = ""b)
	then call fix_kst_seg;

/**** The following code would usually audit the event.  However, setting
      /****  privileges temporarily is a normal function of the ring-1 TCB.
      /****  Therefore, we elect to avoid many unnecessary audit messages.
      /****  Besides, there's no associated object or event flag on which to decide
      /****  upon auditing.
      /****	string (event_flags) = ""b;
      /****	event_flags.grant = "1"b;
      /****	event_flags.WHAT? = "1"b;	HAVE to have an event flag here - admin_op is NOT the correct one
      /****	call access_audit_$log_general (ME, level$get (), string (event_flags),
      /****	     access_operations_$system_privilege_modify, "", 0, null (), 0, "^a turned on", name_string);
      / ****/
	return;


reset_admin_privileges:
     entry (old_privileges);

	if ^substr (old_privileges, 36, 1)
	then return;				/* Not anything to reset. */

	substr (old_privileges, 36, 1) = "0"b;
	privs_before_set = string (pds$access_authorization.privileges);
	priv_value = substr (old_privileges, 1, 18);

	apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization);

	different_privs_mask = bool (privs_before_set, old_privileges, "0110"b);
						/* XOR */
	pds$admin_privileges = pds$admin_privileges & ^(^old_privileges & different_privs_mask);
						/* Zero out privs zero'd out by the reset */

	string (apte_auth.privileges), string (pds$access_authorization.privileges) = priv_value;
	call ring_alarm$reset;

	if (priv_value & DIR_PRIVILEGE) ^= (privs_before_set & DIR_PRIVILEGE)
	then call fix_kst;
	if (priv_value & SEG_PRIVILEGE) ^= (privs_before_set & SEG_PRIVILEGE)
	then call fix_kst_seg;

	name_string = "";
	do x = 1 to hbound (system_privilege_names, 1);
	     if substr (privs_before_set, x, 1) ^= substr (priv_value, x, 1)
	     then do;
		     if length (name_string) > 0
		     then name_string = name_string || ",";
		     name_string = name_string || rtrim (system_privilege_names (x).short);
		     if substr (priv_value, x, 1)
		     then name_string = name_string || "(set)";
		     else name_string = name_string || "(reset)";
		end;
	end;


/**** The following code would usually audit the event.  However, setting
      /****  privileges temporarily is a normal function of the ring-1 TCB.
      /****  Therefore, we elect to avoid many unnecessary audit messages.
      /****  Besides, there's no associated object or event flag on which to decide
      /****  upon auditing.
      /****	string (event_flags) = ""b;
      /****	event_flags.grant = "1"b;
      /****	event_flags.WHAT? = "1"b;	HAVE to have an event flag here - admin_op is NOT the correct one
      /****	call access_audit_$log_general (ME, level$get (), string (event_flags),
      /****	     access_operations_$system_privilege_modify, "", 0, null (), 0, "change: ^a", name_string);
      / ****/
	return;

     end set_admin_privileges;

/* format: off */
%page; %include aim_privileges;
%page; %include aim_template;
%page; %include apte;
%page; %include kst;
%page; %include system_privileges;
%page; %include access_audit_eventflags;
/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION


   Message:
   AUDIT (set_privileges): GRANTED modification of system AIM privilege ADDED_INFO

   S:	$access_audit

   T:	$run

   M:	The specified user made a privileged call for modifying the
   process AIM privileges

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end set_privileges;




		    set_sons_lvid.pl1               11/11/89  1132.4r w 11/11/89  0800.6       58203



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


/* format: style4 */
set_sons_lvid: proc (a_dirname, a_ename, a_sons_lvid, a_code);

/*
   Last modified:

   06/03/76 by R. Bratt to call find_$finished
   02/28/82 by J. Bongiovanni to eliminate use of FSDCT
   08/06/83 by E. N. Kittlitz for search_ast$check
   831219   by E. N. Kittlitz for set_pdir_sons_lvid
   07/03/84 by Keith Loepere to use the new dc_find.
   10/15/84 by Keith Loepere for auditing info; also explicit activate of dir.
   12/17/84 by E. Swenson to not violate the locking protocol.
*/

/* Parameters */

dcl  a_code fixed bin (35) parameter;
dcl  a_dirname char (*) parameter;
dcl  a_ename char (*) parameter;
dcl  a_sons_lvid bit (36) parameter;

/* Variables */

dcl  code fixed bin (35);
dcl  dir_locked bit (1) aligned;			/* indicates we have the directory locked */
dcl  dirname char (168);
dcl  ename char (32);
dcl  ignore fixed bin (35);
dcl  1 my_makeknown_info aligned like makeknown_info;
dcl  pdir bit (1) aligned;
dcl  ring fixed bin;
dcl  seg_pvid bit (36) aligned;
dcl  seg_uid bit (36) aligned;
dcl  seg_vtocx fixed bin;
dcl  segnum fixed bin (17);
dcl  segptr ptr;
dcl  set_lvid bit (1);
dcl  sons_lvid bit (36);
dcl  target_locked bit (1) aligned;			/* indicates we have the target directory locked */
dcl  write_lock bit (36) aligned init ("1"b);

/* External */

dcl  error_table_$argerr fixed bin (35) ext;
dcl  error_table_$bad_ring_brackets fixed bin (35) ext;
dcl  error_table_$fulldir fixed bin (35) ext;
dcl  error_table_$notadir fixed bin (35) ext;
dcl  error_table_$segknown fixed bin (35) ext;
dcl  pvt$root_lvid bit (36) aligned ext;

/* Entries */

dcl  level$get entry returns (fixed bin);
dcl  lock$dir_lock_write entry (ptr, fixed bin (35));
dcl  lock$dir_unlock entry (ptr);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  makeknown_ entry (ptr, fixed bin (17), fixed bin, fixed bin (35));
dcl  makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  sum$dirmod entry (ptr);

/* Misc */

dcl  (addr, baseptr, fixed, ptr, null, unspec) builtin;
%page;
	sons_lvid = a_sons_lvid;			/* Copy arg */
	set_lvid = "1"b;
	pdir = "0"b;
	go to join;

set_pdir_sons_lvid: entry (a_dirname, a_ename, a_sons_lvid, a_code);

	sons_lvid = a_sons_lvid;
	set_lvid = "1"b;
	pdir = "1"b;
	go to join;

set_rpv: entry (a_dirname, a_ename, a_code);		/* Force segs to be created on rpv */

	pdir = "0"b;
	set_lvid = "0"b;
join:
	dirname = a_dirname;			/* copy arguments */
	ename = a_ename;

	ring = level$get ();			/* get validation level */

	target_locked = "0"b;
	dir_locked = "0"b;
	segptr = null;

	call dc_find$obj_status_write (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_SONS_LVID_MOD, ep, code); /* get ptr to entry + lock dir for writing */
	if code ^= 0 then go to finale;
	dp = ptr (ep, 0);
	dir_locked = "1"b;

	if ^ep -> entry.dirsw then do;
	     code = error_table_$notadir;
	     go to finale;
	end;

	if ring > fixed (ep -> entry.ex_ring_brackets (1), 3)
	then do;
	     code = error_table_$bad_ring_brackets;	/* ringbrackets must be consistent with validation level */
	     go to finale;
	end;

	seg_uid = entry.uid;

	makeknown_infop = addr (my_makeknown_info);	/* activate target dir */
	unspec (makeknown_info) = "0"b;
	makeknown_info.activate, makeknown_info.dirsw, makeknown_info.allow_write = "1"b;
	makeknown_info.uid = seg_uid;
	makeknown_info.entryp = ep;
	call makeknown_ (makeknown_infop, segnum, (0), code);
	if code ^= 0 then
	     if code ^= error_table_$segknown then go to finale;
	segptr = baseptr (segnum);

	call dc_find$finished (dp, "1"b);		/* unlock so we can lock child */
	dir_locked = "0"b;

	call lock$dir_lock_write (segptr, code);	/* Lock the dir to be modified */
	if code ^= 0 then go to finale;
	target_locked = "1"b;

	call dc_find$obj_status_write (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_SONS_LVID_MOD, ep, code); /* refind and relock parent */
	if code ^= 0 then go to finale;
	dp = ptr (ep, 0);				/* just in case it changed */
	dir_locked = "1"b;				/* remember to unlock it */

	if set_lvid then do;
	     if segptr -> dir.sons_lvid ^= sons_lvid then do; /* If this is really a change */
		if segptr -> dir.seg_count ^= 0 & ^pdir then do;
		     code = error_table_$fulldir;
		     go to finale;
		end;

		if ^pdir then do;
		     segptr -> dir.master_dir = "1"b;
		     segptr -> dir.master_dir_uid = seg_uid;
		     entry.master_dir = "1"b;
		end;
		segptr -> dir.sons_lvid = sons_lvid;	/* Tudo bem. Set the directory header */
		entry.sons_lvid = sons_lvid;		/* Set into branch for the dir too. */
		seg_pvid = entry.pvid;		/* no page fault with dir & ast locked */
		seg_vtocx = entry.vtocx;		/* ... */
		if ^pdir then do;
		     call lock$lock_ast;		/* turn on ast bit */
		     astep = search_ast$check (seg_uid, seg_pvid, seg_vtocx, (0)); /* ignore double-uid error */
		     if astep ^= null () then astep -> aste.master_dir = "1"b;
		     call lock$unlock_ast;
		end;
	     end;
	end;
	else do;					/* Setting RPV */
	     if segptr -> dir.sons_lvid ^= pvt$root_lvid then do;
		code = error_table_$argerr;
		go to finale;
	     end;
	     segptr -> dir.force_rpv = "1"b;
	end;
	call sum$dirmod (dp);			/* Indicate parent dir modified */

finale:	if segptr ^= null then do;
	     if target_locked then
		call lock$dir_unlock (segptr);
	     call makeunknown_ (segnum, "0"b, ("0"b), ignore);
	end;
	if dir_locked then
	     call dc_find$finished (dp, "1"b);
	a_code = code;
	return;

/* format: off */

%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_name;
%page; %include fs_obj_access_codes;
%page; %include makeknown_info;
     end set_sons_lvid;




		    set_stack_ptr.alm               11/11/89  1132.4rew 11/11/89  0800.6        9675



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

" routine to set the value of pds$stacks(cur_val_level) to the specified value 
" required for tasking with separate linkage for each stack 

	entry	set_stack_ptr
set_stack_ptr:
	eppbp	ap|2,*		bp<-->new_stack_pointer
	epbpbp	bp|0,*		bp<-->base of new stack
	lda	<pds>|[validation_level]	a<-current validation level
	als	1		a<-2*cur_val_level (two words for each pointer)
	spribp	<pds>|[stacks],al	place new value into appropriate slot
	short_return
	end




		    shutdown.pl1                    11/11/89  1132.4rew 11/11/89  0800.6       63144



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
shutdown:
     procedure ();

/* Procedure to stop the system in preparation for File System Shutdown.
   This can be called only from the Initializer. After setting CPU
   required to the bootload CPU, it stops all CPUs and disables traffic
   control. It calls shutdown_file_system, switching stacks along the
   way to inzr_stk0.

   This is called only during normal shutdown.  During emergency shutdown,
   shutdown_file_system is called directly.

   For the new Storage System, Bernard Greenberg, 10/20/75
   For demountable volumes, BSG 03/26/76
   For new flags in flagbox, 9/30/76 by Noel I. Morris
   For shutdown with downed drives, BSG 02/26/77
   For shutdown which doesn't give up, W. Olin Sibert, 05/18/81
   For set_procs_required, J. Bongiovanni, October 1981
   To remove Page Multilevel, C. Hornig, December 1981.
   To remove File System shutdown, J. Bongiovanni, March 1982
   To shutdown scavenger, J. Bongiovanni, September 1982
   To call stop_cpu$shutdown instead of stop_cpu, Chris Jones, April 1984
*/


/****^  HISTORY COMMENTS:
  1) change(86-09-23,Beattie), approve(86-08-11,MCR7517),
     audit(86-10-23,Fawcett), install(86-11-03,MR12.0-1206):
     No BOS support for MR12.
                                                   END HISTORY COMMENTS */


dcl	pds$processid	   bit (36) aligned external;

dcl	condition_	   entry (char (*), entry);
dcl	disk_emergency$test_all_drives
			   entry;
dcl	scavenger$shutdown	   entry;
dcl	set_procs_required	   entry (bit (8) aligned, fixed bin (35));
dcl	stop_cpu$shutdown	   ext entry (fixed bin (2), fixed bin (35));
dcl	switch_shutdown_file_system
			   entry;
dcl	syserr		   entry options (variable);
dcl	syserr$error_code	   entry options (variable);
dcl	tc_shutdown	   ext entry;

dcl	tc_data$initializer_id bit (36) aligned external;

dcl	code		   fixed bin (35);
dcl	i		   fixed bin (2);
dcl	cpu_mask		   bit (8) aligned;

dcl	LETTERS		   char (8) internal static options (constant) init ("ABCDEFGH");
dcl	my_name		   char (8) internal static options (constant) init ("shutdown");

dcl	(null, stackbaseptr, substr)
			   builtin;

/**/

	if pds$processid ^= tc_data$initializer_id then
	     return;				/* Only initializer can perform shutdown (trad.) */


	stackbaseptr () -> stack_header.stack_begin_ptr -> stack_frame.prev_sp = null ();
						/* Guarantee that we shall never leave ring zero again */

	call condition_ ("any_other", shutdown_failed);	/* Don't let anything untoward happen, either */

/* Now stop all CPU's other than the bootload one we are returning to */

	cpu_mask = "0"b;
	substr (cpu_mask, scs$bos_processor_tag + 1, 1) = "1"b;
	call set_procs_required (cpu_mask, code);
	if code ^= 0 then				/* Couldn't run on bootload CPU */
	     call syserr$error_code (CRASH, code, "^a: Cannot run on CPU ^a (bootload CPU). Dump and try ESD.", my_name,
		substr (LETTERS, scs$bos_processor_tag + 1, 1));

	do i = 0 to 7;
	     if i ^= scs$bos_processor_tag then do;
		if scs$processor_data (i).online then do;
		     call stop_cpu$shutdown (i, code);
		     if code ^= 0 then
			call syserr (ANNOUNCE, "^a: Could not stop CPU ^a.", my_name, substr (LETTERS, i + 1, 1));
		end;
	     end;
	end;

/* Determine downed drives. Done in wired_shutdown in ESD case */

	call disk_emergency$test_all_drives;

/* Now stop other processes */

	call tc_shutdown;

/*  After traffic control is shut down, reset any scavenges in progress  */

	call scavenger$shutdown;

/* Switch stacks to inzr_stk0 and shutdown File System */

	call switch_shutdown_file_system;

/**/

shutdown_failed:
     proc (a_mcptr, a_condition, a_coptr, a_infoptr, a_continue) options (non_quick);

dcl	a_mcptr		   pointer parameter;
dcl	a_condition	   char (*) parameter;
dcl	a_coptr		   pointer parameter;
dcl	a_infoptr		   pointer parameter;
dcl	a_continue	   bit (1) aligned parameter;

/* This procedure is called if any signallable faults occur in shutdown,
   and simply crashes the system, in the hope that an ESD will be more
   successful. */

	do while ("1"b);
	     call syserr (CRASH,
		"^a: Condition ^a signalled during shutdown. Normal shutdown failed. Get a dump, and try an ESD.",
		my_name, a_condition);
	end;

     end shutdown_failed;

%page;
%include scs;
%page;
%include stack_frame;
%page;
%include stack_header;
%page;
%include syserr_constants;

/**/

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   shutdown: Could not stop CPU TAG.

   S: $info

   T: System shutdown.

   M: Shutdown stops all but the bootload processor. The CPU whose
   tag is TAG could not be stopped.

   A: $note
   If shutdown fails, put all CPU's other than the
   bootload processor in step, return to BCE manually, and
   attempt an ESD.

   Message:
   shutdown: Condition CCCC signalled during shutdown. Normal shutdown
   failed. Get a dump, and try an ESD.

   S: $crash

   T: System shutdown

   M: During the attempt to shut down the system, an unexpected condition
   has been signalled. This may result from hardware problems, or a logic
   error in the supervisor. The system crashes and returns to BCE, whereupon
   an ESD should be attempted in order to finish flushing Multics
   information from main memory. Because of the difference in implementation
   between normal shutdown and ESD, it is possible that ESD will not
   encounter the same problem, and instead be successful.

   Message:
   shutdown: Cannot run on CPU X (bootload CPU). Dump and try ESD. ERRORMESSAGE

   S: $crash

   T: System shutdown

   M: During an attempt to shut down the system, the system could not run
   on the bootload CPU. This problem may be due to hardware or software
   problems.  The system will attempt to crash, which it may not complete.

   A: If the system does not complete its attempt to crash, it should
   be crashed manually. It may be necessary to change the bootload CPU
   manually. This can be done by putting all CPUs into STEP mode, manually
   assigning an interrupt mask to the new bootload CPU from the bootload SCU
   maintenance panel, taking only the new bootload CPU out of STEP mode, and
   doing an EXECUTE SWITCHES on that CPU.  Once the system has crashed
   successfully, an ESD should be attempted.  This will most likely succeed.

   END MESSAGE DOCUMENTATION */

     end;




		    stack_oob_handler.pl1           11/11/89  1132.4r   11/11/89  0800.6       51012



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



/* format: style2 */

stack_oob_handler:
     procedure (mcptr);

/* This procedure is called by the fim when an out_of_bounds fault
   has occurred on the stack.  It either extends the stack by  48K
   and returns to the fim  to signal storage or it terminates the process. */
/* coded by M. Weaver 5/29/74 */
/* re-coded by Mike Grady 8/79 to improve algorithim */
/* re-re-coded by Benson I. Margulies 1/82 to further improve algorithm */

/* Automatic */

	dcl     mcptr		 ptr;
	dcl     max_lng		 fixed bin (19);
	dcl     ca		 fixed bin (19);
	dcl     code		 fixed bin (35);
	dcl     e_code		 fixed bin (35);
	dcl     extend		 bit (1) aligned;
	dcl     extend_to		 fixed bin (19);
	dcl     signal_storage	 bit (1) aligned;
	dcl     signal_oob		 bit (1) aligned;

/* Constants */

	dcl     INCREMENT		 fixed bin int static init (49152) options (constant);
						/* 48K */

/* Externals */

	dcl     sys_info$max_seg_size	 ext fixed bin (19);
	dcl     error_table_$stack_overflow
				 fixed bin (35) ext;
	dcl     error_table_$oob_stack fixed bin (35) ext;
	dcl     error_table_$oob_stack_ref
				 fixed bin (35) ext;

/* Builtins */

	dcl     (addr, binary, bit, min, pointer, rel)
				 builtin;

/* Entries */

	dcl     status_$get_max_length_ptr
				 entry (ptr, fixed bin (19), fixed bin (35));
	dcl     set$max_length_ptr	 entry (ptr, fixed bin (19), fixed bin (35));
	dcl     terminate_proc	 entry (fixed bin (35));
	dcl     boundfault		 entry (ptr);

%page;
%include stack_header;
%page;
%include mc;
%page;
%include static_handlers;


	mcp = mcptr;
	sb = pointer (mc.prs (6), 0);			/* get ptr to stack at time of fault */
	call status_$get_max_length_ptr (sb, max_lng, code);
						/* get current max length  of stack */
	if code ^= 0
	then /* can't imagine this would ever happen */
	     call term_proc;

	e_code = 0;				/* code will be reset if signalling proves appropriate */

	scup = addr (mc.scu (0));			/* get addr of SCU data */
	ca = bin (scu.ca, 18);			/* pull out computed address */
	signal_storage = "0"b;
	signal_oob = "0"b;
	extend = "0"b;

/* If the reference is beyond the end of the pl1 stack, then */
/* extending is unneccessary. If, by coincidence, the end_ptr */
/* is also beyond the end, we will take another fault when the error */
/* handlers push, and then entend. The 64 words is slop for programs */
/* that authentically stash data off of the end. */


	if ca < max_lng
	then do;
		call boundfault (mcptr);		/* ordinary aste problem */
		e_code = mcptr -> mc.errcode;		/* preserve any code from boundfault */
		if e_code ^= 0
		then signal_oob = "1"b;
	     end;

	else if ca > (binrel (stack_header.stack_end_ptr) + 64)
						/* past the end */
	then do;
		signal_oob = "1"b;			/* no need to extend */
		e_code = error_table_$oob_stack_ref;
	     end;

	else if ca > (240 * 1024)			/* leave space for pl1 snap and all that */
	then do;
		signal_storage = "1"b;
		extend = "1"b;
		e_code = error_table_$stack_overflow;
		extend_to = sys_info$max_seg_size;	/* go for it */
	     end;

	else do;					/* extend silently, the max length is just < stack_end, and there is plenty of space */
						/** code stays zero */
		extend = "1"b;
		extend_to = binrel (stack_header.stack_end_ptr) + 64;
	     end;

/* Now do the extension if it was mandated. */


	if extend & (extend_to > (max_lng - 1))		/* needed */
	then do;
		if max_lng = sys_info$max_seg_size	/* see if we have extended all the way already */
		then call term_proc;		/* noplace to go */

		extend_to = min (extend_to, sys_info$max_seg_size);

		do while (max_lng <= extend_to);	/* move upto desired size */
		     max_lng = max_lng + INCREMENT;
		end;

		if max_lng > (240 * 1024)
		then do;				/* equivalent to storage condition case */
			signal_storage = "1"b;
			e_code = error_table_$stack_overflow;
			max_lng = sys_info$max_seg_size;
		     end;

		call set$max_length_ptr (sb, max_lng, code);
						/* extend the stack */
		if code ^= 0
		then call term_proc;

/* If we extended the stack, then we may need a bigger aste. So we might */
/* as well call boundfault to do that, instead of taking another fault. */

		call boundfault (mcptr);
		if mcptr -> mc.errcode ^= 0
		then do;
			signal_oob = "1"b;
			e_code = mcptr -> mc.errcode;
		     end;
	     end;

/* if mc.errcode is zero, the fim will restart the fault. So for the */
/* silent extension, it will be zero. */

	mc.errcode = e_code;
	if signal_oob
	then do;
		mc.fim_temp.resignal = "1"b;
		mc.fim_temp.fcode = bit (out_of_bounds_sct_index, 17);
	     end;
	else if signal_storage
	then do;
		mc.fim_temp.resignal = "1"b;
		mc.fim_temp.fcode = bit (storage_sct_index, 17);
	     end;

	return;

term_proc:
     procedure;

	call terminate_proc (error_table_$oob_stack);	/* terminate the process */

     end term_proc;

binrel:
     procedure (ptr_to_rel) returns (fixed bin (18) unsigned);

	dcl     ptr_to_rel		 pointer;

	return (binary (rel (ptr_to_rel), 18));
     end binrel;

     end stack_oob_handler;




		    star_.pl1                       11/11/89  1132.4rew 11/11/89  0800.0      196290



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


/* Modified June 1984 by Keith Loepere to use the new dc_find. */
/* Modified by C. Hornig to no longer use system_free_seg */
/* Modified May 1981 by C. Hornig to compress link pathnames */
/* Modified Jul 79 by Greenberg for another oversize stack problem. */
/* Modified Oct 1978 by B. Greenberg to fix oversize stack problem. */
/* Modified May 1978 by T. Casey to fix bug in list_dir entry point when returning link authors */
/* Modified 04/78 by G. Palter to fix bug when asking for links only */
/* Modified 07/77 by THVV for bad_dir_ check */
/* modified 06/77 by THVV to combine star and dc_pack */
/* modified 04/77 by THVV to use system_free_seg better */
/* modified 05/31/76 by R. Bratt to call find_$finished */
/* modified 04/20/76 by R. Bratt to return partial  info if not mounted */
/* modified Dec 75 by REM and TAC to add dir_list_ entry for NSS performance */
/* Modified 4/75 for NSS by THVV */
/* modified by Kobziar on 11-12-73 to drop setting of append bit on segs  */
/* modified by Ackerman-Lewis on 12-03-74 to return correct count of names matching star name  */
/* modified by Kobziar on 741203 to call new entry in access_mode */
/* Modified 750117 by PG to eliminate $no_acc_ck entry & clean up program */


/****^  HISTORY COMMENTS:
  1) change(86-08-18,JSLove), approve(86-08-18,MCR7518),
     audit(86-09-29,Parisek), install(86-10-02,MR12.0-1174):
     Changed to call check_star_name_ with control mask CHECK_STAR_IGNORE_ALL
     rather than check_star_name_$entry. This bypasses syntactic checks which
     ring zero is not responsible for enforcing.  Also changed to use named
     constants defined in check_star_name.incl.pl1.
  2) change(87-06-01,GDixon), approve(87-07-13,MCR7740),
     audit(87-07-24,Hartogs), install(87-08-04,MR12.1-1055):
      A) Modified to properly declare check_star_name_.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */

star_:
     procedure (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code);

dcl  a_areap ptr parameter;
dcl  a_bcount fixed bin parameter;
dcl  a_bptr ptr parameter;				/* for dc_pack */
dcl  a_code fixed bin (35) parameter;
dcl  a_dirname char (*) parameter;
dcl  a_ecount fixed bin parameter;
dcl  a_eptr ptr parameter;
dcl  a_lcount fixed bin parameter;
dcl  a_lptr ptr parameter;				/* for dc_pack */
dcl  a_nptr ptr parameter;
dcl  a_pbl fixed bin (3) parameter;
dcl  a_star_name char (*) parameter;
dcl  dcpack_area area parameter;

dcl  branch_count fixed bin;
dcl  call_find_finish bit (1) aligned;
dcl  code fixed bin (35);
dcl  dc_pack bit (1) aligned;
dcl  dirname char (168);
dcl  eptr ptr;
dcl  fast_listing bit (1) aligned;
dcl  just_return_totals bit (1) aligned;
dcl  locked bit (1) aligned;
dcl  n_branches_match fixed bin;
dcl  n_links_match fixed bin;
dcl  need_vtoc bit (1) aligned;
dcl  nptr ptr;
dcl  number_of_entries fixed bin;
dcl  pbl fixed bin (3);
dcl  priv bit (1) aligned;
dcl  return_link_path bit (1) aligned;
dcl  saved_dir_change_pclock fixed bin (35);
dcl  star_list_entry bit (1) aligned;
dcl  star_name char (32);
dcl  starname_type fixed bin (2);
dcl  u_areap ptr;
dcl  want_branches bit (1) aligned;
dcl  want_links bit (1) aligned;
dcl  vtoc_available bit (1) aligned;

dcl  error_table_$argerr fixed bin (35) external;
dcl  error_table_$nomatch fixed bin (35) external;
dcl  error_table_$notalloc fixed bin (35) external;

dcl  acc_name_$get entry (ptr, ptr);
dcl  access_mode$effective entry (pointer, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  alloc_ external entry (fixed bin, pointer, pointer);
dcl  check_star_name_ entry (char(*), bit(36), fixed bin(2), fixed bin(35));
dcl  freen_ entry (pointer);
dcl  hash$search entry (ptr, ptr, ptr, fixed bin (35));
dcl  lock$dir_lock_read entry (ptr, fixed bin (35));
dcl  lock$dir_unlock entry (ptr);
dcl  match_star_name_ entry (char(*) aligned, char(*), fixed bin(35));
dcl  mountedp entry (bit (36) aligned) returns (fixed bin (35));
dcl  vtoc_attributes$get_info entry (bit (36) aligned, bit (36), fixed bin, ptr, fixed bin (35));

dcl  (addr, addrel, binary, bit, divide, max, mod, null, rel, size, substr, unspec) builtin;

dcl  (area, bad_dir_, seg_fault_error) condition;
%page;
/*
   star_:
   procedure (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code);
*/

	dc_pack, priv, fast_listing, star_list_entry = "0"b;
	go to common;

star_priv:
     entry (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code);

	dc_pack, fast_listing, star_list_entry = "0"b;
	priv = "1"b;
	go to common;

list_dir:
     entry (a_dirname, dcpack_area, a_bptr, a_bcount, a_lptr, a_lcount, a_code);

	priv, fast_listing, star_list_entry = "0"b;
	dc_pack = "1"b;
	go to common;

list_dir_fast:
     entry (a_dirname, dcpack_area, a_bptr, a_bcount, a_lptr, a_lcount, a_code);

	priv, star_list_entry = "0"b;
	dc_pack, fast_listing = "1"b;
	go to common;

dir_list_:
     entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code);

	dc_pack, priv = "0"b;
	fast_listing, star_list_entry = "1"b;
	go to common;

list_:
     entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code);

	dc_pack, priv, fast_listing = "0"b;
	star_list_entry = "1"b;
	go to common;

list_priv:
     entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code);

	dc_pack, fast_listing = "0"b;
	priv, star_list_entry = "1"b;
	go to common;
%page;
common:
	code = 0;
	want_branches, want_links, return_link_path, need_vtoc = "0"b;
	call_find_finish, locked = "0"b;
	dirname = a_dirname;

/*	      Make sure we always return consistent values.		*/

	n_branches_match, n_links_match = 0;
	dc_branch_arrayp, dc_link_arrayp, eptr, nptr = null ();
	code = 0;

/* Analyze starname type */

	if dc_pack then do;
	     starname_type = STAR_TYPE_MATCHES_EVERYTHING;
	     want_branches, want_links = "1"b;
	     u_areap = addr (dcpack_area);
	     end;
	else do;
	     star_name = a_star_name;
	     u_areap = a_areap;
	     pbl = a_pbl;
	     if pbl > 3 then do;			/* pathname desired */
		return_link_path = "1"b;
		pbl = mod (pbl, 4);			/* trim the pathname option */
		end;

	     if /* case */ pbl = 1 then want_links = "1"b;
	     else if pbl = 2 then want_branches = "1"b;
	     else if pbl = 3 then want_branches, want_links = "1"b;
	     else do;
		code = error_table_$argerr;
		go to finish;
		end;

	     call check_star_name_ (star_name, CHECK_STAR_IGNORE_ALL, starname_type, code);
	     if code ^= 0 then go to finish;
	     end;

RESCAN_DIR:
	eptr, nptr, dc_branch_arrayp, dc_link_arrayp = null ();
	call_find_finish, locked = "0"b;

	if priv
	then call dc_find$dir_read_priv (dirname, dp, code);
	else call dc_find$dir_read (dirname, dp, code);
	if code ^= 0 then go to finish;

	call_find_finish, locked = "1"b;

	if starname_type = STAR_TYPE_USE_PL1_COMPARE	/* Special case names with no * or ? */
	then branch_count, number_of_entries = 1;	/* .. since at most one item can match */
	else do;
	     branch_count = dir.seg_count + dir.dir_count;
	     number_of_entries = branch_count + dir.lcount;
	     end;


	if u_areap = null () then do;			/* Just wants totals */
	     if starname_type = STAR_TYPE_MATCHES_EVERYTHING then do;
		if want_branches then n_branches_match = branch_count;
		if want_links then n_links_match = dir.lcount;
		go to finish;
		end;
	     else just_return_totals = "1"b;		/* No vtoc needed, but must scan thru dir */
	     end;
	else just_return_totals = "0"b;

	if ^fast_listing
	then					/* Never need VTOC for fast list */
	     if dc_pack | (want_branches & star_list_entry & ^just_return_totals) then do;
		need_vtoc = "1"b;			/* See if need any info from VTOC */
		code = mountedp (dir.sons_lvid);	/* volume may not be mounted */
		vtoc_available = (code = 0);		/* sorry, force fast list, N.B. code must stay set */
		end;

	call SCAN_DIR;				/* Internal proc does the two scans */
%page;
finish:
	if call_find_finish then call dc_find$finished (dp, locked);

	if star_list_entry | dc_pack then do;		/* Copy values back to caller args */
	     a_bcount = n_branches_match;
	     a_lcount = n_links_match;
	     end;
	else do;
	     a_ecount = n_branches_match + n_links_match;
	     end;

	if dc_pack then do;
	     a_bptr = dc_branch_arrayp;
	     a_lptr = dc_link_arrayp;
	     end;
	else do;
	     a_eptr = eptr;
	     a_nptr = nptr;
	     end;

	a_code = code;
	return;
%page;
SCAN_DIR:
     procedure;

dcl  alloc_size fixed bin;
dcl  ec fixed bin (35);
dcl  entry_list (number_of_entries) uns fixed bin (18);
dcl  entry_rel bit (18);
dcl  link_path_blocks fixed bin;
dcl  n_entries_in_list fixed bin;
dcl  n_names_match fixed bin;
dcl  name_rel bit (18);
dcl  total_names_seen fixed bin;

dcl  u_narray (n_names_match + link_path_blocks) char (32) aligned based (nptr);
dcl  user_area area based (u_areap);


	n_branches_match, n_links_match, total_names_seen = 0;
	n_entries_in_list, n_names_match, link_path_blocks = 0;

	call MAKE_ENTRY_LIST;

	if n_links_match + n_branches_match = 0 then do;
	     if ^dc_pack then code = error_table_$nomatch;
	     go to done;
	     end;

	if just_return_totals then go to done;		/* If all we want is counts, we got them */

/* Allocate room in user area for copying it out */
/* We have to unlock the dir first */

	saved_dir_change_pclock = dir.change_pclock;

	call lock$dir_unlock (dp);
	locked = "0"b;

	on area go to set_no_alloc;

	if dc_pack then do;
	     dc_n_branches = max (branch_count, 1);
	     allocate dcpack_branch_array in (user_area);

	     dc_n_links = max (n_links_match, 1);
	     allocate dcpack_link_array in (user_area);
	     allocate dcpack_grand_link_pathname_array in (user_area);
	     dc_grand_n_names = max (total_names_seen, 1);
	     allocate dcpack_grand_name_array in (user_area);

	     end;

	else do;
	     if n_names_match + link_path_blocks > 0
	     then allocate u_narray in (user_area) set (nptr);
	     else nptr = null;

	     if star_list_entry
	     then alloc_size = size (star_list_link) * n_links_match + size (star_list_branch) * n_branches_match;
	     else alloc_size = n_links_match + n_branches_match;
						/* size (entries) = 1 */
	     if alloc_size = 0
	     then eptr = null;
	     else do;
		on area go to free_nptr;
		call alloc_ (alloc_size, u_areap, eptr);/* entries */
		if eptr = null then go to free_nptr;
		end;
	     end;

/* Now relock the dir */

	on seg_fault_error signal bad_dir_;
	call lock$dir_lock_read (dp, code);
	if code ^= 0 then go to finish;
	locked = "1"b;
	revert seg_fault_error;

	if dir.change_pclock ^= saved_dir_change_pclock then do;
	     if dc_pack then do;
		free dcpack_branch_array;
		free dcpack_link_array;
		free dcpack_grand_name_array;
		free dcpack_grand_link_pathname_array;
		end;
	     else do;
		free u_narray;
		if eptr ^= null () then call freen_ (eptr);
		end;
	     call dc_find$finished (dp, locked);
	     go to RESCAN_DIR;
	     end;

	call SORT_ENTRY_LIST;

	call RETURN_INFO;

	goto done;


free_nptr:
	free u_narray in (user_area);
set_no_alloc:
	code = error_table_$notalloc;

done:
	return;					/* normal exit from SCAN_DIR */
%page;
MAKE_ENTRY_LIST:
	procedure;

dcl  dir_nwords fixed bin (18);
dcl  entry_names_match_star fixed bin;
dcl  n_entries_seen fixed bin;
dcl  n_names_seen fixed bin;


	     dir_nwords = addrel (dp, dir.arearp) -> area.lu;

	     if starname_type ^= STAR_TYPE_USE_PL1_COMPARE then do;
		n_entries_seen = 0;			/* if there may be several entries */
		do entry_rel = dir.entryfrp repeat (entry.efrp) while (entry_rel ^= ""b);
		     ep = addrel (dp, entry_rel);
		     n_entries_seen = n_entries_seen + 1;
		     if (n_entries_seen > number_of_entries) | (binary (entry_rel, 18) > dir_nwords)
		     then signal bad_dir_;		/* check for loop */


		     call CHECK_VALID_ENTRY;

		     if (entry.bs & want_branches) | (^entry.bs & want_links) then do;
						/* Type is correct */
			entry_names_match_star = 0;	/* Does a name match? */
			n_names_seen = 0;
			do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b);
			     np = addrel (dp, name_rel);
			     n_names_seen = n_names_seen + 1;
			     if (n_names_seen > entry.nnames)
						/* check for loop */
				| (binary (name_rel, 18) > dir_nwords) | (np -> names.owner ^= entry.uid)
				| (np -> names.type ^= NAME_TYPE) | (np -> names.entry_rp ^= entry_rel)
			     then signal bad_dir_;


			     if NAME_MATCHES () then do;
				entry_names_match_star = entry_names_match_star + 1;
						/* This name will be listed */
				n_names_match = n_names_match + 1;
				end;
			end;

			if entry_names_match_star > 0 then call TAKE_ENTRY;
			end;
		end;				/* end of loop on ep */
		end;

	     else do;				/* STAR_TYPE_USE_PL1_COMPARE:  Return one or none */
		call hash$search (dp, addr (star_name), ep, ec);
		if ec = 0 then do;			/* Special case for efficiency. use hash table */
		     call CHECK_VALID_ENTRY;		/* Found the entry */
		     n_names_match = 1;		/* Found desired name */
		     call TAKE_ENTRY;
		     end;
		end;

	     return;

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

TAKE_ENTRY:
	     procedure;

		n_entries_in_list = n_entries_in_list + 1;
		entry_list (n_entries_in_list) = binary (rel (ep), 18);
		total_names_seen = total_names_seen + n_names_seen;
		if ^entry.bs then do;		/* link */
		     n_links_match = n_links_match + 1;
		     if return_link_path
		     then link_path_blocks = link_path_blocks + divide (link.pathname_size + 31, 32, 17, 0);
		     end;
		else n_branches_match = n_branches_match + 1;

		return;

	     end TAKE_ENTRY;

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

CHECK_VALID_ENTRY:
	     procedure;

		if entry.bs
		then if (entry.owner ^= dir.uid) | ((entry.type ^= SEG_TYPE) & (entry.type ^= DIR_TYPE))
		     then signal bad_dir_;
		     else ;
		else if (link.owner ^= dir.uid) | (link.type ^= LINK_TYPE) then signal bad_dir_;

		return;

	     end CHECK_VALID_ENTRY;
%page;
%include dir_allocation_area;

	end MAKE_ENTRY_LIST;
%page;
SORT_ENTRY_LIST:
	procedure ();

/* Someday, this should sort the entry list by rel(ep). */

	     return;

	end SORT_ENTRY_LIST;
%page;
RETURN_INFO:
	procedure;

dcl  code fixed bin (35);
dcl  earrayx fixed bin;
dcl  exmode bit (36) aligned;
dcl  grand_larrayx fixed bin;
dcl  grand_narrayx fixed bin;
dcl  larrayx fixed bin;
dcl  link_author char (32) aligned;
dcl  mode bit (36) aligned;
dcl  narrayx fixed bin;
dcl  ret_mode bit (5) aligned;
dcl  1 sci aligned like based_sc_info;
dcl  tx fixed bin;
dcl  vtoc_code fixed bin (35);

	     narrayx, larrayx, earrayx = 1;
	     grand_narrayx, grand_larrayx = 1;

	     do tx = 1 to n_entries_in_list;
		ep = addrel (dp, entry_list (tx));

		if entry.bs then do;
		     call access_mode$effective (ep, mode, exmode, code);
		     if entry.dirsw
		     then ret_mode = "0"b || substr (exmode, 1, 1) || "1"b || substr (exmode, 2, 2);
		     else ret_mode = "0"b || substr (mode, 1, 4);

		     if need_vtoc then do;
			unspec (sci) = ""b;		/* clear out old junk */
			vtoc_code = code;
			if vtoc_available then do;
			     call vtoc_attributes$get_info (entry.uid, entry.pvid, (entry.vtocx), addr (sci),
				vtoc_code);
			     if ^dc_pack & (vtoc_code ^= 0) & (code = 0) then code = vtoc_code;
			     end;
			end;
		     end;
		else call acc_name_$get (addr (link.author), addr (link_author));

		if dc_pack
		then call RETURN_DCPACK_INFO;
		else call RETURN_STAR_INFO;
	     end;

	     return;
%page;

RETURN_DCPACK_INFO:
	     procedure;

declare  first_name_relp bit (18);

/* in this program earrayx goes up by 1 for each branch.
   larrayx goes up by 1 for each link, and narrayx by 1 for each name on an entry (resets each time) */

		if entry.bs then do;
		     dc_branchp = addr (dcpack_branch_array (earrayx));
		     earrayx = earrayx + 1;
		     unspec (dcpack_branch) = ""b;
		     dcpack_branch.vtoc_error = (vtoc_code ^= 0);
		     dcpack_branch.uid = entry.uid;
		     dcpack_branch.dtu = sci.dtu;
		     dcpack_branch.dtm = sci.dtm;
		     dcpack_branch.dtd = entry.dtd;
		     dcpack_branch.dtem = entry.dtem;
		     dcpack_branch.dirsw = entry.dirsw;
		     dcpack_branch.optsw = entry.copysw;
		     dcpack_branch.bc = bit (entry.bc, 24);
		     dcpack_branch.cl = bit (divide (sci.csl, 1024, 9, 0), 9);
		     dcpack_branch.ml = bit (divide (sci.msl, 1024, 9, 0), 9);
		     dcpack_branch.nnames = entry.nnames;
		     dcpack_branch.mode = ret_mode;

		     if entry.dirsw then do;
			dcpack_branch.rb1 = (3)"0"b || entry.ex_ring_brackets (1);
			dcpack_branch.rb2 = (3)"0"b || entry.ex_ring_brackets (2);
			dcpack_branch.rb3 = dcpack_branch.rb2;
			end;
		     else do;
			dcpack_branch.rb1 = (3)"0"b || entry.ring_brackets (1);
			dcpack_branch.rb2 = (3)"0"b || entry.ring_brackets (2);
			dcpack_branch.rb3 = (3)"0"b || entry.ring_brackets (3);
			end;
		     end;

		else do;				/* link */

		     dc_linkp = addr (dcpack_link_array (larrayx));
		     larrayx = larrayx + 1;
		     unspec (dcpack_link) = ""b;
		     dcpack_link.uid = link.uid;
		     dcpack_link.dtu = ""b;
		     dcpack_link.dtem = link.dtem;
		     dcpack_link.dtd = link.dtd;
		     dcpack_link.nnames = link.nnames;
		     dc_pnp = null ();
		     if grand_larrayx > dc_n_links then signal bad_dir_;
		     dc_pnp = addr (dcpack_grand_link_pathname_array (grand_larrayx));
		     grand_larrayx = grand_larrayx + 1;
		     dcpack_path.size = link.pathname_size;
		     dcpack_path.name = link.pathname;
		     dcpack_path.author = link_author;
		     dcpack_link.pathnamerp = rel (dc_pnp);

		     end;				/* links */

		first_name_relp = rel (addr (dcpack_grand_name_array (grand_narrayx)));

		do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b);

		     if grand_narrayx > dc_grand_n_names then signal bad_dir_;
		     dc_namep = addr (dcpack_grand_name_array (grand_narrayx));
		     grand_narrayx = grand_narrayx + 1;
		     np = addrel (dp, name_rel);
		     dcpack_ename.name = np -> names.name;
		     dcpack_ename.size = 32;
		end;

		if entry.bs
		then dcpack_branch.namerp = first_name_relp;
		else dcpack_link.namerp = first_name_relp;


		return;

	     end RETURN_DCPACK_INFO;
%page;
RETURN_STAR_INFO:
	     procedure;

dcl  full_pathname char (168) aligned based;

/* In this program, earrayx is in WORDS not entries. It goes up a different amount
   depending on whether(a) star_ was called, (b) star_list_ was called and it's a branch,
   (c) star_list_ was called and it's a link. Also, narrayx goes up by 1 for each name
   and 6 for each link path. */

		esp = addrel (eptr, earrayx - 1);
		star_entry.nindex = narrayx;
		star_entry.nnames = 0;
		if entry.bs
		then if entry.dirsw
		     then star_entry.type = "10"b;	/* dir */
		     else star_entry.type = "01"b;	/* seg */
		else star_entry.type = "00"b;		/* link */

		do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b);
		     np = addrel (dp, name_rel);
		     if NAME_MATCHES () then do;
			u_narray (narrayx) = np -> names.name;
			narrayx = narrayx + 1;
			star_entry.nnames = star_entry.nnames + 1;
			end;
		end;

		if ^star_list_entry
		then earrayx = earrayx + size (star_entry);
		else do;
		     if entry.bs then do;		/* branch */
			earrayx = earrayx + size (star_list_branch);
			if entry.dirsw then star_list_branch.master_dir = entry.master_dir;
			star_list_branch.mode = ret_mode;

			if need_vtoc then do;
			     star_list_branch.dtm_or_dtem = sci.dtm;
			     star_list_branch.dtu = sci.dtu;
			     star_list_branch.rec_or_bc = sci.records;
			     end;
			else do;			/* didn't access vtoce */
			     star_list_branch.dtu = ""b;
			     star_list_branch.dtm_or_dtem = entry.dtem;
			     star_list_branch.rec_or_bc = entry.bc;
			     end;
			end;

		     else do;			/* link */
			earrayx = earrayx + size (star_list_link);
			if return_link_path then do;	/* copy path name */
			     star_list_link.pln = link.pathname_size;
			     substr (addr (u_narray (narrayx)) -> full_pathname, 1, link.pathname_size) =
				link.pathname;
			     star_list_link.pindex = narrayx;
			     narrayx = narrayx + divide (link.pathname_size + 31, 32, 17, 0);
			     end;
			else do;
			     star_list_link.pln = 0;
			     star_list_link.pindex = 0;
			     end;

			star_list_link.dtm = link.dtem;
			star_list_link.dtd = link.dtd;
			end;
		     end;

	     end RETURN_STAR_INFO;

	end RETURN_INFO;
%page;
NAME_MATCHES:
	procedure returns (bit (1) aligned);

dcl  code fixed bin (35);

	     if starname_type = STAR_TYPE_MATCHES_EVERYTHING then return ("1"b);
	     call match_star_name_ (np -> names.name, star_name, code);
	     return (code = 0);

	end NAME_MATCHES;

     end SCAN_DIR;
%page;
%include check_star_name;
%page;
%include dc_find_dcls;
%page;
%include dcpack_info;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include dir_link;
%page;
%include dir_name;
%page;
%include fs_types;
%page;
%include quota_cell;
%page;
%include sc_info;
%page;
%include star_info;
     end star_;




		    status_.pl1                     11/11/89  1132.4rew 11/11/89  0800.0      379908



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



/* format: style2 */

status_:
     proc (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code);

/* STATUS returns the contents of a specified entry
   in a directory.
   dir_name = path name of directory (input)
   entry = name of the entry to be listed (input)
   chase = a switch when =1 means list the branch pointed to by "entry" (input)
   type = indicates whether "entry" (output) is a non-dir branch (=1),
   dir branch (=2), or a link (=0)
   return_struc_ptr = the pointer to the structure in which items from "entry" will be returned
   status_area_ptr = pointer to an area in which the names will be returned
   if it is null, no names will be returned. */


/* ************************************************************************** */
/* ************************************************************************** */
/* ************************************************************************** */
/*
   *
   *    NN    NN   OOOOOO   TTTTTTTT  EEEEEEEE
   *    NNN   NN  OO    OO     TT     EE
   *    NN N  NN  OO    OO     TT     EE
   *    NN NN NN  OO    OO     TT     EEEEEEE
   *    NN  N NN  OO    OO     TT     EE
   *    NN  NNNN  OO    OO     TT     EE
   *    NN   NNN  OO    OO     TT     EE
   *    NN    NN   OOOOOO      TT     EEEEEEEE
   *
   *    The variable status_call MUST be set in any entry to this program
   *    before any calls to fatal_error, or the establishment of any
   *    cleanup handler. It should be set to zero for attributes, and
   *    other values for status info. Only status_ and status_long_
   *    should set values other than 0 and 3.
   *
   /**************************************************************************** */
/* *************************************************************************** */
/* *************************************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-10-31,Lippard), approve(86-06-02,MCR7427),
     audit(86-06-17,Farley), install(86-06-17,MR12.0-1077):
      Modified to zero out status_branch structures before calling dc_find
      so that status_link.pathname_length is zeroed when user doesn't have
      status permission on the containing directory.
  2) change(86-05-20,Lippard), approve(86-06-02,MCR7427),
     audit(86-06-17,Farley), install(86-06-17,MR12.0-1077):
      Modified to not set status_branch.nnames if user doesn't have status
      permission, change status_for_backup to not return bogus information.
  3) change(86-07-03,Farley), approve(86-07-03,MCR7427),
     audit(86-07-03,Fawcett), install(86-07-07,MR12.0-1086):
     This change is a PBF to installation 1077. The effective mode was being
     returned one bit position off.
                                                   END HISTORY COMMENTS */

/* Modified 1985-05-08, EJ Sharpe: added get_mdir_status_priv, made get_mdir_status non-privileged,
	changed get_mdir_status_uid to get_mdir_status_uid_priv */
/* Modified 1985-04-19, BIM: include parent access class in entry_access_info */
/* Modified 04/08/85 by Keith Loepere to use fs_modes when possible (gets priv init right). */
/* Modified 03/25/85 by M. Pandolf to add get_access_(info info_seg) entries */
/* Modified 02/21/85 by E. Swenson to add get_user_access_modes_seg entry */
/* Modified 10/19/84 by Keith Loepere to properly copy status_for_backup. */
/* Modified 9/25/84 by EJ Sharpe for new entry get_user_raw_mode */
/* Modified 6/14/84 Keith Loepere to use the new dc_find */
/* Modified 1/84 BIM for 18 bit quota values */
/* Modified 6/9/83 Jay Pattin to not require status permission in get_author, get_bc_author, and status_for_backup */
/* Modified 830427 BIM to set dp in the root case. */
/* Modified 2/26/83 Jay Pattin to add get_uid_file */
/* Modified 1/3/83 Jay Pattin to add get_user_access_modes */
/* Modified 2/83, BIM, to stop zeroing the version in status_for_backup  and fix Harcore 519. */
/* Modified September 1982, J. Bongiovanni, for synchronized switch, init bug */
/* Modified 3/82, BIM: (1) stop using sfs, (2) get_user_exmode,
   (3) overall cleanup, (4) general branch entrypoint.
   /* Modified 06/08/81, WOS: (1) Accept default of -1 for ring number in get_user_effmode,
   (2): Return documented directory mode values in get_user_effmode (turn off "e" bit)
   (3): Return access without regard to dir_name access if requested username
   is that of calling process, in get_user_effmode. */
/* Modified 11/26/80 W. Olin Sibert to fail when returning names in wrong component of extensible area */
/* Modified 10/79 by Mike Grady to set ptrs and counts before getting space in system
   free seg for names and such. Bug found by GDixon. */
/* Modified 9 Feb 79 by D. Spector to allow call to access_mode$user return an
   error code (status_$get_user_effmode) */
/* Modified 11/15/78 by C. D. Tavares to use status_structures.incl.pl1 */
/* Modified July 1977 by THVV for Bratt's MCR 2364 to return all but names in no_s_permission case */
/* Modified 07/77 by THVV for bad_dir_ check */
/* Modified July 1976 by R. Bratt to return uid in partial info case */
/* Modified June 1976 by R. Bratt to call find_$finished */
/* Modified April 1976 by R. Bratt to check mountedness and return partial info */
/* Modified March 1976 by Larry Johnson for master_dir status entries */
/* Modified March 1976 by R. Bratt for tpd */
/* 11/17/75 RE Mullen: status_for_backup to ret UID's and master_dir */
/* 9/25/75 RE Mullen: remove obsolete seg_activity and backup_branch_info entrypoints */
/* 9/25/75 RE Mullen: status_for_backup to not go to vtoc for maxlength */
/* Modified for NSS 4/75 by THVV */

	dcl     a_access_class	 bit (72) aligned parameter;
	dcl     a_auth		 char (*) parameter;
	dcl     a_bkptr		 ptr parameter;
	dcl     a_bitcnt		 fixed bin (24) parameter;
	dcl     a_chase		 fixed bin (1) parameter;
	dcl     a_code		 fixed bin (35) parameter;
	dcl     a_dates		 (*) bit (36) parameter;
	dcl     a_dir_name		 char (*) parameter;
	dcl     a_entryname		 char (*) parameter;
	dcl     a_ex_modes		 bit (36) aligned parameter;
	dcl     a_max_length	 fixed bin (19) parameter;
	dcl     a_mode		 fixed bin (5) parameter;
	dcl     a_modes		 bit (36) aligned parameter;
						/* note difference in dcl */
	dcl     a_ncd		 fixed bin parameter;
	dcl     a_nid		 fixed bin parameter;
	dcl     a_quota		 fixed bin (18) parameter;
	dcl     a_return_area_ptr	 ptr parameter;
	dcl     a_return_struc_ptr	 ptr parameter;
	dcl     a_ring		 fixed bin parameter;
	dcl     a_safety_sw		 bit (1) parameter;
	dcl     a_seg_usage		 fixed bin (35) parameter;
	dcl     a_segptr		 ptr parameter;
	dcl     a_type		 fixed bin (2) parameter;
	dcl     a_uidpath		 (0:15) bit (36) aligned parameter;
	dcl     a_user		 char (*) parameter;
	dcl     a_voluid		 bit (36) aligned parameter;

/* VARIABLES */

	dcl     access_class	 bit (72) aligned;
	dcl     auth		 char (32) aligned;
	dcl     bitcnt		 fixed bin (24);
	dcl     bkptr		 ptr;
	dcl     1 bks		 aligned like status_for_backup;
	dcl     called_find		 bit (1) aligned init ("0"b);
	dcl     chase		 fixed bin (1);
	dcl     code		 fixed bin (35);
	dcl     cur_length		 fixed bin (35);
	dcl     dates		 (5) bit (36);
	dcl     dir_name		 char (168);
	dcl     dummy		 fixed bin (35);
	dcl     entryname		 char (32);
	dcl     1 local_entry_access_info
				 like entry_access_info;
	dcl     ex_mode_entry	 bit (1) aligned;
	dcl     exmode		 bit (36) aligned;
	dcl     have_s_permission	 bit (1) aligned init ("1"b);
	dcl     i			 fixed bin;
	dcl     locked		 bit (1) aligned init ("0"b);
	dcl     max_length		 fixed bin (19);
	dcl     mode		 bit (36) aligned;
	dcl     n_names_to_allocate	 fixed bin;
	dcl     name_rp		 bit (18) aligned;
	dcl     names_seen		 fixed bin;
	dcl     ncd		 fixed bin;
	dcl     nid		 fixed bin;
	dcl     nnp		 ptr;
	dcl     pathname_length_to_allocate
				 fixed bin;
	dcl     pathname_supplied	 bit (1) aligned;
	dcl     pathname_varying	 char (168) varying;
	dcl     pvid		 bit (36) aligned;
	dcl     1 qcell		 like quota_cell aligned automatic;
	dcl     r			 (3) fixed bin (3);
	dcl     raw_mode_entry	 bit (1) aligned;
	dcl     rec_used		 fixed bin (9);
	dcl     return_area_ptr	 pointer;
	dcl     return_names_or_pathname
				 bit (1) aligned;
	dcl     return_names_ptr	 pointer init (null ());
	dcl     return_pathname_ptr	 pointer init (null ());
	dcl     return_pathname_sw	 bit (1);
	dcl     return_struc_ptr	 ptr;
	dcl     rexmode		 bit (36) aligned;
	dcl     ring		 fixed bin;
	dcl     rmode		 bit (36) aligned;
	dcl     root_lvid		 bit (36) aligned;	/* logical volume ID of the root */
	dcl     safety_sw		 bit (1) aligned;
	dcl     saved_dir_change_pclock
				 fixed bin (35);
	dcl     seg_usage		 fixed bin (35);
	dcl     segptr		 pointer;
	dcl     status_call		 fixed bin (3);
	dcl     tcode		 fixed bin (35);
	dcl     type		 fixed bin;
	dcl     uid		 bit (36) aligned;
	dcl     uidpath		 (0:15) bit (36) aligned;
	dcl     user		 char (32) aligned;
	dcl     vol_dtd		 bit (36);
	dcl     volid		 (3) bit (36);
	dcl     vtocx		 fixed bin;

/* * * * * TEXT SECTION REFERENCES * * * * * * * */

	dcl     ENTRY_status_	 initial (1) fixed binary (3) internal static options (constant);
						/* note that there is code in this program which */
	dcl     ENTRY_status_long	 initial (2) fixed binary (3) internal static options (constant);
						/* assumes this ordering of these indicators */
	dcl     ENTRY_status_min	 initial (3) fixed binary (3) internal static options (constant);
						/* section of the procedure */

/* BASED */

	dcl     return_area		 area based (return_area_ptr);
	dcl     return_names	 (n_names_to_allocate) character (32) unaligned based (return_names_ptr);
	dcl     return_pathname	 aligned based (return_pathname_ptr) char (pathname_length_to_allocate);
	dcl     1 status_branch_short	 aligned based (status_ptr) like status_branch.short;

/* EXTERNAL */

	dcl     error_table_$bad_arg	 fixed bin (35) external;
	dcl     error_table_$dirseg	 fixed bin (35) external;
	dcl     error_table_$link	 fixed bin (35) external;
	dcl     error_table_$mdc_not_mdir
				 fixed bin (35) external;
	dcl     error_table_$no_s_permission
				 fixed bin (35) external;
	dcl     error_table_$noalloc	 fixed bin (35) external;
	dcl     error_table_$notalloc	 fixed bin (35) external;
	dcl     error_table_$null_info_ptr
				 fixed bin (35) external;
	dcl     error_table_$root	 fixed bin (35) external;
	dcl     error_table_$unimplemented_version
				 fixed bin (35) static external;
	dcl     pds$process_group_id	 char (32) aligned external static;
	dcl     pvt$root_lvid	 bit (36) aligned external;
	dcl     pvt$root_pvid	 bit (36) aligned external;
	dcl     pvt$root_vtocx	 fixed bin external;

/* ENTRIES */

	dcl     acc_name_$get	 entry (ptr, ptr);
	dcl     access_mode$effective	 entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     access_mode$raw	 entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     access_mode$user	 entry (ptr, char (32) aligned, bit (36) aligned, bit (36) aligned,
				 fixed bin (35));
	dcl     fs_modes$locked	 entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3),
				 fixed bin (35));
	dcl     get_pathname_	 entry (fixed bin (17), char (*) varying, fixed bin (35));
	dcl     level$get		 entry () returns (fixed bin (3));
	dcl     lock$dir_lock_read	 entry (ptr, fixed bin (35));
	dcl     lock$dir_unlock	 entry (ptr);
	dcl     mountedp		 entry (bit (36) aligned) returns (fixed bin (35));
	dcl     uid_path_util$get	 entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35));
	dcl     vtoc_attributes$get_dump_info
				 entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36), (3) bit (36),
				 fixed bin (35));
	dcl     vtoc_attributes$get_dump_switches
				 entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin,
				 fixed bin (35));
	dcl     vtoc_attributes$get_info
				 entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin (35));
	dcl     vtoc_attributes$get_quota
				 entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin,
				 fixed bin (35));

/* MISC */

	dcl     (addr, baseno, bin, divide, fixed, hbound, ptr, null, rel, segno, substr, unspec)
				 builtin;

	dcl     area		 condition;
	dcl     bad_dir_		 condition;
	dcl     cleanup		 condition;
	dcl     seg_fault_error	 condition;
	dcl     stringsize		 condition;
%page;
/* status:	proc (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code); */

	status_call = ENTRY_status_;
	go to status_join;				/* Join common code. */


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

long:
     entry (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code);

	status_call = ENTRY_status_long;

/* status_ and status_long join here. status_min* does not come in here */

status_join:
	return_struc_ptr = a_return_struc_ptr;
	return_area_ptr = a_return_area_ptr;
	call copy_and_check_pathname_arg;
	chase = a_chase;
	code = 0;
	tcode = 0;
	status_ptr = return_struc_ptr;
	n_names_to_allocate = 0;
	pathname_length_to_allocate = 0;

	if status_call = ENTRY_status_
	then unspec (status_branch_short) = ""b;	/* clear it out */
	else unspec (status_branch) = ""b;

	on cleanup call clean_up_status_;

/* Now set some bit flags to determine what work will be needed */

	return_names_or_pathname = (return_area_ptr ^= null);

RETRY_STATUS:
	call dc_find$obj_status_attributes_read (dir_name, entryname, chase, ep, code);
	if code = error_table_$no_s_permission
	then have_s_permission = "0"b;
	else if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

	dp = ptr (ep, 0);

	call get_type;				/* Get segment type, bit count, and ring brackets. */

/* See how much stuff to allocate */
/* the qualifier of entry is set already */
/* assume we need entry.nnames, and only discover bad_dir_ later */

	if ^return_names_or_pathname
	then do;
		n_names_to_allocate = 0;
		pathname_length_to_allocate = 0;
	     end;
	else do;
		n_names_to_allocate = entry.nnames;
		if type = Link
		then pathname_length_to_allocate = link.pathname_size;

/* Now unlock, allocate, and relock */

		saved_dir_change_pclock = dir.change_pclock;

		call lock$dir_unlock (dp);		/* unlock, i say */
		locked = "0"b;			/* for cleanup benefit */

		on area call fatal_error (error_table_$noalloc);

		if n_names_to_allocate > 0
		then do;
			if have_s_permission
			then allocate return_names in (return_area) set (return_names_ptr);
			else n_names_to_allocate = 0; /* if no status, we have no name structure to copy */
		     end;
		if pathname_length_to_allocate > 0
		then allocate return_pathname in (return_area) set (return_pathname_ptr);

		if return_names_ptr ^= null | return_pathname_ptr ^= null
		then do;
			if (return_names_ptr ^= null & baseno (return_names_ptr) ^= baseno (return_area_ptr))
			     | (return_pathname_ptr ^= null
			     & baseno (return_pathname_ptr) ^= baseno (return_area_ptr))
			then call fatal_error (error_table_$notalloc);


/* note that we could retry the allocation to try to get it into the */
/* segment, but there is a better entrypoint on the way anyway */

/* now relock and check for races */
/* if the dir has been deleted, we could seg-fault here */

			on seg_fault_error signal bad_dir_;

			call lock$dir_lock_read (dp, code);
			if code ^= 0
			then call fatal_error (code);
			locked = "1"b;
			revert seg_fault_error;

			if dir.change_pclock ^= saved_dir_change_pclock
			then do;
				call unlock_dir;
				call clean_up_status_;
						/* free storage */
				go to RETRY_STATUS;
			     end;
		     end;
	     end;

/* Okay, now the dir is locked, and any allocated storage needed */
/* to return the data has been allocated */
/* go ahead and fill things in */

	if type ^= Link
	then do;					/* if a branch */
		if type = Directory
		then tcode = 0;			/* RLV always mounted */
		else tcode = mountedp (dir.sons_lvid);	/* check mountedness */
		if tcode = 0
		then call get_vtoc;			/* okay its mounted */
		else unspec (sc_info) = "0"b;		/* DAMN, give him partial info, N.B. tcode must get out */

		rec_used = sc_info.records;
		cur_length = sc_info.csl;
	     end;
	else tcode = 0;

	uid = entry.uid;				/* can always know uid */

	status_branch.type = type;			/* set fixed information */

/* status_branch.nnames is set to 0 when no names are allocated, regardless of
   whether or not the caller has status permission. As per specs in documentation. */
	status_branch.nnames = 0;
	if n_names_to_allocate > 0			/* we have allocated them */
	then do;
		status_branch.names_relp = rel (return_names_ptr);
		status_branch.nnames = entry.nnames;

		names_seen = 0;
		do name_rp = entry.name_frp repeat ptr (dp, name_rp) -> names.fp while (name_rp ^= ""b);

		     nnp = ptr (dp, name_rp);
		     if nnp -> names.type ^= NAME_TYPE | nnp -> names.owner ^= entry.uid
			| nnp -> names.entry_rp ^= rel (ep)
		     then signal bad_dir_;
		     names_seen = names_seen + 1;
		     if names_seen > n_names_to_allocate
		     then signal bad_dir_;
		     return_names (names_seen) = nnp -> names.name;
		end;
		if names_seen < n_names_to_allocate
		then signal bad_dir_;
	     end;

	if type = Link
	then do;
		if return_pathname_ptr ^= null
		then do;
			status_link.pathname_relp = rel (return_pathname_ptr);
			on stringsize signal bad_dir_;
(stringsize):
			return_pathname = link.pathname;
			revert stringsize;
		     end;

		status_link.dtem = entry.dtem;
		status_link.dtd = entry.dtd;
		status_link.pathname_length = link.pathname_size;
	     end;
	else do;					/* branch only items */
		status_branch.dtu = sc_info.dtu;
		status_branch.dtcm = sc_info.dtm;
		call access_mode$effective (ep, mode, exmode, dummy);
		if type = Segment
		then status_branch.mode = "0"b || substr (mode, 1, 3);
		else status_branch.mode = "0"b || substr (exmode, 1, 1) || "1"b || substr (exmode, 2, 2);
		status_branch.records_used = rec_used;

		call access_mode$raw (ep, rmode, rexmode, dummy);
						/* get raw bits for pad field */
		if type = Segment
		then mode = "0"b || substr (rmode, 1, 3);
		else mode = "0"b || substr (rexmode, 1, 1) || "1"b || substr (rexmode, 2, 2);
		status_branch.raw_mode = substr (mode, 1, 5);

		if status_call ^= ENTRY_status_long
		then goto GOOD_RETURN;

		status_branch.long.dtd = entry.dtd;
		status_branch.long.dtem = entry.dtem;
		if type = Directory
		then status_branch.long.lvid = entry.sons_lvid;
		else status_branch.long.lvid = ptr (ep, 0) -> dir.sons_lvid;
		status_branch.long.current_length = divide (cur_length, 1024, 11, 0);
		status_branch.long.bit_count = bitcnt;
		status_branch.long.copy_switch = entry.copysw;
		status_branch.long.tpd_switch = entry.tpd;
		status_branch.long.mdir_switch = entry.master_dir;
		status_branch.long.damaged_switch = sc_info.damaged;
		status_branch.long.synchronized_switch = sc_info.synchronized;
		status_branch.long.ring_brackets (*) = r (*);
		status_branch.long.uid = entry.uid;
	     end;

GOOD_RETURN:
	if tcode = 0 & ^have_s_permission
	then tcode = error_table_$no_s_permission;

	call unlock_dir;

	a_code = tcode;				/* remember LV problems */
						/* or no_s_permission */
	return;
%page;
mins:
     entry (a_segptr, a_type, a_bitcnt, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to min_join;


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

minf:
     entry (a_dir_name, a_entryname, a_chase, a_type, a_bitcnt, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;
	chase = a_chase;

	call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

min_join:
	dp = ptr (ep, 0);

	call get_type;				/* Get type and bit count. */

	call unlock_dir;				/* Unlock_dir the directory now. */

	a_type = type;				/* Return the segment type. */
	a_bitcnt = bitcnt;				/* Return the bit count. */

	go to RETURN;
%page;
get_author:
     entry (a_dir_name, a_entryname, a_chase, a_auth, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;
	chase = a_chase;

	call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

	dp = ptr (ep, 0);

	call acc_name_$get (addr (entry.author), addr (auth));
						/* decode the name */

	call unlock_dir;				/* Unlock directory before returning info. */

	a_auth = auth;

	go to RETURN;


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

get_bc_author:
     entry (a_dir_name, a_entryname, a_auth, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

	dp = ptr (ep, 0);

	call acc_name_$get (addr (entry.bc_author), addr (auth));

	call unlock_dir;

	a_auth = auth;

	go to RETURN;
%page;
get_uid_file:
     entry (a_dir_name, a_entryname, a_uid, a_code);

	declare a_uid		 bit (36) aligned parameter;

	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg ();

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

	dp = ptr (ep, 0);

	uid = entry.uid;

	call unlock_dir ();

	a_uid = uid;
	go to RETURN;
%page;
get_user_access_modes:
     entry (a_dir_name, a_entryname, a_user, a_ring, a_modes, a_ex_modes, a_code);
						/* modes returned as bit strings (36) */
	ex_mode_entry = "1"b;
	raw_mode_entry = "0"b;
	pathname_supplied = "1"b;
	ring = a_ring;
	goto GET_MODE_JOIN;

get_user_access_modes_seg:
     entry (a_segptr, a_user, a_ring, a_modes, a_ex_modes, a_code);

	ex_mode_entry = "1"b;
	raw_mode_entry = "0"b;
	pathname_supplied = "0"b;
	ring = a_ring;
	goto GET_MODE_JOIN;

get_user_effmode:
     entry (a_dir_name, a_entryname, a_user, a_ring, a_mode, a_code);
						/* mode returned as fixed bin (5) */
	ex_mode_entry = "0"b;
	raw_mode_entry = "0"b;
	pathname_supplied = "1"b;
	ring = a_ring;
	goto GET_MODE_JOIN;

get_user_raw_mode:
     entry (a_dir_name, a_entryname, a_user, a_modes, a_code);
						/* mode returned as bit string (36) */
	ex_mode_entry = "0"b;
	raw_mode_entry = "1"b;
	pathname_supplied = "1"b;

GET_MODE_JOIN:
	user = a_user;				/* copy arg */

	if user = pds$process_group_id
	then user = "";				/* Make the default work (and not require s) */

	if (user = "")
	then /* Don't require dir_name access for this */
	     status_call = ENTRY_status_min;
	else status_call = 0;			/* Otherwise, not a status entry */

	if pathname_supplied
	then call copy_and_check_pathname_arg ();
	else call copy_and_check_segptr_arg ();		/* must be segptr entry */

	if ring < 0
	then ring = level$get ();			/* Default to validation level */
	else if ring > 7
	then ring = 7;				/* And make it "valid" */

	if pathname_supplied
	then do;
		if status_call = ENTRY_status_min
		then call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
						/* allow no s but non-null on object */
		else call dc_find$obj_status_read (dir_name, entryname, 1, ep, code);
	     end;
	else do;
		if status_call = ENTRY_status_min
		then call dc_find$obj_attributes_read_ptr (segptr, ep, code);
		else call dc_find$obj_status_read_ptr (segptr, ep, code);
	     end;

	if code ^= 0
	then call fatal_error (code);

	locked = "1"b;
	if pathname_supplied
	then called_find = "1"b;

	dp = ptr (ep, 0);

	if (user ^= "")
	then /* Someone other than ourselves */
	     call access_mode$user (ep, user, mode, exmode, code);
	else call access_mode$raw (ep, mode, exmode, code);
						/* Otherwise, determine our own mode */
	if code ^= 0
	then call fatal_error (code);

	call get_type;				/* Get segment type, ring brackets and bitcount. */

	call unlock_dir;				/* Unlock the directory now. */

	if raw_mode_entry
	then do;					/* don't need to factor in ring brackets */
		if type = Directory
		then a_modes = exmode;		/* "111"b = sma */
		else a_modes = mode;		/* "111"b = rew */
		goto RETURN;
	     end;

	if type = Directory
	then do;					/* for directories */
		mode = exmode;
		exmode = ""b;
		if ring <= r (1)
		then ;				/* all access allowed */
		else if ring <= r (2)
		then mode = (mode & "100"b);		/* status only */
		else mode = "0"b;
		if ^ex_mode_entry
		then mode = substr (mode, 1, 1) || "0"b || substr (mode, 2, 2);
						/* map "sma" into "rwa" */
	     end;
	else do;					/* a real segment */
		if ring < r (1)
		then mode = (mode & "101"b);
		else if ring = r (1)
		then ;
		else if ring <= r (2)
		then mode = (mode & "110"b);
		else if ring <= r (3)
		then mode = (mode & "010"b);
		else mode = "0"b;
	     end;

	if ex_mode_entry
	then do;
		a_modes = mode;
		a_ex_modes = exmode;
	     end;
	else a_mode = fixed (substr (mode, 1, 4), 5);	/* Return the effective mode. */
						/* the forth bit of the bit string */
						/* mode alignes with the lsb of the fixed bin number a_mode */
	go to RETURN;
%page;
status_for_backup:
     entry (a_dir_name, a_entryname, a_bkptr, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	bkptr = a_bkptr;

	if bkptr = null
	then call fatal_error (error_table_$bad_arg);

	if bkptr -> status_for_backup.version ^= status_for_backup_version_2
	then call fatal_error (error_table_$unimplemented_version);

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

	dp = ptr (ep, 0);

	unspec (bks) = "0"b;
	bks.version = status_for_backup_version_2;
	bks.switches.safety = entry.safety_sw;
	bks.switches.tpd = entry.tpd;
	bks.switches.security_oosw = entry.security_oosw;
	bks.switches.audit_flag = entry.audit_flag;
	bks.switches.multiple_class = entry.multiple_class;
	bks.switches.entrypt = entry.entrypt_sw;
	bks.entrypt_bound = entry.entrypt_bound;
	bks.access_class = entry.access_class;

	if entry.dirsw
	then do;
		bks.lvid = entry.sons_lvid;
		bks.switches.master_dir = entry.master_dir;
	     end;
	else bks.lvid = dp -> dir.sons_lvid;

	bks.pvid = entry.pvid;

	call acc_name_$get (addr (entry.author), addr (bks.author));

	call acc_name_$get (addr (entry.bc_author), addr (bks.bc_author));

	call unlock_dir;

	bkptr -> status_for_backup = bks;		/* return data to user */

	go to RETURN;
%page;

get_safety_sw_ptr:
     entry (a_segptr, a_safety_sw, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to safety_sw_join;


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


get_safety_sw:
     entry (a_dir_name, a_entryname, a_safety_sw, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

safety_sw_join:
	dp = ptr (ep, 0);

	safety_sw = entry.safety_sw;

	call unlock_dir;

	a_safety_sw = safety_sw;

	go to RETURN;
%page;
get_seg_usage_ptr:
     entry (a_segptr, a_seg_usage, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to seg_usage_join;


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


get_seg_usage:
     entry (a_dir_name, a_entryname, a_seg_usage, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

seg_usage_join:
	dp = ptr (ep, 0);

	if type = Directory
	then tcode = error_table_$dirseg;		/* Dirs have quota instead */
	else tcode = mountedp (dir.sons_lvid);		/* Make sure seg is mounted by user */
	if tcode ^= 0
	then call fatal_error (tcode);

	call get_vtoc;				/* Read AST or VTOCE */
	seg_usage = sc_info.pf_count;
	call unlock_dir;

	a_seg_usage = seg_usage;
	go to RETURN;
%page;

get_dates_ptr:
     entry (a_segptr, a_dates, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to dates_join;


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


get_dates:
     entry (a_dir_name, a_entryname, a_dates, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

dates_join:
	dp = ptr (ep, 0);

	call get_vtoc_dates;

	dates (1) = sc_info.dtu;
	dates (2) = sc_info.dtm;
	dates (3) = entry.dtem;
	dates (4) = entry.dtd;
	dates (5) = vol_dtd;

	call unlock_dir;

	do i = 1 to hbound (a_dates, 1);
	     a_dates (i) = dates (i);
	end;

	go to RETURN;
%page;

get_volume_dump_switches_ptr:
     entry (a_segptr, a_nid, a_ncd, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to volume_dump_switches_join;


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


get_volume_dump_switches:
     entry (a_dir_name, a_entryname, a_nid, a_ncd, a_code);


	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

volume_dump_switches_join:
	dp = ptr (ep, 0);

	call get_vtoc_volume_dump_switches;

	call unlock_dir;

	a_nid = nid;
	a_ncd = ncd;

	go to RETURN;
%page;

get_max_length_ptr:
     entry (a_segptr, a_max_length, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to max_length_join;

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

get_max_length:
     entry (a_dir_name, a_entryname, a_max_length, a_code);



	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

max_length_join:
	dp = ptr (ep, 0);

	if type = Directory				/* check mountedness for non-dirs */
	then tcode = 0;
	else tcode = mountedp (dir.sons_lvid);
	if tcode ^= 0
	then call fatal_error (tcode);

	call get_vtoc;
	max_length = sc_info.msl;

	call unlock_dir;

	a_max_length = max_length;

	go to RETURN;
%page;
get_access_class_ptr:
     entry (a_segptr, a_access_class, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_segptr_arg;

	call dc_find$obj_attributes_read_ptr (segptr, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked = "1"b;

	go to access_class_join;

get_access_class:
     entry (a_dir_name, a_entryname, a_access_class, a_code);

	status_call = ENTRY_status_min;
	call copy_and_check_pathname_arg;

	call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code);
	if code ^= 0
	then call fatal_error (code);
	locked, called_find = "1"b;

access_class_join:
	dp = ptr (ep, 0);

	access_class = entry.access_class;

	call unlock_dir;

	a_access_class = access_class;

	go to RETURN;
%page;

get_access_info:
     entry (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_code);

	chase = a_chase;
	pathname_supplied = "1"b;

	go to get_access_info_join;

get_access_info_seg:
     entry (a_segptr, a_return_struc_ptr, a_code);

	pathname_supplied = "0"b;

get_access_info_join:
	status_call = ENTRY_status_min;

	entry_access_info_ptr = a_return_struc_ptr;
	if entry_access_info_ptr = null ()
	then call fatal_error (error_table_$null_info_ptr);
	else if entry_access_info.version ^= ENTRY_ACCESS_INFO_VERSION_1
	then call fatal_error (error_table_$unimplemented_version);

	if pathname_supplied
	then do;
		call copy_and_check_pathname_arg ();

		call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code);
		if code ^= 0
		then call fatal_error (code);

		dp = ptr (ep, 0);

		locked, called_find = "1"b;
	     end;
	else do;
		call copy_and_check_segptr_arg ();

		call dc_find$obj_attributes_read_ptr (segptr, ep, code);
		if code ^= 0
		then call fatal_error (code);

		dp = ptr (ep, 0);

		locked = "1"b;
	     end;

	if ^entry.bs				/* if entry is a link */
	then call fatal_error (error_table_$link);	/* we can't continue */
	else do;
		if called_find			/* use expensive access lookup */
		then call access_mode$effective (ep, mode, exmode, code);
		else call fs_modes$locked (segptr, mode, exmode, r, code);
						/* r gets overwritten at get_type */
		if code ^= 0
		then call fatal_error (code);

		call get_pathname_ (bin (segno (dp), 17, 0), pathname_varying, code);
		if code ^= 0
		then call fatal_error (code);

		local_entry_access_info.version = ENTRY_ACCESS_INFO_VERSION_1;

		call get_type;
		local_entry_access_info.type = type;

		local_entry_access_info.dir_name = pathname_varying;
		local_entry_access_info.entryname = addr (entry.primary_name) -> names.name;

		local_entry_access_info.uid = entry.uid;

		local_entry_access_info.ring_brackets (*) = r (*);
		if type = Directory
		then local_entry_access_info.extended_ring_brackets (*) = 0;
		else do i = 1 to 3;
			local_entry_access_info.extended_ring_brackets (i) = fixed (entry.ex_ring_brackets (i), 3);
		     end;


		if type = Segment
		then do;
			local_entry_access_info.effective_access_modes = mode;
			local_entry_access_info.extended_access_modes = exmode;
		     end;
		else do;
			local_entry_access_info.effective_access_modes = exmode;
			local_entry_access_info.extended_access_modes = ""b;
		     end;

		local_entry_access_info.access_class = entry.access_class;
		local_entry_access_info.multiclass = entry.multiple_class;
		local_entry_access_info.parent_access_class = dir.access_class;

	     end;

	call unlock_dir ();

	entry_access_info = local_entry_access_info;

	go to RETURN;

%page;

/* Status entries used by master directory control */

get_mdir_status:
     entry (a_dir_name, a_entryname, a_uidpath, a_voluid, a_quota, a_code);

	status_call = 0;
	call copy_and_check_pathname_arg;
	return_pathname_sw = "0"b;

	call dc_find$obj_status_read (dir_name, entryname, 0, ep, code);
						/* find it without chasing link */
	goto mdir_common;

get_mdir_status_priv:
     entry (a_dir_name, a_entryname, a_uidpath, a_voluid, a_quota, a_code);

	status_call = 0;
	call copy_and_check_pathname_arg;
	return_pathname_sw = "0"b;

	call dc_find$obj_status_read_priv (dir_name, entryname, 0, ep, code);
						/* find it without chasing link */

mdir_common:
	if code ^= 0
	then if code = error_table_$root
	     then go to mdir_root;			/* the root is NOT locked. we are making up this info */
	     else call fatal_error (code);

	dp = ptr (ep, 0);
	locked, called_find = "1"b;

	call check_master_dir;			/* must be master dir, which is on RLV */
	call get_vtoc_quota;			/* get vtoce atrrbiutes */

	a_quota = qcell.received;			/* and quota received */
	a_voluid = entry.sons_lvid;
	if ^return_pathname_sw
	then do;					/* need uid pathname */
		call uid_path_util$get (dp, uidpath, code);
		if code ^= 0
		then call fatal_error (code);
		uidpath (dir.tree_depth + 1) = entry.uid;
						/* finish name */
		a_uidpath = uidpath;
	     end;
	else do;
		a_dir_name = dir_name;
		a_entryname = entryname;
	     end;

	call unlock_dir;
	go to RETURN;

mdir_root:
	code = 0;					/* clear residual error_table_$root */
	dp = null;

	call get_vtoc_root;				/* read roots vtoc entry */
	a_quota = qcell.received;
	a_voluid = root_lvid;
	if ^return_pathname_sw
	then do;					/* make up pathname of root */
		uidpath = "0"b;
		uidpath (0) = (36)"1"b;
		a_uidpath = uidpath;
	     end;
	else do;
		a_dir_name = ">";
		a_entryname = "";
	     end;
	go to RETURN;

/* this entry is similiar to above, but is given a uid pathname to start with */

get_mdir_status_uid_priv:
     entry (a_uidpath, a_dir_name, a_entryname, a_voluid, a_quota, a_code);

	status_call = 0;
	call copy_and_check_pathname_arg;
	return_pathname_sw = "1"b;			/* remember to return pathname */
	uidpath = a_uidpath;
	call dc_find$obj_status_read_priv_uid (uidpath, dir_name, entryname, ep, code);
						/* find entry and lock dir_name */
	go to mdir_common;



/* procedure to check for a master directory */

check_master_dir:
     proc;

	if entry.bs
	then if entry.dirsw
	     then if entry.master_dir
		then do;
			code = 0;
			return;
		     end;
	call fatal_error (error_table_$mdc_not_mdir);


     end check_master_dir;
%page;
get_vtoc:
     proc;

	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	call vtoc_attributes$get_info (uid, pvid, vtocx, addr (sc_info), dummy);
	if dummy ^= 0
	then call fatal_error (dummy);

     end get_vtoc;

get_vtoc_dates:
     proc;

	call get_vtoc;
	call vtoc_attributes$get_dump_info (uid, pvid, vtocx, vol_dtd, volid, dummy);
	if dummy ^= 0
	then call fatal_error (dummy);

     end get_vtoc_dates;

get_vtoc_volume_dump_switches:
     proc;

	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	call vtoc_attributes$get_dump_switches (uid, pvid, vtocx, nid, ncd, dummy);
	if dummy ^= 0
	then call fatal_error (dummy);

     end get_vtoc_volume_dump_switches;


get_vtoc_quota:
     proc;					/* special get_vtoc for master dirs */

	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code);
	if code ^= 0
	then call fatal_error (code);

     end get_vtoc_quota;

get_vtoc_root:
     proc;					/* get vtoce for the root master dir */

	uid = (36)"1"b;
	pvid = pvt$root_pvid;
	vtocx = pvt$root_vtocx;
	root_lvid = pvt$root_lvid;
	call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code);
	if code ^= 0
	then call fatal_error (code);
	unspec (uidpath) = "0"b;			/* make up uidpathname */
	uidpath (0) = (36)"1"b;
	return;

     end get_vtoc_root;

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

unlock_dir:
     proc;

	if called_find
	then call dc_find$finished (dp, locked);	/* unlock and unuse */
	else if locked
	then call lock$dir_unlock (dp);
	locked, called_find = "0"b;
     end unlock_dir;
%page;

get_type:
     proc;


	if entry.bs
	then do;					/* entry is a branch */
		if entry.dirsw
		then do;				/* entry is a directory branch */
			type = Directory;
			r (1) = fixed (entry.ex_ring_brackets (1), 3);
						/* return extended ring brackets */
			r (2) = fixed (entry.ex_ring_brackets (2), 3);
			r (3) = r (2);
		     end;
		else do;				/* entry is a non_directory branch */
			type = Segment;
			r (1) = fixed (entry.ring_brackets (1), 3);
						/* return ring brackets */
			r (2) = fixed (entry.ring_brackets (2), 3);
			r (3) = fixed (entry.ring_brackets (3), 3);
		     end;
		bitcnt = entry.bc;
	     end;

	else do;					/* entry is a link */
		type = Link;
		bitcnt = 0;
	     end;


     end get_type;
%page;

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

fatal_error:
     procedure (e_code);
	declare e_code		 fixed bin (35);

	call unlock_dir;				/* cleanup */
	call clean_up_status_;			/* free storage if already dereferenced */

	a_code = e_code;
	go to ERR_RETURN;
     end fatal_error;

RETURN:
	a_code = 0;
ERR_RETURN:
	return;

copy_and_check_segptr_arg:
     procedure;

	segptr = a_segptr;
	if segptr = null
	then call fatal_error (error_table_$null_info_ptr);
     end copy_and_check_segptr_arg;

copy_and_check_pathname_arg:
     procedure;

	dir_name = a_dir_name;
	entryname = a_entryname;
	if dir_name = ""
	then call fatal_error (error_table_$bad_arg);
     end copy_and_check_pathname_arg;

clean_up_status_:
     procedure;

/* ASSUME that if we are called as a cleanup handler that */
/* a crawlout is in progress, and we should leave the dir locked */
/* so that verify_lock will find it. */


	if status_call = ENTRY_status_ | status_call = ENTRY_status_long
	then do;
		if return_names_ptr ^= null
		then free return_names;
		if return_pathname_ptr ^= null
		then free return_pathname;
	     end;
	if called_find				/* will be false on error exits */
	then do;
		call dc_find$finished (dp, "0"b);	/* dereference, but leave locked so verify_lock will salvage */
		called_find = "0"b;
	     end;
     end clean_up_status_;
%page;
%include dc_find_dcls;
%page;
%include dir_entry;
%page;
%include dir_header;
%page;
%include dir_link;
%page;
%include dir_name;
%page;
%include entry_access_info;
%page;
%include fs_types;
%page;
%include quota_cell;
%page;
%include sc_info;
%page;
%include status_for_backup;
%page;
%include status_structures;
     end status_;




		    tc_shutdown.pl1                 11/11/89  1132.4rew 11/11/89  0800.7       21564



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


tc_shutdown: proc;

/* Modified by E Stone on 5/74 to call deactivate_segs rather than deact_proc and to turn wait enable on */

dcl  aptptr ptr,					/* pointer to apt entry */
     sstp ptr,					/* pointer to SST */
     pds_astep ptr;					/* pointer to the aste for the pds of a process */

dcl  i fixed bin,					/* variable used to loop through APT */
     state fixed bin,				/* executation state of a process */
     size fixed bin,				/* number of entries in APT */
     length fixed bin;				/* number of words per apte */

dcl  sst_seg$ fixed bin ext,
     tc_data$apt_size fixed bin ext,
     tc_data$apt_entry_size fixed bin ext,
     tc_data$initializer_id ext bit (36) aligned,
     tc_data$system_shutdown fixed bin ext,
     tc_data$wait_enable fixed bin ext,
     tc_data$apt fixed bin ext;

dcl  deactivate_segs entry (ptr);

dcl (addr, addrel, bin) builtin;

% include apte;

/* 
   */

	tc_data$system_shutdown = 1;
	tc_data$wait_enable = 0;			/* make sure we are only process running */

	aptptr = addr (tc_data$apt);
	size = tc_data$apt_size;
	length = tc_data$apt_entry_size;
	sstp = addr (sst_seg$);

/* destroy all processes except initializer and idle processes */

	do i = 1 to size;
	     state = bin(aptptr -> apte.flags.state, 18);
	     if state = 0 | state = 5
		then go to end_apt_loop;
	     if aptptr -> apte.processid = tc_data$initializer_id
		then go to end_apt_loop;
	     if aptptr -> apte.flags.idle
		| aptptr -> apte.flags.hproc
		then go to end_apt_loop;
	     pds_astep = ptr (sstp, aptptr -> apte.asteps.pds);
	     call deactivate_segs (pds_astep);

end_apt_loop:  
	     aptptr = addrel (aptptr, length);
	end;

/* 	return;				/* All done */

     end tc_shutdown;




		    template_address_space.pl1      11/11/89  1132.4r w 11/11/89  0800.7      138870



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


template_address_space: proc ();

/*

   Written October 31, 1975 by R. Bratt

   Last Modified:
   October 1984, Keith Loepere even though this is no longer called, to use 
      fs_modes.  Also removed use of hdr.  Also for terminate_.

   template_address_space provides functions for creating and deleting a template address space.
   A template address space is stored in a directory and is defined by two ring zero
   segments named "template_kst" and "template_dseg".

   ---> call template_address_space$create (dirname, access_calculated, code)

   create initiates the segment "kst_seg" in the given directory. It assumes
   that this segment has the format of a kst. create makes the following demands
   of its environment and the given segment:

   * kst.lowseg = active_all_rings_data$stack_base_segno
   * kst.highseg < active_all_rings_data$max_segno
   * kst.highest_used_segno > kst.lowseg+7
   * kst.time_of_bootload = sys_info$time_of_bootload
   * kst.highest_used_segno is consistent with bitcount
   * caller has read access to kst_seg
   * each kst entry from lowseg to highest_used_segno contains:
   *  a valid uid or a uid of "0"b
   *  baseno (kste.entryp) is valid w.r.t. this kst
   *  usage counts
   * the caller's address space contains every object in the kst to be built
   * no segment named "template_dseg" or "template_kst" exists in the given directory

   create makes two ring zero segments named "template_kst" and
   "template_dseg" with r *.*.* access. create then uses the information in
   kst_seg and its callers's address space to transform kst_seg into a secure, valid
   address space template. If an object in the new address space has a single acl
   term of *.*.* then access is precalculated in the template address space.
   If any inconsistancies are found in template_kst or if any of the assertion above
   are found to be violated then "template_kst" and "template_dseg" are deleted and an error
   is returned. If the address space template is sucessfully built then kst.template
   is set to help template_address_space$delete validate its right to delete
   this template address space and the count of segments which had access precalculated
   is returned.

   ---> call template_address_space$delete (dirname,code)

   delete is called to delete the template address space (template_kst, template_dseg) stored
   in a given directory. delete requires that the given directory contain
   two segments named "template_kst" and "template_dseg". These segments must have ring brackets
   of 0, 0, 0 and the caller must have modify permission to the containing directory.
   delete validates that the kst is marked as a template kst. Unfortunately,
   since we don't have property lists, delete cannot be absolutely certain that it is deleting
   a (template_kst, template_dseg) pair created by template_address_space$create.
   We assume, somewhat nervously, that the checks made by delete are
   sufficiently safe to prevent users from destroying ring zero segments not created
   by template_address_space$create.

*/



dcl  a_dirname char (*),
     a_access_calculated fixed bin (17),
     a_code fixed bin (35);
dcl  access_calculated fixed bin (17),
    (created_kst, created_dseg) bit (1) aligned,
     dirname char (168),
    (mode, exmode) bit (36) aligned,
     ring fixed bin (3),
     rings (3) fixed bin (3),
     level fixed bin (3),
    (my_kstp, my_kstep, my_dsegp, his_dsegp, his_kstp, his_kstep, input_kstp) ptr,
     bc fixed bin (24),
     hash_class fixed bin (17),
     code fixed bin (35),
    (slotx, parent_slotx, segno) fixed bin (17);
dcl  copy_kst bit (bc) aligned based;
dcl 1 star_dot_star_dot_star aligned,
    2 pers_name char (32) initial ("*"),
    2 proj_name char (32) initial ("*"),
    2 tag char (1) initial ("*"),
    2 modes bit (72);
dcl 1 all_access aligned,
    2 name char (32) initial ("*.*.*"),
    2 modes bit (36) initial ("01000"b),
    2 mbz bit (36) initial ("0"b),
    2 code fixed bin (35);
dcl  error_table_$action_not_performed ext fixed bin (35),
     sys_info$time_of_bootload ext fixed bin (71),
     active_all_rings_data$max_segno ext fixed bin (17),
     dseg$ ext fixed bin;
dcl  acc_list_$match entry (fixed bin, bit (36) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)),
     acl$areplace entry (char (*), char (*), ptr, fixed bin (17), bit (1), fixed bin (35)),
     append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)),
     delentry$dfile entry (char (*), char (*), fixed bin (35)),
     delentry$dseg entry (ptr, fixed bin (35)),
     fs_modes entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3), fixed bin (35)),
     initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     initiate$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
     kstsrch entry (bit (36) aligned, fixed bin (17), ptr),
     level$get entry returns (fixed bin (3)),
     level$set entry (fixed bin (3)),
     lock$dir_unlock entry (ptr),
     set$bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
     set$safety_sw_path entry (char (*), char (*), bit (1), fixed bin (35)),
     set$copysw entry (char (*), char (*), fixed bin (1), fixed bin (35)),
     sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35)),
     terminate_$noname entry (ptr, fixed bin (35));

dcl  (addr, baseno, baseptr, bin, fixed, null, ptr, rel, string, substr, unspec) builtin;

create:	entry (a_dirname, a_access_calculated, a_code);

	dirname = a_dirname;
	a_access_calculated = 0;
	a_code = 0;

	access_calculated = 0;
	created_kst, created_dseg = "0"b;
	his_kstp, his_dsegp = null ();
	my_dsegp = addr (dseg$);
	my_kstp = pds$kstp;
	level = level$get ();
	call level$set (0);

/* verify that kst_seg exists, is a segment and is readable by caller */

	call initiate$initiate_count (dirname, "kst_seg", "", bc, 0, input_kstp, code);
	if input_kstp = null () then call abort_create (code);
	if my_kstp -> kst.kst_entry (fixed (baseno (input_kstp))).dirsw
	then call abort_create (0);			/* nice try fella */
	call fs_modes (input_kstp, mode, exmode, rings, code);
	if code ^= 0 then call abort_create (code);
	if (mode & R_ACCESS) ^= R_ACCESS | level > rings (2)
	then call abort_create (0);			/* nasty, nasty */

/* create template_kst */

	call append$branch (dirname, "template_kst", 01010b, code);
	if code ^= 0 then call abort_create (code);
	created_kst = "1"b;
	call initiate (dirname, "template_kst", "", 0, 0, his_kstp, code);
	if code ^= 0 then call abort_create (code);

/* create dseg */

	call append$branch (dirname, "template_dseg", 01010b, code);
	if code ^= 0 then call abort_create (code);
	created_dseg = "1"b;
	call initiate (dirname, "template_dseg", "", 0, 0, his_dsegp, code);
	if his_dsegp = null () then call abort_create (code);

/* copy kst_seg into template_kst */

	his_kstp -> copy_kst = input_kstp -> copy_kst;
	his_kstp -> kst.template = "0"b;
	call terminate_$noname (input_kstp, (0));

/* validate kst header */

	if his_kstp -> kst.time_of_bootload ^= sys_info$time_of_bootload
	then call abort_create (0);			/* must be made this bootload */
	if his_kstp -> kst.lowseg ^= my_kstp -> kst.lowseg
	then call abort_create (0);			/* the fool */
	if his_kstp -> kst.highseg > active_all_rings_data$max_segno
	then call abort_create (0);
	if his_kstp -> kst.highest_used_segno < his_kstp -> kst.lowseg + 7
	then call abort_create (0);
	if bin (rel (addr (his_kstp -> kst_entry (his_kstp -> kst.highest_used_segno + 1)))) * 36 ^= bc
	then call abort_create (0);
	if substr (string (his_kstp -> kst.prelinked_ring), 1, level - 1) ^= ""b
	then call abort_create (0);

/* clean out stuff we won't look at */

	his_kstp -> kst.free_list = "0"b;
	unspec (his_kstp -> kst.uid_hash_bucket) = "0"b;
	do slotx = his_kstp -> kst.lowseg to his_kstp -> kst.highest_used_segno;
	     his_kstep = addr (his_kstp -> kst.kst_entry (slotx));
	     his_kstep -> kste.segno = slotx;
	     his_kstep -> kste.fp = "0"b;
	     unspec (his_kstep -> kste.access_information) = "0"b;
	     unspec (his_kstep -> kste.flags) = "0"b;
	     his_kstep -> kste.infcount = 0;
	     his_kstep -> kste.dtbm = (36) "1"b;
	end;

/* verify and build kstes */

	do slotx = his_kstp -> kst.lowseg to his_kstp -> kst.highest_used_segno;
	     his_kstep = addr (his_kstp -> kst.kst_entry (slotx));
	     if his_kstep -> kste.uid = "0"b
	     then do;
		his_kstep -> kste.usage_count = 0;
		unspec (his_kstep -> kste.entryp) = "0"b;
		if slotx ^> his_kstp -> kst.lowseg + 7
		then his_kstep -> kste.fp = (18)"1"b;	/* reserve stack */
		else do;
		     his_kstep -> kste.fp = his_kstp -> kst.free_list;
		     his_kstp -> kst.free_list = rel (his_kstep);
		end;
	     end;
	     else do;
		call kstsrch (his_kstep -> kste.uid, hash_class, my_kstep);
		if my_kstep = null () then call abort_create (0);
		his_kstep -> kste.fp = his_kstp -> kst.uid_hash_bucket (hash_class);
		his_kstp -> kst.uid_hash_bucket (hash_class) = rel (his_kstep);
		segno = my_kstep -> kste.segno;
		if his_kstep -> kste.entryp ^= null ()
		then do;
		     parent_slotx = bin (baseno (his_kstep -> kste.entryp));
		     if his_kstp -> kst.kst_entry (parent_slotx).uid ^= my_kstp -> kst.kst_entry (bin (baseno (my_kstep -> kste.entryp))).uid
		     then call abort_create (0);
		     his_kstep -> kste.entryp = ptr (his_kstep -> kste.entryp, rel (my_kstep -> kste.entryp));
		     his_kstp -> kst.kst_entry (parent_slotx).infcount = his_kstp -> kst.kst_entry (parent_slotx).infcount + 1;
		end;
		else if my_kstep -> kste.entryp ^= null ()
		then call abort_create (0);
		call set_access ();
		his_kstep -> kste.dirsw, his_kstep -> kste.tms = my_kstep -> kste.dirsw;
		his_kstep -> kste.allow_write = "1"b;
		do ring = 7 to level + 1 while (his_kstep -> kste.usage_count (ring) = 0);
		end;
	     end;
	end;

/* mark it as a valid template_kst */

	his_kstp -> kst.template = "1"b;

/* fix access on template_dseg */

	call set$bc_seg (his_dsegp, (his_kstp -> kst.highest_used_segno + 1) * 72, code);
	if code ^= 0 then call abort_create (code);
	call acl$areplace (dirname, "template_dseg", addr (all_access), 1, "0"b, code);
	if code ^= 0 then call abort_create (code);

/* fix access on template_kst */

	call set$bc_seg (his_kstp, bc, code);
	if code ^= 0 then call abort_create (code);
	call acl$areplace (dirname, "template_kst", addr (all_access), 1, "0"b, code);
	if code ^= 0 then call abort_create (code);

/* cleanup */

	call terminate_$noname (his_kstp, (0));
	call terminate_$noname (his_dsegp, (0));
	call level$set (level);
	a_access_calculated = access_calculated;
	return;

set_access: proc ();

dcl dummy_rings (3) fixed bin (3);

	     call sum$getbranch (baseptr (segno), "0"b, ep, code);
	     if code ^= 0 then return;
	     if ep -> entry.acle_count = 1
	     then do;
		call acc_list_$match ((entry.acle_count), entry.uid, addr (entry.acl_frp),
		addr (star_dot_star_dot_star), (null ()), (0), code);
		if code = 0
		then do;
		     call fs_modes (baseptr (segno), ("0"b), ("0"b), dummy_rings, code);
		     if code = 0
		     then do;
			access_calculated = access_calculated + 1;
			his_kstep -> kste.access_information = my_kstep -> kste.access_information;
			his_dsegp -> sdwa (slotx).r1 = my_dsegp -> sdwa (segno).r1;
			his_dsegp -> sdwa (slotx).r2 = my_dsegp -> sdwa (segno).r2;
			his_dsegp -> sdwa (slotx).r3 = my_dsegp -> sdwa (segno).r3;
			his_dsegp -> sdwa (slotx).read = my_dsegp -> sdwa (segno).read;
			his_dsegp -> sdwa (slotx).write = my_dsegp -> sdwa (segno).write;
			his_dsegp -> sdwa (slotx).execute = my_dsegp -> sdwa (segno).execute;
		     end;
		end;
	     end;
	     call lock$dir_unlock (ptr (ep, 0));
	     return;
	end set_access;

abort_create: proc (code);
dcl  code fixed bin (35);
	     if created_dseg
	     then call delentry$dfile (dirname, "template_dseg", (0));
	     if created_kst
	     then call delentry$dfile (dirname, "template_kst", (0));
	     call level$set (level);
	     if code = 0
	     then a_code = error_table_$action_not_performed;
	     else a_code = code;
	     go to return_to_caller;
	end abort_create;

/*
   
*/

delete:	entry (a_dirname, a_code);

	dirname = a_dirname;
	a_code = 0;

	my_kstp = pds$kstp;
	his_kstp, his_dsegp = null ();
	level = level$get ();
	call level$set (0);

/* verify kst_seg exists, is a segment, and has brackets 0, 0, 0 */

	call initiate_r0_seg ("template_kst", his_kstp);

/* verify dseg exists, is a segment, and has brackets 0, 0, 0 */

	call initiate_r0_seg ("template_dseg", his_dsegp);

/* verify modify permission on containing directory */

	call fs_modes ((my_kstp -> kst.kst_entry (bin (baseno (his_kstp))).entryp), mode, exmode, rings, code);
	if code ^= 0 then call abort_delete (code);
						/* UNCOMMENT WHEN FS_GET FIXED
						   if level > rings (2) then call abort_delete (0);
						   */
	if (mode & M_ACCESS) ^= M_ACCESS then call abort_delete (0);

/* validate that this is a template kst */

	if ^his_kstp -> kst.template then call abort_delete (0);

/* okay lets do it */

	call delete_r0_seg (his_kstp, "template_kst");
	call delete_r0_seg (his_dsegp, "template_dseg");
	call level$set (level);
	return;

initiate_r0_seg: proc (ename, segptr);
dcl  ename char (*),
     segptr ptr;
	     call initiate (dirname, ename, "", 0, 0, segptr, code);
	     if segptr = null () then call abort_delete (code);
	     if my_kstp -> kst.kst_entry (bin (baseno (segptr))).dirsw
	     then call abort_delete (0);
	     call fs_modes (segptr, mode, exmode, rings, code);
	     if code ^= 0 then call abort_delete (code);
	     if rings (1) ^= 0 | rings (2) ^= 0 | rings (3) ^= 0
	     then call abort_delete (0);		/* tut, tut */
	     return;
	end initiate_r0_seg;

delete_r0_seg: proc (segptr, ename);
dcl  segptr ptr,
     ename char (*);
	     call delentry$dseg (segptr, code);
	     if code ^= 0
	     then do;
		call set$safety_sw_path (dirname, ename, "0"b, (0));
		call set$copysw (dirname, ename, 0, (0));
		call delentry$dseg (segptr, code);
		if code ^= 0 then call abort_delete (code);
	     end;
	     segptr = null ();
	     return;
	end delete_r0_seg;

abort_delete: proc (code);
dcl  code fixed bin (35);
	     if his_kstp ^= null () then call terminate_$noname (his_kstp, (0));
	     if his_dsegp ^= null () then call terminate_$noname (his_dsegp, (0));
	     call level$set (level);
	     if code = 0
	     then a_code = error_table_$action_not_performed;
	     else a_code = code;
	     go to return_to_caller;
	end abort_delete;

return_to_caller:
	return;
/*
   
*/
%include access_mode_values;
/*
   
*/
%include dir_entry;
/*
   
*/
%include kst;
/*
   
*/
%include sdw;

     end template_address_space;




		    terminate_.pl1                  11/11/89  1132.4r w 11/11/89  0800.7       71073



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

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

terminate_: proc (a_segptr, a_rsw, a_code);

/* This procedure provides a variety of entries to remove names and segments 
   from the RNT and KST.

   Written October 1974 by R. Bratt as a write around for the old terminate

   Last modified:

   R. Bratt 06/03/76 to call find_$finished
   M. Weaver 04/77 to ignore code r0_refname and to zero lot entry when appropriate
   B. Margulies May 1982 to not trash refnames with noname terminations.
   Keith Loepere July 1984 to use the new dc_find.
   Keith Loepere November 1984 to rename to terminate_; add auditing support;
	also to remove unused directory undetectability.

   -- ->  terminate_$teseg remove the KST entry for a segment given its segment pointer.
   USAGE: call terminate_$teseg, call hcs_$terminate_seg (segptr, rsw, code)

   -- ->  terminate_$tefile removes a segments KST entry, given its directory pathname and entry name
   USAGE: call terminate_$tefile, call hcs_$terminate_file (dirname, ename, rsw, code);

   -- ->  terminate_$noname removes a single null name from a segment given its segment pointer.
   USAGE: call terminate_$noname call hcs_$terminate_noname (segptr, code)

   -- ->  terminate_$name removes a reference name from a segment.
   USAGE: call terminate_$name, call hcs_$terminate_name (name, code)
   note: these last two entries will also remove the KST entry if they have
   deleted the segments last name.

   -- ->  terminate_$id removes a segment from the kst by uid.  It is an 
   internal interface to be used by delentry.
   USAGE: call terminate_$id (uid, rsw, code);

   1) segptr ptr - - - pointer to the segment
   2) rsw fixed bin(1) - - - =1 reserve this segment number for later use, = 0 don't bother
   3) code fixed bin - - - error code (output)
   4) dirname char(*) - - - pathname of superior directory
   5) ename char(*) - - - entry name of segment
   6) name char(*) - - - reference name of segment
   7) uid bit (36) aligned - - - unique identifier of segment

   */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_name			char (*) parameter;
dcl  a_rsw			fixed bin (1) parameter;
dcl  a_segptr			ptr parameter;
dcl  a_uid			bit (36) aligned parameter;

/* Variables */

dcl  code				fixed bin (35);
dcl  dirname			char (168);
dcl  ename			char (32);
dcl  hash_bucket			fixed bin (17);
dcl  n_names			fixed bin;
dcl  refname			char (32) var;
dcl  rsw				fixed bin (1);
dcl  segno			fixed bin (17);
dcl  segptr			ptr;
dcl  uid				bit (36) aligned;

/* External */

dcl  error_table_$r0_refname		ext fixed bin (35);
dcl  error_table_$root		ext fixed bin (35);
dcl  error_table_$seg_deleted		ext fixed bin (35);
dcl  pds$stacks			(0:7) ptr ext;

/* Misc */

dcl  (baseno, baseptr, bit, dim, fixed, mod, ptr, rel) builtin;

/* Entries */

dcl  level$get			ext entry () returns (fixed bin);
dcl  lock$dir_unlock		ext entry (ptr);
dcl  makeunknown_			ext entry (fixed bin (17), bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  makeunknown_$protect_names	ext entry (fixed bin, fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  ref_name_$delete		ext entry (char (32) varying, fixed bin (17), fixed bin (35));
dcl  ref_name_$delete_segno		ext entry (fixed bin (17), fixed bin (35));
dcl  ref_name_$get_count		ext entry (fixed bin (17), fixed bin (17), fixed bin (35));
dcl  ref_name_$get_segno		ext entry (char (32) varying, fixed bin (17), fixed bin (35));
%page;
teseg: entry (a_segptr, a_rsw, a_code);

	segptr = a_segptr;
	rsw = a_rsw;
	segno = fixed (baseno (segptr), 17);
	call dc_find$obj_terminate_ptr (segptr, ep, code);
	if code = 0 then call lock$dir_unlock (ptr (ep, 0));
	if code = error_table_$root then code = 0;
	if code = error_table_$seg_deleted then code = 0;
	if code = 0 then call term_seg;
	a_code = code;
	return;
%page;
tefile: entry (a_dirname, a_ename, a_rsw, a_code);

	dirname = a_dirname;
	ename = a_ename;
	rsw = a_rsw;
	call dc_find$obj_terminate (dirname, ename, DC_FIND_CHASE, ep, code);
	if code = 0 then do;
	     uid = entry.uid;
	     call dc_find$finished (ptr (ep, 0), "1"b);
	     call term_uid;
	end;
	a_code = code;
	return;
%page;
noname: entry (a_segptr, a_code);

	segptr = a_segptr;
	segno = fixed (baseno (segptr), 17);
	call dc_find$obj_terminate_ptr (segptr, ep, code);
	if code = 0 then call lock$dir_unlock (ptr (ep, 0));
	if code = error_table_$root then code = 0;
	if code = error_table_$seg_deleted then code = 0;
	if code = 0 then do;
	     call ref_name_$get_count (segno, n_names, code);
	     if code ^= 0 then				/* r0_refname */
		n_names = 0;				/* no refnames */
	     if n_names > 0 then
		call terminate_and_zero_lot$$protect (segno, ""b, n_names, code);
	     else call terminate_and_zero_lot (segno, ""b, code);
	end;
	a_code = code;
	return;
%page;
name: entry (a_name, a_code);

	refname = a_name;
	call ref_name_$get_segno (refname, segno, code);
	if code = 0 then do;
	     segptr = baseptr (segno);
	     call dc_find$obj_terminate_ptr (segptr, ep, code);
	     if code = 0 then call lock$dir_unlock (ptr (ep, 0));
	     if code = error_table_$root then code = 0;
	     if code = error_table_$seg_deleted then code = 0;
	     if code = 0 then do;
		call ref_name_$delete (refname, segno, code);
		if code = 0 then call terminate_and_zero_lot (segno, "0"b, (0));
	     end;
	end;
	a_code = code;
	return;
%page;
id:  entry (a_uid, a_rsw, a_code);			/* called from hardcore */

	uid = a_uid;
	rsw = a_rsw;
	code = 0;
	call term_uid;
	a_code = code;
	return;
%page;
term_seg: proc;

	call ref_name_$delete_segno (segno, code);
	if (code = 0) | (code = error_table_$r0_refname) then
	     call terminate_and_zero_lot (segno, bit (rsw, 1) || "1"b, code);
	return;
     end;

term_uid: proc;

	kstp = pds$kstp;
	hash_bucket = mod (fixed (uid), dim (kst.uid_hash_bucket, 1));
	do kstep = ptr (kstp, kst.uid_hash_bucket (hash_bucket))
	     repeat (ptr (kstp, kste.fp)) while (rel (kstep) ^= "0"b);
	     if uid = kste.uid then do;
		segno = kste.segno;
		call term_seg;
		return;
	     end;
	end;
	return;
     end;
%page;
terminate_and_zero_lot: proc (segnum, switches, ecode);

dcl  ecode			fixed bin (35) parameter;
dcl  segnum			fixed bin (17) parameter;
dcl  switches			bit (36) aligned parameter;

dcl  n_names			fixed bin;
dcl  ring				fixed bin;
dcl  zero_lot			bit (1) aligned;

	call makeunknown_ (segnum, switches, zero_lot, ecode);
	go to Join;

terminate_and_zero_lot$$protect:
     entry (segnum, switches, n_names, ecode);

	call makeunknown_$protect_names (segnum, n_names, switches, zero_lot, ecode);
	if ecode ^= 0 then return;

Join:
	if zero_lot then do;
	     ring = level$get ();

	     if segnum <= pds$stacks (ring) -> stack_header.cur_lot_size then do;
						/* don't wipe out locations not in lot, isot */
		pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segnum) = baseptr (0);
		pds$stacks (ring) -> stack_header.isot_ptr -> isot.isp (segnum) = baseptr (0);
	     end;
	end;
     end;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include kst;
%page; %include lot;
%page; %include stack_header;
     end;




		    trap_caller_caller_.pl1         11/11/89  1132.4r w 11/11/89  0800.7       68913



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


trap_caller_caller_: proc (mcptr, header_ptr, def_ptr, type_ptr, link_ptr, ecode_ptr, code);

/* This procedure is called by the linker (link_snap) when a trap-before-link or
   trap-at-first-reference is to be satisfied.  It creates a frame in the stack
   of the faulting ring, putting machine conditions there (with the help of the signaller),
   sets up an argument list in that frame, and "calls" trap caller in the
   outer ring.  The pointer to trap_caller's entry point is obtained via
   link_snap$make_ptr so that its linkage section will be properly set up in the outer ring.

   The "call" will wipe out the stack we are running on, and the return from trap_caller
   will actually go to the return point in restart_fault so that the machine conditions
   can be restarted.

   The entry "for_linker" in signaller is used to perform some of the necessary "secure" features
   of the restart such as saving a copy of the machine conditions in ring 0 and setting up a
   cleanup handler to discard these saved machine conditions if they are not to be restarted.

   Initially coded by M Weaver June 1973
   Revised:
   April 75	by S. Webber to add "secure restart" features.
*/

declare (mcptr, header_ptr, def_ptr, type_ptr, link_ptr, entry_ptr, old_sp, ecode_ptr) ptr;

declare  i fixed bin;

declare  link_snap$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
declare  signaller$for_linker entry (ptr, ptr);
declare  level$get entry () returns (fixed bin);

declare  code fixed bin (35);
declare  level fixed bin (18);
declare (frame_add, temp) fixed bin (19);
declare  pds$signal_data (48) fixed bin ext;
declare  m_c (48) fixed bin based;
declare  based_fixed based fixed bin;
declare  error_table_$no_trap_proc ext fixed bin (35);

declare  label_var label;
declare 1 label_temp aligned based,			/* label template */
        2 (locp, stackp) ptr;

declare (addr, addrel, baseno, baseptr, bin, bit, divide, null, ptr, rel) builtin;

declare 1 trap_return_frame aligned based (sp),		/* template for frame we will build */
        2 frame_header (40) fixed bin,
        2 pad (8) fixed bin,
        2 mach_cond (48) fixed bin,			/* put in same place that signaller would */
        2 arg (7) ptr,				/* are the arguments:
						   mcptr, header_ptr, def_ptr, type_ptr, link_ptr;
						   mcptr must stay where it is because
						   signaller may need it for illegal_return */
        2 arglist,
	3 arg_count bit (18) unaligned,
	3 code bit (18) unaligned,
	3 desc_count bit (18) unaligned,
	3 pad bit (18) unaligned,
	3 arg_ptrs (7) ptr,
        2 pad1 (2) fixed bin,
        2 on_unit (16) fixed bin;

/* The variables mach_cond and on_unit in the above structure must start at 48 and 128 words
   from the beginning of the structure respectively because the signaller uses these regions
   of the stack frame set up by trap_caller_caller_. */
/*  */
%include stack_header;
%include its;
%include stack_frame;
%include mc;
/*  */
/* get ptr to trap caller proc in outer ring */
/* validation level has already been set correctly */

begin:	call link_snap$make_ptr (null, "link_trap_caller_", "link_trap_caller_", entry_ptr, code);
	if code ^= 0 then do;			/* have linker return linkage_error */
	     code = error_table_$no_trap_proc;
	     return;
	end;

	if mcptr ^= null then old_sp = mcptr -> mc.prs (6); /* get ptr to proper stack */
	else do;					/* no mc; get old_sp by tracing threads */
	     label_var = begin;			/* use big kludge to get sp */
	     sp = addr (label_var) -> label_temp.stackp;	/* labels have stack ptrs */

/* get frame of caller of link_snap */
/* look for last sp in stack of validation level because */
/* external reference is being processed for ring of validation level */

	     level = level$get ();			/* get validation level */
	     i = 0;				/* initialize */
	     if level = 0 then old_sp = sp;		/* we are the last frame */
	     else do;
		do while (baseno (sp -> stack_frame.prev_sp) = baseno (sp));
		     sp = sp -> stack_frame.prev_sp;	/* try previous one */
		     i = i + 1;
		     if i = 2000 then do;		/* don't loop in ring 0 */
			code = error_table_$no_trap_proc;
			return;
		     end;
		end;
		if bin (addr (sp -> stack_frame.prev_sp) -> its.ringno, 3) ^= level then do;

/* there are stacks in rings between r0 and target ring which
   we are not prepared to handle, so we will abort with a
   linkage_error and let the condition mechanism clean up */

		     code = error_table_$no_trap_proc;
		     return;
		end;
		old_sp = sp -> stack_frame.prev_sp;	/* we found the most recent frame in target ring */
	     end;
	end;


	sb = ptr (old_sp, 0);			/* get ptr to base of new stack */
	temp = bin (rel (sb -> stack_header.stack_end_ptr), 18); /* find starting offset */
	if mcptr ^= null then do;			/* get ring number from mc */
	     frame_add = temp + stack_frame_min_length;
	     old_sp -> stack_frame_flags.signaller = "1"b; /* set appropiate flags so will know to truncate */
	     old_sp -> stack_frame_flags.old_signaller = "1"b;
	end;
	else do;					/* were called; frame not inconsistent */
	     frame_add = temp;			/* start where old left off */
						/* no mc, so don't worry about mod 16 */
	end;

/* add new frame to outer ring stack */

	sp,					/* get ptr to new stack frame */
	     old_sp -> stack_frame.next_sp = ptr (sb, frame_add);

/* thread in new frame */

	sp -> stack_frame.next_sp,
	     sb -> stack_header.stack_end_ptr = addrel (sp, size (trap_return_frame));
	sp -> stack_frame.prev_sp = old_sp;

	sp -> stack_frame_flags.link_trap = "1"b;	/* previous frame was faulted out of */
	sp -> stack_frame.translator_id = bit (bin (10, 18), 18); /* trap_caller_caller_ frame */

/* fill in arguments */

	if mcptr = null then sp -> trap_return_frame.arg (2) = null; /* no mc */
	else do;					/* arg must point to copied mc */
	     old_sp -> stack_frame_flags.old_signaller = "1"b; /* must be after next_sp is updated */
	     pds$signal_data = mcptr -> m_c;
	     sp -> trap_return_frame.arg (2) = addr (sp -> trap_return_frame.mach_cond);
	end;
	sp -> trap_return_frame.arg (1) = null;
	sp -> trap_return_frame.arg (3) = header_ptr;
	sp -> trap_return_frame.arg (4) = def_ptr;
	sp -> trap_return_frame.arg (5) = type_ptr;
	sp -> trap_return_frame.arg (6) = link_ptr;
	sp -> trap_return_frame.arg (7) = ecode_ptr;	/* points to ec in linker caller's frame */

/* fill in argument list */

	sp -> trap_return_frame.arglist.arg_count = bit (bin (12, 18), 18);
	sp -> trap_return_frame.arglist.code = bit (bin (4, 18), 18);
	sp -> trap_return_frame.arglist.desc_count,
	     sp -> trap_return_frame.arglist.pad = "0"b;


	do i = 1 to 7;
	     sp -> trap_return_frame.arglist.arg_ptrs (i) =
		addr (sp -> trap_return_frame.arg (i));
	end;

/* put arglist ptr where next proc can find it */

	sp -> stack_frame.operator_and_lp_ptr = addr (trap_return_frame.arglist);

	call signaller$for_linker (sp, entry_ptr);

	return;					/* this will never be executed */
     end;




		    truncate.pl1                    11/11/89  1132.4r w 11/11/89  0800.7       58428



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

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

truncate$trfile: proc (a_dirname, a_ename, a_addrs, a_code);

/* 	Date last modified and reasons:
   11/84 by Keith Loepere for terminate_.
   7/84 by Keith Loepere to use the new dc_find.
   1/82 BIM to lock dir for write to protect truncate_vtoce from activations.
   11/2/78 by B. Greenberg for raw/effective mode problem (not checking priv_init).
   760630 by L. Scheffler to not audit truncates on copy-on-write segs
   05/31/76 by R. Bratt to call find_$finished
   04/20/76 by R.  Bratt to  check mountedness before truncate
   760309 by L. Scheffler to use info-only entries in dir_control_error
   04/28/75 by Greenberg for NSS
   10/10/74 by Kobziar to call new access_mode entry
   08/24/71 by RHG for page multi-level and to clean up the overlay for zeroing
   07/27/71 by David Vinograd
   06/13/71 by R. Gumpertz to check for negative addrs
   06/12/71 by R. Gumpertz to add zeroing of last page after addrs
   and to check fpage properly against seg length
   and to eliminate accessing of a_addrs while
   a directory is locked
 */
%page;

/* Parameters */

dcl  a_addrs			fixed bin (17) parameter;
dcl  a_code			fixed bin (35) parameter;
dcl  a_dirname			char (*) parameter;
dcl  a_ename			char (*) parameter;
dcl  a_ep				ptr parameter;
dcl  a_segptr			ptr parameter;

/* Variables */

dcl  addrs			fixed bin (17);
dcl  by_name			bit (1) aligned init ("0"b);
dcl  code				fixed bin (35);
dcl  ename			char (32);
dcl  esw				fixed bin (17);
dcl  fpage			fixed bin (17);
dcl  overlay_size			fixed bin;
dcl  parent			char (168);
dcl  segptr			ptr;
dcl  write_lock			bit (36) aligned init ((36)"1"b);

/* Based */

dcl  overlay			bit (overlay_size) based aligned; /* This is used to get at the words to be zeroed */

/* External */

dcl  error_table_$argerr		fixed bin (35) external;
dcl  error_table_$boundviol		fixed bin (35) external;
dcl  error_table_$dirseg		fixed bin (35) external;
dcl  error_table_$rqover		fixed bin (35) external;
dcl  pds$processid			bit (36) aligned ext;

/* Entries */

dcl  get_kstep			entry (fixed bin (18), ptr, fixed bin (35));
dcl  initiate			entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  lock$dir_unlock		entry (ptr);
dcl  mountedp			entry (bit (36) aligned) returns (fixed bin (35));
dcl  sum$dirmod			entry (ptr);
dcl  terminate_$noname		entry (ptr, fixed bin (35));
dcl  truncate_vtoce			entry (ptr, fixed bin, fixed bin (35));

/* Misc */

dcl  (addrel, baseno, divide, fixed, null, ptr) builtin;

dcl  out_of_bounds			condition;
%page;
	esw = 0;					/* set entry point switch */
	code = 0;
	addrs = a_addrs;				/* copy the args */
	parent = a_dirname;				/* copy directory name */
	ename = a_ename;				/* copy entry name */
	call dc_find$obj_truncate (parent, ename, ep, code); /* get pointer to branch + lock directory */
	dp = ptr (ep, 0);
	if code ^= 0 then go to finale;
	by_name = "1"b;
	go to join;				/* transfer to common code */

trseg: entry (a_segptr, a_addrs, a_code);

	esw = 1;					/* set entry point switch */
	code = 0;
	addrs = a_addrs;				/* copy the addrs given */
	segptr = ptr (a_segptr, 0);			/* copy argument */

	call get_kstep (fixed (baseno (segptr)), kstep, code);
	if code ^= 0 then go to finale;

	if kste.priv_init then call dc_find$obj_truncate_raw_ptr (segptr, ep, code); /* get pointer to branch + lock directory */
	else call dc_find$obj_truncate_ptr (segptr, ep, code); /* get pointer to branch + lock directory */
	if code ^= 0 then go to finale;
	dp = ptr (ep, 0);

join:	if ep -> entry.dirsw then do;			/* truncating directories not allowed */
	     code = error_table_$dirseg;
	     go to unlock;
	end;

	if addrs < 0 then do;			/* check for negative length specified */
	     code = error_table_$argerr;
	     go to unlock;
	end;
						/* check for length too big */

	fpage = divide (addrs + 1023, 1024, 17, 0);	/* get number of first page to be truncated */

	go to join1;

trentry: entry (a_ep);

	esw = 2;
	fpage = 0;
	ep = a_ep;
	code = 0;
	dp = ptr (ep, 0);
join1:

	code = mountedp (dir.sons_lvid);
	if code = 0
	then do;
	     dir.modify = pds$processid;		/* Mark dir inconsistent */

	     call truncate_vtoce (ep, fpage, code);	/* Truncate the vtoce/aste */

	     if code ^= 0 then if code = error_table_$rqover then code = 0; /* ignore rqo */
	end;
	if esw = 2 then return;			/* if deleting, return */


	dir.modify = "0"b;
	call sum$dirmod (dp);
	if by_name
	then call dc_find$finished (dp, "1"b);
	else call lock$dir_unlock (dp);		/* unlock the directory */

/* 	The following code zeros out the last page of the segment starting
   at addrs. This is so that truncating will be to the word, rather than
   to the page.
   */

	if code ^= 0 then go to finale;

	on condition (out_of_bounds) go to boundviol;	/* Attempt to trunc beyond current length
						   may cause oob here */
	overlay_size = (fpage * 1024 - addrs) * 36;	/* compute n bits to zero */
	if overlay_size ^= 0 then do;			/* dont bother if none to zero */
	     if esw = 0 then do;			/* if entered without ptr, we must get one */
		call initiate (parent, ename, "", 0, 1, segptr, code);
		if segptr = null then goto finale;
		code = 0;				/* forget any segknowns */
	     end;
	     addrel (segptr, addrs) -> overlay = ""b;	/* clear the words */
	     if esw = 0 then call terminate_$noname (segptr, code); /* terminate the pointer if we had to get one */
	end;

finale:	a_code = code;
	return;

unlock:	if dir.modify then dir.modify = "0"b;
	if by_name
	then call dc_find$finished (dp, "1"b);
	else call lock$dir_unlock (dp);
	go to finale;

boundviol:
	a_code = error_table_$boundviol;
	return;
%page;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include kst;
     end;




		    uid_path_util.pl1               11/11/89  1132.4rew 11/11/89  0800.7       50589



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

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

/* Procedure which contains some entires that now how to deal with uid pathnames.
   This module was written for use by Master directory Control. */

/* UID_PATH_UTIL has the following entries:

   1. uid_path_util$get: Given a pointer to a directory, this entry returns the uidpathname of its parent

   2. uid_path_util$get_uid_path: A gate entry which, given a pathname, returns
   a uid pathname.

   3. uid_path_util$decode_uidpath: A gate entry which, given a uid pathanme,
   returns a directory and entry name.


*/

/* Written March 1975 by Larry Johnson */
/* Modified July 1984 by Keith Loepere to use the new dc_find. */
/* Modified January 1985 by EJ Sharpe to handle et_$root */
/* Modified May 1985 by EJ Sharpe to add decode_uidpath_raw and decode_uidpath_priv,
	the decode_uidpath entry now requires "S" on parent */

uid_path_util: proc;

/* Parameters */

dcl  a_code			fixed bin (35);
dcl  a_dirname			char (*);		/* Name of directory to return */
dcl  a_dp				ptr;		/* Returned pointer to the directory */
dcl  a_ename			char (*);		/* Entry name to return */
dcl  a_uidpath			(0:15) bit (36) aligned; /* Pathname of directory to find */

/* Variables */

dcl  build_dir			char (168) var init ("");
dcl  code				fixed bin (35);
dcl  decodesw			bit (1) init ("0"b);/* Set if entered thru decode_uidpath entry */
dcl  dirsw			bit (1) init ("0"b);/* Set if entered thru dir entry */
dcl  dname			char (168);
dcl  ename			char (32);
dcl  i				fixed bin;
dcl  segnum			fixed bin;
dcl  uidpath			(0:15) bit (36) aligned;

/* Misc */

dcl  (ptr, segno, unspec)		builtin;

/* External */

dcl  error_table_$bad_uidpath		ext fixed bin (35);
dcl  error_table_$root		ext fixed bin (35);

/* Entries */

dcl  get_kstep$dir			entry (fixed bin, ptr, fixed bin (35));
dcl  uid_path_util$get		entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35));
%page;

/* This entry will get a uid pathname from a directory pointer */

get: entry (a_dp, a_uidpath, a_code);

	a_code = 0;
	dp = a_dp;
	a_uidpath = "0"b;

	do i = dir.tree_depth to 0 by -1;		/* Scan backwards thru all parents */
	     segnum = segno (dp);
	     call get_kstep$dir (segnum, kstep, code);	/* Find the kst entry */
	     if code ^= 0 then go to err;
	     a_uidpath (i) = kste.uid;
	     dp = kste.entryp;			/* Back to parent */
	end;
	return;


/* This entry is called thru a gate. Given a directory and entry name,
   it returns the uidpath */

get_uidpath: entry (a_dirname, a_ename, a_uidpath, a_code);

	dname = a_dirname;
	ename = a_ename;
	unspec (a_uidpath) = "0"b;
	call dc_find$obj_status_read_priv (dname, ename, DC_FIND_NO_CHASE, ep, code); /* Find my seg */
	if code ^= 0 then go to err;
	dp = ptr (ep, 0);
	call uid_path_util$get (dp, uidpath, code);	/* Get uidpath of parent */
	if code ^= 0 then do;
	     call dc_find$finished (dp, "1"b);
	     go to err;
	end;
	uidpath (dir.tree_depth + 1) = entry.uid;	/* Finish up with uid of entry */
	call dc_find$finished (dp, "1"b);
	a_uidpath = uidpath;
	return;

err:	a_code = code;
	return;

/* This entry, called thru a gate, will return a directory and entry name,
   given a uidpath name.  The caller must have "S" access on parent of the entry.
   It is used by master directory control via admin_gate_. */

decode_uidpath: entry (a_uidpath, a_dirname, a_ename, a_code);

	uidpath = a_uidpath;
	a_dirname, a_ename = "";
	a_code = 0;

	call dc_find$obj_status_read_uid (uidpath, dname, ename, ep, code);
	goto decode_common;

/* This entry, called thru a gate, will return a directory and entry name,
   given a uidpath name.  The caller need not have "S" access on parent of the entry. */

decode_uidpath_priv: entry (a_uidpath, a_dirname, a_ename, a_code);

	uidpath = a_uidpath;
	a_dirname, a_ename = "";
	a_code = 0;

	call dc_find$obj_status_read_priv_uid (uidpath, dname, ename, ep, code);
	goto decode_common;

/* This entry, called thru a gate, will return a directory and entry name,
   given a uidpath name.  It allows access to the names of aim isolated dirs.
   It is called from the volume backup system via the hc_backup_ gate. */

decode_uidpath_raw: entry (a_uidpath, a_dirname, a_ename, a_code);

	uidpath = a_uidpath;
	a_dirname, a_ename = "";
	a_code = 0;

	call dc_find$obj_status_read_raw_uid (uidpath, dname, ename, ep, code);


decode_common:
	if code = error_table_$root
	then do;
	     code = 0;
	     ename = "";				/* no entry */
	end;
	else if code = error_table_$bad_uidpath then do;	/* return what we know */
	     a_dirname = dname;
	     a_ename = "";
	     go to err;
	end;
	else if code ^= 0
	     then go to err;			/* return the error */
	else call dc_find$finished (ptr (ep, 0), "1"b);	/* we're finished */

	a_dirname = dname;
	a_ename = ename;
	a_code = 0;
	return;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include kst;
     end uid_path_util;




		    vacate_pv.pl1                   11/11/89  1132.4rew 11/11/89  0800.7       49716



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



/****^  HISTORY COMMENTS:
  1) change(88-05-01,Parisek), approve(88-05-27,MCR7907),
     audit(88-06-02,Fawcett), install(88-09-27,MR12.2-1122):
     Changed to NOT set pc_vacating in the pvte. This flag would inhibit any
     new pages being withdrawed from this pv. The concept of inhibit is to
     inhibit any new segments. If pc_vacating is set and a segment like the
     kst needs one more page, the system loop trying to get a page on the pv.
     The kst cannot be moved.
                                                   END HISTORY COMMENTS */


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

vacate_pv: proc (a_pvtx, a_pvid, a_code);


/* vacate_pv     Bernard Greenberg 05/24/76

   Procedure to segmove all of the segments on a given physical volume.
   Must be driven by pathname from outer ring. */

/* modified 4/77 by M. Weaver to change calling sequences to makeknown_ and terminate_ */
/* Modified March 1982, J. Bongiovanni, for new PVTE, demand_segmove */
/* Modified 84-10-17, BIM, TEMPORARILY set pvte.pc_vacating */
/* Modified July 1984 by Keith Loepere to use the new dc_find. */
/* Modified November 1984 by Keith Loepere for auditing. */

/* Parameters */

dcl  a_code			fixed bin (35);
dcl  a_dirname			char (*);
dcl  a_ename			char (*);
dcl  a_pvid			bit (36) aligned;
dcl  a_pvtx			fixed bin;
dcl  a_segptr			ptr;

/* External */

dcl  error_table_$argerr		fixed bin (35) ext;
dcl  error_table_$bad_index		fixed bin (33) ext;
dcl  error_table_$segknown		fixed bin (35) ext;
dcl  pvt$n_entries			fixed bin ext;

/* Variables */

dcl  called_find			bit (1) aligned init ("0"b);
dcl  code				fixed bin (35);
dcl  dir				char (168);
dcl  dp				ptr;
dcl  ent				char (32);
dcl  1 mkinf			aligned like makeknown_info;
dcl  pvid				bit (36) aligned;
dcl  pvtx				fixed bin;
dcl  segno			fixed bin;
dcl  segptr			ptr;

/* Entries */

dcl  activate			entry (ptr, fixed bin (35)) returns (ptr);
dcl  lock$dir_unlock		entry (ptr);
dcl  makeknown_			entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  makeunknown_			entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
dcl  segment_mover$demand_segmove	entry (ptr, ptr, fixed bin, fixed bin (35));

/* Misc */

dcl  (addr, ptr, unspec)		builtin;
%page;

/* These entries are not protected by any form of lock. It is assumed that the
   caller is cooperating with the demounter in the setting of these bits. */
	pvtx = a_pvtx;
	pvt_arrayp = addr (pvt$array);
	pvid = a_pvid;
	code = 0;
	if pvtx <= 0 | pvtx > pvt$n_entries then do;
	     a_code = error_table_$bad_index;
	     return;
	end;
	pvtep = addr (pvt_array (pvtx));		/* Address pvte */

	if pvte.being_demounted | (pvte.pvid ^= pvid) then
	     code = error_table_$argerr;
	else if pvte.storage_system & pvte.used & pvid = pvte.pvid then
	     pvte.vacating = "1"b;
	else code = error_table_$argerr;

	a_code = code;
	return;

stop_vacate: entry (a_pvtx, a_pvid, a_code);

	pvt_arrayp = addr (pvt$array);
	pvid = a_pvid;
	pvtx = a_pvtx;
	code = 0;
	if pvtx <= 0 | pvtx > pvt$n_entries then do;
	     a_code = error_table_$bad_index;
	     return;
	end;
	pvtep = addr (pvt_array (pvtx));
	if pvte.used & pvte.storage_system & pvte.vacating & (pvte.pvid = pvid) then
	     pvte.vacating = "0"b;
	else code = error_table_$argerr;
	a_code = code;
	return;
%page;
move_seg_file: entry (a_dirname, a_ename, a_code);

/* This entry starts a segmove on a seg given the name */

	dir = a_dirname;
	ent = a_ename;
	code = 0;

	call dc_find$obj_status_write_priv (dir, ent, DC_FIND_CHASE, FS_OBJ_SEG_MOVE, ep, code);
	if code ^= 0 then go to finale;
	called_find = "1"b;
	go to join;				/* Merge with seg entry */

move_seg_seg: entry (a_segptr, a_code);

	segptr = a_segptr;
	code = 0;
	call dc_find$obj_status_write_priv_ptr (segptr, FS_OBJ_SEG_MOVE, ep, code);
	if code ^= 0 then go to finale;

join:	dp = ptr (ep, 0);

	makeknown_infop = addr (mkinf);		/* Get local makeknown info */
	unspec (makeknown_info) = ""b;		/* Clear all things we don't know about */
	makeknown_info.uid = entry.uid;
	makeknown_info.dirsw = entry.dirsw;
	makeknown_info.entryp = ep;			/* Set up for makeknown */
	call makeknown_ (makeknown_infop, segno, (0), code);
	if code = 0 | code = error_table_$segknown then do;
	     astep = activate (ep, code);
						/* Get AST entry */
	     if code = 0 then do;
		aste.pack_ovfl = "1"b;		/* Cause seg mover to do thing */
		call segment_mover$demand_segmove (astep, ep, segno, code);
	     end;
	     call makeunknown_ (segno, "0"b, ("0"b), (0));
	end;
	if called_find then call dc_find$finished (dp, "1"b);
	else call lock$dir_unlock (dp);
finale:	a_code = code;
	return;
%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include fs_obj_access_codes;
%page; %include makeknown_info;
%page; %include pvte;
     end;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
