


		    backup_name_.pl1                11/15/82  1844.4rew 11/15/82  1513.1       24534


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


backup_name_:	procedure (name) returns (char(32));


/*

	This procedure, given a name in the series "name", "name.1", "name.2",
	etc., will return the next name in the series.

	P. Bos, May 1972

*/

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


     dcl	name			char(*);

     dcl	convert_binary_integer_$decimal_string	entry (fixed bin) returns (char(12) varying),
	cv_dec_			entry (char(*)) returns (fixed bin(35));

     dcl (index, length, substr)	builtin;

     dcl (i, j, k, l)		fixed bin;

     dcl	chr			char(1),
	string			char(12) varying;

/**/

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


	l = index (name, " ") - 1;			/* get length of segment name */
	if l = -1 then
	     l = length (name);			/* adjust if necessary */
	k = 0;					/* count of digits found */
	do i = l by -1 to 1;			/* start at end of name, work backwards */
	     chr = substr (name, i, 1);		/* get char at this position */
	     if chr = "." then			/* looking for ".nnn" suffix */
		go to dot;
	     else if (chr >= "0") then if (chr <= "9") then	/* char is a digit */
		go to skip;			/* will try again */
	     go to first;				/* other char; we are done */
skip:	     k = k + 1;				/* count chars, continue scan */
	     end;
	go to first;				/* all-digit name no good */

dot:	if k = 0 then				/* terminal "." no good either */
	     go to first;
	j = cv_dec_(substr (name, i+1, k));		/* convert number part of name to binary */
	if j = 0 then				/* if number part = 0, also no good */
first:	     string = "1";				/* fudge up string to avoid call */
	else do;					/* current name already part of series, */
	     j = j + 1;				/* increment suffix */
	     l = i - 1;				/* adjust length to exclude current suffix */
	     string = convert_binary_integer_$decimal_string (j);	/* convert to ascii */
	     end;

rtn:	k = length (string);			/* compute length of suffix */
	if l > 32 - k - 1 then			/* see if name too long to add suffix */
	     l = 32 - k - 1;			/* if so, truncate front part */
	return (substr (name, 1, l) || "." || string);	/* form new name and return */

	end backup_name_;
  



		    lfree_name.pl1                  11/15/82  1844.4rew 11/15/82  1513.2       37287


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


lfree_name: lfn:	procedure (path);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e_s:  lfree_name, lfn							*/
	/*									*/
	/*      This command is part of the Multics Installation System (MIS).  It frees the	*/
	/* entryname portion of its pathname argument so that this entryname may be used	*/
	/* on another segment.  If the final component of the entryname is "._n" where n is an 	*/
	/* integer, then the name is freed by adding one to _n.  Otherwise, the entryname is	*/
	/* freed by appending a component of ".1" to the name.				*/
	/*									*/
	/* E__n_t_r_i_e_s:  lfree_name, lfn							*/
	/*									*/
	/*       This entry frees an entryname.						*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      lfree_name  path_name							*/
	/*									*/
	/* 1) path_name	is the absolute or relative path name of the directory entryname	*/
	/*		which is to be freed. (Input)					*/
	/*									*/
	/* E__n_t_r_i_e_s:  lfree_name$restore, lfn$restore					*/
	/*									*/
	/*      This entry point restores an entryname which has been freed to its original value.*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      lfree_name$restore  path_name						*/
	/*									*/
	/* 1) path_name	is the original absolute or relative path name of the directory	*/
	/*		entryname which is to be restored. (Input)			*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 1) Created:  Jan, 1973 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


     dcl						/*	parameter				*/
	path			char(*);		/* pathname of the entryname to be freed.	*/

     dcl						/*	automatic variables			*/
 	Nargs			fixed bin,	/* number of input arguments we were passed.	*/
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168) aligned,	/* directory portion of path.			*/
	e			fixed bin,	/* entry point indicator.			*/
	entry			char(32) aligned;	/* entry portion of path.			*/

     dcl						/* 	entries and builtin functions		*/
	addr			builtin,
	com_err_			entry options (variable),
	cu_$arg_count		entry (fixed bin),
	expand_path_		entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
	length			builtin,
	upd_free_name_		entry (char(*) aligned, char(*) aligned, fixed bin(35)),
	upd_free_name_$restore	entry (char(*) aligned, char(*) aligned, fixed bin(35));

     dcl						/*	static variables			*/
	ep (2)			char(18) aligned int static init (
				     "lfree_name",
				     "lfree_name$restore"),
	error_table_$wrong_no_of_args	fixed bin(35) ext static;

	e = 1;					/* set entry point indicator.			*/
	go to common;

restore:	entry (path);				/* restore name entry point.			*/
	e = 2;					/* set entry point indicator.			*/

common:	call cu_$arg_count (Nargs);			/* make sure we were passed 1 argument.		*/
	if Nargs ^= 1 then
	     go to wrong_no_of_args;
	call expand_path_ (addr(path), length(path), addr(dir), addr(entry), code);
	if code ^= 0 then				/* convert relative path to absolute one.	*/
	     go to err;
	go to call(e);				/* make call appropo to our entry point.	*/

call(1):	call upd_free_name_ (dir, entry, code);
	go to join;
call(2):	call upd_free_name_$restore (dir, entry, code);	/* free or restore the entryname, as appropo	*/

join:	if code ^= 0 then
	     go to err;
	return;

wrong_no_of_args:
	call com_err_ (error_table_$wrong_no_of_args, (ep(e)),
	     "^/Calling sequence is:^-^a <path_name>", (ep(e)));
	return;

err:	call com_err_ (code, (ep(e)), "^a", path);


	end lfree_name;
 



		    upd_acl_task_.pl1               11/15/82  1844.4rew 11/15/82  1513.2      159588


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


upd_acl_task_:	procedure;


/*

	This procedure includes all acl task primitives for the Multics Online
	Updater; the following are entries:

		upd_acl_task_$list		list acl
		upd_acl_task_$add		add acl entries
		upd_acl_task_$delete	delete acl entries
		upd_acl_task_$replace	replace acl
		upd_acl_task_$list_inacl	list IACL of the target dir

      *   Calling sequences are identical, being

	     call upd_acl_task_$xxx (ctlw, areap, parentp, acode, asev, taskp, seqno,
		dir, seg, msgseg, uid, ap, an, recover);

	     (1)	ctlw	bit(36) aligned	updater task control word
	     (2)	areap	ptr		caller-supplied area
	     (3)	parentp	ptr		pointer to parent arglist
	     (4)	acode	fixed bin(35)	status code
	     (5)	asev	fixed bin		severity code
	     (6)	taskp	ptr init(null)	task pointer
	     (7)	seqno	fixed bin		task sequence no.
	     (8)	dir	char(168)		dirname of affected segment
	     (9)	seg	char(32)		entryname of segment
	    (10)  msgseg	char(32)		entryname of segment for use in messages
	    (11)	uid	bit(36) aligned	unique id of segment (may be ""b)
	    (12)	ap	ptr		pointer to acl structure
	    (13)	an	fixed bin		size of acl structure
	    (14)  recover	bit(1)		on if upd_acl_task_$replace should give this user and
					*.SysDaemon.*  rwa access to segment when running
					in "reverse" mode.
	*   (15)  rings	(3) fixed bin(5)	Extra arg for the "list_inacl" entry.  Determines
					the ring of the IACL to be listed.
	These entry points are restartable, e.g. after a system or process
	failure, provided that all parameters are preserved as of the time
	of the interruption.  Note, however, that severity 1 errors may occur
	if upd_acl_task_$delete is restarted, due to limitations in hardcore
	procedures.  "acode", "asev", and "taskp" are expected to be initialized
	to "0", "0", and "null" respectively.  The "list" entry in addition
	expects "ap" to be initially null.

	P. Bos, May 1972

	Modified Apr. 3, 1973 by Peter B. Kelley	to change acl structures and calls to
						use the new hcs_ acl primitives.
	Modified Jun. 1973 by P.B. Kelley		change to acl_form_sw because of drop
						of bit 2 in options to print_acl_; also renamed
						print_acl_ to upd_print_acl_.
	Modified Mar. 1980 by P. B. Kelley
	     The entry upd_acl_task_$list_inacl was added to list the IACL
	     of the target directory.

          Modified: 09/04/81 by GA Texada to call appropriate hcs_ entries on linkage error.

*/

/**/

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

     dcl	ctlw			bit(36) aligned,	/* updater control word */
	areap			ptr,		/* caller area pointer */
	parentp			ptr,		/* pointer to parent arglist */
	acode			fixed bin(35),	/* status code */
	asev			fixed bin,	/* severity code */
	taskp			ptr,		/* task pointer */
	seqno			fixed bin,	/* task sequence no., for ordering */
	dir			char(168),	/* dirname of affected segment */
	seg			char(32),		/* entryname of segment */
	msgseg			char(32),		/* entryname of segment used in messages.	*/
						/* guaranteed not to be a unique name.		*/
	uid			bit(36) aligned,	/* unique id of segment */
	ap			ptr,		/* pointer to acl structure */
	an			fixed bin,	/* acl count */
	recover			bit(1);		/* on if OK to run "replace" in "reverse" */
dcl
	rings (3)			fixed bin(5),	/* for the "list_inacl" entry */
	Parent_dir		char(168),	/* parent dir of the target seg */
	Idir			char(168);	/* list the INACL of this dir */

     dcl	cu_$arg_list_ptr		entry (ptr),
	cv_acl_			entry (ptr, fixed bin, char(*), fixed bin, bit(*)),
	expand_pathname_		entry ( char(*), char(*), char(*), fixed bin(35)),
	get_group_id_$tag_star	entry returns (char(32)),
	add_acl_entries_entry	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)) variable,
	delete_acl_entries_entry	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)) variable,
	replace_acl_entry		entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35)) variable,
	hcs_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$delete_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$list_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	hcs_$list_inacl		entry ( char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(5), fixed bin(35)),
	hcs_$replace_acl		entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35)),
	ioa_$ioa_stream		entry options (variable),
	upd_print_acl_		entry (ptr, fixed bin, bit(*) aligned),
	upd_add_task_		entry (char(*) aligned, ptr),
	installation_tools_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	installation_tools_$delete_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	installation_tools_$replace_acl	entry (char(*), char(*), ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	upd_status_$long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	upd_task_err_		entry options (variable);

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

     dcl linkage_error		condition;

     dcl (error_table_$bad_ring_brackets,
	error_table_$empty_acl,
	error_table_$newnamerr,
	error_table_$non_matching_uid,
	error_table_$user_not_found)	ext fixed bin(35);

     dcl	acl_form_sw (5)		bit(3) aligned int static init (
				     "100"b,		/* e = 1	*/
				     "110"b,		/* e = 2	*/
				     "010"b,		/* e = 3	*/
				     "110"b,		/* e = 4	*/
				     "100"b),		/* e = 5  */
	entry (5)			char(32) aligned int static init (
				     "upd_acl_task_$list",		/* e = 1	*/
				     "upd_acl_task_$add",		/* e = 2	*/
				     "upd_acl_task_$delete",		/* e = 3	*/
			 	     "upd_acl_task_$replace",		/* e = 4	*/
				     "upd_acl_task_$list_inacl");	/* e = 5  */
     dcl	string			char(52);		/* return string for cv_acl_ */

     dcl	msg (5)			char(12) aligned int static init (
				"List ACL", "Set ACL", "Delete ACL", "Replace ACL", "List INACL");

     dcl	code			fixed bin(35),	/* status code */
	e			fixed bin,	/* entry index */
         (i, n)			fixed bin,	/* random */
	sev			fixed bin;	/* severity code */

     dcl	logsw			bit(1) aligned,	/* non-zero if printing */
	rsw			bit(1) aligned,	/* non-zero if processing in reverse direction	*/
	runsw			bit(1) aligned;	/* non-zero if processing */

     dcl	argp			ptr,		/* arglist pointer */
	cp			ptr,		/* base pointer for expanded control word */
	p			ptr;		/* random */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 rsw			bit(1),		/* non-zero if in reverse mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1),		/* non-zero if to print error tasks only */
	  2 briefsw		bit(1),		/* ignored */
	  2 detailsw		bit(1),		/* non-zero if to list acl when logsw is non-zero */
	  2 clear_code_sw		bit(1)) unal;	/* non-zero if error codes are to be cleared. */

     dcl	1 stat			aligned,		/* data structure for status_ */
	 (2 type			bit(2),		/* entry type */
	  2 nnames		bit(16),		/* number of names returned */
	  2 nrp			bit(18),		/* rel pointer to name array */
	  2 dtm			bit(36),		/* date/time modified */
	  2 dtu			bit(36),		/* date/time used */
	  2 mode			bit(5),		/* t, r, e, w, a */
	  2 pad			bit(13),		/* unused */
	  2 recs			bit(18),		/* pages used */
	  2 dtd			bit(36),		/* date/time dumped */
	  2 dtem			bit(36),		/* date/time entry modified */
	  2 acct			bit(36),		/* accounting data */
	  2 curlen		bit(12),		/* length of segment */
	  2 bitcnt		bit(24),		/* bitcount of segment */
	  2 did			bit(4),		/* device id */
	  2 mdid			bit(4),		/* ? */
	  2 copysw		bit(1),		/* segment copy switch */
	  2 pad2			bit(9),		/* unused */
	  2 rbs (0:2)		bit(6),		/* ring brackets */
	  2 uid			bit(36)) unal;	/* unique id */

     dcl	1 acl (an)		aligned based (ap),	/* acl array */
	  2 userid		char(32),		/* user name for this entry */
	  2 mode			bit(36),		/* 1-3 "rew", rest 0 */
	  2 pad			bit(36),		/* must be 0 */
	  2 code			fixed bin(35);	/* status code */

     dcl	1 acle 			aligned,		/* a temporary ACL array, with only one element.	*/
	  2 userid		char(32),		/* user name for this entry */
	  2 mode			bit(36),		/* 1-3 "rew", rest 0 */
	  2 pad			bit(36) init ("0"b),/* must be 0 */
	  2 code			fixed bin(35);	/* status code */

     dcl	1 del_acl (an)		aligned,		/* acl array for delete_acl_entries */
	  2  userid		char(32),		/* user name for entry */
	  2  code			fixed bin(35);	/* status code */

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

list:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, ap, an);

	if ctlw & "10000000011"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear" modes. return. */
	e = 1;					/* set transfer vector index */
	go to common;				/* join common code */


add:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, ap, an);

	if ctlw & "10000000001"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear uid" modes */
	e = 2;					/* transfer vector index */
	go to common;				/* skip */


delete:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, ap, an);

	if ctlw & "10000000001"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear uid" modes */
	e = 3;					/* transfer vector index */
	do i = 1 to an;				/* transfer regular acl structure into  */
	     del_acl(an).userid = acl(an).userid;	/* "delete" acl structure  */
	     del_acl(an).code = acl(an).code;		/* copy userid and codes  */
	     end;
	go to common;				/* join common code */


replace:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, ap, an, recover);

	if ctlw & "00000000001"b then			/* this entry doesn't run in "clear uid" mode */
	     return;
	if ctlw & "1"b then if ^recover then		/* this entry only runs in "reverse" mode if */
	     return;				/* full recovery is possible. */
	e = 4;					/* transfer vector index */
	go to common;


list_inacl:  entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, ap, an, rings);

	if ctlw & "10000000011"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear" modes. return. */
	e = 5;					/* set transfer vector index */


common:	call cu_$arg_list_ptr (argp);			/* locate arglist */
	cp = addr (ctlw);				/* get pointer to control word */
	rsw = c.rsw;				/* set reverse switch from control word.	*/
	logsw = c.logsw;				/* non-zero if to print */
	if c.errsw then if asev = 0 then		/* errors only to be printed */
	     logsw = "0"b;				/* customer is always right */
	runsw = c.runsw | c.trunsw;			/* non-zero if to process */

	if c.clear_code_sw then			/* if in "clear code" mode, then clear acl codes */
	     if ap ^= null then do i = 1 to an;
		acl(i).code = 0;
		end;

	if c.tasksw then				/* is this a task call? */
	     call upd_add_task_((entry(e)), argp);	/* yes, do it */

	if logsw then do;				/* user is nosy */
	     if e = 5
		then call ioa_$ioa_stream ("installation_list_", "^5x^15a^a  (ring ^d)", msg(e), dir, rings(1));
	     else do;
		if seg = msgseg then
		     call ioa_$ioa_stream ("installation_list_", "^5x^15a^a>^a", msg(e), dir, seg);
		else
		     call ioa_$ioa_stream ("installation_list_", "^5x^15a^a>^a  (^a)", msg(e), dir, seg, msgseg);
	     end;
	end;

	if runsw then do;				/* are we to process call now? */
	     if uid ^= ""b then do;			/* does caller want uid verified? */
		call upd_status_$long (dir, seg, 1, addr(stat), null, code);
		if code = 0 then if uid ^= stat.uid then	/* does it match? */
		     code = error_table_$non_matching_uid;	/* no */
		if code ^= 0 then			/* success? */
		     go to aclerr;			/* no, go give error */
		end;
	     on linkage_error begin;
		add_acl_entries_entry = hcs_$add_acl_entries;
		delete_acl_entries_entry = hcs_$delete_acl_entries;
		replace_acl_entry = hcs_$replace_acl;
		goto revert_linkage_error;
		end;

	     replace_acl_entry = installation_tools_$replace_acl;
	     delete_acl_entries_entry =  installation_tools_$delete_acl_entries;
	     add_acl_entries_entry = installation_tools_$add_acl_entries;
revert_linkage_error:
	     revert linkage_error;
	     if ^rsw then				/* if running forward, then		*/
		go to forward(e);			/* skip to proper function.*/
	     else					/* otherwise, we're running in reverse for	*/
		go to reverse;			/* upd_acl_task_$replace.	*/
	     end;
	go to pracl;				/* skip to print acl */


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


forward(1):
	if ap ^= null then				/* list acl task, see if already done */
	     go to pracl;				/* yes, skip processing again */
	an = 0;					/* zero count */
	call hcs_$list_acl (dir, seg, areap, p, null, n, code);/* ask, and ye shall receive */
	if code ^= 0 then				/* was there an error? */
	     go to aclerr;				/* yes, is fatal */
	an = n;					/* set array count */
	ap = p;					/* and pointer (set pointer last) */
	go to pracl;				/* skip to print generated structure, if wanted */


forward(2):


	call add_acl_entries_entry (dir, seg, ap, an, code);	/* add acl task, call ring 1 entry */
forward2a:
	if code ^= 0 then if code ^= error_table_$newnamerr then if code ^= error_table_$bad_ring_brackets then
	     go to aclerr;				/* any other error is fatal */
	go to ckacl;				/* no fatal error, check for unprocessed entries */


forward(3):


	call delete_acl_entries_entry (dir,seg,addr(del_acl),an,code); /* delete acl task, call ring 1 */
	do i = 1 to an;				/* put info back into "standard" acl structure */
	     acl(an).code = del_acl(an).code;		/* "userid" will remain the same */
	     end;					/* so just copy the codes   */
	if code ^= 0 then if code ^= error_table_$user_not_found then if code ^= error_table_$newnamerr then
	     go to aclerr;				/* fatal error */
	go to ckacl;				/* no, go check acl codes */


forward(4):
	if (ap = null) | (an = 0) then		/* if there's no replacement ACL */
	     go to pracl;				/* then we're done. */


	call replace_acl_entry (dir, seg, ap, an, "1"b, code); /* replace acl task, ask ring 1 */
	go to forward2a;				/* join code for add function */


forward(5):
	if ap ^= null then				/* list acl task, see if already done */
	     go to pracl;				/* yes, skip processing again */
	an = 0;					/* zero count */
	call expand_pathname_ ( dir, Parent_dir, Idir, code);
	if code ^= 0
	     then go to aclerr;
	call hcs_$list_inacl (Parent_dir, Idir, areap, p, null, n, rings(1), code);/* ask, and ye shall receive */
	if code ^= 0 | n = 0			/* was there an error? */
	     then go to aclerr;			/* yes, is fatal */
	an = n;					/* set array count */
	ap = p;					/* and pointer (set pointer last) */
	go to pracl;				/* skip to print generated structure, if wanted */


reverse:	acle.userid = get_group_id_$tag_star();		/* replace ACL with one giving this user rw access 	*/
	acle.mode = "101"b;
	acle.code = 0;
	call replace_acl_entry (dir, seg, addr (acle), 1, "0"b, code);
	if code ^= 0 then				/* any error is fatal.	*/
	     go to aclerr;
	go to pracl;

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


/**/


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


aclerr:	if e = 5 then do;
	     code = error_table_$empty_acl;
	     call upd_task_err_ (code, 3, argp, (entry(e)), "^/Referencing ^a  (ring ^d) .", dir, rings(1));
	end;
	else do;
	     if seg = msgseg then
		call upd_task_err_ (code, 3, argp, (entry(e)), "^/Referencing ^a>^a .", dir, seg);
	     else
		call upd_task_err_ (code, 3, argp, (entry(e)), "^/Referencing ^a>^a^/(^a>^a).", dir, seg, dir, msgseg);
	end;
	go to pracl;				/* go print acl if needed */


ckacl:	do i = 1 to an;				/* here to check for error on acl entries */
	     code = acl(i).code;			/* extract status code for this entry */
	     if code = error_table_$user_not_found then	/* happens on delete function */
		sev = 1;				/* and is severity 1 warning */
	     else if code ^= 0 then			/* any other code means unprocessed entry */
		sev = 2;				/* severity 2 */
	     if code ^= 0 then do;			/* if we have an error */
		call cv_acl_(ap, i, string, n, acl_form_sw(e) & "110"b);	/* format acl entry for error msg */
		if seg = msgseg then
		     call upd_task_err_(code, sev, argp, (entry(e)),
			"^/Referencing ^a>^a .^/Offending entry is:^-^a .",
			dir, seg, string);
		else
		     call upd_task_err_(code, sev, argp, (entry(e)),
			"^/Referencing ^a>^a^/(^a>^a).^/Offending entry is:^-^a.",
			dir, seg, dir, msgseg, string);
		end;
	     end;

pracl:	if logsw then				/* reenter here to print acl for user */
	     if (c.detailsw | c.errsw) then		/* .. with proper options */
		call upd_print_acl_(ap, an, (acl_form_sw(e)));

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


	end upd_acl_task_;



		    upd_add_task_.pl1               11/15/82  1844.4rew 11/15/82  1513.3       57141


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


upd_add_task_:	procedure (name, argp)
		options ( rename (( alloc_, smart_alloc_)) );


/*

	This procedure is used within the Multics Online Updater to construct
	the task list (which is a list of procedure calls including arguments).
	The "thread_task_" condition is signalled (supplying a pointer to the
	generated task) to add the task to the current task list.

	The following are entries:

	     upd_add_task_		allocates a task element and inserts
				it into the current task list by signalling
				the "thread_task_" condition.

	     upd_add_task_$init	specifies the area and linkage table
				to be used for all generated tasks

	     upd_add_task_$reset	reinitializes all procedure entry
				pointers in the task linkage table
				(used to resurrect the updater in
				a new process)

	The pointers specified on the initialization call are not copied;
	rather, internal static pointers to them are maintained, thereby
	allowing the caller to modify the actual pointers.  This is primarily
	useful to allow area switching to be done when the "area" condition
	is signalled.

	Within the Updater, this procedure is restartable, i.e. system or
	process failures are "programmed around".

	P. Bos, May 1972

*/

/**/

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


     dcl	name			char(*),		/* name of entry point to be called, e.g. a$b */
	argp			ptr;		/* argument list pointer */

     dcl	decode_entryname_		entry (char(*), char(32), char(32)),
	signal_			entry (char(*), ptr, ptr, ptr);

     dcl (addr, fixed, null)		builtin;

     dcl	ename			char(32),		/* entryname portion of "name" */
	rname			char(32);		/* refname portion of "name" */

     dcl	based_p			ptr based,	/* the obvious */
         (p, q, r)			ptr;		/* random */

     dcl (ap, lp)			ptr int static init (null);	/* pointers to areap, linkp */

     dcl	size			fixed bin,	/* computed arglist size */
	space (size)		fixed bin based;	/* overlay for arglist copy */

     dcl	area			area based (ap -> based_p);	/* user area to allocate tasks in */

     dcl	1 arglist			aligned based (argp),	/* argument list */
	 (2 an			bit(18),		/* argument count */
	  2 sn			bit(18),		/* sp flag (for internal calls) */
	  2 dn			bit(18),		/* descriptor count */
	  2 pad			bit(18)) unal,	/* unused */
	  2 p (100)		ptr;		/* arg pointers for standard updater task args */

     dcl	1 l			aligned based (p),	/* linkage table (list) entry */
	  2 nextp			ptr,		/* pointer to next link in list */
	  2 procp			ptr,		/* procedure entry pointer */
	 (2 rname			char(32),		/* procedure refname and entryname */
	  2 ename			char(32)) unal;	/* (fudge alignment for stupid pl1) */

     dcl	1 task			aligned based (q),	/* task element */
	  2 nextp			ptr,		/* pointer to following task */
	  2 backp			ptr,		/* pointer to previous task */
	  2 procp			ptr,		/* task procedure pointer */
	  2 arglist (size)		fixed bin;	/* argument list for this task */

/**/

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


	call decode_entryname_(name, rname, ename);	/* get refname, entry point name separately */
	q = lp;					/* get linkage list root pointer */
	p = q -> based_p;				/* and pointer to first link */
	do while (p ^= null);			/* search linkage table (list) for this entry point */
	     if rname = l.rname then if ename = l.ename then	/* does it match? */
		go to found;			/* yes, go allocate task */
	     q = p;				/* no, remember him in case we fall off end */
	     p = l.nextp;				/* get next linkage entry */
	     end;
	allocate l in (area);			/* allocate new linkage block */
	l.nextp = null;				/* will be on end of list */
	l.procp = null;				/* null procedure pointer */
	l.rname = rname;				/* and procedure name */
	l.ename = ename;				/* and entry point name */
	q -> l.nextp = p;				/* add it to list */

found:	q = arglist.p(6) -> based_p;			/* 6th arg to all updater tasks is task pointer */
	if q = null then do;			/* if no task there yet, */
	     size = fixed (arglist.an) + fixed (arglist.dn) + 2;	/* compute arglist size */
	     if fixed (arglist.sn) = 2 then		/* what dummy added values "4" and "8" here? */
		size = size + 2;			/* .. once upon a time, we could just add */
	     else if fixed (arglist.sn) = 8 then	/* .. all three halfwords to get arglist size */
		size = size + 2;			/* .. and save all this diddling */
	     allocate task in (area);			/* allocate task element */
	     task.nextp, task.backp = null;		/* not connected to anybody */
	     task.procp = addr (l.procp);		/* task procedure pointer points to linkage table entry */
	     r = addr (task.arglist);			/* get pointer to arglist substructure */
	     r -> space = argp -> space;		/* copy arglist into task block */
	     arglist.p(6) -> based_p = q;		/* give caller pointer to task in his taskp argument */
	     end;
	call signal_("thread_task_", null, q, null);	/* throw task in the air, see who catches it */

	return;					/* done, exit */

/**/

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


     dcl	areap			ptr,		/* pointer to caller's area */
	linkp			ptr;		/* pointer to linkage table */


init:		entry (areap, linkp);		/* initialization entry point */


	ap = addr (areap);				/* save pointer to user's areap */
	lp = addr (linkp);				/* and to his linkp */
	return;					/* not much of a cough... */


reset:		entry (linkp);			/* entry to reinitialize linkage table */


	p = linkp;				/* get pointer to first entry in table */
	do while (p ^= null);			/* linkage table is threaded list */
	     l.procp = null;			/* make entry pointer null */
	     p = l.nextp;				/* get pointer to next linkage entry */
	     end;
	return;					/* done, exit */


	end upd_add_task_;
   



		    upd_copy_seg_task_.pl1          11/15/82  1844.4rew 11/15/82  1513.4      162243


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


upd_copy_seg_task_:	procedure (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, 
			 ndir, nseg, nmsgseg, nuid, max_length, entry_bound, recover);


/*

	This procedure implements the copy_seg task function for the Multics
	Installation System.  Segment dir>seg (with unique id "uid") is copied into
	ndir>nseg; the new segment's unique id is returned in "nuid".  This
	procedure is restartable; if ndir>nseg already exists, it is compared
	with dir>seg, and if found to be identical, is assumed to have been
	in the process of being copied at the time of a process or system
	failure.  If "nuid" is non-zero on input in this case, it is verified
	as well.  "acode", "asev", and "taskp" should be initialized to "0",
	"0", and "null" respectively.

	If "recover" is on, then this task is reversible.

	P. Bos, May 1972

	Modified: May 1974 P. B. Kelley
		turns the safety switch on for all segments.
	Modified: Nov 1974 P. B. Kelley
		sets the maximum length attribute on all segments with optional
		user specification.
	Modified: Mar 1981 E. N. Kittlitz
		sets entry bound if one exists in object map.

*/

     dcl	ctlw			bit(36) aligned,	/* updater control word */
	areap			ptr,		/* caller area pointer */
	parentp			ptr,		/* pointer to parent arglist */
	acode			fixed bin(35),	/* status code */
	asev			fixed bin,	/* severity code */
	taskp			ptr,		/* task pointer */
	seqno			fixed bin,	/* task sequence no. */
	dir			char(168),	/* dirname of source segment */
	seg			char(32),		/* entryname of source segment */
	msgseg			char(32),		/* entryname of source segment used in messages */
	uid			bit(36) aligned,	/* unique id of source segment */
	ndir			char(168),	/* dirname of target segment */
	nseg			char(32),		/* entryname of target segment */
	nmsgseg			char(32),		/* entryname of target segment used in messages */
	nuid			bit(36) aligned,	/* unique id of target segment (output) */
	max_length		fixed bin(18),	/* max length attribute of target segment */
	entry_bound		fixed bin (14),	/* entry bound */
	recover			bit(1);		/* on if segment should be deleted when "run" */
						/* in "reverse" mode. */

     dcl	condition_		entry (char(*), entry),
	cu_$arg_list_ptr		entry (ptr),
	hcs_$append_branch		entry (char(*), char(*), fixed bin(5), fixed bin(35)),
	hcs_$delentry_file		entry (char(*), char(*), fixed bin(35)),
	hcs_$initiate		entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)),
	hcs_$set_bc		entry (char(*), char(*), fixed bin(24), fixed bin(35)),
	hcs_$set_entry_bound	entry (char (*), char (*), fixed bin (14), fixed bin (35)),
	hcs_$set_max_length		entry (char(*), char(*), fixed bin(18), fixed bin(35)),
	hcs_$set_safety_sw		entry (char(*), char(*), bit(1), fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	ioa_$ioa_stream		entry options (variable),
	reversion_		entry (char(*)),
	upd_add_task_		entry (char(*), ptr),
	upd_print_err_		entry options (variable),
	upd_status_$long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	upd_task_err_		entry options (variable);

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

     dcl (error_table_$badcall,
	error_table_$namedup,
	error_table_$non_matching_uid,
	error_table_$rqover,
	error_table_$segknown,
	error_table_$zero_length_seg)	ext fixed bin(35),
	sys_info$page_size		fixed bin (35) ext static,	/* no words per page. */
	sys_info$max_seg_size	ext fixed bin;		/* max seg size */

     dcl	argp			ptr,		/* arglist pointer for alloc_task, task_err_ */
	cp			ptr,		/* control word pointer */
	dp			ptr,		/* baseptr for "bdir" */
	msp			ptr,		/* baseptr for "bmsgseg" */
         (p, q)			ptr,		/* random */
	sp			ptr;		/* baseptr for "bseg" */

     dcl	bc			fixed bin(24),	/* bitcount */
	code			fixed bin(35),	/* status code for outward calls */
	data (n)			fixed bin(35) based (p), /* used to copy segment */
	bits 			 bit (bc) based,
	err_label			label local,	/* error branch vector. */
	maxl			fixed bin(18),	/* length for max length setting */
	n			fixed bin(35),	/* no. of words to copy */
	tbc			fixed bin(24),	/* temp bitcount for copy */
	tcode			fixed bin(35),	/* temp status code */
	tn			fixed bin,	/* copy of "n" for source segment */
	sev			fixed bin init (3);	/* nornal severity code. */

     dcl	bdir			char(168) based (dp),
	bmsgseg			char(32) based (msp),
	bseg			char(32) based (sp);

     dcl (dupsw			bit(1),		/* non-zero if namedup on append_branch call */
	logsw			bit(1),		/* non-zero if printing */
	nsw			bit(1),		/* non-zero if error refers to target seg */
	runsw			bit(1)) aligned;	/* non-zero if to process */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 rsw			bit(1),		/* non-zero if in reverse mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1)) unal;	/* non-zero if to print error tasks only */

     dcl	1 stat			aligned,		/* data structure for status_ */
	 (2 type			bit(2),		/* entry type */
	  2 nnames		bit(16),		/* number of names returned */
	  2 nrp			bit(18),		/* rel pointer to name array */
	  2 dtm			bit(36),		/* date/time modified */
	  2 dtu			bit(36),		/* date/time used */
	  2 mode			bit(5),		/* t, r, e, w, a */
	  2 pad			bit(13),		/* unused */
	  2 recs			bit(18),		/* pages used */
	  2 dtd			bit(36),		/* date/time dumped */
	  2 dtem			bit(36),		/* date/time entry modified */
	  2 acct			bit(36),		/* accounting data */
	  2 curlen		bit(12),		/* length of segment */
	  2 bitcnt		bit(24),		/* bitcount of segment */
	  2 did			bit(4),		/* device id */
	  2 mdid			bit(4),		/* ? */
	  2 copysw		bit(1),		/* segment copy switch */
	  2 pad2			bit(9),		/* unused */
	  2 rbs (0:2)		bit(6),		/* ring brackets */
	  2 uid			bit(36)) unal;	/* unique id */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  */
	call cu_$arg_list_ptr (argp);			/* get arglist pointer for alloc_task_, task_err_ */
	cp = addr (ctlw);				/* get control word pointer */
	if c.rsw then if ^recover then		/* this task doesn't run in reverse mode */
	     return;				/* unless caller specified full recovery */
						/* for the segment being copied. */
	if c.tasksw then				/* are we to allocate a task? */
	     call upd_add_task_("upd_copy_seg_task_", argp);
	logsw = c.logsw;				/* non-zero if to print */
	if c.errsw then if asev = 0 then		/* error tasks only? */
	     logsw = "0"b;				/* turn it off if no error */
	runsw = c.runsw | c.trunsw;			/* non-zero if to process */
	if logsw then do;				/* user wants to know what happened */
						/* print path name of source segment */
	     if seg = msgseg then
		call ioa_$ioa_stream ("installation_list_", "^5x^RCopy^B^2-^a>^a", dir, seg);
	     else
		call ioa_$ioa_stream ("installation_list_", "^5x^RCopy^B^2-^a>^a  (^a)", dir, seg, msgseg);
	     if nseg = nmsgseg then			/* print path name of target segment */
		call ioa_$ioa_stream ("installation_list_", "^-^Rto^B^-^a>^a", ndir, nseg);
	     else
		call ioa_$ioa_stream ("installation_list_", "^-^Rto^B^-^a>^a  (^a)", ndir, nseg, nmsgseg);
	     if asev ^= 0 then			/* was there an error? */
		call upd_print_err_(acode, asev);	/* yes, tell user */
	     end;
	if ^runsw then				/* if not in process mode, */
	     go to prtuid;				/* go away */

	p, q = null;				/* zap segment pointers */

	if c.rsw then				/* in "reverse" */
	     go to delete;
						/* ******************************* */
						/*   FORWARD		     */
						/* ******************************* */
	nsw = "0"b;				/* any error now refers to source seg */
	err_label = return;				/* most are fatal errors. */
	call upd_status_$long (dir, seg, 1, addr(stat), null, code);
	if code ^= 0 then				/* error? */
	     go to err;				/* skip if so */
	if uid ^= ""b then if uid ^= stat.uid then do;	/* verify unique id */
	     code = error_table_$non_matching_uid;	/* no match, set error code */
	     go to err;				/* and exit */
	     end;
	n, tn, maxl = fixed (stat.curlen) * sys_info$page_size; /* get word count for segment */
	if n = 0 then do;				/* zero length segment is error */
	     code = error_table_$zero_length_seg;	/* set error code */
	     go to err;				/* skip */
	     end;
	call hcs_$initiate (dir, seg, "", 0, 0, p, code);	/* initiate source segment */
	if code ^= 0 then if code ^= error_table_$segknown then
	     go to err;				/* exit on error */
	bc = fixed (stat.bitcnt);			/* fix bitcount */
	nsw = "1"b;				/* errors from here on are for target seg */
	call hcs_$append_branch (ndir, nseg, 01010b, code);	/* add entry for new segment */
	if code ^= 0 then				/* oops */
	     if code = error_table_$namedup then	/* segment already exists */
		dupsw = "1"b;			/* might be ok, though */
	     else					/* any other error is fatal */
		go to err;			/* skip */
	else					/* code = 0 */
	     dupsw = "0"b;				/* reset switch */
	call upd_status_$long (ndir, nseg, 1, addr(stat), null, code);
	if code ^= 0 then				/* hard to believe... */
	     go to err;				/* skip */
	if nuid = ""b then				/* if uid has not been set in previous invocation */
	     nuid = stat.uid;			/* .. which was interrupted, set it now */
	else if nuid ^= stat.uid then do;		/* uid has been set, compare it */
	     if dupsw then				/* if segment existed prior to call, */
dup:		code = error_table_$namedup;		/* namedup error */
	     else					/* if not, caller forgot to initialize args */
		code = error_table_$badcall;		/* tell him so */
	     go to err;				/* exit */
	     end;
	call hcs_$initiate (ndir, nseg, "", 0, 0, q, code); /* initiate copy */
	if code ^= 0 then if code ^= error_table_$segknown then
	     go to err;
	if dupsw then do;				/* segment may have been partially copied */
	     if bc ^= 0 then if q -> bits ^= p -> bits then	/* compare segment with original */
		go to dup;			/* again namedup error */
	     if n = tn then do;			/* segments are identical */
		tbc = fixed (stat.bitcnt);		/* get bitcount of copy */
		if tbc = bc then			/* was it already set? */
		     go to exit;			/* yes, skip set_bc call */
		go to setbc;			/* go set bitcount */
		end;
	     n = tn;				/* was partially copied; get length & do it again */
	     end;
	call condition_ ("record_quota_overflow", record_quota_overflow);
						/* handle record quota overflows during copy. */
	q -> data = p -> data;			/* copy segment */
	call reversion_ ("record_quota_overflow");	/* disable rqover handler, after copy complete. */
	go to setbc;
rqover:	call reversion_ ("record_quota_overflow");	/* don't handle them any more. */
	if nseg = nmsgseg then
	     call upd_task_err_ (error_table_$rqover, 4, argp, "upd_copy_seg_task_",
		"^/Referencing ^R^a>^a^B .", ndir, nseg);
	else
	     call upd_task_err_ (error_table_$rqover, 4, argp, "upd_copy_seg_task_",
		"^/Referencing ^R^a>^a^B^/(^a>^a).", ndir, nseg, ndir, nmsgseg);

setbc:	if q -> bits ^= p -> bits then do;		/* make sure the hardware did what it's supposed to!!! */
	     if nseg = nmsgseg then			/* CSL's used to fail.  Here we're testing the MLR */
		call upd_task_err_ ( 0, 4, argp, "upd_copy_seg_task_",
		     "Segment not copied correctly:  ^R^a>^a^B^/Please re-initiate and try again.", ndir, nseg );
	     else
		call upd_task_err_ ( 0, 4, argp, "upd_copy_seg_task_",
		     "Segment not copied correctly:  ^R^a>^a^B^/(^R^a>^a^B)^/Please re-initiate and try again.",
			ndir, nseg, ndir, nmsgseg );
	     end;

						/* ******************************* */
						/* SET BIT COUNT		     */
	call hcs_$set_bc (ndir, nseg, bc, code);	/* ******************************* */
	if code ^= 0 then				/* can't do it */
	     if nseg = nmsgseg then
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set bit count on ^R^a>^a^B .", ndir, nseg);
	     else
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set bit count on ^R^a>^a^B^/(^a>^a).", ndir, nseg, ndir, nmsgseg);
exit:						/* always set max length, safety switch & entry bound */
	if max_length > sys_info$max_seg_size then	/* can't set it to > max segment length */
	     maxl = sys_info$max_seg_size;
	else if max_length = 0 then			/* set to current length (maxl) */
	     go to sml;
	else if max_length < maxl then;		/* can't set it less than current length */
	else do;					/* guess value of max_length looks ok */
	     maxl = (divide((max_length + 1023), 1024, 35, 0)) * 1024; /* set temporary to nearest upper page boundary */
	     go to sml;				/* xfer to call */
	     end;
	if nseg = nmsgseg then			/* errors fall thru to here */
	     call upd_task_err_ ( 0, 1, argp, "upd_copy_seg_task_",
		"Attempt to set illegal maximum length on ^R^a>^a^B.", ndir, nseg);
	else
	     call upd_task_err_ ( 0, 1, argp, "upd_copy_seg_task_",
		"Attempt to set illegal maximum length on ^R^a>^a^B.^/(^a>^a).",
		ndir, nseg, ndir, nmsgseg);
						/* if task_err_ call returns, then continue */
	call upd_print_err_ (0, 0, "", "", "Warning", "", "Maximum length will be set to ^d words.", maxl);

						/* ******************************* */
						/* SET MAX LENGTH		     */
sml:	call hcs_$set_max_length ( ndir, nseg, maxl, code);/* ****************************** */
	if code ^= 0 then
	     if nseg = nmsgseg then
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set the maximum length of ^R^a>^a^B.", ndir, nseg);
	     else
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set the maximum length of ^R^a>^a^B (^a>^a).",
		     ndir, nseg, ndir, nmsgseg);
						/* ******************************* */
						/* SET SAFETY SWITCH	     */
	call hcs_$set_safety_sw ( ndir, nseg, "1"b, code);/* ******************************* */
	if code ^= 0 then
	     if nseg = nmsgseg then
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set the safety switch on ^R^a>^a^B .", ndir, nseg );
	     else
		call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		     "^/Unable to set the safety switch on ^R^a>^a^B^/(^a>^a).", ndir, nseg, ndir, nmsgseg);

	if entry_bound > 0				/* ******************************* */
	     then do;				/* SET ENTRY BOUND                 */
						/* ******************************* */
		call hcs_$set_entry_bound (ndir, nseg, entry_bound, code);	
		if code ^= 0 then do;
		     if nseg = nmsgseg then
		          call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		               "^/Unable to set entry bound on ^R^a>^a^B .", ndir, nseg);
		     else
		          call upd_task_err_ (code, 2, argp, "upd_copy_seg_task_",
		               "^/Unable to set entry bound on ^R^a>^a^B^/(^a>^a).", ndir, nseg, ndir, nmsgseg);
		end;
	     end;

	call hcs_$terminate_noname (p, code);		/* terminate source segment */
	call hcs_$terminate_noname (q, code);		/* terminate target segment */

prtuid:	if logsw then if nuid ^= ""b then		/* user wants to know */
	     call ioa_$ioa_stream ("installation_list_", "^-target seg unique id = ^w", nuid);/* tell him */
	return;					/* and finally exit */
/*  */
						/* ****************************** */
						/*   REVERSE		    */
						/* ****************************** */
delete:	nsw = "1"b;				/* errors refer to  new segment. */
	err_label = del_err;			/* these errors can be non-fatal. */
	sev = 1;					/* all errors here are severity 1 */
	call upd_status_$long (ndir, nseg, 1, addr(stat), null, code);
	if code ^= 0 then				/* error ? */
	     go to err;				/* We tried. Tell user. He may want to continue. */
	if nuid ^= ""b then if nuid ^= stat.uid then do;	/* verify unique id to prevent deletion */
	     code = error_table_$non_matching_uid;	/* of the wrong segment. */
	     go to err;
	     end;
	call hcs_$set_safety_sw ( ndir, nseg, "0"b, code); /* turn safety switch off */
						/* we'll find out if successful by next call */
	call hcs_$delentry_file (ndir, nseg, code);	/* delete the segment. */
	if code ^= 0 then				/* oops, an error. */
	     go to err;
del_err:	nuid = ""b;				/* clear out our variables. */
	return;

err:	if p ^= null then				/* if source segment was initiated, */
	     call hcs_$terminate_noname (p, tcode);	/* terminate it */
	if q ^= null then				/* same for target segment */
	     call hcs_$terminate_noname (q, tcode);	/* ignore error codes returned */
	if ^nsw then do;				/* decide which name to use in message */
	     dp = addr (dir);			/* source segment name */
	     sp = addr (seg);
	     msp = addr (msgseg);
	     end;
	else do;
	     dp = addr (ndir);			/* target segment name */
	     sp = addr (nseg);
	     msp = addr (nmsgseg);
	     end;
	if bseg = bmsgseg then
	     call upd_task_err_ (code, sev, argp, "upd_copy_seg_task_",
		"^/Referencing ^R^a>^a^B .", bdir, bseg);
	else
	     call upd_task_err_ (code, sev, argp, "upd_copy_seg_task_",
		"^/Referencing ^R^a>^a^B^/(^a>^a).", bdir, bseg, bdir, bmsgseg);
	go to err_label;				/* all done, back to the shadows */
return:	return;					/* return point from errors. */


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


record_quota_overflow:	procedure;		/* handler for record quota overflows. */

	go to rqover;

	end record_quota_overflow;


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

	end upd_copy_seg_task_;
 



		    upd_describe_task_.pl1          11/15/82  1844.4rew 11/15/82  1515.4       47151


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


/*	This first generation MIS task is similar in function to upd_install_task_.  And,	*/
/*	like upd_install_task_$init, this task is allocated only once per installation.		*/
/*	When executed, it sets up a subtask, upd_doc_task_$write_prose, which is		*/
/*	responsible for adding a description of the installation to Installations.log		*/
/*	and Installations.info, the documentation segments.				*/
/*	Currently, the entries upd_doc_task_$write_tree and upd_doc_task_$write_prose		*/
/*	are responsible for locking and unlocking the documentation segments while		*/
/*	adding information.  If the need ever arises to have two or more online		*/
/*	Installers performing installations concurrently, then it is suggested that		*/
/*	the lock and unlock tasks be generated by this program to guarantee			*/
/*	consistency within the documentation segments.					*/
/*										*/
/*	P. B. Kelley								*/

upd_describe_task_:	proc ( ctlw, areap, parentp, acode, asev, taskp, seqno, temp, log_directory, descp, install_date )

		options ( rename (( alloc_, smart_alloc_)) );

dcl
     ctlw		bit (36) aligned,			/* control word */
     areap	ptr,				/* ptr to Area */
     parentp	ptr,				/* ptr to parent */
     acode	fixed bin(35),			/* error code */
     asev		fixed bin,			/* error severity */
     taskp	ptr,				/* task ptr */
     seqno	fixed bin,			/* sequence number */
     temp		ptr,				/* ptr to temporaries */
     log_directory	char (168) aligned,			/* documentation directory */
     descp	ptr,				/* ptr to description structure */
     install_date	fixed bin(35);			/* date of installation */

dcl  1 c	aligned based (addr(ctlw)),			/* definition of ctlw bits */
      (2  reverse_sw	bit (1),
       2  task_sw		bit (1),
       2  compile_sw	bit (1),
       2  run_sw		bit (1),
       2  task_run_sw	bit (1),
       2  log_sw		bit (1),
       2  error_sw		bit (1),
       2  brief_sw		bit (1),
       2  detail_sw		bit (1),
       2  clear_code_sw	bit (1),
       2  clear_uid_sw	bit (1) )unal;
/*  */
dcl
     addr		builtin,
     argp		ptr,
     control	bit(36) aligned,
     entry	char(32) init ("upd_describe_task_"),
     null		builtin,
     tp		ptr;
dcl
     cu_$arg_list_ptr	entry (ptr),
     ioa_$ioa_stream	entry options (variable),
     upd_add_task_		entry (char(*), ptr),
     upd_doc_task_$write_prose entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
			     char (168) aligned, ptr, fixed bin(35), bit(1) aligned, fixed bin);

dcl  1 t  aligned based (tp),				/* internal temps */
       2 argp		ptr,			/* arglist pointer */
       2 taskp		ptr init (null),		/* task pointer for subtasks */
       2 seqno		fixed bin init (34),	/* sequence number for subtask */
       2 code		fixed bin (35) init (0),	/* subtask status code */
       2 sev		fixed bin init (0),		/* subtask severity */
       2 log_directory	char (168) aligned,		/* documentation directory */
       2 descp		ptr,			/* ptr to description structure */
       2 max_line_size	fixed bin init (65),	/* max. line size */
       2 fwd_done_sw	bit (1) aligned init ("0"b);	/* "on" if description already documented */

dcl  Area area based (areap);				/* area */

/*  */

	call cu_$arg_list_ptr (argp);				/* get the arg. list ptr */
	if c.reverse_sw then				/* can't run in reverse */
	     return;
	if c.task_sw then
	     call upd_add_task_ (entry, argp);			/* allocate task into 1st generation */
							/* task list */
	control = (ctlw & "00100111100"b);			/* allow only "cpmpile" or "print" */
	if c.log_sw then					/* if we're logging... */
	     control = control & "00000111100"b;		/* mask all but the print bits */
	if c.compile_sw then
	     control = "01"b;				/* if compiling, then set tasksw for subtasks */

	if control = "0"b then
	     return;					/* nothing to do */

	if temp = null then					/* if temps don't exist yet */
	     if (control & "01"b) then do;			/* and we're setting up subtasks */
	     allocate t in (Area);			     	/* allocate temps */
	     t.argp = argp;
	     t.log_directory = log_directory;
	     t.descp = descp;
	     temp = tp;
	     end;

	tp = temp;					/* just get it back again */

	if (control & "00000000100"b) then			/* if printing detail */
	     call ioa_$ioa_stream ( "installation_list_", "^|");	/* start on a NEW PAGE */

	if temp ^= null then				/* if temps have been allocated */
	     call upd_doc_task_$write_prose (control, areap, t.argp, t.code, t.sev, t.taskp, t.seqno,
		t.log_directory, t.descp, install_date, t.fwd_done_sw, t.max_line_size);
	else						/* I guess we're only printing */
	     call upd_doc_task_$write_prose (control, null, null, 0, 0, null, 0,
		log_directory, descp, install_date, "0"b, 65);

	return;

	end upd_describe_task_;
 



		    upd_doc_task_.pl1               08/11/87  1004.5rew 08/11/87  0926.5      404019


/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

upd_doc_task_:	procedure
		options ( rename (( alloc_, smart_alloc_ )) );

/*	April 1973,  P. B. Kelley								*/
/*	October 1981, E. N. Kittlitz  multiply sys_info_$max_seg_size by 4, not 9			  */

/****^  HISTORY COMMENTS:
  1) change(86-06-25,GDixon), approve(86-08-18,MCR7494),
     audit(86-08-18,Martinson), install(86-08-19,MR12.0-1129):
     Changed to use more flexible mechanism to change Installations.info.
  2) change(87-01-13,GDixon), approve(87-04-16,MCR7609),
     audit(87-08-10,GJohnson), install(87-08-11,MR12.1-1080):
     Fix bug which prevents adding installation documentation in a totally
     empty Installations.info segment.
                                                   END HISTORY COMMENTS */
dcl
     control_word		bit (36) aligned,		/* control word */
     areap		ptr,			/* ptr to segment Area */
     parentp		ptr,			/* ptr to parent */
     acode		fixed bin (35),		/* error code */
     asev			fixed bin,		/* error severity */
     taskp		ptr,			/* task ptr */
     seqno		fixed bin,		/* sequence no. */
     treep		ptr,			/* ptr to modification description */
     log_name		char (168),		/* pathname of documentation segment */
     info_name		char (168),		/* pathname of documentation info segment */
     ename (3)		char(32) aligned,		/* entry name array */
     dname (3)		char(168) aligned,		/* directory name array */
     Uid (3)		bit (36) aligned,		/* unique id array */
     Sfwd_done		bit(1),			/* ON if already done */
     install_date		fixed bin (35),		/* installation date */
     de_install_date	fixed bin(35),		/* de-installation date */
     log_directory		char (168) aligned,		/* pathname of documentation directory */
     max_line_size		fixed bin,		/* maximum line size */
     prosep		ptr;			/* ptr to documentation description structure */

dcl  LOG_NAME		char(32) int static options(constant) init("Installations.log" ),
						/* MUST end with suffix ".log" */
     INFO_NAME		char(32) int static options(constant) init("Installations.info" ),
						/* MUST end with suffix ".info" */
     INFO_NAME_WHEN_FULL	char(32) int static options(constant) init("Installations.new.info"),
     INFO_HEADER		char(56) int static options(constant) init("Reverse chronological list of system software changes.

" );						/* Standard header for Installations.info. 	*/
						/* MUST be changed in this program.     	*/

dcl  1  c  aligned based (addr ( control_word)),
       (2  reverse_sw	bit (1),
        2  task_sw		bit (1),
        2  compile_sw	bit (1),
        2  run_sw		bit (1),
        2  task_run_sw	bit (1),
        2  log_sw		bit (1),
        2  error_sw		bit (1),
        2  brief_sw		bit (1),
        2  detail_sw	bit (1) ) unaligned;

dcl  A  area based (areap);				/* outside segment area where everything happens */


dcl  1  limb  aligned based (blkp),			/* block to be allocated by $get_tree */
        2  Nsegname	char (32),			/* primary name of Nsegment */
        2  Osegname	char (32),			/* former name of seg       */
        2  Nlib	char (168) aligned,			/* "target" seg library     */
        2  Olib	char (168) aligned,			/* "old" seg library */
        2  date	char (16),			/* install date */
        2  actxn	fixed bin,			/* action code of segment  */
        2  nc	fixed bin (17),			/* number components if bound */
        2  el 	(nn refer (limb.nc)),		/* array of components   */
	 3  cname		char (32),		/* component name */
	 3  cactxn	fixed bin;		/* action code of component */

dcl  1  prose based (prosep),					/* place where prose is stored */
        2  editsw		bit(1),				/* "on" if editted */
        2  no_char		fixed bin,			/* no. of characters */
        2  prose_string	char (0 refer (prose.no_char));	/* the string */

						/* structures for moving info seg around */
dcl  Inon_nl		fixed bin(21),
     created_sw		bit(1) aligned,
     full_bc		fixed bin(24),
     full_info_p		ptr,
     header_l		fixed bin(21),
     header_p		ptr,
     header		char(header_l) based(header_p),
     info_bc		fixed bin(24),
     info_l		fixed bin(21),
     info_p		ptr,
     info			char(info_l) based(info_p);

dcl  BITS_PER_CHAR		fixed bin int static options(constant) init(9);
dcl  CHARS_PER_WORD		fixed bin int static options(constant) init(4);
dcl  NL			char(1) int static options(constant) init ("
");
dcl  NL_NL		char(2) int static options(constant) init("

");

dcl  1  control_base aligned based (addr(control)),
       (2  path_given (3)	bit(1),
        2  pad 		bit(33) ) unal;

dcl  1  status based (addr(scode)),
        2  code	fixed bin(35);

dcl  mask (4) bit (36) aligned init
	("101"b,		/* ADD     action */
	 "111"b,		/* REPLACE action */
	 "010"b,		/* DELETE  action */
	 "011"b );	/* MOVE - NO REPL action */

dcl					/* codes for possible actions */
     added       fixed bin init	(1),
     replaced    fixed bin init	(2),
     deleted     fixed bin init	(3),
     moved       fixed bin init	(4),
     del_com     fixed bin init	(3);

dcl   com (1:8)  char (17)  init		/* printable comments for action codes */
    ("added to",
     "replaced in",
     "deleted from",
     "moved to",
     "de-installed from",
     "de-installed from",
     "re-installed to",
     "moved back"  );

dcl  comp_array (4) char (16) init
	("          added:",
	 "       replaced:",
	 "        deleted:",
	 "          moved:");

dcl
     cu_$arg_list_ptr 	entry (ptr),
     upd_add_task_ 		entry (char (*), ptr),
     upd_log_task_$lock	entry (char(*) aligned, fixed bin(35)),
     upd_log_task_$unlock	entry (char(*) aligned, fixed bin(35)),
     upd_print_err_		entry options ( variable ),
     upd_status_$long	entry ( char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)),
     upd_task_err_ 		entry  options (variable),
     ioa_$ioa_stream 	entry options (variable),
     ios_$attach		entry  (char(*) aligned, char(*) aligned, char(*), char(32) aligned,
			       bit(72) aligned),
     ios_$detach		entry (char(*) aligned, char(*) aligned, char(*) aligned, bit(72) aligned),
     ios_$write		entry (char(*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
     date_time_$fstime 	entry (fixed bin(35), char(*) aligned),
     get_wdir_		entry returns (char(168) aligned),
     get_temp_segments_	entry (char(*), (*) ptr, fixed bin(35)),
     hcs_$delentry_seg	entry (ptr, fixed bin(35)),
     hcs_$initiate_count	entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr,
			     fixed bin(35)),
     hcs_$terminate_noname 	entry (ptr, fixed bin(35)),
     initiate_file_$create	entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24),
			     fixed bin(35)),
     pathname_		entry (char(*), char(*)) returns(char(168)),
     release_temp_segments_	entry (char(*), (*) ptr, fixed bin(35)),
     terminate_file_	entry (ptr, fixed bin(24), bit(*), fixed bin(35));

dcl
    (error_table_$bad_segment,
     error_table_$moderr,
     error_table_$namedup,
     error_table_$noarg,
     error_table_$non_matching_uid,
     error_table_$oldobj,
     error_table_$rqover,
     error_table_$segknown)		fixed bin(35) ext static,
     sys_info$max_seg_size		ext fixed bin (35);

dcl  1  s1  (1000)  aligned,				/* structure containing info on segment */
        2   segname 	char (32) aligned,
        2   dtc      	fixed bin (71);
dcl  1  s2  (1000)  aligned,
        2   segname 	char(32) aligned,
        2   dtc     	fixed bin(71);

dcl  1  Stat aligned,				/* structure for upd_status_$long   */
      (2  type	bit (2),
       2  nnames	bit (16),
       2  nrp	bit (18),
       2  dtm	bit (36),
       2  dtu	bit (36),
       2  mode	bit (5),
       2  pad	bit (13),
       2  rec	bit (18),
       2  dtd	bit (36),
       2  dtem	bit (36),
       2  acct	bit (36),
       2  curlen	bit (12),
       2  bitcnt	bit (24),
       2  did	bit (4),
       2  mdid	bit (4),
       2  copysw	bit (1),
       2  pad2	bit (9),
       2  rbs (3)	bit (6),
       2  uid	bit (36)  )  unaligned;

dcl						/* misc variables */
     actions (1001)		fixed bin,
     axn 			fixed bin,		
     b1_date		char(24) aligned init (" "),
     b2_date		char(24) aligned init (" "),
     b1_name		char(32) aligned init (" "),
     b2_name		char(32) aligned init (" "),
     bitc 		fixed bin (24),
     buffer		char(132) aligned,
     code			fixed bin (35),
     control		bit(36) aligned init ("0"b),
     Date			char(16) aligned,
     de_installation_sw	bit (1),
     entry		char (32),
     errname		char(32),
     errpath		char (168),
     gate_sw		bit (1) init ("0"b),
     ignore		fixed bin(35),
     log_dir		char(168),
     logsw		bit (1),
     names (1001) 		char (32),
     new_lib		char (168) aligned,
     no_more		bit(1) init ("0"b),
     old_lib		char (168) aligned,
     record_quota_overflow	condition,
     rev			fixed bin,
     runsw		bit (1),
     scode		bit (72) aligned,
     sev			fixed bin,
     unb_sw 		bit (1) init ("1"b);

dcl (e, i, ii, nn, line_size, point) fixed bin (17);
dcl (j, k) fixed bin(17) init (1);		/* needed for do loops */
dcl (argp, q, p1, p2, Pseg, blkp) ptr init (null);
dcl  p(2) ptr init((2) null);
dcl (addr, dimension, divide, fixed, index, length, min, null, reverse,
     rtrim, setcharno, substr, verify) builtin;


/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */
/**/
get_tree:		entry (control_word, areap, parentp, acode, asev, taskp, seqno,
		     dname, ename, Uid, treep );

	e = 1;
	entry = "upd_doc_task_$get_tree";
	go to common;

write_tree:	entry (control_word, areap, parentp, acode, asev, taskp, seqno,
		     treep, install_date, de_install_date, log_directory, Sfwd_done);

	e = 2;
	entry = "upd_doc_task_$write_tree";
	go to common;

write_prose:	entry (control_word, areap, parentp, acode, asev, taskp, seqno,
		     log_directory, prosep, install_date, Sfwd_done, max_line_size);

	e = 3;
	entry = "upd_doc_task_$write_prose";

common:
	call cu_$arg_list_ptr (argp);			/* get arglist ptr       */
	logsw = c.log_sw;				/* set internal log switch */
	runsw = c.run_sw | c.task_run_sw;		/* and internal process switch */
	if c.error_sw then if asev = 0 then		/* print errors only */
	     logsw = "0"b;
	if c.task_sw then				/* add a task to list */
	     call upd_add_task_ ( entry, argp );		
	if e ^= 1 then do;				/* get_tree entry doesn't pass log_directory */
	     if substr(log_directory, 1, 1) = " " then do;
		log_dir = get_wdir_();
		log_name = LOG_NAME;		/* set the value of log_name */
		info_name = INFO_NAME;		/* and info name */
		end;
	     else do;
		log_dir = log_directory;
		log_name =  rtrim(log_directory)||">"||LOG_NAME;
		info_name = rtrim(log_directory)||">"||INFO_NAME;
		end;
	     end;

	go to start(e);

/**/
start(1):						/* get_tree entry */
	if logsw then do; 				/* user wants something printed, so... */
	     call ioa_$ioa_stream ( "installation_list_",
		"^5x^RGather documentation info^B");
	     if asev ^= 0 then
	 	call upd_print_err_ ( acode, asev );
	     return;				/* that's all we do when logging */
	     end;
	if c.reverse_sw then			/* do not run in reverse mode */
	     return;
	if ^runsw then return;			/* if not processing now, quit  */
	if treep ^= null then return;			/* if info already gathered, then quit */

	nn = 0;
	do i = 1 to 3;				/* which paths were received?  */
	     if substr (dname(i), 1, 1) ^= " "
		then path_given (i) = "1"b;
	     end;
	if control = "0"b then do;			/* means no paths received */
	     code = error_table_$noarg;		/* can't do something with nothing */
	     sev = 3;				/* bad error */
	     errpath = "<no paths received>";
	     errname = "";
	     go to err;				/* leave thru error exit */
	     end;

	do i = 1 to 2;				/* let's get some info on existing paths */
	     if path_given(i) then do;
		call upd_status_$long ( dname(i), ename(i), 1, addr(Stat), null, code);    
		   if code = 0 then do;				/* it better be */
		     if fixed(Stat.rbs(2),6) ^= fixed(Stat.rbs(3),6)     	/* If gate seg... */
			then gate_sw = "1"b;			/* then don't worry 'bout it */
		     if fixed(Uid(i)) ^= 0 then if Uid(i) ^= Stat.uid then do;/* check uid           */
			sev = 3;					/* whoops, got one */
			code = error_table_$non_matching_uid;
			errpath = dname(i);
			errname = ename(i);
			go to err;				/* let's get out now  */
			end;
		     end;
		end;
	     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*			Find action being performed		 				*/

	if (control & "010"b)			/* get standardized form of "old" lib */
	     then call valid_lib_ (dname(2), old_lib);
	     else old_lib = "";
	if (control & "001"b)			/* and standardized form of "target" lib */
	     then call valid_lib_ (dname(3), new_lib);	/* (may be different) */
	     else new_lib = old_lib;			/* only poss. is DEL; print routine expects "new_lib" */

	if control = mask(1) then do;			/* ADD action			*/
	     axn = added;
	     ename(2) = ename(3);				/* used later		 */
	     end;
	else if control = mask(2) then do;		/* REPLACE action			*/
	     if new_lib = old_lib then         			/* simple REPLACE		*/
		axn = replaced;
	     else    					/* REPLACE with MOVE	*/
		axn = moved;
	     end;
	else if control = mask(3) then do;		/* DELETE action			*/
	     axn = deleted;
	     ename(3) = ename(2);				/* used later		*/
	     end;
	else if control = mask(4) then do;		/* MOVE with no replace		*/
	     axn, del_com = moved;
	     end;
	go to init_entry;

err:						/* common out for severe errors	 */
	call upd_task_err_ ( code, sev, argp, entry, "^a>^a", errpath, errname );/* call error handler */
	return;							/* scram    */
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*			gather info for segs given						*/
init_entry:
	if gate_sw then go to record_seg;			/* special case gates, might not have access  	*/
	errpath = dname(1);
	errname = ename(1);
	sev = 3;
	p1 = addr(s1);
	p2 = addr(s2);
	s1(1).segname, s2(1).segname = "";

	if (control & "100"b) then do;			/* let's find out about the "new" seg */
	     call hcs_$initiate_count ((dname(1)), (ename(1)), "", bitc, 0, Pseg, code); 
		 if code ^= 0 then if code ^= error_table_$segknown then do; /* sounds like it's not there */
		     if code = error_table_$moderr then go to no_rec;	/* nope, just no access */
		     go to err;					/* bad error */
		     end;
	     call doc_util_ (Pseg, bitc, p1, ename(1), unb_sw, k, b1_date, b1_name, code);
	 	if code ^= 0 then if code ^= error_table_$bad_segment then	/* might not be an object segment */
		     go to err;				/* segment probably clobbered */
	     call hcs_$terminate_noname ( Pseg, code);
	     end;

	errpath = dname(2);
	errname = ename(2);

	if (control & "010"b) then do;				/* let's find out about the "old" seg */
	     call hcs_$initiate_count ((dname(2)), (ename(2)), "", bitc, 0, Pseg, code); 
		if code ^= 0 then if code ^= error_table_$segknown then do; /* might not be there */
		     if code = error_table_$moderr then go to no_rec;	/* rings are probably 1,1,1 */
		     go to err;					/* bad error */
		     end;
	     call doc_util_ ( Pseg, bitc, p2, ename(2), unb_sw, j, b2_date, b2_name, code);
		if code ^= 0 then do;				/* couldn't get it    */
		     if code = error_table_$bad_segment then go to record_seg; /* could be non-object segment  */
		     if code = error_table_$oldobj then do;		/* wrong incls for older than '72 stuff */
			if unb_sw  then go to record_seg;		/* if unbound then don't worry  */
no_rec:			sev = 0;					/* inform user if it */
			if substr(ename(2),1,6) = "bound_" then		/* starts with "bound_"*/
			     call upd_task_err_ ( code, sev, argp, entry,
				"Not recording component changes.  ^a>^a" , errpath, errname);
			go to record_seg;				/* non-fatal, so continue... */
			end;
		     go to err;
		     end;
	     call hcs_$terminate_noname ( Pseg, code);
	     end;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*			what kind of info have we found ?					*/
	if unb_sw then
	     go to record_seg;				/* neither seg is bound */

	if (control & "010"b) then do ii = 1 to j;		/*  dig out the deleted ones first  */
	     do i = 1 to k;
		if s1(i).segname = s2(ii).segname then go to next1; /* this one's still there  */
		end;
	     nn = nn + 1;					/* this name didn't match up, so add it to list */
	     names(nn) = s2(ii).segname;
	     actions(nn) = del_com;
next1:	     end;

	if control = mask(4) then go to changed;		/* if moving w/ no repl. then xfer */

	if (control & "001"b) then do i = 1 to k;		/* now for the replaced and added ones */
	     do ii = 1 to j;
		if s1(i).segname = s2(ii).segname then do;	/* found a name-match */
		     if s1(i).dtc ^= s2(ii).dtc then do;	/* this one's being replaced */
			nn = nn + 1;			/* add it to our collection */
			names(nn) = s1(i).segname;
			actions(nn) = replaced;
			go to next2;
			end;
		     if axn = moved then do;			/* if moving, then record all components */
			nn = nn + 1;			/* add it to collection */
			names(nn) = s1(i).segname;
			actions(nn) = moved;
			end;
		     go to next2;
		     end;
		end;
	     nn = nn + 1;					/* no name-match, must be an added one */
	     names(nn) = s1(i).segname;			/* so we'll add it   */
	     actions(nn) = added;
next2:	     end;

	if b1_date ^= " " then				/* check for bindfile change */
	     if b2_date ^= " " then				/* both have been bound with v2 */
		if b1_date ^= b2_date then go to changed;  	/* and not with same bindfile */
		else go to record_seg;
							/* one (or both) was bound with v1 */
	do i = 1 to nn;					/* if any components were added, deleted, */
	     if actions(i) ^= replaced then go to changed;	/* or moved, then report bindfile change */
	     end;
	go to record_seg;
changed:  nn = nn + 1;					/* add it to our list */
	if (control & "100"b) then
	     names(nn) = b1_name;
	else
	     names(nn) = b2_name;
	actions(nn) = axn;				/* assume the action of the bound seg */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*			transfer info into external area					*/

record_seg:
	allocate limb in (A) set (q);			/* allocate storage for limb */
	q->limb.Nsegname = ename(3);			/* new name of seg   */
	q->limb.Osegname = ename(2);			/* former name of seg	   */
	q->limb.Nlib = new_lib;			/* "target" seg lib */
	q->limb.Olib = old_lib;			/* "old" seg library */
	q->limb.date = "  (date)";			/* future date */
	q->limb.actxn = axn;			/* action code reflecting segment */
	if nn = 1 then if ename(3) = names(1) then 	/* means unbound seg being added|replaced|deleted */
	     nn = 0;				/* pretend no components */
	q->limb.nc = nn;				/* number of components (if bound seg) */
	if nn > 0 then do i = 1 to nn;		/* if bound, then copy all components changed */
	     q->limb.el(i).cname = names(i);		/* component name 		*/
	     q->limb.el(i).cactxn = actions(i);		/* action code reflecting component */
	     end;	
	treep = q;				/* set treep to limb   */
	return;					/* finis */

/*			end of upd_doc_task_$get_tree					*/
/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */
/**/
start(2):							/* write_tree entry */
	if ^logsw then if ^runsw then
	     return;
	if logsw then do;					/* if we're in "print" mode, then do it. */
	     if c.detail_sw then 				/* if detail, then print what's happening */ 
		call ioa_$ioa_stream ("installation_list_", "^5x^RLog into^B^-^a", log_name);
	     if treep = null then do;				/* we haven't gotten info yet */
		call ioa_$ioa_stream ("installation_list_", "^-Log Information list is empty.^/");
		return;
		end;
	     call ios_$attach ( "installation_log_", "syn", "installation_list_", "w", scode);
	     if status.code ^= 0 then do;			/* attach unsuccessful */
		call upd_task_err_ (status.code, 0, argp, entry, "Attempting to attach I/O stream.");
		go to skip_comps;
		end;
	     go to print_it;		     		/* zip thru the printing routine */
	     end;

	if Sfwd_done ^= c.reverse_sw then
	     return;					/* already finished in this direction*/
	if treep = null then 				/* can't get info from null ptr   */
	     return;

	call upd_log_task_$lock ((log_name), code);		/* lock the installation log file */
	if code ^= 0 then do;				/* whoops, something's not there */
	     call upd_task_err_ (code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
	     return;					/* only issue warning if processing */
	     end;
	call ios_$attach ("installation_log_", "file_", log_name, "w", scode);
	if status.code ^= 0 then do;				/* attach unsuccessful? */
	     call upd_task_err_ (status.code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
	     go to skip_comps;
	     end;

print_it:	de_installation_sw = c.reverse_sw;

	if ^de_installation_sw then do;			/* if going forward... */
	     rev = 0;
	     if install_date ^=  0 then			/* and if we have a date */
		call date_time_$fstime (install_date, Date);	/* then decode it */
	     else
		Date = "  (date)";				/*  or, for printing...	*/
	     if runsw then					/* unless we're listing */
		treep->limb.date = Date;			/* set Date fwd only 	*/
	     end;
	else do;						/* if going in reverse... */
	     rev = 4;
	     call date_time_$fstime (de_install_date, Date);
	     call ioa_$ioa_stream ( "installation_log_", "^/+++++"); /* a "reverse" separator? */
	     end;

	if treep->limb.actxn ^= moved then do;			/* Major line, fwd or rev, not moving	*/
	     call ioa_$ioa_stream ("installation_log_", "^/^16a^4x^a ^a ^a",
		Date, treep->limb.Nsegname, com(treep->limb.actxn+rev),treep->limb.Nlib);
	     if de_installation_sw then do;			/* reverse		*/
		call ioa_$ioa_stream ("installation_log_", "^/^-^5x(previously installed ^16a)",
		     treep->limb.date);			/* use block date */
		go to skip_comps;				/* skip component printing */
		end;
	     if treep->limb.Nsegname ^= treep->limb.Osegname then
		call ioa_$ioa_stream ("installation_log_", "^/^-^5x(renamed from ^a)",
			treep->limb.Osegname);
	     go to print_comps;
	     end;
							/* Major line for moving */
	if ^de_installation_sw then do;			/* fwd...		*/
	     call ioa_$ioa_stream ("installation_log_", "^/^16a^4x^a moved from ^a to ^a",
		Date, treep->limb.Nsegname, treep->limb.Olib,treep->limb.Nlib);
	     if treep->limb.Nsegname ^= treep->limb.Osegname then
		call ioa_$ioa_stream ("installation_log_", "^/^-^5x(renamed from ^a)",
		     treep->limb.Osegname);
	     end;
	else do;						/* reverse	*/
	     call ioa_$ioa_stream ("installation_log_", "^/^16a^4x^a moved back from ^a to ^a",
		Date, treep->limb.Osegname, treep->limb.Nlib, treep->limb.Olib);
	     call ioa_$ioa_stream ("installation_log_", "^/^-^5x(previously installed ^16a)",
		treep->limb.date);
	     go to skip_comps;
	     end;

print_comps:						/* now for the components */
	if treep->limb.nc = 0 then				/* if zero comps, then can't print them */
	     go to skip_comps;
	do i = 1 to 4;					/* 4 possible actions */
	     k = i;
	     do j = 1 to treep->limb.nc;			/* random arrangement, so simplest is..*/
		if treep->limb.el(j).cactxn = i then do;
		     if k ^= 0 then
			call ioa_$ioa_stream ("installation_log_",
			     "^/^16a^4x^a", comp_array(k), treep->limb.el(j).cname);
		     else
			call ioa_$ioa_stream ("installation_log_", "^2-^a", treep->limb.el(j).cname);
		     k = 0;
		     end;
		end;
	     end;

skip_comps:
	call ios_$detach ("installation_log_", "", "", scode);	/* remember to always detach this stream here */
	if runsw then do;
	     call upd_log_task_$unlock ((log_name), code);	/* unlocks log file */
	     Sfwd_done = ^Sfwd_done;
	     if substr(log_directory, 1, 1) = " " then
		log_directory = get_wdir_();
	     end;

	return;

/*			end of upd_doc_task_$write_tree				*/
/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */
/**/
start(3):							/* write_prose entry */
	if ^runsw then if ^logsw then
	     return;
	if c.reverse_sw then
	     return;					/* do nothing in reverse */
	if logsw then do;					/* user wants to check */
	     call ioa_$ioa_stream ("installation_list_",		/* already attached at this point */
		"^2/^RDocument modification description into:^B^/^5x^a.", log_name);
	     if asev ^= 0 then
		call upd_print_err_ ( acode, asev );		/* print any errors */
	     if prosep = null then do;			/* but description is empty */
		call ioa_$ioa_stream ("installation_list_",	/* already attached */
		     "^/^5x(modification description is empty)^/");
		return;
		end;
	     if (c.detail_sw | ^c.brief_sw) then do;		/* print what's there */
		call ios_$attach ( "installation_log_", "syn", "installation_list_", "w", scode);
		if status.code ^= 0 then do;
		     call upd_task_err_ ( status.code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
		     return;
		     end;
		end;
	     else
		return;
	     end;

	if runsw then
	     if Sfwd_done ^= c.reverse_sw then			/* we've already done this */
		return;
	if runsw then
	     if prosep = null then do;			/* at least print separator */
	     no_more = "1"b;
	     go to skipedit;
	     end;
	if prose.editsw then				/* if we've already gone thru this... */
	     go to skipedit;				/* then let's save some time */
							/* *************************** */
							/* EDIT the best we can        */
							/* *************************** */
	point = 1;
	line_size = max_line_size;
look:	i = min ( line_size, ( (no_char - point) + 1 ) );		/* make sure we don't grab too much */
	buffer = substr ( prose_string, point, i );		/* let's look at the string */
	if i < line_size then
	     go to process;					/* we've got all we need */
	i = index ( buffer, NL );				/* look for a new_line */
	if i = 0 then do;					/* let's try something else */
	     if line_size > max_line_size then			/* if we had to grap extra chars */
		i = index ( substr ( buffer, 1, line_size ) , " "); /* look for first occurance of a blank */
	     else do;					/* non-expanded buffer, so... */
		k = index ( reverse ( substr ( buffer, 1, line_size ) ), " "); /* look for last occurance of a blank */
		if k ^= 0 then
		     i = line_size - ( k - 1 );		/* set i to blank char */
		end;
	     if i ^= 0 then do;				/* if we found one */
		substr ( buffer, i, 1 ) = NL;			/* make it a new_line */
		go to process;
		end;
	     if line_size ^> (max_line_size + 10) then do;	/* increase size of line ( max. 10) */
		line_size = line_size + 5;
		go to look;
		end;
	     i = max_line_size;				/* have to cut off line */
	     end;

process:	substr ( prose_string, point, i) = substr ( buffer, 1, i);
	point = point + i;					/* adjust out pointer */
	if point < no_char then				/* check for end of the line */
	     go to look;

skipedit:	if logsw then do;					/* write description on already attached stream */
	     call ioa_$ioa_stream ("installation_log_", "");	/* NL */
	     call ios_$write ("installation_log_", addr(prose.prose_string), 0, prose.no_char, i, scode);
	     call ioa_$ioa_stream ("installation_log_", "");	/* NL (really CR here) */
	     go to return;					/* nothing more to do here */
	     end;
							/* *************************** */
							/* first, the LOG file         */
							/* *************************** */
	call upd_log_task_$lock ((log_name), code );		/* set the lock */
	if code ^= 0 then 
	     go to lock_err;
	call ios_$attach ( "installation_log_", "file_", log_name, "w", scode);
	if status.code ^= 0 then do;
	     call upd_task_err_ ( status.code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
	     go to un_log;
	     end;
	call ioa_$ioa_stream ( "installation_log_", "^/*****");	/* start with a separator */
	if ^no_more then do;				/* continue only if there's more */
	     call ios_$write ("installation_log_", addr(prose.prose_string), 0, prose.no_char, i, scode);
	     call ioa_$ioa_stream ("installation_log_", "");     	/* NL */
	     end;
un_log:	call ios_$detach ("installation_log_", "", "", scode);	/* detach the print stream */
	call upd_log_task_$unlock ((log_name), code);		/* unlock the log */
	if code ^= 0 then
	     call upd_task_err_ ( code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
	if no_more then					/* nothing more to do */
	     go to return;
							/* *************************** */
							/* and now the INFO file       */
							/* *************************** */
	call date_time_$fstime ( install_date, Date);
	call upd_log_task_$lock ((info_name), code);		/* lock the info file */
	if code ^= 0 then do;
	     log_name = info_name;
	     go to lock_err;
	     end;
							/* get temp space */
	call get_temp_segments_ ("upd_doc_task_", p, code);
	if code ^= 0 then do;
	     call upd_task_err_ ( code, 0, argp, entry, "Getting temp segment.");
	     go to un_info;
	     end;
							/* now the REAL seg */
	call hcs_$initiate_count ( log_dir, INFO_NAME, "", info_bc, 1, info_p, code);
	if (code ^= 0 & code ^= error_table_$segknown) then do;
	     call upd_task_err_ ( code, 0, argp, entry, "^2xInitiating info segment^/^2x(^a).",
		info_name);
	     go to un_info;
	     end;
	info_l = divide (info_bc, BITS_PER_CHAR, 21, 0);

	call save$init (p(1));				/* save copy of current info seg in case*/
	call save$str (info);				/*   it must be restored (eg on RQO).	*/

	call out$init (p(2));				/* prepare to build new copy of info seg. */
	if substr(info,1,min(length(info),length(INFO_HEADER))) = INFO_HEADER then do;
							/* if our heading line is present, then */
	     header_p = info_p;				/* insert new data between header and   */
	     header_l = length(INFO_HEADER);			/* existing data.			*/
	     end;
	else do;						/* if our heading line is NOT present,  */
	     header_p = info_p;				/* insert new data after first blank    */
	     header_l = index(info, NL_NL);			/* line in the info segment.		*/
	     if header_l > 0 then
	        header_l = header_l - 1 + length(NL_NL);
	     end;
	info_p = setcharno(info_p, length(header));
	info_l = info_l - length(header);

	Inon_nl = verify(info, NL);				/* Strip extra NLs from start of data.	*/
	if Inon_nl > 1 then do;
	     info_p = addcharno(info_p, Inon_nl-1);
	     info_l = info_l - (Inon_nl-1);
	     end;

	call out$str (header);				/* output our header, date line and	*/
	call out$str (substr(Date,1,8));			/* new documentation into temp segment. */
	call out$str (":");
	call out$str (NL);
	call out$str (prose_string);
	call out$str (NL);
	call out$str (NL);
	call out$str (NL);

	if out$len() + length(info) > sys_info$max_seg_size * CHARS_PER_WORD then do;
							/* handle overflow of info seg by 	*/
							/* writing new data into a new 	*/
							/* permanent segment, leaving the old	*/
							/* segment untouched.		*/
	     call upd_print_err_ ( 0, 0, "Warning", "", entry, "",	/* print a warning to the effect	*/
		"^2xInfo segment is full^/(^a).
  New data placed in ^a.
  Please rename info segment as appropriate.",
		info_name, pathname_ (log_dir, INFO_NAME_WHEN_FULL));
	     on record_quota_overflow begin;
		call hcs_$delentry_seg (full_info_p, code);
		code = error_table_$rqover;
		go to rqo_full;
		end;
	     call initiate_file_$create (log_dir, INFO_NAME_WHEN_FULL, RW_ACCESS,
		full_info_p, created_sw, full_bc, code);
	     if code = 0 & ^created_sw then do;
		code = error_table_$namedup;
		call terminate_file_ (full_info_p, 0, TERM_FILE_TERM, ignore);
		end;
	     if code ^= 0 then do;
rqo_full:		call upd_task_err_ (code, 0, argp, entry, "Creating ^a.
Documentation for current installation lost.",
		     pathname_ (log_dir, INFO_NAME_WHEN_FULL));
		go to un_info;
		end;
	     call out$copy (full_info_p, full_bc);
	     revert record_quota_overflow;
	     call terminate_file_ (full_info_p, full_bc, TERM_FILE_TRUNC_BC_TERM, code);
	     if code ^= 0 then do;
		call upd_task_err_ (code, 0, argp, entry, "Setting bit count on ^a.
Documentation for current installation lost.",
		     pathname_ (log_dir, INFO_NAME_WHEN_FULL));
		go to un_info;
		end;
	     end;
	else do;
	     call out$str (info);
	     on record_quota_overflow begin;		/* restore info contents to its previous value 	*/
		call save$copy (info_p, info_bc);	/*   abandon built data, report the error.	*/
		call upd_task_err_ (error_table_$rqover, 0, argp, entry,
		   "Updating ^a.
Documentation for current installation lost.",
		     info_name);
		go to term_info;
		end;
	     info_p = header_p;
	     call out$copy (info_p, info_bc);
term_info:     revert record_quota_overflow;
	     call terminate_file_ (info_p, info_bc, TERM_FILE_TRUNC_BC, code);
	     if code ^= 0 then
		call upd_task_err_ (code, 0, argp, entry, "Writing ^a.
Segment may be damaged.",
		     info_name);
	     end;

un_info:	call terminate_file_ (info_p, 0, TERM_FILE_TERM, code);	/* terminate original and copy */
	call release_temp_segments_ ("upd_doc_task_", p, code);
	call upd_log_task_$unlock ((info_name), code);		/* unlock the lock */
	if code ^= 0 then
	     call upd_task_err_ (code, 0, argp, entry, "While unlocking ^a", info_name);


return:	if runsw then do;
	     Sfwd_done = ^Sfwd_done;				/* reset the forward done sw */
	     if substr(log_directory, 1, 1) = " " then
		log_directory = get_wdir_();
	     end;
	if logsw then					/* remember to detach I/O stream */
	     call ios_$detach ( "installation_log_", "", "", scode);
	return;

lock_err:	call upd_task_err_ ( code, 0, argp, entry, "Referencing ^R^a^B.", log_name);
	go to return;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* The following declarations and internal procedures provide a utility for  */
/* building up the new contents of an info segment in a temp segment.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
    dcl   out_len		fixed bin(21),		/* data built so far.			*/
	out_ptr		ptr,
	out_seg		char(out_len) based (out_ptr);


out$copy: proc (target_ptr, target_bc);			/* proc to copy built data into info seg.	*/

    dcl	target_ptr	ptr,
	target_bc		fixed bin(24);

	target_ptr -> out_seg = out_seg;
	target_bc = length(out_seg) * BITS_PER_CHAR;
	return;


out$init:	entry (aout_ptr);				/* procedure to initialize temp seg to empty 	*/
						/* state (ie, no built data).			*/

    dcl	aout_ptr		ptr;

	out_ptr = aout_ptr;
	out_len = 0;
	return;


out$len:	entry returns(fixed bin(21));			/* function returning length of data built so far.*/

	return (out_len);


out$str:	entry (str);				/* procedure to add a string to end of built data.*/

    dcl	str		char(*);
    dcl	insert_point	fixed bin(21);

	insert_point = out_len + 1;
	out_len = out_len + length(str);
	substr(out_seg,insert_point) = str;
	return;

	end out$copy;


    dcl	save_len		fixed bin(21),		/* saved copy of previous info seg contents,	*/
	save_ptr		ptr,			/*   stored beyond end of built (new) data.	*/
	save_seg		char(save_len) based(save_ptr);

save$copy:
	proc (target_ptr, target_bc);			/* proc to copy saved data into info seg.	*/

    dcl	target_ptr	ptr,
	target_bc		fixed bin(24);

	target_ptr -> save_seg = save_seg;
	target_bc = length(save_seg) * BITS_PER_CHAR;
	return;

save$init:
	entry (asave_ptr);				/* procedure to initialize temp seg to empty 	*/
						/* state (ie, no built data).			*/

    dcl	asave_ptr		ptr;

	save_ptr = asave_ptr;
	save_len = 0;
	return;


save$str:						/* procedure to add data to saved info seg image. */
     	entry (str);

    dcl	str		char(*);
    dcl	insert_point	fixed bin(21);

	insert_point = save_len + 1;
	save_len = save_len + length(str);
	substr(save_seg,insert_point) = str;
	return;

	end save$copy;

/*			end of upd_doc_task_$write_prose					 */
/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */

/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */

doc_util_:   procedure (p, bitc, ptrp, Segname, unb_sw, i, bf_date, bfname, ec);
/* Procedure which returns information about referenced segment. Notably,
   name (or component names) and compile date ( or component compile dates ).	*/
%include symbol_block;
%include bind_map;
%include object_info;

dcl  1  oi  aligned like object_info;
dcl  p 		ptr,				/* ptr to segment                 IN  */
     bitc 	fixed bin(24),			/* bitcount of seg                IN  */
     ptrp 	ptr,				/* ptr to structure               IN  */
     Segname	char (32) aligned,			/* name of seg, we might need it  IN  */
     unb_sw 	bit (1),				/* = 0 if bound, = 1 if not bound OUT */
     i 		fixed bin,			/* number of components of        OUT */
     bf_date	char(24) aligned,			/* bindfile date updated	    OUT */
     bfname	char(32) aligned,			/* bindfile name		    OUT */
     ec 		fixed bin(35);			/* return error code              OUT */
dcl  1  struc  (1000)  aligned based (ptrp),		/* likeness of ext  structure          */
        2  segname  	char (32) aligned,		/* name of component         */
        2  dtc      	fixed bin (71);		/* compile time of component */
dcl  ( j, k ) 		fixed bin,
     (bmp, sblkp, mapp, q)	ptr,
     name			char (k) based (q),
     (addr, addrel, index, substr)	builtin;
dcl  object_info_$display 	entry (ptr, fixed bin (24), ptr, fixed bin (35)),
     get_bound_seg_info_ 	entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35));

	     i = 1;
	     oi.version_number = 2;
	     call object_info_$display (p, bitc, addr (oi), ec);
	          if ec ^= 0 then do;		/* might not be an object segment  */
		     ptrp->struc(1).segname = Segname;
		     ptrp->struc(1).dtc = 0;
		     unb_sw = "1"b;
		     return;
		     end;
	     if oi.format.bound then do;			/* if bound then do this...   */
		unb_sw = "0"b;
		call get_bound_seg_info_ (p, bitc, addr (oi), bmp, sblkp, ec);
		     if ec ^= 0 then return;			/* bad error here  */
		do i = 1 to n_components while ( i < 1001 );	/* put upper limit on this */
		     q = addrel (sblkp, component (i).name.name_ptr);
		     k = fixed (component (i).name_lng, 18);
		     j = fixed (component (i).symb_start, 18);
		     mapp = addrel (oi.symbp, j);
		     ptrp->struc(i).dtc = mapp->sb.obj_creation_time;
		     ptrp->struc(i).segname = substr(name, 1, k);
		     end;
		i = i - 1;				/* do loops count one too many */
		if dcl_version > 1 then do;			/* report bindfile date if possible */
		     bf_date = bindmap.bf_date_up;
		     q = addrel (sblkp, bf_name_ptr);
		     k = fixed ( bf_name_lng, 18 );
		     if k ^= 0 then bfname = substr ( name, 1, k);
		     end;
		else do;
		     bf_date = " ";				/* earlier version */
		     k = index(Segname, " ");
		     bfname = substr(Segname, 1, k)||".bind";
		     end;
		return;
	          end;
	     ptrp->struc(1).segname = Segname;			/* for unbound segments, the following... */
	     ptrp->struc(1).dtc = oi.compile_time;
          end doc_util_;
/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */
/*  */
/*  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  ==  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  =  */

valid_lib_:	 procedure ( dn, lib);

/* Since directories can be referenced by several names, this procedure standardizes
   the system library names for documentation purposes and sets them to CAPS		     */

dcl
     dn 	char (168) aligned,				/* primary directory name       IN */
     lib 	char (168) aligned,				/* library name (or directory)  OUT */
     lb   char (32) aligned,
     i 	fixed bin;

dcl n_root_libs    fixed bin;

dcl root_libs (27) char (32) aligned init (
	"standard", "system_library_standard", "sss", "SSS",
	"system_library_dev",
	"system_library_tools", "tools", "t",
	"system_library_languages", "lang",
	"system_library_auth_maint", "auth_maint", "am", "aml",
	"installation_maintained_library", "iml", "IML",
	"system_library_unbundled", "unbundled", "unb",
	"network", "net", "system_library_network", "NET",
	 "system_library_obsolete", "obsolete", "obs" );

dcl LIBS (27) char (10) aligned init (
	"SSS", "SSS", "SSS", "SSS",
	"DEV",
	"TOOLS", "TOOLS", "TOOLS",
	"LANG", "LANG",
	"AML", "AML", "AML", "AML",
	"IML", "IML", "IML",
	"UNB", "UNB", "UNB",
	"NET", "NET", "NET", "NET",
	 "OBS", "OBS", "OBS" );

dcl n_odd_libs 	fixed bin;

dcl ODD_LIBS (10) char (10) init (
	"INCL",
	"INFO",
	"IIS",
	"RDMS",
	"RDMS_TOOLS",
	"RDMS_INCL",
	"RDMS_INFO",
	"HARD",
	"BOS",
	"MCS" );

	n_root_libs = dimension ( LIBS, 1 );
	n_odd_libs  = dimension ( ODD_LIBS, 1 );

	lb = substr (dn, 2, length(lb));			/* get rid of leading ">" */
	i = index ( lb , ">");
	if i ^= 0
	    then lb = substr ( lb, 1, (i-1));

	do i = 1 to n_root_libs;
	     if lb = root_libs(i)
		then go to got_lib;			/* look for system library */
	     end;
	i = 1;
	call MATCH_PATHS ( dn, ">ldd>include", code );		/* INCLUDE SEG? */
	if code = 0
	     then go to got_odd_lib;	

	i = 2;	
	call MATCH_PATHS ( dn, ">doc>info", code );		/* INFO SEG? */
	if code = 0
	     then go to got_odd_lib;	

	i = 3;	
	call MATCH_PATHS ( dn, ">doc>iis", code );		/* IML INFO SEG? */
	if code = 0
	     then go to got_odd_lib;	

	i = 4;	
	call MATCH_PATHS ( dn, ">lib>rdms", code );		/* RDMS SERVICE? */
	if code = 0
	     then go to got_odd_lib;	

	i = 5;	
	call MATCH_PATHS ( dn, ">lib>rdms>tools", code);		/* RDMS TOOLS? */
	if code = 0
	     then go to got_odd_lib;	

	i = 6;	
	call MATCH_PATHS ( dn, ">lib>rdms>include", code );	/* RDMS INCL? */
	if code = 0
	     then go to got_odd_lib;	

	i = 7;	
	call MATCH_PATHS ( dn, ">lib>rdms>info", code );		/* RDMS INFO? */
	if code = 0
	     then go to got_odd_lib;	

	i = 8;	
	call MATCH_PATHS (dn, ">ldd>hard>object", code );		/* HARDCORE */
	if code = 0					/*  .        */
	     then go to got_odd_lib;				/*  .        */
							/*  .        */
	call MATCH_PATHS (dn, ">ldd>hard>execution", code );	/* HARDCORE */
	if code = 0
	     then go to got_odd_lib;	

	i = 9;	
	call MATCH_PATHS (dn, ">ldd>bos>object", code );		/* BOS */
	if code = 0					/*  .  */
	     then go to got_odd_lib;				/*  .  */
							/*  .  */
	call MATCH_PATHS (dn, ">ldd>bos>execution", code );	/* BOS */
	if code = 0
	     then go to got_odd_lib;	

	i = 10;	
	call MATCH_PATHS (dn, ">ldd>comm>fnp>o", code );		/* MCS */
	if code = 0					/*  .  */
	     then go to got_odd_lib;				/*  .  */
							/*  .  */
	call MATCH_PATHS (dn, ">ldd>comm>fnp>execution", code);	/* MCS */
	if code = 0
	     then go to got_odd_lib;	

	code = 0;						/* zap error code - not needed */
no_lib:	lib = dn;						/* can't get a proper name for this one */
	return;						/* if not system lib, then leave it alone */

got_lib:	lib = LIBS(i);				/* if system lib, then set to CAPS */
	return;

got_odd_lib:
	lib = ODD_LIBS(i);				/* if known ODD lib, then set to CAPS */
	return;

     end valid_lib_;


MATCH_PATHS:	proc ( path1, path2, code );
					/* This procedure compares the unique id's of the   */
					/* two input pathnames to determine if they REALLY  */
					/* point to the same place.  If so, a 0 is returned */
					/* in the error code.  If not, a non-zero.          */

dcl
     path1	char(168) aligned,
     path2	char(168) aligned,
     code		fixed bin(35);

dcl
     UID1		bit(36),
     UID2		bit(36),
     dir_name	char(168) aligned,
     entry_name	char(32) aligned;

dcl
     expand_pathname_	entry (char(*) aligned, char(*) aligned, char(*) aligned, fixed bin(35));


	call expand_pathname_ (path1, dir_name, entry_name, code );
	if code ^= 0
	     then return;

	call upd_status_$long ( dir_name, entry_name, 1, addr(Stat), null, code );
	if code ^=0
	     then return;

	UID1 = Stat.uid;

	call expand_pathname_ ( path2, dir_name, entry_name, code );
	if code ^= 0
	     then return;

	call upd_status_$long ( dir_name, entry_name, 1, addr(Stat), null, code );
	if code ^= 0
	     then return;

	UID2 = Stat.uid;

	if UID1 = UID2
	     then code = 0;
	     else code = 1;

	return;

	end MATCH_PATHS;

%include access_mode_values;

%include terminate_file;

end upd_doc_task_;
 



		    upd_free_name_.pl1              10/04/84  1256.2rew 10/04/84  1255.5       56556


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


upd_free_name_:	procedure (dir, seg, code);


/*

	This procedure is used to rename a segment entry name to its corresponding
	backup name.  The transformation is "name" -> "name.1" (-> "name.2", etc.).
	If the backup name already exists in the directory, it will be renamed as
	well by a recursive call to upd_free_name_.  Entry point upd_free_name_$restore
	effects the inverse operation; all contiguous names in the series will be
	renamed to the previous name in the series.

	P. Bos, May 1972

     Modified: 09/04/81 by GA Texada to call appropriate hcs_ entries on linkage error.
     Modified: 09/10/84 by BL Braun to add $retain_suffix and $restore_with_suffix entrypoints.
*/

     dcl	dir			char(*),		/* dirname of affected segment */
	seg			char(*),		/* entryname to be transformed */
	suffix			char(*),            /* suffix of the entryname */
	code			fixed bin(35);	/* status code */

     dcl	backup_name_		entry (char(*)) returns (char(32)),
	chname_entry		entry(char(*), char(*), char(*), char(*), fixed bin(35)) variable,
	hcs_$chname_file		entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	installation_tools_$chname_file	entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	suffixed_name_$make		entry (char(*), char(*), char(32), fixed bin(35)),
	upd_free_name_		entry (char(*), char(*), fixed bin(35)),
	upd_free_name_$restore	entry (char(*), char(*), fixed bin(35)),
	upd_free_name_$restore_with_suffix 
				entry (char(*), char(*), char(*), fixed bin(35)),
	upd_free_name_$retain_suffix	entry (char(*), char(*), char(*), fixed bin(35));
		
     dcl linkage_error		condition;

     dcl (error_table_$namedup,
	error_table_$noentry)	ext fixed bin(35);

     dcl  (after, reverse, rtrim)	builtin;

     dcl  dot_suffix		char(32) var;
     dcl	name			char(32);		/* backup name */
     dcl  name_without_suffix		char(32);
     dcl  new_name			char(32);
     dcl  old_name			char(32);
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	name = backup_name_(seg);			/* get name transform */
	on linkage_error begin;
	     chname_entry = hcs_$chname_file;
	     goto revert_linkage_error_1;
	     end;
	chname_entry = installation_tools_$chname_file;
revert_linkage_error_1:
	revert linkage_error;
	

	call chname_entry (dir, seg, seg, name, code);	/* attempt to rename it */
	if code = error_table_$namedup then do;		/* backup name already in use */
	     call upd_free_name_(dir, name, code);	/* attempt to rename it also */
	     if code = 0 then			/* if that worked, try rename again */
		call chname_entry (dir, seg, seg, name, code);
	     end;

	return;					/* finis */


restore:		entry (dir, seg, code);		/* inverse operation */


	name = backup_name_(seg);			/* form backup name */
	on linkage_error begin;
	     chname_entry = hcs_$chname_file;
	     goto revert_linkage_error_2;
	     end;
	chname_entry = installation_tools_$chname_file;

revert_linkage_error_2:
	revert linkage_error;
	call chname_entry (dir, name, name, seg, code);	/* attempt to restore this name */
	if code = 0 then do;			/* worked, try next segment in series */
	     call upd_free_name_$restore (dir, name, code);		/* and the next, and the next, ... */
	     if code = error_table_$noentry then	/* if end of series reached, */
		code = 0;				/* no big thing */
	     end;

	return;					/* done */
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

retain_suffix:  entry  (dir, seg, suffix, code);

          code = 0;
          call suffixed_name_$make (seg, suffix, old_name, code);
	if code ^= 0 then return;
	dot_suffix = "." || rtrim(suffix);
	name_without_suffix = reverse(after(reverse(old_name), reverse(dot_suffix)));
						/* get name transform */
	name_without_suffix = backup_name_(name_without_suffix); 
	new_name = rtrim(name_without_suffix) || dot_suffix;
	
	on linkage_error begin;
	     chname_entry = hcs_$chname_file;
	     goto revert_linkage_error_3;
	     end;
	chname_entry = installation_tools_$chname_file;

revert_linkage_error_3:
	revert linkage_error;

						/* attempt to rename it */
	call chname_entry (dir, old_name, old_name, new_name, code);
	if code = error_table_$namedup then do;		/* backup name already in use */
						/* attempt to rename it also */
	     call upd_free_name_$retain_suffix(dir, new_name, suffix, code);
	     if code = 0 then			/* if that worked, try rename again */
		call chname_entry (dir, old_name, old_name, new_name, code);
	     end;
	return;					
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

restore_with_suffix:  entry  (dir, seg, suffix, code);

          code = 0;
          call suffixed_name_$make (seg, suffix, old_name, code);
	if code ^= 0 then return;
	dot_suffix = "." || rtrim(suffix);
	name_without_suffix = reverse(after(reverse(old_name), reverse(dot_suffix)));
						/* get name transform */
	name_without_suffix = backup_name_(name_without_suffix);
	new_name = rtrim(name_without_suffix) || dot_suffix;

	on linkage_error begin;
	     chname_entry = hcs_$chname_file;
	     goto revert_linkage_error_4;
	     end;
	chname_entry = installation_tools_$chname_file;

revert_linkage_error_4:
	revert linkage_error;
						/* attempt to restore this name */
	call chname_entry (dir, new_name, new_name, old_name, code);
	if code = 0 then do;			/* worked, try next segment in series */
	     call upd_free_name_$restore_with_suffix (dir, new_name, suffix, code);
						/* and the next, and the next, ... */
	     if code = error_table_$noentry then	/* if end of series reached, */
		code = 0;				/* no big thing */
	     end;

	return;					/* done */


	end upd_free_name_;



		    upd_gen_call_.pl1               11/15/82  1844.4rew 11/15/82  1513.9       24642


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


upd_gen_call_:	procedure (lp, ap);


/*

	This procedure is used within the Multics Online Updater
	to call all user-ring task procedures.  The interface is
	identical to that of cu_$gen_call, except that the procedure
	pointer is indirect, pointing to the true procedure pointer
	in the entry table maintained by upd_make_ptr_.  This allows
	task calls to be made in a new process without regenerating
	pointers in the task elements, by simply re-initializing
	the entry table.

	P. Bos, May 1972

*/

     dcl	lp			ptr,		/* task linkage pointer */
	ap			ptr;		/* task arglist pointer */

     dcl	cu_$gen_call		entry (ptr, ptr),
	hcs_$make_ptr		entry (ptr, char(*), char(*), ptr, fixed bin(35)),
	signal_			entry (char(*), ptr, ptr, ptr);

     dcl (addr, null)		builtin;

     dcl	1 l			based (lp),	/* task linkage table entry */
	  2 procp			ptr,		/* procedure pointer or null */
	  2 rname			char(32),		/* refname of procedure to be called */
	  2 ename			char(32);		/* entry point name to be called */

     dcl	1 s			aligned,		/* status block for "task_linkage_err_" */
	  2 proc			char(32),		/* name of procedure causing error */
	  2 entry			char(32),		/* entry point name */
	  2 code			fixed bin(35),	/* status code */
	  2 sev			fixed bin,	/* severity code */
	  2 rname			char(32),		/* refname of called procedure */
	  2 ename			char(32);		/* entry point name of called procedure */

/**/

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


	if l.procp = null then do;			/* has procedure entry pointer been set up? */
retry:	     call hcs_$make_ptr (null, l.rname, l.ename, l.procp, s.code);	/* no, do it */
	     if s.code ^= 0 then do;			/* error? */
		s.proc, s.entry = "upd_gen_call_";	/* that's us! */
		s.sev = 4;			/* very fatal error */
		s.rname = l.rname;			/* fill in name of called procedure */
		s.ename = l.ename;			/* and entry point */
		call signal_("task_linkage_err_", null, addr (s), null);	/* signal error */
		go to retry;			/* retry call if signal_ returns */
		end;
	     end;
	call cu_$gen_call (l.procp, ap);		/* call task procedure with specified arglist */

	return;					/* back to task dispatcher */


	end upd_gen_call_;
  



		    upd_install_task_.pl1           10/06/88  1302.4rew 10/06/88  1301.3      475470


/****^  ***********************************************************
        *                                                         *
        * 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-09-16,GDixon), approve(88-09-20,MCR8009),
     audit(88-09-22,Brunelle), install(88-10-06,MR12.2-1138):
      A) Changed update_seg to avoid reference through unset pointer for
         update_seg delete operation.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  upd_install_task_							*/
	/*									*/
	/*      This procedure is the lowest-level task translator for the Multics Online Updater.*/
	/* Its input is a single-segment installation request, and its output is a sequence of	*/
	/* primitive subtasks which perform the installation.				*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl upd_install_task_ entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin,	*/
	/*	ptr, fixed bin, (3) char(168), (3) char(32), (3) fixed bin(5), (3) ptr, 	*/
	/*	(3) fixed bin, (3) ptr, (3) fixed bin, bit(36) aligned, ptr, fixed bin(18),	*/
	/*	bit(1), char(168) aligned, fixed bin(35), fixed bin(35));			*/
	/*									*/
	/*      call upd_install_task_ (ctlw, areap, parentp, acode, asev, taskp, seqno,	*/
	/*	dir, seg, rb, ap, an, np, nn, options, max_length, full_recovery, log_dir, 	*/
	/*	installation_date, de_installation_date);				*/
	/*									*/
	/*  1) ctlw	a Multics Online Updater task control word.(In)			*/
	/*  2) areap	ptr to a caller-supplied area.(In)				*/
	/*  3) parentp	ptr to the caller's argument list.  It may be a null ptr.(In)	*/
	/*  4) acode	0.(In)							*/
	/*		a status code.(Out)						*/
	/*  5) asev	0.(In)							*/
	/*		a severity number.(Out)					*/
	/*  6) taskp	a null ptr.(In)						*/
	/*		ptr to the task control block for this call.(Out)			*/
	/*  7) seqno	a Multics Online Updater task sequence number.(In)		*/
	/*  8) dir (3)	new, old, and target segment directory names.(In)			*/
	/*  9) seg (3)	new, old, and target segment entry names.(In)			*/
	/* 10) rb (3)	ring brackets for target segment.(In)				*/
	/* 11) ap (3)	replace, delete, and add ACL array ptrs.(In)			*/
	/* 12) an (3)	replace, delete, and add ACL array entry dimensions.(In)		*/
	/* 13) np (3)	replace, delete, and add name list ptrs.(In)			*/
	/* 14) nn (3)	replace, delete, and add name list dimensions.(In)		*/
	/* 15) options	option bits:						*/
	/*     bit 1	on if the names of an archive's components are to be added to the	*/
	/*		archive itself.						*/
	/*     bit 2	on if names are to be copied from the "old" segment to the "target".	*/
	/*     bit 3	on if a "special" segment is being installed.			*/
	/*     bit 4	on if installation is to be recorded in a log.			*/
	/*     bit 5	on if information gathering to be deferred until "run" time.	*/
	/*     bit 6	on if max length setting has been explicitly specified.		*/
	/* 16) temp	a null ptr.(In)						*/
	/*		ptr to the information structure allocated by upd_install_task_.(Out)	*/
	/* 17) max_length	the value for the maximum length attribute of added or replaced	*/
	/*		segments.							*/
	/* 18) full_recovery							*/
	/*		on if the "special" target segments can be deleted when the		*/
	/*		ctlw says to run in "de_install" mode.				*/
	/* 19) log_dir								*/
	/*		if bit 4 of "options" is "on", then this argument is the documentation*/
	/*		directory where the description of the installation is to be recorded.*/
	/* 20) installation_date							*/
	/*		a Multics Storage System value for the date and time at which the 	*/
	/*		installation of the modification was performed.			*/
	/*		If this is zero, then the installation is being performed now. (In)	*/
	/* 21) de_installation_date							*/
	/*		a Multics Storage System value for the date and time at which any	*/
	/*		de-installation of the modification is performed.  If this is zero on	*/
	/*		input, then the de-installation is being performed now.(In)		*/
	/*									*/
	/* N__o_t_e_s									*/
	/*									*/
	/*      The type of installation operation to be performed (replace, add, move, or delete)*/
	/* is determined from the directory array, as follows:				*/
	/*									*/
	/*	dir(1)>seg(1)	the path name of the "new" segment to be installed.	*/
	/*	dir(2)>seg(2)	the path name of the "old" segment to be deleted.		*/
	/*	dir(3)>seg(3)	the path name of the "target" segment which is the result	*/
	/*			of the installation.				*/
	/*									*/
	/* The following combinations of path names invoke recognized installation operations:	*/
	/*									*/
	/*	dir(1)>seg(1), dir(2)>seg(2), dir(3)>seg(3)	Replace operation		*/
	/*	dir(1)>seg(1),      ""      , dir(3)>seg(3)	Add operation		*/
	/*	     ""      , dir(2)>seg(2), dir(3)>seg(3)	Move operation		*/
	/*	     ""      , dir(2)>seg(2),      ""		Delete operation		*/
	/*									*/
	/* Any other combination of pathnames is considered invalid, and triggers a		*/
	/* severity 4 error in the Multics Online Updater error handler.			*/
	/*									*/
	/*      If a target segment is to be installed, and an old segment is to be deleted	*/
	/* (as in a replace or move operation), special action is taken if ap(1) (ptr to	*/
	/* the replacement ACL array) and/or np(1) (ptr to the replacement name list) are null.	*/
	/* If ap(1) = null, then the ACL from the "old" segment is copied onto the "target"	*/
	/* segment.  If np(1) = null, then for a move operation, the names of the "old" segment	*/
	/* are placed on the "target" segment; and for a replace operation, the names of the	*/
	/* "new" segment are placed on the "target" segment, if option bit 2 is off;		*/
	/* the names of the "old" segment are placed on the "target" segment, if option bit 2 is	*/
	/* on.  Also, if a target segment is to be installed, and an old segment is to be deleted	*/
	/* (as in a replace or move operation), special action is taken if rb(1) (first ring	*/
	/* bracket for the target segment) is zero.  The rings will be listed on the old segment	*/
	/* and be placed on the target segment.  Otherwise, the caller is responsible for filling	*/
	/* in the ring bracket array (rb(1), rb(2), rb(3)), for the target segment.		*/
	/*									*/
	/*      If option bit 1 is on, then: for a replace operation, if the "new"		*/
	/* segment is an archive, the names of its components are added to the "target" segment;	*/
	/* for an add operation, if the "new" segment is an archive, the names of its components	*/
	/* are added to the "target" segment;  for a move operation, if the "old" segment	*/
	/* is an archive, the names of its components are added to the "target" segment.	*/
	/*									*/
	/*      If option bit 3 is on, then the "target" segment is said to be a "special"	*/
	/* segment, which is accorded the following special attention:			*/
	/*									*/
	/* 1) "special" segments are installed last, after all other segments.		*/
	/* 2) "special" segments are not deleted, and their ACL's are left intact, when		*/
	/*    upd_install_task_ is invoked in "de_install" mode (via the ctlw) after having been	*/
	/*    invoked in "install" mode, if (and only if) the full_recovery switch		*/
	/*    is off.  If it is not off, then "special" segments are deleted as a part of	*/
	/*    "de_install" mode processing.						*/
	/*									*/
	/*      If option bit 5 is on, the the new and old segment unique ids, the names on	*/
	/* the new and old segments, the ACL on the old segment, and the names of new segment	*/
	/* archive components are not gathered until upd_install_task_ is executed in "run" mode.	*/
	/* Otherwise, these things are gathered the first time upd_install_task_ is executed in	*/
	/* any mode.								*/
	/*									*/
	/*      If option bit 6 is off, then the max length attribute of the "target" segment	*/
	/* will acquire a default value.  If the "target" segment is a "special segment", then	*/
	/* the max length attribute will be set to the segments current length.  Otherwise, the	*/
	/* max length will default to sys_info$default_max_length.  If option bit 6 is on, then	*/
	/* the max length will assume the value of the max_length argument passed by the caller.	*/
	/*									*/
	/* N__a_m_e:  upd_install_task_$init						*/
	/*									*/
	/*      This procedure is invoked only once during the installation of a modification,	*/
	/* (a group of related segments that are to be installed at the same time).  Its output	*/
	/* is a sequence of primitive subtasks which type messages to the installer informing	*/
	/* him or her of the progress of the installation.				*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl upd_install_task_$init entry (bit(36) aligned, ptr, ptr, fixed bin(35),	*/
	/*	fixed bin, ptr, fixed bin, bit(1), bit(1), ptr);				*/
	/*									*/
	/*      call upd_install_task_$init (ctlw, areap, parentp, acode, asev, taskp, seqno,	*/
	/*	special_segs, full_recovery, temp);					*/
	/*									*/
	/* 1) - 7)	are as above.						*/
	/* 8) special_segs								*/
	/*		on if "special" segs are being installed as part of the		*/
	/*		modification.(In)						*/
	/* 9) full_recovery								*/
	/*		is as above.(In)						*/
	/* 10) temp	a null ptr.(In)						*/
	/*		ptr to the information structure allocated by upd_install_task_$init	*/
	/*		for its own use.(Out)					*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 1) Created:  May, 1972 by P. R. Bos						*/
	/* 2) Modified: Dec, 1972 by G. C. Dixon - upd_install_task_$init, "special" segments,	*/
	/*				   full_recovery added; improved error recovery	*/
	/*				   message information values passed to subtasks.	*/
	/* 3) Modified: Dec, 1972 by G. C. Dixon - "deferred gathering" option added		*/
	/* 4) Modified: May, 1973 by P.B. Kelley - added upd_ring_task_ to task list to perform	*/
	/*				   all ring bracket tasks.	  		*/
	/* 5) Modified: Nov, 1974 by P.B. Kelley - added option 6 to incorporate max length	*/
	/*				   attribute setting.			*/
	/* 6) Modified: Mar, 1981 by E. N. Kittlitz - added get_entry_bound entry, support        */
	/*				   for setting EB in copy task.                   */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

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


upd_install_task_:	procedure (ctlw, areap, parentp, acode, asev, taskp, seqno,
			 dir, seg, rb, ap, an, np, nn, options, temp, max_length,
			full_recovery_sw,  log_dir, in_date, de_in_date)
		options ( rename ((alloc_, smart_alloc_ )) );


     dcl	ctlw			bit(36) aligned,	/* control word */
	areap			ptr,		/* pointer to user area */
	parentp			ptr,		/* pointer to parent task */
	acode			fixed bin(35),	/* returned status code */
	asev			fixed bin,	/* severity code to match */
	taskp			ptr,		/* pointer to task for this call */
	seqno			fixed bin,	/* task seqno for this call */
	dir (3)			char(168),	/* dirname array (upd, old, target) */
	seg (3)			char(32),		/* entryname array */
	rb (3)			fixed bin(5),	/* ring brackets for target seg */
	ap (3)			ptr,		/* acl pointer array (replace, delete, add) */
	an (3)			fixed bin,	/* corresponding acl sizes */
	np (3)			ptr,		/* name list pointer array */
	nn (3)			fixed bin,	/* name list sizes */
	options			bit(36) aligned,	/* name options */
	temp			ptr,		/* pointer to "t" or "it" structure (initially null) */
	max_length		fixed bin(18),	/* max seg length attribute */
	full_recovery_sw		bit(1),		/* on if segs can be deleted in "de_install" */
	special_segs_sw		bit(1),		/* on if special segments are being installed. */
	log_dir			char(168) aligned,	/* documentation directory */
	ioseg			char(32) aligned,	/* name of current io seg */
	in_date			fixed bin(35),	/* 0, or file system value for date of installation */
	de_in_date		fixed bin(35);	/* 0, or value for date of any de_installation */

     dcl (addr, fixed, index, length, mod, null, substr)
				builtin;

     dcl	cu_$arg_list_ptr		entry (ptr),
	ioa_$ioa_stream		entry options (variable),
	upd_print_acl_		entry (ptr, fixed bin, bit(*)),
	unique_chars_		entry (bit(*)) returns (char(15)),
	upd_add_task_		entry (char(*), ptr),
	upd_print_err_		entry options (variable),
	upd_print_names_		entry (ptr, fixed bin, bit(*)),
	upd_task_err_		entry options (variable);

     dcl	upd_acl_task_$add		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_acl_task_$delete	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_acl_task_$list		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_acl_task_$list_inacl	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin, (3) fixed bin(5)),
	upd_acl_task_$replace	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin, bit(1)),
	upd_copy_seg_task_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned,
				char(168), char(32), char(32), bit(36) aligned, fixed bin(18), fixed bin (14), bit(1)),
	upd_doc_task_$get_tree	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				(3) char(168), (3) char(32), (3) bit(36) aligned, ptr),
	upd_doc_task_$write_tree	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				ptr, fixed bin(35), fixed bin(35), char(168) aligned, bit(1) aligned),
	upd_message_task_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				bit(1), bit(1), bit(1) aligned, ptr, fixed bin, ptr, fixed bin),
	upd_name_task_$add		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_name_task_$delete	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_name_task_$free		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_name_task_$list		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_name_task_$list_archive	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, ptr, fixed bin),
	upd_ring_task_$list		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, (3) fixed bin(5)),
	upd_ring_task_$set		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), char(32), bit(36) aligned, (3) fixed bin(5), bit(1)),
	upd_status_task_$get_uid	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				char(168), char(32), bit(36) aligned);

     dcl (error_table_$badcall,
	error_table_$not_done)	ext fixed bin(35);

     dcl  sys_info$default_max_length	ext static fixed bin(18);

     dcl	argp			ptr,		/* arglist pointer */
	cp			ptr,		/* control word pointer */
	sp			ptr,		/* for overlay on "sws" */
	tp			ptr;		/* pointer to "t" structure */

     dcl	aclsw (3)			bit(2) int static init ("10"b, "00"b, "10"b),
	logsw			bit(1) aligned,	/* c.logsw | (c.errsw & asev ^= 0) */
	sws			bit(18) aligned,	/* define type of call, from args */
	state			bit(36) aligned,	/* = sws || ^sws */
	ndig_ctl			bit(36) aligned,	/* control word for non-deferred subtasks */
	no_print_ctl		bit(36) aligned,	/* control word for subtasks which print normally */
	print_ctl			bit(36) aligned;	/* control word for subtasks which print in detail */

     dcl	ndig_mask (9)		bit(36) int static init (	/* non-deferred information gathering mask */
							/* for the condition state word. */
		"010000000000000000000000000000001000"b,	/*  (1)  dsw(2) & ^option(5) */
		"010000000000000000000000000000001000"b,	/*  (2)  dsw(2) & ^option(5) */
		"011000000000000000000000000100001000"b,	/*  (3)  dsw(2) & dsw(3) & ^rbsw & ^option(5)  */
		"011000000000000000000100000000001010"b,	/*  (4)  dsw(2) & dsw(3) & ^asw(1) & ^option(5) &^o(7)*/
		"001000000000000010000100000000001000"b,	/*  (5)   dsw(3) & ^asw(1) & ^option(5) & option(7)*/
		"100000000000000000000001000000001000"b,	/*  (6)  dsw(1) & ^option(5) */
		"001000000000000000000000100000001000"b,	/*  (7)  dsw(3) & ^nsw(1) & ^option(5) */
		"001000000010000000000000000000001000"b,	/*  (8)  dsw(3) & option(1) & ^option(5) */
		"000000000000010000000000000000001000"b);	/*  (9)  option(4) & ^option(5) */

     dcl	mask (30)			bit(36) int static init (	/* condition masks for state word */
		"010000000000001000000000000000000000"b,	/*  (1)  dsw(2) & option(5) */
		"010000000000001000000000000000000000"b,	/*  (2)  dsw(2) & option(5) */
		"011000000000001000000000000100000000"b,	/*  (3)  dsw(2) & dsw(3) & ^rbsw & option(5)  */
		"011000000000001000000100000000000010"b,	/*  (4)  dsw(2) & dsw(3) & ^asw(1) & option(5) & ^o(7)*/
		"001000000000001010000100000000000000"b,	/*  (5)  dsw(3) & ^asw(1) & option(5) & option(7) */
		"100000000000001000000000000000000000"b,	/*  (6)  dsw(1) & option(5) */
		"001000000000001000000000100000000000"b,	/*  (7)  dsw(3) & ^nsw(1) & option(5) */
		"001000000010001000000000000000000000"b,	/*  (8)  dsw(3) & option(1) & option(5) */
		"000000000000011000000000000000000000"b,	/*  (9)  option(4) & option(5) */
		"001000000000000000000000000000100000"b,	/* (10)  dsw(3) & ^option(3) */
		"001000000000100000000000000000000000"b,	/* (11)  dsw(3) & option(3) */
		"001000000000000000000000000000100000"b,	/* (12)  dsw(3) & ^option(3) */
		"001000000000100000000000000000000000"b,	/* (13)  dsw(3) & option(3) */
		"001000000000000000000000000000100000"b,	/* (14)  dsw(3) & ^option(3) */
		"001000000000100000000000000000000000"b,	/* (15)  dsw(3) & option(3) */
		"001010000000000000000000000000000000"b,	/* (16)  dsw(3) & asw(2) */
		"001001000000000000000000000000000000"b,	/* (17)  dsw(3) & asw(3) */
		"010000000000000000000000000000000000"b,	/* (18)  dsw(2) */
		"010000000000000000000000000000100000"b,	/* (19)  dsw(2) & ^option(3) */
		"001000000000000000000000000000100000"b,	/* (20)  dsw(3) & ^option(3) */
		"001000001000000000000000000000100000"b,	/* (21)  dsw(3) & nsw(3) & ^option(3) */
		"001000000010000000000000000000100000"b,	/* (22)  dsw(3) & option(1) & ^option(3) */
		"001000010000000000000000000000100000"b,	/* (23)  dsw(3) & nsw(2) & ^option(3) */
		"010000000000100000000000000000000000"b,	/* (24)  dsw(2) & option(3) */
		"001000000000100000000000000000000000"b,	/* (25)  dsw(3) & option(3) */
		"001000001000100000000000000000000000"b,	/* (26)  dsw(3) & nsw(3) & option(3) */
		"001000000010100000000000000000000000"b,	/* (27)  dsw(3) & option(1) & option(3) */
		"001000010000100000000000000000000000"b,	/* (28)  dsw(3) & nsw(2) & option(3) */
		"001000000000000000000000000000000000"b,	/* (29)  dsw(3) */
		"000000000000010000000000000000000000"b);	/* (30)  option(4) */

     dcl	a			fixed bin,	/* action index */
	i			fixed bin;	/* random */

     dcl	action_table (0:7)		fixed bin int static init (0, 0, 4, 3, 0, 2, 0, 1);

     dcl	amsg (4)			char(28) int static init ("Access control list", "ACL deletions", "ACL additions", "Initial access control list"),
	msg1 (4)			char(4) int static init ("by", "Add", "", ""),
	msg2 (4)			char(8) int static init ("Replace", "", "Move", "Delete"),
	msg3 (4)			char(4) int static init ("as", "as", "to", ""),
	nmsg (3)			char(16) int static init ("Names", "Name deletions", "Name additions"),
	install_message (5)		char (58) aligned varying init (
				"Beginning installation of ",
				"",
				"Copying special target segments.",
				"Adding names to special target segments.",
				"Installation complete."),
	de_install_message (5)	char (61) aligned varying init (
				"De-installation complete.",
				"Non-special target segments deleted.",
				"Special target segments deleted.",
				"Names removed from special target segments.",
				"Beginning De-installation of ");

     dcl	bdir			char(168) based,	/* based dirname */
	bseg			char(32) based,	/* based entryname */
	buid			bit(36) aligned based;	/* based uid */

     dcl	area			area based (areap);	/* caller-supplied area */

     dcl	1 s			aligned based (sp),	/* exploded version of "sws" */
	 (2 dsw (3)		bit(1),		/* non-zero if dir(i) ^= "" */
	  2 asw (3)		bit(1),		/* non-zero if ap(i) ^= null */
	  2 nsw (3)		bit(1),		/* non-zero if np(i) ^= null */
	  2 rbsw			bit(1),		/* non-zero if rb(1) ^= 0 */
	  2 option (7)		bit(1)) unal;	/* 1-7: copy of option bits */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 de_install_sw		bit(1),		/* non-zero if in de_install mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1),		/* non-zero if printing error tasks only */
	  2 briefsw		bit(1),		/* non-zero if brief mode */
	  2 detailsw		bit(1),		/* non-zero if to print subtasks */
	  2 clear_code_sw		bit(1),		/* non-zero if to clear error codes and try again */
	  2 clear_uid_sw		bit(1)) unal;	/* non-zero if to clear unique ids */

     dcl	1 t			aligned based (tp),	/* internal temporaries which need preserving */
	  2 t,					/* dummy name list for temp name on new seg */
	    3 name		char(32) unal,	/* fudge alignment */
	    3 pcode		fixed bin(35),	/* process code */
	    3 rcode		fixed bin(35),	/* restore code */
	  2 tp			ptr,		/* pointer to "t.t" */
	  2 d,					/* dummy name list for temp name on old seg */
	    3 name		char(32) unal,	/* name (fudge alignment) */
	    3 pcode		fixed bin(35),	/* process code */
	    3 rcode		fixed bin(35),	/* restore code */
	  2 dp			ptr,		/* pointer to "t.d" */
	  2 nldp			ptr,		/* pointer to dirname of seg to have names listed */
	  2 nlsp			ptr,		/* pointer to entryname of same */
	  2 nlup			ptr,		/* pointer to uid of same */
	  2 cpdp			ptr,		/* pointer to dirname of seg to be copied */
	  2 cpsp			ptr,		/* pointer to entryname of same */
	  2 cpup			ptr,		/* pointer to uid of same */
	  2 a			fixed bin,	/* action code */
	  2 state			bit(36),		/* state word (sws || ^sws) */
	  2 np,					/* pointers to generated name arrays */
	    3 old			ptr init (null),	/* names to be removed from old seg */
	    3 arc			ptr init (null),	/* component names for archive */
	  2 nn,					/* name list sizes (go with "t.np.xxx") */
	    3 old			fixed bin init (0),	/* names to be removed from old seg */
	    3 arc			fixed bin init (0),	/* archive component names */
	  2 treep			ptr init (null),	/* ptr to modification description tree */
	  2 maxlen		fixed bin(18),	/* max length */
	  2 eb			fixed bin (14),     /* entry bound */
	  2 logdir		char(168) aligned init (""), /* documentation directory */
	  2 argp			ptr init (null),	/* arglist pointer, for subtask parentp */
	  2 taskp (30)		ptr init ((30) null),	/* task pointer array for subtasks */
	  2 seqno (30)		fixed bin init (
				     2,3,4,5,6,7,8,9,10,12,
				     14,15,16,17,18,19,20,21,22,23,
				     24,25,26,27,28,30,31,32,33,36),
	  2 code (30)		fixed bin(35) init ((30) 0),	/* subtask status codes */
	  2 sev (30)		fixed bin init ((30) 0),	/* subtask severity codes */
	  2 uid (3)		bit(36) init ((3) (36) "0"b),	/* unique id's for all three segs */
	  2 fwd_logging_done_sw	bit(1) aligned init ("0"b),	/* non-zero if installation was logged */
	  2 log_dir_sw		bit(1) aligned init ("0"b),	/* non-zero if logdir cannot be changed */
	  2 one			fixed bin init (1),	/* constant "1" */
	  2 recover		bit(1) unal init ("1"b);	/* static for "always full recovery switch" */

     dcl	1 it			aligned based (tp),	/* internal temps used by upd_install_task_$init */
	  2 argp			ptr init (null),	/* static ptr to our arg list */
	  2 taskp (5)		ptr init ((5) null),/* subtasks tasp ptrs. */
	  2 code (5)		fixed bin(35) init ((5) 0),
						/* status code 			*/
	  2 sev  (5)		fixed bin init ((5) 0),
						/* severity code. */
	  2 seqno (5)		fixed bin init (1, 11, 13, 29, 34),
						/* sequence number of task execution order. */
	  2 fwd_done_sw (5)		bit(1) aligned init ((5)(1)"0"b),
						/* fwd message printed switches. */
	  2 fwd_msgp (5)		ptr,		/* ptr to "install" messages. */
	  2 rev_msgp (5)		ptr,		/* ptr to "de_install" messages. */
	  2 fwd_msgl (5)		fixed bin,	/* length of "install" messages. */
	  2 rev_msgl (5)		fixed bin,	/* length of "de_install" messages. */
	  2 print			bit(1) unal init ("1"b),
						/* static switch for "always print message" */
	  2 noprint		bit(1) unal init ("0"b);
						/* static switch for "never print message" */

     dcl	fwd_msg			char (it.fwd_msgl(i)) aligned based (it.fwd_msgp(i)),
	rev_msg			char (it.rev_msgl(i)) aligned based (it.rev_msgp(i));

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

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


	call cu_$arg_list_ptr (argp);			/* get pointer to arglist */
	cp = addr (ctlw);				/* get pointer to control word */
	if c.de_install_sw then			/* upd_install_task_ does not run in de_install */
	     return;				/* bye.. */
	print_ctl = ctlw & "00010111110"b;		/* form subtask control words */
	no_print_ctl = ctlw & "00010111010"b;		/* suppresses detailed printing of some tasks */
	ndig_ctl = ctlw & "0001"b;
	if c.compsw then do;			/* if we're compiling subtasks, */
	     print_ctl = print_ctl | "01"b;		/* set tasksw for them */
	     no_print_ctl = no_print_ctl | "01"b;
	     end;
	if c.tasksw then				/* if we're allocating a task, */
	     ndig_ctl = ndig_ctl | "0001"b;		/* "run" non-deferred information gatherers now. */

	if temp = null then do;			/* allocated temps yet? */
	     sp = addr (sws);			/* reference sws as arrays */
	     sws = "0"b;				/* zero them first */
	     do i = 1 to 3;				/* 3 of everything */
		s.dsw(i) = (dir(i) ^= "");		/* test all kinds of conditions */
		s.asw(i) = (ap(i) ^= null);		/* see which acls given */
		s.nsw(i) = (np(i) ^= null);		/* see which name lists given */
		end;
	     if s.dsw(3)				/* if there is to exist a target seg */
		then s.rbsw = (rb(1) ^= 0);		/* were rings given for it? */
	     substr (sws, 11, 7) = substr(options,1,7);	/* fill in caller's option bits */
	     a = action_table (fixed (substr (sws, 1, 3)));
						/* s.dsw define type of call */
	     if a = 0 then do;			/* unknown action */
		call upd_task_err_(error_table_$badcall, 4, argp, "upd_install_task_", "Unknown action implied.");
		return;
		end;
	     state = sws || ^sws;			/* form 36 bit state word for masking */
	     allocate t in (area);			/* allocate space for temps, etc. */
	     t.t.name = unique_chars_("0"b);		/* get temp name for new seg */
	     t.d.name = unique_chars_("0"b);		/* and a handle for old seg */
	     t.t.pcode, t.d.pcode = error_table_$not_done;/* initialize status codes on dummy name lists */
	     t.t.rcode, t.d.rcode = 0;
	     t.tp = addr (t.t);			/* get pointers to them also */
	     t.dp = addr (t.d);
	     if a < 3 then do;			/* replace or add operation */
		t.cpdp, t.nldp = addr (dir(1));	/* copying, getting names from new seg */
		t.cpsp, t.nlsp = addr (seg(1));
		t.cpup, t.nlup = addr (t.uid(1));
		if s.dsw(2) & s.option(2) then do;	/* user wants names from old seg */
		     t.nldp = addr (dir(2));		/* so change them */
		     t.nlsp = addr (seg(2));
		     t.nlup = addr (t.uid(2));
		     end;
		end;
	     else if a = 3 then do;			/* move operation */
		t.cpdp, t.nldp = addr (dir(2));	/* everything comes from old seg */
		t.cpsp, t.nlsp = addr (seg(2));
		t.cpup, t.nlup = addr (t.uid(2));
		end;
	     else do;				/* delete operation */
		t.cpdp, t.nldp, t.cpsp, t.nlsp, t.cpup, t.nlup = null;
		end;
	     t.a = a;				/* save action code */
	     t.logdir = log_dir;			/* copy documentation directory; it gets changed later */
	     if a < 4 then
		call get_entry_bound (t.cpdp -> bdir, t.cpsp -> bseg, t.eb);
						/* try for entry bound */
	     else t.eb = 0;
	     if (options & "000001"b) then		/* max length */
		t.maxlen = max_length;		/* fill in from caller */
	     else if (options & "001000"b) then		/* give default for special segs */
		t.maxlen = 0;			/* (will be set to curlen) */
	     else					/* give default for non-special segs */
		t.maxlen = sys_info$default_max_length;	/* (system default) */
						/* perform non-deferred information gathering */
	     t.argp = argp;
	     if (state & ndig_mask(1)) = ndig_mask(1) then/* get unique id of old seg */
		call upd_status_task_$get_uid (ndig_ctl, areap, t.argp, t.code(1), t.sev(1), t.taskp(1), t.seqno(1),
		     dir(2), seg(2), t.uid(2));
	     if (state & ndig_mask(2)) = ndig_mask(2) then/* list names on old seg, to remove later */
		call upd_name_task_$list (ndig_ctl, areap, t.argp, t.code(2), t.sev(2), t.taskp(2), t.seqno(2),
		     dir(2), seg(2), seg(2), t.uid(2), t.np.old, t.nn.old);
	     if (state & ndig_mask(3)) = ndig_mask(3) then/* get rings of old seg to put on new seg */
		call upd_ring_task_$list (ndig_ctl, areap, t.argp, t.code(3), t.sev(3), t.taskp(3), t.seqno(3),
		     dir(2), seg(2), seg(2), t.uid(2), rb);
	     if (state & ndig_mask(4)) = ndig_mask(4) then/* get acl of old seg to put on new seg */
		call upd_acl_task_$list (ndig_ctl, areap, t.argp, t.code(4), t.sev(4), t.taskp(4), t.seqno(4),
		     dir(2), seg(2), seg(2), t.uid(2), ap(1), an(1));
	     if (state & ndig_mask(5)) = ndig_mask(5) then/* get acl of old seg to put on new seg */
		call upd_acl_task_$list_inacl (ndig_ctl, areap, t.argp, t.code(4), t.sev(4), t.taskp(4), t.seqno(4),
		     dir(3), seg(3), seg(3), t.uid(3), ap(1), an(1), rb);
	     if (state & ndig_mask(6)) = ndig_mask(6) then/* get unique id of new seg */
		call upd_status_task_$get_uid (ndig_ctl, areap, t.argp, t.code(5), t.sev(5), t.taskp(5), t.seqno(5),
		     dir(1), seg(1), t.uid(1));
	     if (state & ndig_mask(7)) = ndig_mask(7) then/* get name list for target seg from new seg */
		call upd_name_task_$list (ndig_ctl, areap, t.argp, t.code(6), t.sev(6), t.taskp(6), t.seqno(6),
		     t.nldp -> bdir, t.nlsp -> bseg, t.nlsp -> bseg, t.nlup -> buid, np(1), nn(1));
	     if (state & ndig_mask(8)) = ndig_mask(8) then/* archive option, get name list from components */
		call upd_name_task_$list_archive (ndig_ctl, areap, t.argp, t.code(7), t.sev(7), t.taskp(7), t.seqno(7),
		     t.cpdp -> bdir, t.cpsp -> bseg, t.cpsp -> bseg, t.cpup -> buid, t.np.arc, t.nn.arc);
	     if (state & ndig_mask(9)) = ndig_mask(9) then/* log option; get modification description tree */
		call upd_doc_task_$get_tree (ndig_ctl, areap, t.argp, t.code(8), t.sev(8), t.taskp(8), t.seqno(8),
		     dir, seg, t.uid, t.treep);

	     t.state = state;			/* save state word */
	     temp = tp;				/* have caller save pointer for us */
	     end;
	else do;					/* already done, we were interrupted */
	     tp = temp;				/* just get it back again */
	     a = t.a;				/* make code a little more efficient */
	     state = t.state;
	     end;


	if c.tasksw then 				/* allocating a task? */
	     call upd_add_task_("upd_install_task_", argp);
	logsw = c.logsw;				/* non-zero if printing */
	if c.errsw then if asev = 0 then		/* error option, print if error only */
	     logsw = "0"b;				/* reset bit if no error */

	if c.clear_code_sw then do;			/* user wants error codes cleared for a retry */
	     acode,
	     asev,
	     t.code,
	     t.sev = 0;
	     end;

	if c.clear_uid_sw then			/* user wants unique id's cleared for a retry */
	     t.uid = "0"b;				/* reloader resets uid's on all segments. */
						/* uid's stored in io seg must be set to 0 to do a */
						/* restore after a reload has been done. */

	if ^t.log_dir_sw then			/* if we can still update the log directory */
	     t.logdir = log_dir;			/* then do it */

	if logsw then do;				/* user wants to know what's going on (don't we all) */
	     sp = addr (state);			/* overlay structure on it */
	     if c.detailsw then			/* space up paper a bit */
		call ioa_$ioa_stream ("installation_list_", "^|^/");
	     else
		call ioa_$ioa_stream ("installation_list_", "^/");
	     if s.dsw(2) then			/* replacing, moving or deleting somebody? */
		call ioa_$ioa_stream ("installation_list_", "^10a^a>^a", (msg2(a)), dir(2), seg(2));
	     if s.dsw(1) then			/* adding or replacing? */
		call ioa_$ioa_stream ("installation_list_", "^10a^a>^a", (msg1(a)), dir(1), seg(1));
	     if dir(2) = dir(3) then if seg(2) = seg(3) then	/* replace with target = old, omit third msg */
		go to skip;			/* skip */
	     if s.dsw(3) then			/* somebody going in? */
		call ioa_$ioa_stream ("installation_list_", "^10a^a>^a", (msg3(a)), dir(3), seg(3));
skip:	     if c.briefsw then			/* brief mode? */
		go to brief;			/* yes, skip options */
	     if (options & "1111111"b) then do;		/* tell user what options are */
		call ioa_$ioa_stream ("installation_list_", "^5xOptions:");
		if s.option(1) then
		     call ioa_$ioa_stream ("installation_list_", "^-Add component names");
		if s.option(2) then
		     call ioa_$ioa_stream ("installation_list_", "^-Use old names");
		if s.option(3) then
		     call ioa_$ioa_stream ("installation_list_", "^-Special segment");
		if s.option(4) then
		     call ioa_$ioa_stream ("installation_list_", "^-Log the installation");
		if s.option(5) then
		     call ioa_$ioa_stream ("installation_list_", "^-Deferred information gathering");
		if s.option(6) then
		     call ioa_$ioa_stream ("installation_list_", "^-Set maximum length");
		end;
	     if c.detailsw | c.errsw then		/* do print args in full if they will be printed */
		go to end_log_print;		/* later. */
	     if s.rbsw then				/* print ring brackets option, if exists */
		call ioa_$ioa_stream ("installation_list_", "^5xSet ring brackets:^/^10x^d,^d,^d",
		     rb(1), rb(2), rb(3) );
	     if t.eb > 0 then
		call ioa_$ioa_stream ("installation_list_", "^5xSet entry bound:^/^10x^d", t.eb);

	     if option(7) then do;			/* user requested INACL */
		     call ioa_$ioa_stream ("installation_list_", "^5x^a:", (amsg(4)));	/* print header */
		     call upd_print_acl_(ap(1), an(1), (aclsw(1)));
	     end;		
	     else do i = 1 to 3;				/* print acl options */
		if ap(i) ^= null then do;		/* this one here? */
		     call ioa_$ioa_stream ("installation_list_", "^5x^a:", (amsg(i)));	/* print header */
		     call upd_print_acl_(ap(i), an(i), (aclsw(i)));
		     end;
		end;
	     do i = 1 to 3;				/* print name options */
		if np(i) ^= null then do;		/* this one here? */
		     call ioa_$ioa_stream ("installation_list_", "^5x^a:", (nmsg(i)));	/* print header */
		     call upd_print_names_(np(i), nn(i), "00"b);
		     end;
		end;
	     if s.option(1) then do;			/* archive option? */
		call ioa_$ioa_stream ("installation_list_", "^5xArchive component names:");	/* print header */
		call upd_print_names_(t.np.arc, t.nn.arc, "00"b);	/* print name list */
		end;
	     if s.option(4) then do;			/* print Log information */
		call ioa_$ioa_stream ("installation_list_", "^5xLog Information:");		/* print header */
		call upd_doc_task_$write_tree ("00000100000"b, areap, null, 0, 0, null, 0,
		     t.treep, in_date, de_in_date, t.logdir, "0"b);	/* pass only minimum arguments */
		end;
brief:	     if asev ^= 0 then			/* was there an error last time? */
		call upd_print_err_(acode, asev);	/* yes, print it */
	     end;

end_log_print:
	t.argp = argp;				/* set parentp for subtasks in static. */
	ndig_ctl = ctlw & "000001110"b;		/* ndig's can only print from this point on, */
						/* and never in detail. */
	if ^c.detailsw & ^c.errsw then do;		/* user want subtasks printed? */
	     print_ctl = print_ctl & "11110000010"b;		/* no, mask out all print bits */
	     no_print_ctl = no_print_ctl & "11110000010"b;
	     ndig_ctl = "0"b;
	     end;

	if ndig_ctl = "0"b then			/* no more ndig tasks? */
	     go to check_dig;			/* see if there are any deferred tasks to do */

	if logsw then				/* don't confuse user */
	     call ioa_$ioa_stream ("installation_list_", "Subtasks follow.");		/* tell him which is which */
	if (state & ndig_mask(1)) = ndig_mask(1) then	/* get unique id of old seg */
	     call upd_status_task_$get_uid (ndig_ctl, areap, t.argp, t.code(1), t.sev(1), t.taskp(1), t.seqno(1),
	          dir(2), seg(2), t.uid(2));
	if (state & ndig_mask(2)) = ndig_mask(2) then	/* list names on old seg, to remove later */
	     call upd_name_task_$list (ndig_ctl, areap, t.argp, t.code(2), t.sev(2), t.taskp(2), t.seqno(2),
	          dir(2), seg(2), seg(2), t.uid(2), t.np.old, t.nn.old);
	if (state & ndig_mask(3)) = ndig_mask(3) then	/* get rings of old seg to put on new seg */
		call upd_ring_task_$list (ndig_ctl, areap, t.argp, t.code(3), t.sev(3), t.taskp(3), t.seqno(3),
		     dir(2), seg(2), seg(2), t.uid(2), rb);
	if (state & ndig_mask(4)) = ndig_mask(4) then	/* get acl of old seg to put on new seg */
	     call upd_acl_task_$list (ndig_ctl, areap, t.argp, t.code(4), t.sev(4), t.taskp(4), t.seqno(4),
	          dir(2), seg(2), seg(2), t.uid(2), ap(1), an(1));
	if (state & ndig_mask(5)) = ndig_mask(5) then	/* get INACL of target dir */
	     call upd_acl_task_$list_inacl (ndig_ctl, areap, t.argp, t.code(5), t.sev(5), t.taskp(5), t.seqno(5),
	          dir(3), seg(3), seg(3), t.uid(3), ap(1), an(1), rb);
	if (state & ndig_mask(6)) = ndig_mask(6) then	/* get unique id of new seg */
	     call upd_status_task_$get_uid (ndig_ctl, areap, t.argp, t.code(6), t.sev(6), t.taskp(6), t.seqno(6),
	          dir(1), seg(1), t.uid(1));
	if (state & ndig_mask(7)) = ndig_mask(7) then	/* get name list for target seg from new seg */
	     call upd_name_task_$list (ndig_ctl, areap, t.argp, t.code(7), t.sev(7), t.taskp(7), t.seqno(7),
	          t.nldp -> bdir, t.nlsp -> bseg, t.nlsp -> bseg, t.nlup -> buid, np(1), nn(1));
	if (state & ndig_mask(8)) = ndig_mask(8) then	/* archive option, get name list from components */
	     call upd_name_task_$list_archive (ndig_ctl, areap, t.argp, t.code(8), t.sev(8), t.taskp(8), t.seqno(8),
	          t.cpdp -> bdir, t.cpsp -> bseg, t.cpsp -> bseg, t.cpup -> buid, t.np.arc, t.nn.arc);
	if (state & ndig_mask(9)) = ndig_mask(9) then	/* log option; get modification description tree */
	     call upd_doc_task_$get_tree (ndig_ctl, areap, t.argp, t.code(9), t.sev(9), t.taskp(9), t.seqno(9),
		dir, seg, t.uid, t.treep);

check_dig:
	if no_print_ctl = "0"b then			/* nothing more to do */
	     return;				/* scram */

	if (no_print_ctl & "01"b) then		/* if we're setting up the subtasks */
	     t.log_dir_sw = "1"b;			/* log directory cannot be changed from now on */

	if (state & mask(1)) = mask(1) then		/* get unique id of old seg */
	     call upd_status_task_$get_uid (no_print_ctl, areap, t.argp, t.code(1), t.sev(1), t.taskp(1), t.seqno(1),
		dir(2), seg(2), t.uid(2));
	if (state & mask(2)) = mask(2) then		/* list names on old seg, to remove later */
	     call upd_name_task_$list (no_print_ctl, areap, t.argp, t.code(2), t.sev(2), t.taskp(2), t.seqno(2),
		dir(2), seg(2), seg(2), t.uid(2), t.np.old, t.nn.old);
	if (state & mask(3)) = mask(3) then		/* get rings of old seg to put on new seg */
	     call upd_ring_task_$list (no_print_ctl, areap, t.argp, t.code(3), t.sev(3), t.taskp(3), t.seqno(3),
		dir(2), seg(2), seg(2), t.uid(2), rb);
	if (state & mask(4)) = mask(4) then		/* get acl of old seg to put on new seg */
	     call upd_acl_task_$list (no_print_ctl, areap, t.argp, t.code(4), t.sev(4), t.taskp(4), t.seqno(4),
		dir(2), seg(2), seg(2), t.uid(2), ap(1), an(1));
	if (state & mask(5)) = mask(5) then		/* get acl of old seg to put on new seg */
	     call upd_acl_task_$list_inacl (no_print_ctl, areap, t.argp, t.code(5), t.sev(5), t.taskp(5), t.seqno(5),
		dir(2), seg(2), seg(2), t.uid(2), ap(1), an(1), rb);
	if (state & mask(6)) = mask(6) then		/* get unique id of new seg */
	     call upd_status_task_$get_uid (no_print_ctl, areap, t.argp, t.code(6), t.sev(6), t.taskp(6), t.seqno(6),
		dir(1), seg(1), t.uid(1));
	if (state & mask(7)) = mask(7) then		/* get name list for target seg from new seg */
	     call upd_name_task_$list (no_print_ctl, areap, t.argp, t.code(7), t.sev(7), t.taskp(7), t.seqno(7),
		t.nldp -> bdir, t.nlsp -> bseg, t.nlsp -> bseg, t.nlup -> buid, np(1), nn(1));
	if (state & mask(8)) = mask(8) then		/* archive option, get name list from components */
	     call upd_name_task_$list_archive (no_print_ctl, areap, t.argp, t.code(8), t.sev(8), t.taskp(8), t.seqno(8),
		t.cpdp -> bdir, t.cpsp -> bseg, t.cpsp -> bseg, t.cpup -> buid, t.np.arc, t.nn.arc);
	if (state & mask(9)) = mask(9) then		/* log option; get modification description tree */
	     call upd_doc_task_$get_tree (no_print_ctl, areap, t.argp, t.code(9), t.sev(9), t.taskp(9), t.seqno(9),
		dir, seg, t.uid, t.treep);
	if (state & mask(10)) = mask(10) then		/* copy segment (new/old -> target) (non-special) */
	     call upd_copy_seg_task_(print_ctl, areap, t.argp, t.code(10), t.sev(10), t.taskp(10), t.seqno(10),
		t.cpdp -> bdir, t.cpsp -> bseg, t.cpsp -> bseg, t.cpup -> buid, dir(3), t.t.name, seg(3), 
		t.uid(3), t.maxlen, t.eb, t.recover);
	if (state & mask(11)) = mask(11) then		/* copy segment (new/old -> target) (special) */
	     call upd_copy_seg_task_(print_ctl, areap, t.argp, t.code(11), t.sev(11), t.taskp(11), t.seqno(11),
		t.cpdp -> bdir, t.cpsp -> bseg, t.cpsp -> bseg, t.cpup -> buid, dir(3), t.t.name, seg(3),
		t.uid(3), t.maxlen, t.eb, full_recovery_sw);
	if (state & mask(12)) = mask(12) then		/* set ring brackets (target) (non-special) */
	     call upd_ring_task_$set (no_print_ctl, areap, t.argp, t.code(12), t.sev(12), t.taskp(12), t.seqno(12),
		dir(3), t.t.name, seg(3), t.uid(3), rb, t.recover);
	if (state & mask(13)) = mask(13) then		/* set ring brackets (target) (special) */
	     call upd_ring_task_$set (no_print_ctl, areap, t.argp, t.code(13), t.sev(13), t.taskp(13), t.seqno(13),
		dir(3), t.t.name, seg(3), t.uid(3), rb, full_recovery_sw);
	if (state & mask(14)) = mask(14) then		/* replace acl (target) (non-special) */
	     call upd_acl_task_$replace (print_ctl, areap, t.argp, t.code(14), t.sev(14), t.taskp(14), t.seqno(14),
		dir(3), t.t.name, seg(3), t.uid(3), ap(1), an(1), t.recover);
	if (state & mask(15)) = mask(15) then		/* replace acl (target) (special) */
	     call upd_acl_task_$replace (print_ctl, areap, t.argp, t.code(15), t.sev(15), t.taskp(15), t.seqno(15),
		dir(3), t.t.name, seg(3), t.uid(3), ap(1), an(1), full_recovery_sw);
	if (state & mask(16)) = mask(16) then		/* delete from acl (target) */
	     call upd_acl_task_$delete (print_ctl, areap, t.argp, t.code(16), t.sev(16), t.taskp(16), t.seqno(16),
		dir(3), t.t.name, seg(3), t.uid(3), ap(2), an(2));
	if (state & mask(17)) = mask(17) then		/* add to acl (target) */
	     call upd_acl_task_$add (print_ctl, areap, t.argp, t.code(17), t.sev(17), t.taskp(17), t.seqno(17),
		dir(3), t.t.name, seg(3), t.uid(3), ap(3), an(3));
	if (state & mask(18)) = mask(18) then		/* add name (old) (unique) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(18), t.sev(18), t.taskp(18), t.seqno(18),
		dir(2), seg(2), seg(2), t.uid(2), t.dp, t.one);
	if (state & mask(19)) = mask(19) then		/* free names (old) (non-special) */
	     call upd_name_task_$free (print_ctl, areap, t.argp, t.code(19), t.sev(19), t.taskp(19), t.seqno(19),
		dir(2), t.d.name, seg(2), t.uid(2), t.np.old, t.nn.old);
	if (state & mask(20)) = mask(20) then		/* add names (target) (-name) (non-special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(20), t.sev(20), t.taskp(20), t.seqno(20),
		dir(3), t.t.name, seg(3), t.uid(3), np(1), nn(1));
	if (state & mask(21)) = mask(21) then		/* add names (target) (-add_name) (non-special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(21), t.sev(21), t.taskp(21), t.seqno(21),
		dir(3), t.t.name, seg(3), t.uid(3), np(3), nn(3));
	if (state & mask(22)) = mask(22) then		/* add names (target) (-archive) (non-special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(22), t.sev(22), t.taskp(22), t.seqno(22),
		dir(3), t.t.name, seg(3), t.uid(3), t.np.arc, t.nn.arc);
	if (state & mask(23)) = mask(23) then		/* delete names (target) (-delete_name) (non-special) */
	     call upd_name_task_$delete (print_ctl, areap, t.argp, t.code(23), t.sev(23), t.taskp(23), t.seqno(23),
		dir(3), t.t.name, seg(3), t.uid(3), np(2), nn(2));
	if (state & mask(24)) = mask(24) then		/* free names (old) (special) */
	     call upd_name_task_$free (print_ctl, areap, t.argp, t.code(24), t.sev(24), t.taskp(24), t.seqno(24),
		dir(2), t.d.name, seg(2), t.uid(2), t.np.old, t.nn.old);
	if (state & mask(25)) = mask(25) then		/* add names (target) (-name) (special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(25), t.sev(25), t.taskp(25), t.seqno(25),
		dir(3), t.t.name, seg(3), t.uid(3), np(1), nn(1));
	if (state & mask(26)) = mask(26) then		/* add names (target) (-add_name) (special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(26), t.sev(26), t.taskp(26), t.seqno(26),
		dir(3), t.t.name, seg(3), t.uid(3), np(3), nn(3));
	if (state & mask(27)) = mask(27) then		/* add names (target) (-archive) (special) */
	     call upd_name_task_$add (print_ctl, areap, t.argp, t.code(27), t.sev(27), t.taskp(27), t.seqno(27),
		dir(3), t.t.name, seg(3), t.uid(3), t.np.arc, t.nn.arc);
	if (state & mask(28)) = mask(28) then		/* delete names (target) (-delete_name) (special) */
	     call upd_name_task_$delete (print_ctl, areap, t.argp, t.code(28), t.sev(28), t.taskp(28), t.seqno(28),
		dir(3), t.t.name, seg(3), t.uid(3), np(2), nn(2));
	if (state & mask(29)) = mask(29) then		/* delete names (target) (unique) */
	     call upd_name_task_$delete (print_ctl, areap, t.argp, t.code(29), t.sev(29), t.taskp(29), t.seqno(29),
		dir(3), seg(3), seg(3), t.uid(3), t.tp, t.one);
	if (state & mask(30)) = mask(30) then		/* log option; write formatted tree into log */
	     call upd_doc_task_$write_tree (print_ctl, areap, t.argp, t.code(30), t.sev(30), t.taskp(30), t.seqno(30),
		t.treep, in_date, de_in_date, t.logdir, t.fwd_logging_done_sw);

	return;					/* sigh */

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


/**/


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


get_entry_bound:	entry (Dir, Seg, Eb);

     dcl  (Dir, Seg)		char (*),
	Eb			fixed bin (14);

     dcl  bc 			fixed bin (24),	/* bitcount for get_entry_bound */
	code			fixed bin (35),
	mode			fixed bin (5),
	segp			ptr,		/* seg pointer for get_entry_bound */
	1 obj_info		like object_info aligned;

     dcl  (bit, unspec)		builtin;

     dcl  cleanup			condition;

     dcl  (get_group_id_		entry() returns(char(32)),
	get_ring_			entry() returns(fixed bin(3)),
	hcs_$get_user_effmode	entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)),
     	hcs_$initiate_count		entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	object_info_$brief		entry (ptr, fixed bin(24), ptr, fixed bin(35)));

	Eb = -1;					/* default to no successful status */
	segp = null;

	call hcs_$get_user_effmode ( Dir, Seg, get_group_id_ (), get_ring_ (), mode, code);
	if code ^= 0 | (bit (mode,5) & "01000"b ^= "01000"b) then
	     return;				/* no read access */

	on cleanup begin;
	     if segp ^= null then call hcs_$terminate_noname ( segp, (0));
	end;

	call hcs_$initiate_count ( Dir, Seg, "", bc, 0, segp, code);
	if segp = null then return;			/* should never happen */
	unspec ( obj_info) = ""b;
	obj_info.version_number = object_info_version_2;

	call object_info_$brief ( segp, bc, addr (obj_info), code);
	if code = 0 & obj_info.gate then		/* really an object and really a gate */
	     Eb = obj_info.entry_bound;
	else Eb = 0;				/* otherwise no entry bound */
	call hcs_$terminate_noname ( segp, code);
	return;

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


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


init:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, special_segs_sw, full_recovery_sw, temp, ioseg);
						/* installer message task initialization. */

	call cu_$arg_list_ptr (argp);			/* get ptr to arglist for use by called pgms */
	cp = addr (ctlw);				/* overlay the control word */
	if c.de_install_sw then			/* upd_install_task_$init doesn't run in de_install */
	     return;

	if temp = null then do;			/* allocated temps yet? */
	     i = mod ( index(ioseg, " ") + 32, 33);	/* calculate length of io seg name */
	     install_message(1) = install_message(1)||substr(ioseg,1,i); /* form new forward msg */
	     allocate it in (area);			/* if not, allocate and fill in. */
	     de_install_message(5) = de_install_message(5)||substr(ioseg,1,i); /* and new reverse msg */
						/* (bug in optimize forces this placement) */
	     do i = 1 to 5;				/* copy messages into static. */
		it.fwd_msgl(i) = length (install_message(i));
		allocate fwd_msg in (area);
		fwd_msg = install_message(i);

		it.rev_msgl(i) = length (de_install_message(i));
		allocate rev_msg in (area);
		rev_msg = de_install_message(i);
		end;
	     temp = tp;				/* store ptr to it in caller-preserved argument. */
	     end;
	else
	     tp = temp;				/* if so, get ptr to it. */

	if c.tasksw then				/* allocating a task? */
	     call upd_add_task_ ("upd_install_task_$init", argp);

	no_print_ctl = ctlw & "000100000"b;			/* for subtask control word (allow only runsw) */
	if c.compsw then				/* if we're compiling a subtask list, then */
	     no_print_ctl = no_print_ctl | "01"b;			/* turn on tasksw for our subtasks. */

	if no_print_ctl = "0"b then				/* nothing more to do? */
	     return;				/* then return. */

	it.argp = argp;				/* set parentp for use by our subtasks */

	call upd_message_task_ (no_print_ctl, areap, it.argp, it.code(1), it.sev(1), it.taskp(1), it.seqno(1),
	     it.print, it.print, it.fwd_done_sw(1), it.fwd_msgp(1), it.fwd_msgl(1), it.rev_msgp(1), it.rev_msgl(1));
						/* first msg - start/end */
	call upd_message_task_ (no_print_ctl, areap, it.argp, it.code(2), it.sev(2), it.taskp(2), it.seqno(2),
	     it.noprint, it.print, it.fwd_done_sw(2), it.fwd_msgp(2), it.fwd_msgl(2), it.rev_msgp(2), it.rev_msgl(2));
						/* second msg - copy/delete (non-special) */
	if special_segs_sw then
	     call upd_message_task_ (no_print_ctl, areap, it.argp, it.code(3), it.sev(3), it.taskp(3), it.seqno(3),
		special_segs_sw, full_recovery_sw, it.fwd_done_sw(3), it.fwd_msgp(3), it.fwd_msgl(3), 
		it.rev_msgp(3), it.rev_msgl(3));
						/* third msg - copy/delete (special) */
	if special_segs_sw then
	     call upd_message_task_ (no_print_ctl, areap, it.argp, it.code(4), it.sev(4), it.taskp(4), it.seqno(4),
		special_segs_sw, special_segs_sw, it.fwd_done_sw(4), it.fwd_msgp(4), it.fwd_msgl(4), 
		it.rev_msgp(4), it.rev_msgl(4));
						/* fourth msg - names_on/names_off (special) */
	call upd_message_task_ (no_print_ctl, areap, it.argp, it.code(5), it.sev(5), it.taskp(5), it.seqno(5),
	     it.print, it.print, it.fwd_done_sw(5), it.fwd_msgp(5), it.fwd_msgl(5), it.rev_msgp(5), it.rev_msgl(5));
						/* fifth msg - end/start */

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


%include object_info;


	end upd_install_task_;
  



		    upd_log_task_.pl1               11/15/82  1844.4rew 11/15/82  1514.3       95562


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


upd_log_task_:	procedure;


     dcl						/*	automatic variables			*/
	Ldir			fixed bin,	/* length of the non-blank part of dir.		*/
	Llog_name			fixed bin,	/* length of the non-blank part of log_name.	*/
	Plock			ptr,		/* ptr to the lock segment.			*/
	Stype			fixed bin(2),	/* type of found installation log;  1 = segment,	*/
						/* 2 = directory, 3 = MSF.			*/
	bitc			fixed bin(24),
	bitct			fixed bin(24),	/* bit count */
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168) aligned,	/* directory part of log_name (absolute) path	*/
	dummy_code		fixed bin(35),	/* dummy code value 			*/
	e			fixed bin,	/* entry variable		 		*/
	entry			char(32) aligned,	/* entry part of log_name (absolute) path	*/
	lock_seg			char(32) aligned,	/* entry part of properly-suffixed lock seg path.	*/
	log_file			char(32) aligned,	/* entry part of found log file's path.		*/
	log_name			char(168),	/* relative or absolute path of installation log	*/
	mode			fixed bin(5),	/* installer's access mode to found log.	*/
	p			ptr,
	path			char(168) aligned,	/* absolute path name of found installation log.	*/
	status_code		bit(72) aligned,	/* an IO system status code.			*/
	time			fixed bin;	/* time (in sec) we will wait for lock to unlock	*/

     dcl						/*	based variables			*/
	1 lock			based (Plock),	/* structure of the lock segment.		*/
	  2 word			bit(36) aligned,	/* the lock word.				*/
	  2 process_group_id	char(32) aligned,	/* installer who has locked the lock.		*/
	  2 program		char(65) aligned,	/* the program he is running which did the locking*/
	1 status			based (addr (status_code)),
						/* overlay for the IO status code.		*/
	  2 code			fixed bin(35);	/* for file_; this is a regular status code.	*/

     dcl  1 acl aligned,				/*  acl structure				*/
	 2  userid char (32),			/* user id				*/
	 2  mode bit(36),				/* access mode				*/
	 2  pad bit(36) init ("0"b),			/* padding				*/
	 2  code fixed bin (35);			/* error code				*/

     dcl  1 diracl aligned,				/* directory acl structure			*/
	 2  userid char (32),			/* user					*/
	 2  dir_mode bit (36),			/* bits 1-3 are "sma"			*/
	 2  code fixed bin (35);			/* error code				*/

     dcl						/* 	entries and builtin functions		*/
	addr			builtin,
	expand_path_		entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
	get_group_id_		entry returns (char(32) aligned),
	get_group_id_$tag_star	entry returns (char(32) aligned),
	hcs_$add_acl_entries	entry (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)),
	hcs_$add_dir_acl_entries	entry (char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)),
	hcs_$initiate_count		entry ( char(*) aligned, char(*) aligned, char(*) aligned,
				     fixed bin(24), fixed bin(2), ptr, fixed bin(35) ),
	hcs_$make_seg		entry (char(*) aligned, char(*) aligned, char(*) aligned, fixed bin(5),
				       ptr, fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	index			builtin,
	ios_$attach		entry (char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned,
				       bit(72) aligned),
	ios_$detach		entry (char(*) aligned, char(*) aligned, char(*) aligned, bit(72) aligned),
	mod			builtin,
	null			builtin,
	set_lock_$lock		entry (bit(36) aligned, fixed bin, fixed bin(35)),
	set_lock_$unlock		entry (bit(36) aligned, fixed bin(35)),
	substr			builtin,
	suffixed_name_$find		entry (char(*) aligned, char(*) aligned, char(*) aligned, char(32) aligned,
				       fixed bin(2), fixed bin(5), fixed bin(35)),
	suffixed_name_$new_suffix	entry (char(*) aligned, char(*) aligned, char(*) aligned, char(32) aligned,
				       fixed bin(35)),
	upd_print_err_		entry options (variable);

     dcl						/*	static variables			*/
	directory			fixed bin(2) int static init (2),
	error_table_$dirseg		fixed bin(35) ext static,
	error_table_$file_is_full	fixed bin(35) ext static,
	error_table_$incorrect_access	fixed bin(35) ext static,
	error_table_$invalid_lock_reset
				fixed bin(35) ext static,
	error_table_$locked_by_this_process
				fixed bin(35) ext static,
	error_table_$lock_wait_time_exceeded
				fixed bin(35) ext static,
	error_table_$moderr		fixed bin(35) ext static,
	error_table_$namedup	fixed bin(35) ext static,
	error_table_$noentry	fixed bin(35) ext static,
	error_table_$segknown	fixed bin(35) ext static,
	msf			fixed bin(2) int static init (3),
	proc			char (32) aligned int static init ("upd_log_task_");
	
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lock:	entry (log_name, code);

	e = 1;
	go to COMMON;

unlock:	entry ( log_name, code);

	e = 2;

COMMON:
	Llog_name = mod (index (log_name, " ")+168, 169);	/* get length of non-blank part of log name path.	*/
	call expand_path_ (addr (log_name), Llog_name, addr (dir), addr (entry), code);
	if code ^= 0 then				/* split the path into directory and entry parts.	*/
	     return;
	if index ( entry, ".log") ^= 0 then
	     call suffixed_name_$new_suffix (entry, "log", "lock", lock_seg, code);
	else
	     call suffixed_name_$new_suffix (entry, "info", "lock", lock_seg, code);
	if code ^= 0 then				/* get name of lock segment assoc. with log.	*/
	     return;
	go to start(e);

start(1):
	acl.userid = get_group_id_$tag_star();		/* find out who the installer is.		*/
	acl.mode = "101"b;				/* set his "mode" to "rw".			*/
	acl.code = 0;				/* zap error code.				*/
	call hcs_$make_seg (dir, lock_seg, "", 01010b, Plock, code);
	if code ^= 0 then do;			/* try to create the lock segment.		*/
	     if code = error_table_$namedup | code = error_table_$segknown | code = error_table_$moderr then do;
		call hcs_$add_acl_entries (dir, lock_seg, addr(acl), 1, code);
		if code ^= 0 then			/* if it already exists, make sure the installer	*/
		     return;			/* has "rw" access to it.			*/
		end;
	     else					/* treat any other errors as such.		*/
		return;
	     end;
	else					/* if we had to create the lock segment, then	*/
						/* warn the installer.			*/
	     call upd_print_err_ (0, 0, "Warning", "", (proc), "", "^2xCreating  ^a>^a .", dir, lock_seg);

	time = 60;				/* lock the lock segment.  Wait 60 sec for it to	*/
lock_it:	call set_lock_$lock (lock.word, time, code);	/* be unlocked, if its already locked.		*/
	if code ^= 0 then do;
	     if code = error_table_$invalid_lock_reset then do;
		call upd_print_err_ ( code, 0, "Warning", "", (proc), "",
		     "^/^a ^R^a>^a^B  ^/^a", "Installation lock segment",
		     dir, lock_seg, "The lock has been re-locked by this process.");
		code = 0;				/* someone had it locked when his process or system failed */
		end;
	     else
		if code = error_table_$locked_by_this_process then
		code = 0;				/* I was the guy that previously locked it. */
	     else
		if code = error_table_$lock_wait_time_exceeded then do;
		     if time = 60 then do;		/* if its already locked, tell user.		*/
		          call upd_print_err_ (code, 0, "Warning", "", (proc), "",
			     "^/^a  ^R^a>^a^B  ^/^a  ^a (^a).^/^a ^a.", "Installation lock segment",
			     dir, lock_seg, "has been locked for  1  minute by", lock.process_group_id,
			     lock.program, (proc), "will continue waiting on this lock for  20  minutes");
		          time = 1200;		/* this time, wait for 20 minutes on the lock.	*/
		          go to lock_it;
		          end;
		else				/* if lock isn't unlocked after 21 minutes, then	*/
		     return;			/* quit.		*/
		end;
	     end;
	lock.process_group_id = get_group_id_();	/* it's locked.				*/
	lock.program = proc;			/* let other processes know who's in control.	*/

	if index ( entry, ".log") ^= 0 then
	     call suffixed_name_$find (dir, entry, "log", log_file, Stype, mode, code);
	else
	     call suffixed_name_$find (dir, entry, "info", log_file, Stype, mode, code);
						/* find the installation log.			*/
	Ldir = mod (index (dir, " ")+168, 169);		/* get length of non-blank part of directory.	*/
	path = substr (dir, 1, Ldir) || ">" || log_file;	/* concatenate directory and log entry name.	*/
	if (code = 0 | code = error_table_$incorrect_access) then do;
						/* log exists.				*/
	     if Stype = directory then do;		/* make sure it's not a directory.		*/
		code = error_table_$dirseg;
		go to un_lock;
		end;
	     else if Stype = msf then do;		/* if log is an MSF, then make sure installer is	*/
						/* on the ACL of the MSF directory.		*/
		if index ( log_file, ".info") ^= 0 then do; /* unless it's an info file		*/
		     code = error_table_$file_is_full;	/* then we don't allow further expansion		*/
		     go to un_lock;
		     end;
		diracl.userid = get_group_id_$tag_star();/* who is the installer			*/
		diracl.dir_mode = "111"b;		/* set acl to "sma"				*/
		diracl.code = 0;			/* zap error code				*/
		call hcs_$add_dir_acl_entries (path, "", addr(diracl), 1, code);
		if code ^= 0 then
		     go to un_lock;
		end;
						/* and if it's a segment,			*/
	     else if mode ^= 101b then do;		/* make sure installer has access to the log.	*/
		call hcs_$add_acl_entries (dir, log_file, addr(acl), 1, code);
		if code ^= 0 then
		     go to un_lock;
		end;
	     end;
	else
	     if code = error_table_$noentry then do;	/* if there's no entry, then warn the installer	*/
		call upd_print_err_ (0, 0, "Warning", "", (proc), "", "^2xCreating  ^a>^a .", dir, log_file);
		call hcs_$make_seg (dir, log_file, "", 01010b, p, code);
		if code ^= 0 then
		     goto un_lock;
		end;
	else					/* the only other error is incorrect_access.	*/
	     go to un_lock;				/* entlong cannot happen since we already made 	*/
						/* the lock_seg name.  Tell user.		*/

	return;


start(2):
	call hcs_$initiate_count ( dir, lock_seg, "", bitc, 0, Plock, code);
	if Plock = null then
	     return;				/* something's wrong.			*/
	code = 0;					/* clear "segknown code */

un_lock:	call set_lock_$unlock (lock.word, dummy_code);	/* unlock the lock segment.			*/
	if dummy_code ^= 0 then
	     call upd_print_err_ (dummy_code, 0, "Warning", "", (proc), "^/While unlocking  ^R^a>^a^B .",
		dir, lock_seg);
	call hcs_$terminate_noname (Plock, dummy_code);	/* clean up completely.			*/
	return;					/* That's All, Folks!			*/

	end upd_log_task_;
  



		    upd_message_task_.pl1           11/15/82  1844.4rew 11/15/82  1514.3       63045


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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  upd_message_task_							*/
	/*									*/
	/*      This procedure types messages on the user's console.  Two messages are supplied	*/
	/* by the caller: one to be typed while processing in the "forward" direction; and a	*/
	/* second to be typed while processing in the "reverse" direction.			*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  upd_message_task_ entry(bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin,	*/
	/*		ptr, fixed bin, bit(1), bit(1), bit(1) aligned, 			*/
	/*		ptr, fixed bin, ptr, fixed bin);				*/
	/*									*/
	/*      call upd_message_task_ (ctlw, areap, parentp, code, sev, taskp, seqno, 		*/
	/*		fwd_msg_sw, rev_msg_sw, fwd_done_sw, fwd_msgp, fwd_msgl, rev_msgp,	*/
	/*		rev_msgl);						*/
	/*									*/
	/* 1) ctlw	updater task control word.(In)				*/
	/* 2) areap	ptr to caller-supplied area.(In)				*/
	/* 3) parentp	ptr to caller's arglist.(In)					*/
	/* 4) code	0. (In)							*/
	/*		status code of highest-severity error encountered during 		*/
	/*		processing.(Out)						*/
	/* 5) sev		0. (In)							*/
	/*		severity of highest error encountered during processing.(Out)	*/
	/* 6) taskp	null pointer.(In)						*/
	/*		task pointer.(Out)						*/
	/* 7) seqno	sequence number.(In)					*/
	/* 8) fwd_msg_sw	on if fwd_msg is to be typed. (In)				*/
	/* 9) rev_msg_sw	on if rev_msg is to be typed. (In)				*/
	/* 10) fwd_done_sw	on if fwd_msg has been typed; off if rev_msg has been typed.(In/Out)	*/
	/* 11) fwd_msgp	ptr to message to be typed when "run" in "forward" mode.(In)	*/
	/* 12) fwd_msgl	length of message to be typed when "run" in "forward" mode.(In)	*/
	/* 13) rev_msgp	ptr to message to be typed when "run" in "reverse" mode.(In)	*/
	/* 14) rev_msgl	length of message to be typed when "run" in "reverse" mode.(In)	*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 1) Created:  in Dec 1972 by G. C. Dixon					*/
	/* 2) Modified: in Dec 1972 by G. C. Dixon; pass ptr/length of strings to be typed,	*/
	/*				    rather than strings themselves to avoid	*/
	/*				    references through descriptors.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/**/


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


upd_message_task_:	procedure (ctlw, areap, parentp, code, sev, taskp, seqno, 
			 fwd_msg_sw, rev_msg_sw, fwd_done_sw, fwd_msgp, fwd_msgl, rev_msgp, rev_msgl);


     dcl						/*	parameters			*/
	ctlw			bit(36) aligned,	/* updater control word.			*/
	areap			ptr,		/* caller-supplied area.			*/
	parentp			ptr,		/* parent's arglist ptr.			*/
	code			fixed bin(35),	/* status code.				*/
	sev			fixed bin,	/* severity code.				*/
	taskp			ptr,		/* task ptr.				*/
	seqno			fixed bin,	/* task sequence no.			*/
	fwd_msg_sw		bit(1) unal,	/* on if fwd message to be printed. 		*/
	rev_msg_sw		bit(1) unal,	/* on if rev message to be print. 		*/
	fwd_done_sw		bit(1) aligned,	/* on if fwd message has been printed. 		*/
	fwd_msgp			ptr,		/* ptr to message to be typed in forward mode.	*/
	fwd_msgl			fixed bin,	/* length of message to be typed in forward	*/
	rev_msgp			ptr,		/* ptr to message to be typed in reverse mode.	*/
	rev_msgl			fixed bin;	/* length of message to be typed in reverse mode.	*/

     dcl						/*	automatic variables			*/
	Lmsg			fixed bin,	/* length of message			*/
	Pmsg			ptr,		/* ptr to message.				*/
	Psw			ptr,		/* ptr to msg_sw				*/
	argp			ptr,		/* ptr to our argument list.			*/
	cp			ptr,		/* ptr to task control word.			*/
	nelemt			fixed bin,	/* number of elements actually written.		*/
	rsw			bit(1) aligned,	/* copy of c.rsw for efficiency.		*/
	status_code		bit(72) aligned;	/* an IO system status code.			*/

     dcl						/*	based variables			*/
	1 c			aligned based (cp),	/* overlay for task control word.		*/
	 (2 rsw			bit(1),		/* non-zero if in reverse mode.		*/
	  2 tasksw		bit(1),		/* non-zero if to set up a task call to ourself.	*/
	  2 compsw		bit(1),		/* ignored.				*/
	  2 runsw			bit(1),		/* non-zero if messages to be typed immediately	*/
	  2 trunsw		bit(1)) unaligned,	/* non-zero if this task to be processed	*/
						/* immediately, but not its subtasks.		*/
	sw			bit(1) based (Psw);	/* on if message is to be printed.		*/

     dcl						/*	entries and builtin functions		*/
	addr			builtin,
	cu_$arg_list_ptr		entry (ptr),
	ios_$write		entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
	length			builtin,
	upd_add_task_		entry (char(*), ptr);

     dcl						/*	static variable			*/
	nl			char(1) aligned int static init ("
");						/* a new-line character.			*/

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


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


	call cu_$arg_list_ptr (argp);			/* get ptr to arglist for "task" mode.		*/
	cp = addr (ctlw);				/* overlay our control word.			*/
	if c.tasksw then				/* called in "task" mode? Then create a task call	*/
						/* to ourself.				*/
	     call upd_add_task_ ("upd_message_task_", argp);

	if ^c.runsw then if ^c.trunsw then		/* no more to do? Then quit.			*/
	     return;

	rsw = c.rsw;				/* copy reverse switch for efficiency.		*/
	if ^rsw then do;				/* "Forward" Ho!				*/
	     Psw = addr (fwd_msg_sw);			/* use fwd msg switch.			*/
	     Lmsg = fwd_msgl;			/* set length and ptr to msg.			*/
	     Pmsg = fwd_msgp;
	     end;
	else do;					/* "Reverse" Away!				*/
	     Psw = addr (rev_msg_sw);			/* use rev msg switch.			*/
	     Lmsg = rev_msgl;
	     Pmsg = rev_msgp;
	     end;

	if rsw = fwd_done_sw then do;			/* if "forward" mode and "forward" hasn't been 	*/
						/* done, or vica versa for "reverse".		*/
	     if sw then				/* if we're supposed to type message, then	*/
		if Lmsg > 0 then do;		/* if there is a message, then type it.		*/
		     call ios_$write ("installation_list_", Pmsg, 0, Lmsg, nelemt, status_code);
		     call ios_$write ("installation_list_", addr (nl), 0, 1, nelemt, status_code);
		     end;
	     fwd_done_sw = ^rsw;			/* set our current direction done.		*/
	     end;


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


	end upd_message_task_;
   



		    upd_name_task_.pl1              11/15/82  1844.4rew 11/15/82  1514.4      175725


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


upd_name_task_:	procedure
		options ( rename (( alloc_, smart_alloc_)) );

/*

	This procedure includes all name task primitives for the Multics Online
	Updater; the following are entries:

		upd_name_task_$list		list names on branch
		upd_name_task_$list_archive	list archive component names
		upd_name_task_$add		add names
		upd_name_task_$delete	delete names
		upd_name_task_$free		transform (name -> name.1 -> name.2 ...)
					for primary name on segment; otherwise delete name

	Calling sequences are identical for all entries, being:

	     call upd_name_task_$xxx (ctlw, areap, parentp, acode, asev, taskp, seqno,
		dir, seg, uid, np, nn);

	     (1)	ctlw	bit(36) aligned	updater task control word
	     (2)	areap	ptr		caller area pointer
	     (3)	parentp	ptr		parent arglist pointer
	     (4)	acode	fixed bin(35)	status code
	     (5)	asev	fixed bin		severity code
	     (6)	taskp	ptr		task pointer
	     (7)	seqno	fixed bin		task sequence no.
	     (8)	dir	char(168)		dirname of affected segment
	     (9)	seg	char(32)		entryname of segment
	    (10)	msgseg	char(32)		entryname of segment for use in messages
	    (11)	uid	bit(36) aligned	unique id of segment (may be ""b)
	    (12)	np	ptr		pointer to names structure
	    (13)	nn	fixed bin		count of names in structure

	These entry points are restartable, e.g. after a system or process failure,
	and are also invertible, i.e. by repeating the call with c.rsw set, all
	processing which was done may be undone, even after an abnormal termination.
	In order that these functions may operate correctly, it is necessary that
	"acode", "asev", and "taskp" be initialized to "0", "0", and "null",
	respectively, and that for the "add", "delete", and "free" entry points,
	names(i).pcode be initialized to error_table_$not_done, and names(i).rcode
	to "0".  The "list" and "list_archive" entry points properly initialize
	the latter two in "names" arrays output by them.  These two entry points
	additionally require that "np" be initially null.

	P. Bos, May 1972

     Modified: 09/04/81 by GA Texada to call appropriate hcs_ entries on likage_error.

*/
/**/

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


     dcl	ctlw			bit(36) aligned,	/* updater control word */
	areap			ptr,		/* caller-supplied area */
	parentp			ptr,		/* parent arglist pointer */
	acode			fixed bin(35),	/* status code */
	asev			fixed bin,	/* severity code */
	taskp			ptr,		/* task pointer */
	seqno			fixed bin,	/* task sequence no. */
	dir			char(168),	/* dirname of affected segment */
	seg			char(32),		/* entryname of segment */
	msgseg			char(32),		/* entryname of segment for use in messages */
	uid			bit(36) aligned,	/* unique id of segment */
	np			ptr,		/* pointer to names array */
	nn			fixed bin;	/* count */

     dcl	archive_util_$disected_element entry (ptr, ptr, char(32) aligned, fixed bin(24), fixed bin(35)),
	archive_util_$first_disected	entry (ptr, ptr, char(32) aligned, fixed bin(24), fixed bin(35)),
	chname_file_entry		entry (char(*), char(*), char(*), char(*), fixed bin(35))variable,
	cu_$arg_list_ptr		entry (ptr),
	hcs_$chname_file		entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	hcs_$initiate		entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	ioa_$ioa_stream		entry options (variable),
	upd_add_task_		entry (char(*), ptr),
	upd_free_name_		entry (char(*), char(*), fixed bin(35)),
	upd_free_name_$restore	entry (char(*), char(*), fixed bin(35)),
	installation_tools_$chname_file	entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	upd_print_err_		entry options (variable),
	upd_print_names_		entry (ptr, fixed bin, bit(*)),
	upd_status_		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	upd_status_$long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	upd_task_err_		entry options (variable);

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

     dcl linkage_error		condition;

     dcl (error_table_$archive_fmt_err,
	error_table_$namedup,
	error_table_$nonamerr,
	error_table_$not_done,
	error_table_$oldnamerr,
	error_table_$segknown,
	error_table_$segnamedup,
	error_table_$too_many_names,
	error_table_$non_matching_uid,
	error_table_$zero_length_seg)	ext fixed bin(35);

     dcl	aname			char(32) aligned,	/* name arg for archive_util_ */
	entry (5)			char(32) int static init (
				"upd_name_task_$list",
				"upd_name_task_$list_archive",
				"upd_name_task_$add",
				"upd_name_task_$delete",
				"upd_name_task_$free"),
						/* name of entry which was called */
	name			char(32) based (nmp),	/* for name changes */
	name_array (n)		char(32) based (p);	/* temp name array (for status_, etc.) */

     dcl	msg (5)			char(15) aligned int static init ("Get names",
				"Get comp names", "Add names", "Delete names", "Free names");

     dcl	argp			ptr,		/* arglist pointer */
	cdp			ptr,		/* base pointer for "cd" */
	cp			ptr,		/* control word pointer */
	nmp			ptr,		/* base pointer for "name" */
         (p, q, r)			ptr,		/* random */
	savep			ptr,		/* copy of archive pointer */
	temp			ptr;		/* random */

     dcl	bc			fixed bin(24),	/* bitcount */
	cc			fixed bin,	/* index for "call" vector */
	cd			fixed bin(35) based (cdp),	/* status code overlaid on "names" element */
	code			fixed bin(35),	/* random status code */
	e			fixed bin,	/* entry switch */
         (i, j, n)			fixed bin,	/* random */
	sev			fixed bin,	/* severity code for name change functions */
	tcode			fixed bin(35);	/* status code */

     dcl	initsw			bit(1) aligned int static init ("0"b),	/* non-zero when "ctable" set up */
	logsw			bit(1) aligned,	/* c.logsw | (c.errsw & asev ^= 0) */
	rsw			bit(1) aligned,	/* copy of c.rsw */
	runsw			bit(1) aligned,	/* c.runsw | c.trunsw */
	sws			bit(2);		/* option bits for upd_print_names_ */

     dcl	area			area based (areap);	/* caller-supplied area */

     dcl	ctable (4)		fixed bin(35) int static,	/* used by name change functions */
	stable (4, 4)		fixed bin int static init (	/* severity matrix to match */
				1, 3, 2, 2,	/* segnamedup */
				2, 3, 2, 2,	/* namedup */
				3, 1, 2, 2,	/* oldnamerr */
				3, 2, 2, 2);	/* nonamerr */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 rsw			bit(1),		/* non-zero if in reverse mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1),		/* non-zero if to print error tasks only */
	  2 briefsw		bit(1),		/* ignored */
	  2 detailsw		bit(1),		/* non-zero if to list names when logsw is non-zero */
	  2 clear_code_sw		bit(1),		/* non-zero if error codes in name list to be cleared */
	  2 clear_uid_sw		bit(1)) unal;	/* non-zero if segment uid's to be cleared */

     dcl	1 names (n)		aligned based (np),	/* updater-format names array */
	  2 name			char(32) unal,	/* fudge alignment for pl1 */
	  2 pcode			fixed bin(35),	/* process code */
	  2 rcode			fixed bin(35);	/* restore code */

     dcl	1 stat			aligned,		/* data structure for status_ */
	 (2 type			bit(2),		/* entry type */
	  2 nnames		bit(16),		/* number of names returned */
	  2 nrp			bit(18),		/* rel pointer to name array */
	  2 dtm			bit(36),		/* date/time modified */
	  2 dtu			bit(36),		/* date/time used */
	  2 mode			bit(5),		/* t, r, e, w, a */
	  2 pad			bit(13),		/* unused */
	  2 recs			bit(18),		/* pages used */
	  2 dtd			bit(36),		/* date/time dumped */
	  2 dtem			bit(36),		/* date/time entry modified */
	  2 acct			bit(36),		/* accounting data */
	  2 curlen		bit(12),		/* length of segment */
	  2 bitcnt		bit(24),		/* bitcount of segment */
	  2 did			bit(4),		/* device id */
	  2 mdid			bit(4),		/* ? */
	  2 copysw		bit(1),		/* segment copy switch */
	  2 pad2			bit(9),		/* unused */
	  2 rbs (0:2)		bit(6),		/* ring brackets */
	  2 uid			bit(36)) unal;	/* unique id */


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


list:		entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, np, nn);

	if ctlw & "10000000011"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear" modes */
	e = 1;					/* set transfer vector index */
	sws = "00"b;				/* don't want to interpret status codes when printing */
	go to common;				/* join common code */


list_archive:	entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, np, nn);

	if ctlw & "10000000011"b then			/* this entry doesn't run in "reverse" or */
	     return;				/* "clear" modes */
	e = 2;					/* t.v. index */
	sws = "00"b;				/* options for printing */
	go to common;				/* skip */


add:		entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, np, nn);

	e = 3;					/* t.v. index */
	sws = "11"b;				/* want to print everything */
	go to common;				/* skip to common code */


delete:		entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, np, nn);

	e = 4;					/* transfer vector index */
	sws = "11"b;				/* want it all */
	go to common;				/* skip */


free:		entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, uid, np, nn);

	e = 5;					/* set t.v. index */
	sws = "11"b;				/* want status codes interpreted */

common:	cp = addr (ctlw);				/* overlay control word with bit structure "c" */
	if c.clear_uid_sw then			/* none of the entries runs in "clear uid" mode */
	     return;
	call cu_$arg_list_ptr (argp);			/* get arglist pointer */
	rsw = c.rsw;				/* it gets used a lot */
	logsw = c.logsw;				/* non-zero if printing */
	if c.errsw then if asev = 0 then		/* errors only? */
	     logsw = "0"b;				/* sure thing */
	runsw = c.runsw | c.trunsw;			/* non-zero if processing */
	if c.clear_code_sw then			/* clear error codes in name lists, if asked */
	     if np ^= null then do i = 1 to nn;
		names(i).pcode = error_table_$not_done;
		names(i).rcode = 0;
	    	end;

	if c.tasksw then				/* is this a task call? */
	     call upd_add_task_((entry(e)), argp);

	if logsw then do;				/* are we talking to him? */
	     if seg = msgseg then
		call ioa_$ioa_stream ("installation_list_", "^5x^R^14a^B ^a>^a", (msg(e)), dir, seg);
	     else
		call ioa_$ioa_stream ("installation_list_", "^5x^R^14a^B ^a>^a  (^a)", (msg(e)), dir, seg, msgseg);
	     if asev ^= 0 then			/* has an error occurred? */
		call upd_print_err_(acode, asev);	/* yes, tell user */
	     end;

	if runsw then do;				/* are we to process it now? */
	     if uid ^= ""b then do;			/* should we verify unique id? */
		if e = 1 then			/* don't waste call to status_ */
		     temp = areap;			/* if "list" function, get names also */
		else				/* but don't waste effort either */
		     temp = null;			/* any other function, skip the names */
		call upd_status_$long (dir, seg, 1, addr (stat), temp, code);
		if code = 0 then if uid ^= stat.uid then	/* does it match? */
		     code = error_table_$non_matching_uid;	/* no, set error code */
		if code ^= 0 then			/* did we get it? */
		     go to error;			/* no, go complain */
		end;
	     go to lbl(e);				/* skip to proper function */
	     end;

prnames:	if logsw then				/* reentry after processing */
	     if (c.detailsw | c.errsw) then		/* print names if user wants them */
		call upd_print_names_(np, nn, sws);
	return;					/* all done, exit */


error:	if seg = msgseg then
	     call upd_task_err_ (code, 3, argp, (entry(e)),
		"^/Referencing ^R^a>^a^B .", dir, seg);
	else
	     call upd_task_err_ (code, 3, argp, (entry(e)),
		"^/Referencing ^R^a>^a^B^/(^a>^a).", dir, seg, dir, msgseg);
	return;					/* can't go no farther */


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


lbl(1):	if np ^= null then				/* "list" function, see if already done */
	     go to prnames;				/* yes, don't repeat */
	if uid = ""b then do;			/* call status_ if we didn't */
	     call upd_status_(dir, seg, 0, addr (stat), areap, code);
	     if code ^= 0 then			/* error? */
		go to error;			/* yes, skip */
	     end;
	n = fixed (stat.nnames);			/* get count of names returned */
	p = ptr (areap, stat.nrp);			/* get pointer to name array */
	go to common1;				/* join common code */


lbl(2):	if np ^= null then				/* "list_archive" function, see if we did it */
	     go to prnames;				/* yes, don't process again */
	call hcs_$initiate (dir, seg, "", 0, 0, r, code);	/* initiate archive segment */
	if code ^= 0 then if code ^= error_table_$segknown then
	     go to error;				/* trouble, can't initiate it */
	savep = r;				/* copy archive pointer; archive_util_ clobbers it */
	call archive_util_$first_disected (r, q, aname, bc, code);	/* get name of first component */
	if code ^= 0 then do;			/* something amiss? */
	     if code = 1 then			/* archive_util_ has funny error codes */
		code = error_table_$zero_length_seg;	/* fix it up for other people */
	     else if code = 2 then			/* format error in archive */
fmterr:		code = error_table_$archive_fmt_err;	/* get standard code for him too */
acerr:	     call hcs_$terminate_noname (savep, tcode);	/* terminate archive segment, don't destroy code */
	     go to error;				/* and go complain */
	     end;
	i = 1;					/* starting on first name */
	n = 1000;					/* have to have a limit somewhere */
	allocate name_array in (area);		/* get space to collect names */
	go to next1;				/* join loop to insert first name */
next:	call archive_util_$disected_element (r, q, aname, bc, code);	/* get next component */
	if code = 0 then do;			/* got him */
	     if i = 1000 then do;			/* hath our cup run over? */
		if seg = msgseg then
		     call upd_task_err_ (error_table_$too_many_names, 0, argp, (entry(e)),
			"^/For ^R^a>^a^B^/only the first 1000 component names will be listed.", dir, seg);
		else
		     call upd_task_err_ (error_table_$too_many_names, 0, argp, (entry(e)),
			"^/For ^R^a>^a^B^/(^a>^a)^/only the first 1000 component names will be listed.",
			dir, seg, dir, msgseg);
		go to last;			/* exit from loop */
		end;
	     i = i + 1;				/* still room, bump index */
next1:	     name_array(i) = aname;			/* add name to list */
	     go to next;				/* go get next one */
	     end;
	else if code = 1 then do;			/* end of archive reached */
last:	     n = i;				/* set count of names found */
	     call hcs_$terminate_noname (savep, code);	/* terminate archive segment */
	     go to common1;				/* join common code */
	     end;
	else if code = 2 then			/* format error in archive */
	     go to fmterr;				/* go get standard error code */
	else					/* some other error */
	     go to acerr;				/* go terminate seg and exit */

common1:	allocate names in (area) set (q);		/* allocate updater-format names array */
	do i = 1 to n;				/* copy names into it */
	     q -> names(i).name = name_array(i);	/* the name */
	     q -> names(i).pcode = error_table_$not_done;	/* initialize process code */
	     q -> names(i).rcode = 0;			/* restore code */
	     end;
	free name_array in (area);			/* free temporary name array */
	nn = n;					/* set array count */
	np = q;					/* and pointer (pointer must be set last) */
	go to prnames;				/* skip to common exit */


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


lbl(3):	if ^rsw then				/* "add" function, select proper call */
	     cc = 1;				/* adding name */
	else					/* restore mode, */
	     cc = 2;				/* removing name */
	go to common2;				/* join common code */


lbl(4):	if ^rsw then				/* "delete" function */
	     cc = 2;				/* removing name */
	else					/* restore mode, */
	     cc = 1;				/* putting it back */
	go to common2;				/* skip */


lbl(5):	if ^rsw then				/* "free" function */
	     cc = 3;				/* calling free_name */
	else					/* restore mode */
	     cc = 4;				/* restore_name */

common2:	if ^initsw then do;				/* initialize int static error code table */
	     ctable(1) = error_table_$segnamedup;
	     ctable(2) = error_table_$namedup;
	     ctable(3) = error_table_$oldnamerr;
	     ctable(4) = error_table_$nonamerr;
	     initsw = "1"b;				/* don't do it again */
	     end;

	on linkage_error begin;
	     chname_file_entry = hcs_$chname_file;
	     goto revert_linkage_error;
	     end;
	chname_file_entry = installation_tools_$chname_file;
revert_linkage_error:
	revert linkage_error;

	do i = 1 to nn;				/* hardcore puts names on in right order now */
	     if ^rsw then				/* select proper status code in names array */
		cdp = addr (names(i).pcode);		/* "pcode" if in process mode */
	     else
		cdp = addr (names(i).rcode);		/* "rcode" if in restore mode */
	     if cd ^= 0 then do;			/* if it hasn't been done yet, do it */
		if ^rsw then			/* if processing, */
		     names(i).rcode = error_table_$not_done;	/* initialize restore code */
		else if names(i).pcode ^= 0 then	/* if in restore mode, must have processed it ok */
		     go to skip;			/* skip this name if not */
		nmp = addr (names(i).name);		/* get pointer to this name */
		go to call(cc);			/* select proper call */
call(1):		call chname_file_entry (dir, seg, "", name, cd);	/* adding name */
		go to rejoin;
call(2):		call chname_file_entry (dir, seg, name, "", cd);	/* removing name */
		go to rejoin;
call(3):		if i = 1 then			/* if this is the primary name of segment */
		     call upd_free_name_(dir, name, cd); /* free name by renaming to backup name */
		else				/* if not primary name, then		*/
		     call chname_file_entry ( dir, seg, name, "", cd); /* delete the name */
		go to rejoin;
call(4):		if i = 1 then			/* if primary name, then reverse fxn is to rename it */
		     call upd_free_name_$restore (dir, name, cd); /* inverse of upd_free_name_ */
		else				/* otherwise, we have to put name back on seg */
		     call chname_file_entry ( dir, seg, "", name, cd);
rejoin:		if cd ^= 0 then do;			/* error? */
		     do j = 1 to 4;			/* see if it's one we know about */
			if cd = ctable(j) then do;	/* look up in table */
			     sev = stable(j, cc);	/* found it, get severity code */
			     go to err;		/* skip */
			     end;
			end;
		     sev = 3;			/* unknown error, severity 3 */
err:		     if seg = msgseg then
			call upd_task_err_ (cd, sev, argp, (entry(e)),
			     "^R^a^B^/Referencing ^R^a>^a^B .", name, dir, seg);
		     else
			call upd_task_err_ (cd, sev, argp, (entry(e)),
			     "^R^a^R^/Referencing ^R^a>^a^B^/(^a>^a).", name, dir, seg, dir, msgseg);
		     end;
		else if rsw then			/* successful restore, reinitialize process code */
		     names(i).pcode = error_table_$not_done;	/* so we can repeat task if desired */
skip:		end;				/* here if restore skipped */
	     end;

	go to prnames;				/* done, go to common exit */


	end upd_name_task_;
   



		    upd_print_acl_.pl1              11/15/82  1844.4rew 11/15/82  1514.4       26676


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


upd_print_acl_:	procedure (aclp, n, sws);


/*

	This procedure will print a standard-format access control
	list on the user's terminal.  Procedure cv_acl_ is called to
	format each entry.  Options allow the mode field, 
	and error message corresponding to the status code to be
	suppressed.  When extended access is fully implemented, it
	is expected that a fourth argument to upd_print_acl_ will specify
	the acl type.

	P. Bos, May 1972

	Modified Apr. 3, 1973 by Peter B. Kelley	to change acl structure for new
						hcs_ acl primitives.

*/

     dcl	aclp			ptr,		/* pointer to acl array */
	n			fixed bin,	/* size of array */
	sws			bit(*);		/* option bits */

     dcl	cv_acl_			entry (ptr, fixed bin, char(*), fixed bin, bit(*)),
	ios_$write		entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned);

     dcl (addr, null, substr)		builtin;

     dcl (nl			char(1) init ("
"),	noacl			char(15) init ("	ACL is empty.
"),	tab			char(1) init ("	")) aligned int static;

     dcl	1 characters		auto,
	  2 tab			char (1),		/* tab at beginning of every line. */
	  2 string		char (160);	/* sufficiently large output string */

     dcl (i, len, nelemt)		fixed bin;

     dcl	status_code		bit(72) aligned;	/* an IO system status code. */

     dcl	1 acl (n)			aligned based (aclp),	/* acl array */
	  2 userid		char(32),		/* user name for this entry */
	  2 mode			bit (36),		/* 1-3 "rew", rest 0 */
	  2 pad 			bit (36),		/* must be 0 */
	  2 code			fixed bin (35);     /* error code */

/**/

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


	if aclp ^= null then if n ^= 0 then		/* check for empty acl */
	     go to skip;				/* no, go print */
	call ios_$write ("installation_list_", addr (noacl), 0, 15, nelemt, status_code);
						/* yes, print message, */
	return;					/* and exit */

skip:	characters.tab = tab;			/* initialize tab character. */
	do i = 1 to n;				/* list acl in order */
	     call cv_acl_(aclp, i, string, len, sws);	/* format this entry */
	     len = len + 1;				/* make room for new_line */
	     if len > 160 then			/* make sure our cup doesn't run over */
		len = 160;			/* adjust if so */
	     substr (string, len, 1) = nl;		/* insert new_line */
	     call ios_$write ("installation_list_", addr (characters), 0, len+1, nelemt, status_code);
						/* write it on user_output */
	     end;

	return;					/* done */


	end upd_print_acl_;



		    upd_print_err_.pl1              11/15/82  1844.4rew 11/15/82  1514.4       97983


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


upd_print_err_:	procedure (code, sev);


/*

	This procedure will format and print an error message, given a
	status code, severity code, condition name, procedure name, and
	optional ioa_ string and arguments.  Character string arguments
	which are "" (null string) will result in suppression of the
	corresponding portions of the message, as will status code and
	severity code of 0.  In addition, the case of severity code only
	is special-cased to produce the message

		"An error of severity _n has occurred."

	and the case of status code/format string and procedure/entry
	name only is special-cased to produce

		"proc$entry: Expanded error message."

	in the format of com_err_.  Calling sequence to print_err_ is:

	     call upd_print_err_(code, sev, prefix, condition,
		     proc, entry, string, args ...);

	     (1)	code	fixed bin(35)	status code
	     (2)	sev	fixed bin		severity code
	     (3)	prefix	char(*)		instead of "Error"
	     (4)	condition	char(*)		condition name
	     (5)	proc	char(*)		procedure name
	     (6)	entry	char(*)		entry point name
	     (7)	string	char(*)		format string
	     (8)	args	...		format args

	The error message produced will be a subset of:

	     Error (severity _n): condition condition from proc$entry
	     Expanded error message.  Optional formatted string.

	Trailing unwanted arguments may be omitted.

	P. Bos, May 1972

*/

/**/

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


     dcl	code			fixed bin(35),	/* status code */
	sev			fixed bin,	/* severity code */
	prefix			char(xl) based(xp),	/* message prefix */
	condition			char(cl) based(cp),	/* condition name */
	proc			char(pl) based(pp),	/* procedure name */
	entry			char(el) based(ep),	/* entry point name */
	string			char(sl) based(sp);	/* ioa_$general_rs control_ string */

     dcl	check_fs_errcode_		entry (fixed bin(35), char(8) aligned, char(300) aligned),
	convert_binary_integer_$decimal_string	entry (fixed bin) returns (char(12) varying),
	cu_$arg_count		entry (fixed bin),
	cu_$arg_list_ptr		entry (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char(*) aligned, fixed bin, bit(1) aligned,
				       bit(1) aligned),
	ios_$write		entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned);

     dcl (addr, null)		builtin;

     dcl	sws			bit(5) aligned;	/* control bits for message subfields */

     dcl (cl, el, i, l, n, pl, sl, xl)	fixed bin,
	ignore			fixed bin(35),
	nelemt			fixed bin,
	status_code		bit(72) aligned;

     dcl (argp, cp, ep, p, pp, sp, swp, xp)
				ptr;

     dcl	chars			char(i) based(p),	/* unaligned char string overlay */
	dummy			char(8) aligned,	/* ignored short format from check_fs_errcode_ */
	info			char(300) aligned,	/* long form message from same */
	line			char(400) aligned;	/* output message */

     dcl	1 s			aligned based(swp),	/* bit array overlaid on "sws" */
	  2 sw (5)		bit(1) unal;

/**/

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


	sws = "00000"b;				/* initialize */
	sl, el, pl, cl, xl = 0;			/* nobody home yet */
	swp = addr (sws);				/* for bit array overlay */
	call cu_$arg_count (n);			/* get number of arguments supplied */
	if n > 6 then do;				/* user supplied ioa_$general_rs control_ string */
	     call cu_$arg_ptr (7, sp, sl, ignore);	/* get arg pointer and size */
	     call adjust (sp, sl);			/* strip leading & trailing blanks */
	     if sl ^= 0 then			/* anything left? */
		s.sw(1) = "1"b;			/* error message switch */
	     go to a;				/* skip */
	     end;
	if n > 5 then do;				/* entry name supplied */
a:	     call cu_$arg_ptr (6, ep, el, ignore);	/* get pointer and length */
	     call adjust (ep, el);			/* get rid of leading and trailing blanks */
	     if el ^= 0 then			/* anything left? */
		s.sw(4) = "1"b;			/* proc$entry switch */
	     go to b;				/* skip */
	     end;
	if n > 4 then do;				/* procedure name supplied */
b:	     call cu_$arg_ptr (5, pp, pl, ignore);	/* get pointer and length */
	     call adjust (pp, pl);			/* strip leading & trailing blanks */
	     if pl ^= 0 then			/* all blanks? */
		s.sw(4) = "1"b;			/* proc$entry switch */
	     go to c;				/* skip */
	     end;
	if n > 3 then do;				/* condition name supplied */
c:	     call cu_$arg_ptr (4, cp, cl, ignore);	/* get pointer and length */
	     call adjust (cp, cl);			/* strip blanks */
	     if cl ^= 0 then			/* was it really supplied? */
		s.sw(3) = "1"b;			/* yes */
	     go to d;				/* skip */
	     end;
	if n > 2 then do;				/* prefix arg supplied? */
d:	     call cu_$arg_ptr (3, xp, xl, ignore);	/* yes, get it */
	     call adjust (xp, xl);			/* get rid of blanks */
	     if xl ^= 0 then			/* was it really supplied ? */
		s.sw(5) = "1"b;			/* yes */
	     go to h;				/* skip */
	     end;
	if n > 1 then do;				/* severity code supplied? */
h:	     if sev ^= 0 then			/* omitted if zero */
		s.sw(2) = "1"b;			/* but it's there */
	     go to e;				/* skip */
	     end;
	if n ^= 0 then				/* how about status code? */
e:	     if code ^= 0 then			/* zero code implies not there */
		s.sw(1) = "1"b;			/* error message switch */

	l = 1;					/* output message starts out length one */
	line = "
";						/* start with a carriage return. */
	if sws = "01000"b then			/* special case for severity code only */
	     go to sevmsg;				/* skip */
	if sws = "10010"b then			/* and for status code/procedure name */
	     go to errmsg;				/* skip also */

	if xl ^= 0 then				/* did caller specify prefix string? */
	     call addchr (prefix);			/* yes, use his */
	else					/* no, */
	     call addchr ("Error");			/* use canned one */
	if sws & "0100"b then			/* severity code supplied? */
	     call addchr (" (severity " || convert_binary_integer_$decimal_string (sev) || ")");
	if ((sws & "1001"b) = "1000"b) | (sws & "0011"b) then
						/* if followed by err msg, cond name, or proc name */
	     call addchr (":");			/* add colon */
	if sws & "0010"b then			/* N.B. note red, black shift chars */
	     call addchr (" " || condition || " condition");	/* around condition name */
	if sws & "0001"b then do;			/* procedure/entry name supplied? */
	     call addchr (" from ");			/* note red shift after "from" */
	     if pl ^= 0 then			/* if procedure name there, */
		call addchr (proc);			/* insert it */
	     if el ^= 0 then			/* if entry name there, */
		call addchr ("$" || entry);		/* add him too */
	     call addchr ("");			/* black shift */
	     end;
	if sws & "1000"b then do;			/* status code or format string */
	     if (sws & "0011"b) then			/* if condition name or procedure name, */
		call addchr ("
");	     else					/* new_line in previous stmt */
		call addchr (" ");			/* if not, rest goes on same line */
f:	     if code ^= 0 then do;			/* status code? */
		call check_fs_errcode_(code, dummy, info);	/* expand it into a message */
		p = addr (info);			/* get pointer, size for adjust */
		i = 100;
		call adjust (p, i);			/* strip leading, trailing blanks */
		if i ^= 0 then			/* anything left? */
		     call addchr (chars);		/* do it to it */
		if sl ^= 0 then do;			/* if formatted string there also, */
		     call addchr ("  ");		/* insert couple of blanks */
		     go to g;			/* skip */
		     end;
		end;
	     if sl ^= 0 then do;			/* did user supply ioa_$general_rs control_ string? */
g:		if n > 7 then do;			/* yes, were there args to be formatted? */
		     sp = addr (info);		/* yes, get a place to put them */
		     sl = 300;			/* initialize length */
		     call cu_$arg_list_ptr (argp);	/* get ptr to our argument list. */
		     call ioa_$general_rs (argp, 7, 8, info, sl, "0"b, "1"b);
		     end;				/* otherwise, sp, sl still point to arg 6 */
		call addchr (string);		/* insert it */
		end;
	     end;
	call addchr ("
");						/* add terminal carriage return */

write:	call ios_$write ("installation_error_", addr (line), 0, l, nelemt, status_code);
						/* write message onto error stream. */
	return;					/* done. */


sevmsg:	call addchr ("An error of severity " || convert_binary_integer_$decimal_string (sev) || " has occurred.
");	go to write;				/* lots of new_line's in strings */


errmsg:	if pl ^= 0 then				/* here to form com_err_ style message */
	     call addchr (proc);			/* procedure name */
	if el ^= 0 then
	     call addchr ("$" || entry);		/* entry name */
	call addchr (": ");				/* colon, spaces */
	go to f;					/* join common code to add error message, string */

/**/

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


addchr:		procedure (arg);			/* procedure to add arg to line */


     dcl	arg			char(*);		/* char string to insert into line */

     dcl (length, substr)		builtin;

     dcl	t			fixed bin;	/* temp */


	t = length (arg);				/* get size of string to add */
	if t > 400 - l then				/* maximum of 400 chars in message */
	     t = 400 - l;				/* make sure we don't run off end */
	if t ^= 0 then do;				/* still room, put it in */
	     substr (line, l+1, t) = arg;		/* after what's already there */
	     l = l + t;				/* line got longer */
	     end;
	return;					/* done */

	end addchr;


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


adjust:		procedure (argp, argl);		/* procedure to strip leading, trailing blanks */


     dcl	argp			ptr,		/* pointer to char string */
	argl			fixed bin;	/* length of string */

     dcl	t			fixed bin;	/* temp */

     dcl	1 c			based (argp),	/* char array overlaid on string */
	  2 char (argl)		char(1) unal;	/* makes better code than substr */


	do t = 1 to argl;				/* scan from front for first non-blank */
	     if c.char(t) ^= " " then			/* non-blank? */
		go to first;			/* yes, exit loop */
	     end;
first:	argp = addr (c.char(t));			/* adjust pointer to point to it */
	argl = argl - t + 1;			/* adjust length */
	if argl ^= 0 then do;			/* if string not all blank */
	     do t = argl to 1 by -1;			/* scan from end for last non-blank */
		if c.char(t) ^= " " then		/* found it? */
		     go to last;			/* yes, skip */
		end;
last:	     argl = t;				/* set new length */
	     end;
	return;					/* bye... */

	end adjust;


	end upd_print_err_;
 



		    upd_print_names_.pl1            11/15/82  1844.4rew 11/15/82  1514.5       54585


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


upd_print_names_:		procedure (np, n, asw);


/*

	This procedure is used within the Multics Online Updater to
	print standard updater-format name lists on the user's terminal.
	Options allow suppression of error messages which correspond
	to the process and restore status codes.

	P. Bos, May 1972

*/

     dcl	np			ptr,		/* pointer to name array */
	n			fixed bin,	/* size of array */
	asw			bit(*);		/* option switches */

     dcl	check_fs_errcode_		entry (fixed bin(35), char(8) aligned, char(100) aligned),
	ios_$write		entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned);

     dcl (addr, null, length)		builtin;

     dcl	error_table_$not_done	ext fixed bin(35);

     dcl (p, sp)			ptr;

     dcl	code			fixed bin(35),
	status_code		bit(72) aligned;

     dcl	chars			char(j) based (p),	/* char string overlay */
         (dummy			char(8),
	info			char(100),
	line			char(266)) aligned;

     dcl	sws			bit(2) aligned;	/* copy of asw */

     dcl	1 s			based (sp),	/* overlaid on sws */
	 (2 psw			bit(1),		/* non-zero if to interpret process code */
	  2 rsw			bit(1)) unal;	/* non-zero if to interpret restore code */

     dcl	1 names (n)		aligned based (np),	/* updater-format names array */
	  2 name			char(32),		/* segment name */
	  2 pcode			fixed bin(35),	/* status code during processing */
	  2 rcode			fixed bin(35);	/* status code during restore */

     dcl	empty			char(21) aligned init ("	Name list is empty.
");
     dcl (i, j, l, ll, lmax, nelemt)	fixed bin;

/**/

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


	if np ^= null then if n ^= 0 then		/* see if null name list */
	     go to skip;				/* no, go print it */
	call ios_$write ("installation_list_", addr (empty), 0, 21, nelemt, status_code);
						/* yes, print message saying this, */
	return;					/* and exit */

skip:	sws = asw;				/* align option bits */
	sp = addr (sws);				/* get pointer for overlay */
	lmax = length (line);			/* set max. line length for addchr */
	do i = 1 to n;				/* once over lightly */
	     line = "	";			/* blank out line image and start with a tab */
	     l = 1;				/* nothing in it yet */
	     p = addr (names(i).name);		/* get pointer to this name */
	     j = 32;				/* and length */
	     call adjust (p, j);			/* strip blanks */
	     call addchr (chars);			/* and insert into output line */
	     if s.psw then do;			/* user want process code? */
		code = names(i).pcode;		/* copy status code */
		if code = 0 then			/* nothing there */
		     go to skip1;			/* well, don't put it in then */
		if l < 30 then			/* most names will fit in 30 chars */
		     l = 30;			/* make error message fall on tab stop */
		else				/* big name */
		     l = l + 1;			/* add a blank */
		call check_fs_errcode_(code, dummy, info);	/* get error_table_ message */
		p = addr (info);			/* get pointer to it */
		j = 100;				/* and length */
		call adjust (p, j);			/* pajamas too big? */
		call addchr (chars);		/* just right, now */
		end;
skip1:	     if s.rsw then do;			/* want restore code? */
		code = names(i).rcode;		/* copy it */
		if code ^= 0 then if code ^= error_table_$not_done then do;
		     call check_fs_errcode_(code, dummy, info);	/* expand message */
		     call addchr ("
 (restore)                    ");			/* 20 blanks on end */
		     p = addr (info);		/* get pointer to message */
		     j = 100;			/* and length */
		     call adjust (p, j);		/* strip blanks */
		     call addchr (chars);		/* and insert it */
		     end;
		end;
	     call addchr ("
");	     call ios_$write ("installation_list_", addr (line), 0, l, nelemt, status_code);
						/* append <nl> and write it on listing stream. */
	     end;

	return;					/* done, exit */

/**/

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


addchr:		procedure (arg);			/* procedure to add arg to line */


     dcl	arg			char(*);		/* char string to insert into line */

     dcl (length, substr)		builtin;

     dcl	t			fixed bin;	/* temp */


	t = length (arg);				/* get size of string to add */
	if t > lmax - l then			/* maximum of lmax chars in message */
	     t = lmax - l;				/* make sure we don't run off end */
	if t ^= 0 then do;				/* still room, put it in */
	     substr (line, l+1, t) = arg;		/* after what's already there */
	     l = l + t;				/* line got longer */
	     end;
	return;					/* done */

	end addchr;


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


adjust:		procedure (argp, argl);		/* procedure to strip leading, trailing blanks */


     dcl	argp			ptr,		/* pointer to char string */
	argl			fixed bin;	/* length of string */

     dcl	t			fixed bin;	/* temp */

     dcl	1 c			based (argp),	/* char array overlaid on string */
	  2 char (argl)		char(1) unal;	/* makes better code than substr */


	do t = 1 to argl;				/* scan from front for first non-blank */
	     if c.char(t) ^= " " then			/* non-blank? */
		go to first;			/* yes, exit loop */
	     end;
first:	argp = addr (c.char(t));			/* adjust pointer to point to it */
	argl = argl - t + 1;			/* adjust length */
	if argl ^= 0 then do;			/* if string not all blank */
	     do t = argl to 1 by -1;			/* scan from end for last non-blank */
		if c.char(t) ^= " " then		/* found it? */
		     go to last;			/* yes, skip */
		end;
last:	     argl = t;				/* set new length */
	     end;
	return;					/* bye... */

	end adjust;


	end upd_print_names_;
   



		    upd_ring_task_.pl1              11/15/82  1844.4rew 11/15/82  1514.6       52227


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


upd_ring_task_:	proc;

dcl					/* arguments passed */
     ctlw		bit (36) aligned,
     areap	ptr,
     parentp	ptr,
     acode	fixed bin (35),
     asev		fixed bin,
     taskp	ptr,
     seqno	fixed bin,
     dir		char (168),
     seg		char (32),
     msgseg	char (32),
     Uid		bit (36) aligned,
     Rb (3)	fixed bin (3),
     recover	bit (1);

dcl  1  c  aligned based ( addr(ctlw) ),	/* expanded view of control_word (ctlw) */
      (2  rsw		bit (1),
       2  task_sw		bit (1),
       2  compile_sw	bit (1),
       2  run_sw		bit (1),
       2  task_run_sw	bit (1),
       2  log_sw		bit (1),
       2  error_sw		bit (1),
       2  brief_sw		bit (1),
       2  detail_sw		bit (1),
       2  clear_code_sw	bit (1),
       2  clear_uid_sw	bit (1)) unaligned;

dcl  1  Stat aligned,			/* area for info gotten from upd_status_ */
      (2  type		bit (2),
       2  nnames		bit (16),
       2  nrp		bit (18),
       2  dtm		bit (36),
       2  dtu		bit (36),
       2  mode		bit (5),
       2  pad		bit (13),
       2  rec		bit (18),
       2  dtd		bit (36),
       2  dtem		bit (36),
       2  acct		bit (36),
       2  curlen		bit (12),
       2  bitcnt		bit (24),
       2  did		bit (4),
       2  mdid		bit (4),
       2  copysw		bit (1),
       2  pad2		bit (9),
       2  rbs (3)		bit (6),
       2  uid		bit (36) ) unaligned;

dcl
     cu_$arg_list_ptr			entry (ptr),
     cu_$level_get				entry returns (fixed bin),
     upd_add_task_				entry ( char(*), ptr),
     upd_print_err_				entry options (variable),
     upd_status_$long			entry ( char(*), char(*), fixed bin, ptr, ptr, fixed bin (35) ),
     upd_task_err_				entry options (variable),
     hcs_$get_ring_brackets			entry (char(*), char(*), (3) fixed bin(3), fixed bin(35)),
     set_ring_brackets_entry			entry (char(*), char(*), (3)fixed bin(3), fixed bin(35)) variable,
     hcs_$set_ring_brackets			entry (char(*), char(*), (3)fixed bin(3), fixed bin(35)),
     installation_tools_$set_ring_brackets	entry (char(*), char(*), (3) fixed bin(3), fixed bin(35)),
     ioa_$ioa_stream			entry options (variable);

dcl linkage_error			condition;
dcl  error_table_$non_matching_uid	ext fixed bin (35);
dcl  null builtin;

dcl
     argp		ptr,
     e		fixed bin,
     i		fixed bin,
     sev		fixed bin init (3),
     code		fixed bin (35) init (0),
     logsw	bit (1),
     runsw	bit (1),
     trb (3)	fixed bin (3),
     Entry (2)	char (32) init (
		     "upd_ring_task_$list",
		     "upd_ring_task_$set" ),
     amsg (2)	char (4) init (
		     "List",
		     "Set " );


list:	entry ( ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, Uid, Rb);

	if ctlw & "10000000011"b		/* this entry doesn't run in reverse mode or */
	     then return;			/* in "clear" mode                       */
	e = 1;
	goto common;

set:	entry ( ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, msgseg, Uid, Rb, recover);

	if ctlw & "00000000011"b		/* doesn't run in "clear" mode             */
	     then return;
	if ctlw & "10000000000"b		/* but does run in reverse if full           */
	     then if ^recover		/* recovery is possible                      */
		then return;
	e = 2;

common:
	call cu_$arg_list_ptr (argp);
	logsw = c.log_sw;
	runsw = c.run_sw | c.task_run_sw;
	if c.error_sw			/* if printing errors, and we have */
	     then if asev = 0		/* no errors to print then         */
		then logsw = "0"b;		/* we won't print any!             */
	if c.task_sw
	     then call upd_add_task_ ( (Entry(e)), argp);	/* add my task to list */
	if logsw
	     then do;
	          if seg = msgseg
		     then call ioa_$ioa_stream ("installation_list_","^5x^R^a rings^-^a>^a^B",amsg(e),dir,seg);
		     else call ioa_$ioa_stream("installation_list_","^5x^R^a rings^-^a>^a^2x(^a)^B",
						amsg(e),dir,seg,msgseg);
		if Rb(1) ^= 0		/* zero here means deferred information gathering */
		     then call ioa_$ioa_stream("installation_list_","^-^R^d,^d,^d^B",Rb(1),Rb(2),Rb(3));
		     else if e = 2 
			then call ioa_$ioa_stream("installation_list_","^-^RRing list is empty.^B");
		if asev ^= 0
		     then call upd_print_err_ (acode,asev);
		end;
	if runsw
	     then do;
		call upd_status_$long ( dir, seg, 1, addr(Stat), null, code);
		     if code ^= 0 then goto baderr;
		if Uid ^= ""b
		     then do;
			if Uid ^= Stat.uid
			     then code = error_table_$non_matching_uid;
			if code ^= 0 then goto baderr;
			end;
		     on linkage_error begin;
			set_ring_brackets_entry = hcs_$set_ring_brackets;
			goto revert_linkage_error;
			end;
		     set_ring_brackets_entry = installation_tools_$set_ring_brackets;
revert_linkage_error:    revert linkage_error;
		if ^c.rsw
		     then goto lable(e);
		     else goto reverse;
		end;
	goto exit;

baderr:
	call upd_task_err_ (code, sev, argp, (Entry(e)),"^a>^a", dir, seg);
	return;

lable(1):
	if Rb(1) = 0			/* if we haven't already gotten the info, */
	     then call hcs_$get_ring_brackets (dir, seg, Rb, code); /* then get the ring brackets */
	goto exit;

lable(2):
	call set_ring_brackets_entry ( dir, seg, Rb, code);
	     if code ^= 0 then goto baderr;
	goto exit;

reverse:
	trb(1), trb(2), trb(3) = fixed ( cu_$level_get(), 3);
	call set_ring_brackets_entry ( dir, seg, trb, code);
	     if code ^= 0 then goto baderr;
exit:
	return;					/* normal exit */


	end;
 



		    upd_status_.pl1                 11/15/82  1844.4rew 11/15/82  1514.6       29223


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


upd_status_:	procedure (dir, seg, chase, statp, areap, code);


/*

	This procedure provides an interface to hcs_$status which makes
	links transparent to the caller if the chase switch in the call
	is non-zero, i.e. status of the target branch is returned with
	names on the link.

	P. Bos, May 1972

*/

     dcl	dir			char(*),		/* dirname of segment in question */
	seg			char(*),		/* entryname of segment */
	chase			fixed bin(1),	/* non-zero if to chase link */
	statp			ptr,		/* pointer to status structure */
	areap			ptr,		/* pointer to area */
	code			fixed bin(35);	/* status code for call */

     dcl	hcs_$status_		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	hcs_$status_long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));

     dcl	null			builtin;

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

     dcl	long_status_block		bit(360) aligned based (statp),
						/* overlay for status block */
	status_block		bit(144) aligned based (statp);
						/* ditto */

     dcl	1 stat			aligned based (statp),	/* first part of status block */
	 (2 type			bit(2),		/* entry type */
	  2 nnames		bit(16),		/* number of names on entry */
	  2 nrp			bit(18)) unal;	/* rel. pointer to name array */

     dcl (nnames			bit(16),
	nrp			bit(18),
	sw			bit(1)) aligned;

/**/

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


	sw = "0"b;				/* short mode of status_ call */
	status_block = "0"b;			/* hcs_$status_ doesn't zero entries in stat */
	call hcs_$status_(dir, seg, 0, statp, areap, code);
	go to join;				/* skip */


long:		entry (dir, seg, chase, statp, areap, code);


	sw = "1"b;				/* long mode */
	long_status_block = "0"b;			/* hcs_$status_long doesn't zero entries either. */
	call hcs_$status_long (dir, seg, 0, statp, areap, code);

join:	if code ^= 0 then				/* was there an error? */
	     if code ^= error_table_$no_s_permission then	/* ignore no_s_permission errors. */
		return;
	     else if areap ^= null then		/* unless user wants names also. */
		return;
	if chase ^= 0 then if stat.type = "00"b then do;	/* user wants to chase link */
	     nnames = stat.nnames;			/* save count and pointer */
	     nrp = stat.nrp;			/* of current name list */
	     if sw then				/* call status_ again with chase option */
		call hcs_$status_long (dir, seg, 1, statp, null, code);
	     else					/* but without names */
		call hcs_$status_(dir, seg, 1, statp, null, code);
	     stat.nnames = nnames;			/* put back original name list */
	     stat.nrp = nrp;			/* count and pointer */
	     end;

	if code = error_table_$no_s_permission then	/* ignore this error. */
	     code = 0;


	end upd_status_;
 



		    upd_status_task_.pl1            11/15/82  1844.4rew 11/15/82  1514.8       58869


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


upd_status_task_:	procedure;


/*

	This procedure includes various utility task functions which return
	status information about a directory entry, used by the Multics Online
	Updater.  The following are entries:

		upd_status_task_$get_uid	get segment unique id

	The first 10 arguments are identical for each entry, being:

	     (1)	ctlw	bit(36) aligned	updater control word
	     (2)	areap	ptr		caller area pointer
	     (3)	parentp	ptr		pointer to parent arglist
	     (4)	acode	fixed bin(35)	status code
	     (5)	asev	fixed bin		severity code
	     (6)	taskp	ptr		task pointer
	     (7)	seqno	fixed bin		task sequence no.
	     (8)	dir	char(168)		dirname of segment
	     (9)	seg	char(32)		entryname of segment
	    (10)	uid	bit(36) aligned	unique id (output for "uid" entry)

	These entry points are restartable.  "acode", "asev", and "taskp" should
	be initialized to "0", "0", and "null", respectively.  upd_status_task_$get_uid
	additionally expects "uid" to be initialized to "0"b; any non-zero value
	will be assumed to have been output prior to a system or process failure,
	and will be verified instead of being overwritten.

	P. Bos, May 1972

	Modified Apr. 4, 1973 by Peter B. Kelley	to put in a check to issue a warning if
						the "directory entry" is a directory.

*/

/**/

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


     dcl	ctlw			bit(36) aligned,	/* updater task control word */
	areap			ptr,		/* caller area pointer */
	parentp			ptr,		/* pointer to parent arglist */
	acode			fixed bin(35),	/* status code */
	asev			fixed bin,	/* severity code */
	taskp			ptr,		/* task pointer */
	seqno			fixed bin,	/* task sequence no. */
	dir			char(168),	/* dirname of segment */
	seg			char(32),		/* entryname of segment */
	uid			bit(36) aligned;	/* unique id of segment */

     dcl	cu_$arg_list_ptr		entry (ptr),
	ioa_$ioa_stream		entry options (variable),
	upd_add_task_		entry (char(*), ptr),
	upd_print_err_		entry options (variable),
	upd_status_$long		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
	upd_task_err_		entry options (variable);

     dcl (addr, null)		builtin;

     dcl	error_table_$non_matching_uid	ext fixed bin(35),
          error_table_$not_seg_type     ext fixed bin(35);

     dcl	argp			ptr,		/* arglist pointer */
	cp			ptr;		/* control word pointer */

     dcl	code			fixed bin(35),	/* status code for call */
          sev               		fixed bin init (3);	/* severity code for call */

     dcl	logsw			bit(1) aligned,	/* c.logsw | (c.errsw & asev ^= 0) */
	runsw			bit(1) aligned;	/* c.runsw | c.trunsw */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 rsw			bit(1),		/* non-zero if in reverse mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1)) unal;	/* non-zero if to print error tasks only */

     dcl	1 stat			aligned,		/* data structure for status_ */
	 (2 type			bit(2),		/* entry type */
	  2 nnames		bit(16),		/* number of names returned */
	  2 nrp			bit(18),		/* rel pointer to name array */
	  2 dtm			bit(36),		/* date/time modified */
	  2 dtu			bit(36),		/* date/time used */
	  2 mode			bit(5),		/* t, r, e, w, a */
	  2 pad			bit(13),		/* unused */
	  2 recs			bit(18),		/* pages used */
	  2 dtd			bit(36),		/* date/time dumped */
	  2 dtem			bit(36),		/* date/time entry modified */
	  2 acct			bit(36),		/* accounting data */
	  2 curlen		bit(12),		/* length of segment */
	  2 bitcnt		bit(24),		/* bitcount of segment */
	  2 did			bit(4),		/* device id */
	  2 mdid			bit(4),		/* ? */
	  2 copysw		bit(1),		/* segment copy switch */
	  2 pad2			bit(9),		/* unused */
	  2 rbs (0:2)		bit(6),		/* ring brackets */
	  2 uid			bit(36)) unal;	/* unique id */

/**/

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


get_uid:		entry (ctlw, areap, parentp, acode, asev, taskp, seqno, dir, seg, uid);

	call cu_$arg_list_ptr (argp);			/* get arglist pointer for alloc_task_, etc. */
	cp = addr (ctlw);				/* get control word pointer */
	if c.rsw then				/* if in restore phase, we don't do that */
	     return;				/* scram */
	if c.tasksw then				/* are we to allocate a task? */
	     call upd_add_task_("upd_status_task_$get_uid", argp);
	logsw = c.logsw;				/* non-zero if printing */
	if c.errsw then if asev = 0 then		/* errors only? */
	     logsw = "0"b;				/* happy to oblige */
	runsw = c.runsw | c.trunsw;			/* non-zero if processing */
	if logsw then do;				/* user is nosy */
	     call ioa_$ioa_stream ("installation_list_", "^5x^RGet unique id^B^-^a>^a", dir, seg);
	     if asev ^= 0 then			/* was there an error last time? */
		call upd_print_err_(acode, asev);	/* yes, tell user */
	     end;
	if runsw then do;				/* are we in process mode? */
	     call upd_status_$long (dir, seg, 1, addr(stat), null, code);
	     if code = 0 then if stat.type = "10"b then do; /* is entry a directory ? */
		code = error_table_$not_seg_type;	/* give user some kind of error */
		sev = 0;				/* but only a sev of 0, he might want this! */
		end;
	     if code = 0 then if uid ^= ""b then if uid ^= stat.uid then do;
		code = error_table_$non_matching_uid;	/* verify unique id */
		sev = 3;				/* make sure severity is 3 here */
		end;
	     if code ^= 0 then do;			/* error? */
err:		call upd_task_err_(code, sev, argp, "upd_status_task_$get_uid", "^a>^a", dir, seg);
		return;				/* exit */
		end;
	     end;
	if runsw then				/* do it? */
	     uid = stat.uid;			/* do it */
	if logsw then if uid ^= "0"b then		/* printing too? */
	     call ioa_$ioa_stream ("installation_list_", "^-^w", uid);/* yes, print non-zero uid */
	return;					/* not much of a cough... */


	end upd_status_task_;
   



		    upd_subtask_.pl1                11/15/82  1844.4rew 11/15/82  1514.9       45018


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


upd_subtask_:	procedure (ctlw, areap, parentp, acode, asev, taskp, seqno, listp, temp)
		options ( rename (( alloc_, smart_alloc_)) );


/*

	This procedure is the subtask dispatcher for the Multics Online Updater.
	If the task list supplied at "listp" is not empty, upd_subtask_ will add
	a task call to itself to the task list, specifying a lower-level sublist,
	will establish a condition handler for the "thread_task_" condition, which
	will cause all subtasks generated while processing the task list to be
	inserted into this sublist, and will call upd_task_ to invoke all tasks
	in the list.  The control word is masked to eliminate all immediate-call
	bits for subtasks.

	P. Bos, June 1972

*/

     dcl	ctlw			bit(36) aligned,	/* task control word */
	areap			ptr,		/* pointer to caller area */
	parentp			ptr,		/* pointer to caller's arglist */
	acode			fixed bin(35),	/* status code (not used here) */
	asev			fixed bin,	/* severity code (not used here) */
	taskp			ptr,		/* task pointer for this call */
	seqno			fixed bin,	/* task sequence number for all upd_subtask_ tasks */
	listp			ptr,		/* pointer to first task in list to be processed */
	temp			ptr;		/* pointer to "t" structure (initially null) */

     dcl	condition_		entry (char(*), entry),
	cu_$arg_list_ptr		entry (ptr),
	upd_add_task_		entry (char(*), ptr),
	upd_gen_call_		entry (ptr, ptr),
	upd_task_			entry (bit(1), ptr, entry, ptr);

     dcl	upd_subtask_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				ptr, ptr);

     dcl (addr, null)		builtin;

     dcl (argp, cp, tp)		ptr;		/* arglist pointer, control word pointer, temp copy */

     dcl	xctl			bit(36) aligned;	/* subtask control word */

     dcl	area			area based (areap);	/* caller-supplied area */

     dcl	1 c			aligned based (cp),	/* exploded control word */
	 (2 rsw			bit(1),		/* non-zero if in reverse mode */
	  2 tasksw		bit(1),		/* non-zero if to set up task */
	  2 compsw		bit(1),		/* non-zero if compile-only task */
	  2 runsw			bit(1),		/* non-zero if call to be processed immediately */
	  2 trunsw		bit(1),		/* non-zero if subtask list to be processed */
	  2 logsw			bit(1),		/* non-zero if in print mode */
	  2 errsw			bit(1)) unal;	/* non-zero if to print error tasks only */

/**/

     dcl	1 t			aligned based (tp),	/* super-static storage */
	 (2 argp			ptr,		/* copy of "argp" */
	  2 taskp			ptr,		/* task pointer for subtask */
	  2 listp			ptr,		/* task sublist pointer */
	  2 temp			ptr) init (null),	/* "temp" for subtask */
	  2 subsw			bit(1) aligned init ("0"b);	/* non-zero if subtask allocated */


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


	call cu_$arg_list_ptr (argp);			/* get arglist pointer */
	cp = addr (ctlw);				/* and control word pointer */
	if c.tasksw then				/* is this allocate call? */
	     call upd_add_task_("upd_subtask_", argp);	/* yes, go make a task */
	if temp = null then do;			/* have we gotten temps yet? */
	     allocate t in (area);			/* no, go do it */
	     temp = tp;				/* and have caller save pointer for us */
	     end;
	else					/* yes we did */
	     tp = temp;				/* restore pointer */

	xctl = ctlw & "10101"b;			/* mask unwanted bits from control word */
	if (xctl & "00101"b) then do;			/* anything left? */
	     t.argp = argp;				/* yes, put arglist pointer in static */
	     if ^t.subsw then if listp ^= null then do;	/* need to allocate subtask? */
		call upd_subtask_("01"b, areap, t.argp, acode, asev, t.taskp, seqno, t.listp, t.temp);
		t.subsw = "1"b;			/* don't keep doing it */
		end;
	     call condition_("thread_task_", thread_task);	/* set up somebody to catch generated tasks */
	     call upd_task_(c.rsw, listp, upd_gen_call_, addr (xctl));	/* process list */
	     end;

	return;					/* finished */


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


thread_task:	procedure (mcp, name, wcp, taskp, csw);	/* handler for "thread_task_" condition */


     dcl	mcp			ptr,		/* machine condition pointer */
	name			char(*),		/* condition name */
	wcp			ptr,		/* wall-crossing pointer */
	taskp			ptr,		/* "info_ptr", points to allocated task */
	csw			bit(1) aligned;	/* continue switch */

     dcl	upd_thread_task_		entry (ptr, ptr);


	call upd_thread_task_(t.listp, taskp);		/* thread task onto current list */
	return;					/* that's all */

	end thread_task;


	end upd_subtask_;
  



		    upd_task_.pl1                   11/15/82  1844.4rew 11/15/82  1515.0       27216


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


upd_task_:	procedure (rsw, taskp, gen_call, ctlp);


/*

	This procedure is the task dispatcher for the Multics Online Updater.
	A task consists of a pointer defining a procedure to be called, and an
	argument list to be passed when making the call, plus forward and back
	pointers for threading.  For each task in the input task list, caller-
	supplied procedure gen_call is invoked, by

		call gen_call (task.procp, addr (task.arglist));

	Within the Updater, upd_gen_call_ should be provided as gen_call, as
	the procedure pointers obtained from upd_add_task_ are indirect.
	If task.procp is a true procedure pointer (i.e. from hcs_$make_ptr),
	then cu_$gen_call may be supplied for this purpose.  If "rsw" is non-
	zero, the task list will be processed backward, starting at the task
	pointed to by "taskp", otherwise, it will be processed normally.  "taskp"
	will always point to the current (or last) task being processed.

	Task list back pointers are stored as the task list is processed in
	the forward direction.  Forward pointers are never modified.

	P. Bos, June 1972

*/

     dcl	rsw			bit(1),		/* forward or backward */
	taskp			ptr,		/* pointer to first or next task */
	gen_call			entry (ptr, ptr),	/* user-supplied procedure to invoke task */
	ctlp			ptr;		/* control argument pointer */

     dcl (addr, fixed, null)		builtin;

     dcl (p, q)			ptr;		/* random */

     dcl	1 task			aligned based (p),	/* task element */
	  2 nextp (0:1)		ptr,		/* pointers to next, previous tasks */
	  2 procp			ptr,		/* procedure entry pointer or equivalent */
	  2 arglist,				/* argument list */
	    3 hdr			bit(72),		/* arg count, etc. */
	    3 p (1)		ptr;		/* argument pointers */

/**/

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


	p = taskp;				/* begin at the beginning */
	do while (p ^= null);			/* .. and continue until the end */
	     taskp = p;				/* update caller task pointer */
	     q = addr (task.arglist);			/* get arglist pointer */
	     if ctlp ^= null then			/* if caller supplied control arg, */
		task.arglist.p(1) = ctlp;		/* give it to all tasks */
	     call gen_call (task.procp, q);		/* invoke task procedure via user routine */
	     p = task.nextp (fixed (rsw));		/* get pointer to next or previous task */
	     if ^rsw then if p ^= null then		/* if processing forward, */
		task.nextp(1) = taskp;		/* set back pointer on following task */
	     end;

	return;					/* .. then stop */


	end upd_task_;



		    upd_task_err_.pl1               11/15/82  1844.4rew 11/15/82  1515.1       42435


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


upd_task_err_:	procedure (code, sev, argp);


/*

	This procedure is used within the Multics Online Updater to signal
	task errors.  Calling sequence is as follows:

	     call upd_task_err_(code, sev, argp, name, string, args);

	     (1)	code	fixed bin(35)	status code
	     (2)	sev	fixed bin		severity code
	     (3)	argp	ptr		pointer to caller's arglist
	     (4)	name	char(*)		caller's entryname, e.g. a$b
	     (5)	string	char(*) (optional)	format string
	     (6)	args	(optional)	format args

	upd_task_err_ performs the following functions:

	     (1)	Updates the caller's status code, if the current error
		is of higher severity, and does the same for all parent
		tasks (updater task arg 3 is parent arglist pointer)

	     (3)	signals the condition "task_error_" and passes an updater
		status block via the info_ptr.

*/

/**/

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


     dcl	code			fixed bin(35),	/* status code */
	sev			fixed bin,	/* severity code */
	argp			ptr,		/* caller arglist pointer */
	name			char(nl) based (np),/* entry point name of caller */
	line			char(ll) based (lp);/* format string */

     dcl	cu_$arg_count		entry (fixed bin),
	cu_$arg_list_ptr		entry returns (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	decode_entryname_		entry (char(*), char(32), char(32)),
	ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char(*) aligned, fixed bin(35),
				       bit(1) aligned, bit(1) aligned),
	signal_			entry (char(*), ptr, ptr, ptr),
	upd_print_err_		entry options (variable);

     dcl (addr, length, null)		builtin;

     dcl	based_p			ptr based,	/* based pointer */
	cdp			ptr,		/* baseptr for "cd" */
	lp			ptr,		/* arg ptr for "line" */
	np			ptr,		/* arg ptr for "name" */
	p			ptr,		/* random */
	svp			ptr;		/* baseptr for "sv" */

     dcl	cd			fixed bin(35) based (cdp),	/* task procedure status code arg */
	ignore			fixed bin(35),	/* status code */
	ll			fixed bin,	/* arg length for "line" */
	n			fixed bin,	/* arg count */
	nl			fixed bin,	/* arg length for "name" */
	sv			fixed bin based (svp);	/* task procedure severity code arg */

     dcl	1 arglist			aligned based (argp),	/* argument list */
	  2 hdr			bit(72),		/* arg count, etc. */
	  2 p (5)			ptr;		/* arg pointer array */

     dcl	1 ts			aligned,		/* internal status block */
	  2 proc			char(32) unal,
	  2 entry			char(32) unal,
	  2 code			fixed bin(35),
	  2 sev			fixed bin,
	  2 string		char(200);

/**/

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


	p = argp;					/* copy pointer to current task arglist */
	do while (p ^= null);			/* update his status code */
	     cdp = p -> arglist.p(4);			/* status code is updater task arg 4 */
	     svp = p -> arglist.p(5);			/* severity code is arg 5 */
	     if sev > sv then do;			/* if current error is higher severity, */
		cd = code;			/* update his status code */
		sv = sev;				/* and severity code */
		end;
	     else					/* somebody else got there first; we are done */
		go to skip;			/* exit from loop */
	     p = p -> arglist.p(3) -> based_p;		/* not done, get parent arglist pointer (arg 3) */
	     end;
skip:	call cu_$arg_ptr (4, np, nl, ignore);		/* locate 4th arg (entryname) */
	call decode_entryname_(name, ts.proc, ts.entry);	/* break up into refname and entryname */
	ts.code = code;				/* copy status code */
	ts.sev = sev;				/* and severity code */
	call cu_$arg_count (n);			/* get our own arg count */
	if n > 5 then				/* did caller specify formatted message? */
	     call ioa_$general_rs (cu_$arg_list_ptr(), 5, 6, ts.string, ignore, "1"b, "1"b);
						/* yes, format it. */
	else if n > 4 then do;			/* no, but he did provide the string */
	     call cu_$arg_ptr (5, lp, ll, ignore);	/* get pointer and length */
	     ts.string = line;			/* copy it without call to formline_ */
	     end;
	else					/* no, he didn't supply anything like that */
	     ts.string = "";			/* blank out message */
	p = addr (ts);				/* get pointer to temp status block */
	call signal_("task_error_", null, p, null);	/* signal error */


	end upd_task_err_;
 



		    upd_thread_task_.pl1            11/15/82  1844.4rew 11/15/82  1515.2       22995


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


upd_thread_task_:	procedure (listp, taskp);


/*

	This procedure is used within the Multics Online Updater to insert
	updater tasks into the task list.  Tasks are ordered by task sequence
	number, which is argument 7 to all updater tasks.  This procedure is
	restartable; if the task to be inserted is found to be already in the
	task list, the call is ignored, otherwise insertion is completed at
	the same place in the list.

	P. Bos, June 1972

*/

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


     dcl	listp			ptr,		/* pointer to first task in list */
	taskp			ptr;		/* pointer to task to be inserted */

     dcl (addr, null)		builtin;

     dcl (p, q, r)			ptr;		/* previous, current, next tasks during insertion */

     dcl	seqno			fixed bin based;	/* used to access seqno argument via arglist */

     dcl	1 task			aligned based,	/* task element */
	  2 nextp			ptr,		/* pointer to following task */
	  2 backp			ptr,		/* pointer to previous task */
	  2 procp			ptr,		/* procedure pointer */
	  2 arglist,				/* argument list */
	    3 hdr			bit(72),		/* argument count, etc. */
	    3 p (100)		ptr;		/* arg pointer array */

/**/

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


	p = addr (listp);				/* fudge: use listp as task.nextp */
	r = listp;				/* window points ahead of first task */
	q = taskp;				/* simplify accessing */
	do while (r ^= null);			/* search task list for place to put him */
	     if q = r then				/* already in list, must have been interrupted */
		return;				/* just exit */
	     if r -> task.arglist.p(7) -> seqno > q -> task.arglist.p(7) -> seqno then do;
append:		q -> task.nextp = r;		/* set pointer to next task */
		p -> task.nextp = q;		/* and make final connection */
		return;				/* done, exit */
		end;
	     p = r;				/* advance window */
	     r = p -> task.nextp;
	     end;
	go to append;				/* ran off end, append task there */


	end upd_thread_task_;
 



		    update_seg.pl1                  08/19/86  2210.5rew 08/19/86  2159.5      750636


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

update_seg:  us:	procedure
		options ( rename (( alloc_, smart_alloc_ )) );


/*

	This procedure is the first-generation user interface to the Multics
	Online Updater.  Facilities are provided for batching several segments
	which must be installed together into a single operation, for error
	recovery (consisting of restoring the affected libraries to a consistent
	state), and for deinstallation.  Flexible options are provided for
	setting names and acl's on installed segments.

	All calls to update_seg are of the form:

		update_seg function args options


	"function" may be: set_defaults (sd), print_defaults (pd), init (in),
	print (pr), add, replace (rp), move (mv), delete (dl), install,
	de_install, clear, and list (ls).  All installation requests
	are placed in a list of updater tasks;  these tasks are then
	compiled into a list of installation operations in which the
	most sensitive operations (adding names to target segments)
	come last in the list, and are processed nearly simultaneously.
	Error recovery during processing may be inhibited if desired.  Actions
	performed may be logged on the console (before or after processing)
	via the "print" function.  

	P. Bos, June 1972
	G. Dixon, February 1973
	P. Kelley, May 1973
	P. Kelley, March 1980
	  1) Added optional pathname specification to the "-log"
	     control argument with the "initiate" function.
	  2) Added the "-initial_acl" & "-iacl" control arguments for
	     the add, replace, move operations.
	     MIS version number changed to 1.5
	E. N. Kittlitz, March 1981
	  Changed MIS version number to 1.6 for entry_bound support
	  in upd_install_task_ and upd_copy_seg_task_.
            Modified 1984-12-05 BIM to pass signal_io_ conditions.
*/

/****^  HISTORY COMMENTS:
  1) change(86-07-17,GDixon), approve(86-08-18,MCR7494),
     audit(86-08-18,Martinson), install(86-08-19,MR12.0-1129):
     Add -fill and -no_fill control arguments to control filling of the
     -log description.
                                                   END HISTORY COMMENTS */

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

     dcl	com_err_			entry options (variable),
	command_query_		entry options (variable),
	condition_		entry (char(*), entry),
	condition_interpreter_	entry (ptr, ptr, fixed bin, fixed bin, ptr, char(*), ptr, ptr),
	continue_to_signal_		entry (fixed bin(35)),
	cu_$arg_count		entry (fixed bin),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$cl			entry,
	cu_$level_get		entry returns (fixed bin),
	cv_dec_check_		entry (char(*), fixed bin(35)) returns (fixed bin(35)),
	cv_mode_			entry (char(*), bit(36) aligned, fixed bin(35)),  
	cv_userid_		entry (char(*)) returns (char(32)),
	date_time_		entry (fixed bin(71), char(*) aligned),
	date_time_$fstime		entry (fixed bin(35), char(*) aligned),
	equal_			entry (ptr, ptr, ptr, fixed bin(35)),
	expand_path_		entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
	find_condition_info_	entry (ptr, ptr, fixed bin(35)),
	get_group_id_$tag_star	entry returns (char(32) aligned),
	get_process_id_		entry returns (bit(36) aligned),
	get_wdir_			entry returns (char(168) aligned),
	hcs_$delentry_file		entry (char(*), char(*), fixed bin(35)),
	ioa_$ioa_stream		entry options (variable),
	ios_$attach		entry (char(*), char(*), char(*), char(*), bit(72) aligned),
	ios_$detach		entry (char(*), char(*), char(*), bit(72) aligned),
	msa_manager_$area_handler	entry (ptr, char(*), ptr, ptr, bit(1) aligned),
	msa_manager_$make_special	entry (fixed bin, char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
	msa_manager_$initiate	entry (char(*), char(*), ptr, fixed bin, ptr, fixed bin(35)),
	msa_manager_$terminate	entry (ptr, fixed bin(35)),
	msf_manager_$adjust		entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35)),
	msf_manager_$close		entry (ptr),
	msf_manager_$open		entry (char(*), char(*), ptr, fixed bin(35)),
	upd_print_acl_		entry (ptr, fixed bin, bit(*)),
	reversion_		entry (char(*)),
	set_lock_$lock		entry (bit(36) aligned, fixed bin, fixed bin(35)),
	set_lock_$unlock		entry (bit(36) aligned, fixed bin(35)),
	suffixed_name_$find		entry (char(*), char(*), char(*), char(*), fixed bin(2), fixed bin(5),
				fixed bin(35)),
	suffixed_name_$new_suffix	entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	upd_add_task_$init		entry (ptr, ptr),
	upd_add_task_$reset		entry (ptr),
	upd_gen_call_		entry (ptr, ptr),
	upd_print_err_		entry options (variable),
	upd_task_			entry (bit(1), ptr, entry, ptr),
	upd_thread_task_		entry (ptr, ptr);

     dcl	upd_install_task_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				(3) char(168), (3) char(32), (3) fixed bin(5), (3) ptr, (3) fixed bin, (3) ptr, 
				(3) fixed bin, bit(36) aligned, ptr, fixed bin(18), bit(1), char(168) aligned,
				fixed bin(35), fixed bin(35)),
	upd_install_task_$init	entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				bit(1), bit(1), ptr, char(32) aligned),
	upd_describe_task_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				ptr, char (168) aligned, ptr, fixed bin(35) ),
	upd_subtask_		entry (bit(36) aligned, ptr, ptr, fixed bin(35), fixed bin, ptr, fixed bin,
				ptr, ptr);

     dcl (addr, baseno, clock, dim, fixed, index, length, max, mod, null, size, substr)
				builtin;

     dcl (error_table_$bad_conversion,
	error_table_$bad_ring_brackets,
	error_table_$badcall,
	error_table_$badopt,
	error_table_$dirseg,
	error_table_$fatal_error,
	error_table_$improper_data_format,
	error_table_$invalid_lock_reset,
	error_table_$segno_in_use,
	error_table_$locked_by_this_process,
	error_table_$lock_wait_time_exceeded,
	error_table_$moderr,
	error_table_$namedup,
	error_table_$noentry,
	error_table_$not_done,
	error_table_$out_of_bounds,
	error_table_$out_of_sequence,
	error_table_$seg_not_found,
	error_table_$seglock,
	error_table_$too_many_names,
	error_table_$too_many_acl_entries,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static;

     dcl  (sys_info$default_max_length,
	 sys_info$max_seg_size)	fixed bin ext static;

     dcl	area			area based (Pmsa_ptr);	/* all allocations will be within log segment */

     dcl (argp, fp, p, q, inp, rqp, desp)	 ptr;

     dcl	(logp, msa_ptr)		ptr int static init (null);	/* log segment pointer */

     dcl  Pmsa_ptr			ptr based (msa_ptr);

     dcl	a			fixed bin,	/* used by acl, name options */
	argi			fixed bin,	/* argument index */
	argl			fixed bin,	/* argument length */
	code			fixed bin(35),	/* status code */
	f			fixed bin,	/* updater function called */
	fail			fixed bin,	/* from -severity option */
	fl			fixed bin,	/* length of function arg */
         (i, j)			fixed bin,	/* random */
	mode			fixed bin(5),	/* argument to suffixed_name_$find */
	n			fixed bin,	/* used by acl, ringbracket, name options */
	nargs			fixed bin,	/* argument count */
	npath			fixed bin,	/* number of non-control (i.e. pathname) args */
	option			fixed bin,	/* code for control arg being processed */
	r			fixed bin,	/* temp used by ringbracket option */
	state			fixed bin,	/* used in decoding acl option */
	status			bit(72) aligned,	/* an I/O system status code. */
	type			fixed bin(2);	/* argument to suffixed_name_$find */

     dcl	arg			char(argl) based (argp);	/* argument */

     dcl	answer			char(3) aligned,	/* answer to a query */
	date			char(24) aligned,	/* a date-time string */
	dir (3)			char(168),	/* dirname array */
	doc_dir			char(168) aligned,	/* documentation directory */
	docsw			bit(1) init ("0"b),	/* ON if documentation directory being changed */
	dummy			char(1),		/* dummy char string */
	eqseg			char(32),		/* entryname to match = */
	fcbp			ptr,	/* ptr to _file _control _block used by msf_manager_ */
	function			char(fl) based (fp),/* updater function invoked */
	init_log_segment		char(168) aligned,		/* pathname of opt. "init" log segment */
	listdir			char(168),		/* dirname of installation list segment */
	Llistdir			fixed bin,		/* length of non-blank part of listdir */
	listseg			char(32), 		/* entryname of installation list segment */
	logdir			char(168) int static,	/* dirname of current installation log */
	logseg			char(32) int static,/* entryname of log */
	maxl			fixed bin(18) init (0), /* max seg length */
	proc			char(10) aligned int static init ("update_seg"),	/* for com_err_ */
	seg (3)			char(32),		/* entryname array */
	tseg			char(32),		/* temp. entryname */
	Version_No		char(4) aligned int static init ("1.6"), /* MIS Version No. */
	xxx			char(16);		/* part of com_err_ comment */

     dcl	ctlw			bit(36) aligned,	/* control word for task procedures */
	eqsw			bit(1) aligned,	/* non-zero if = may be decoded */
	nofillsw			bit(1) aligned,	/* non-zero for "-no_fill" */
	rstrtsw			bit(1) aligned,	/* non-zero for "-restart" option */
	stopsw			bit(1) aligned,	/* non-zero for "-stop" option */
	sws			bit(36) aligned;	/* option word for segment request */

     dcl  owp ptr;					/* ptr to option switches		*/
						/* meaning of switches depends upon	*/
						/* function being performed, so...	*/
     dcl	1 request_option_word	aligned based (owp),/* breakdown of sws by "request" actions */
	 (2 archivesw		bit (1),		/* "-archive" */
	  2 old_namesw		bit (1),		/* "-old_name" */
	  2 spec_segsw		bit (1),		/* "-special_seg" */
	  2 logsw			bit (1),		/* "-log" */
	  2 defersw		bit (1),		/* "-defer" */
	  2 mlsw			bit (1),		/* "-max_length" */
	  2 pad			bit (30)) unal;

     dcl	1 print_option_word		aligned based (owp),/* breakdown of sws by "print"/"list" actions */
	 (2 errorsw		bit (1),		/* "-error" */
	  2 briefsw		bit (1),		/* "-brief" */
	  2 longsw		bit (1),		/* "-long" */
	  2 log_sw		bit (1),		/* "-log" */
	  2 pad			bit (32)) unal;

     dcl	1 clear_option_word		aligned based (owp),/* breakdown of sws by "clear" actions */
	 (2 cerrorsw		bit (1),		/* "-error" */
	  2 uidsw			bit (1),		/* "-uid" */
	  2 pad			bit (34)) unal;

     dcl	1 install_option_word	aligned based (owp),/* breakdown of sws by "install" actions */
	 (2 stopsw		bit (1),		/* "-stop" */
	  2 pad			bit (35)) unal;

     dcl	1 init_option_word		aligned based (owp),/* breakdown of sws by "init" actions */
	 (2 restartsw		bit (1),		/* "-restart" */
	  2 padd			bit (2),
	  2 log_sw		bit (1),		/* "-log" */
	  2 pad			bit (32)) unal;

     dcl (endlabel, errlabel)		label local;	/* used for install/de_install functions */

     dcl	faultlabel		label local init (logerr);
						/* used to recover from seg_fault errors during */
						/* installation object segment initialization. */

     dcl	1 stat			based (addr (status)),/* overlay for I/O status code */
	  2 code			fixed bin(35);	/* a system status code */


     dcl	1 global_default		aligned int static,	/* per-process default acl, rb's */
	  2 log_directory		char (168) aligned init (""),/* default is "working_dir" */
	  2 rb (3)		fixed bin init (1,5,5), /* default is " 1,5,5 " */
	  2 acl,					/* n.b. not same as "acl" array */
	    3 n			fixed bin init (1),	/* 1 entry to start with */
	    3 a1,					/* default is "re *.*.*" */
	      4 userid		char(32) init ("*.*.*"),
	      4 mode		bit(36) init ("1100"b),
	      4 bits		bit(36) init ("0"b),
	      4 code		fixed bin(35) init (0),
	    3 a2 (29),				/* leave room for 30 entries in default acl */
	      4 userid		char(32),
	      4 mode		bit(36),
	      4 pad		bit(36),
	      4 code		fixed bin(35);

     dcl	1 t			aligned,		/* all acl, rb, name args fill in here */
	  2 log_directory		char (168) aligned, /* -sld */
	  2 rb (3)		fixed bin,	/* -rb */
	  2 acl (3),				/* -acl, -deleteacl, -setacl */
	    3 n			fixed bin,	/* acl count */
	    3 a (30),				/* acl array */
	      4 userid		char(32),		/* user name */
	      4 mode		bit(36),		/* mode (rew) */
	      4 pad		bit(36),		/* padding     */
	      4 code		fixed bin(35),	/* error code   */
	  2 names (3),				/* -names, -deletenames, -addnames */
	    3 n			fixed bin,	/* name count */
	    3 a (30),				/* name array */
	      4 name		char(32),		/* name */
	      4 pcode		fixed bin(35),	/* installation code */
	      4 rcode		fixed bin(35);	/* de_installation code */

     dcl	1 default			aligned based,	/* overlay for "t", "global_default" */
	  2 log_directory		char (168) aligned, /* documentation dir */
	  2 rb (3)		fixed bin,	/* ring brackets */
	  2 acl,					/* default acl */
	    3 n			fixed bin,	/* acl count */
	    3 a (30),				/* acl array */
	      4 userid		char(32),		/* user name */
	      4 mode		bit(36),		/* mode	         */
	      4 pad		bit(36),		/* padding */
	      4 code		fixed bin(35);	/* error code */

     dcl	1 acl (n)			aligned based,	/* single acl array */
	  2 userid		char(32),		/* .. used for allocations */
	  2 mode			bit(36),
	  2 pad			bit(36),
	  2 code			fixed bin(35);

     dcl	1 names (n)		aligned based,	/* single names array */
	  2 name			char(32),		/* .. also for allocations */
	  2 pcode			fixed bin(35),	/* installation status code */
	  2 rcode			fixed bin(35);	/* de_installation status code */

     dcl	1 in			aligned based(inp),	/* args for upd_install_task_$init call */
	  2 temp			ptr init (null),	/* pointer to its internal temps */
	  2 taskp			ptr init (null),	/* its task pointer */
	  2 code			fixed bin(35) init (0), /* status code */
	  2 sev			fixed bin init (0),	/* severity code */
	  2 seqno			fixed bin init (0),	/* sequence no (no special task ordering) */
	  2 io_name		char (32) aligned init (""); /* name of io seg */

     dcl	1 desc			aligned based (desp), /* args for upd_describe_task_ task call */
	  2 taskp			ptr init (null),	/* its task pointer */
	  2 code			fixed bin(35) init (0), /* status code */
	  2 sev			fixed bin init (0),	/* severity code */
	  2 seqno			fixed bin init (1),	/* sequence no. */
	  2 temp			ptr init (null);	/* ptr to temps */

     dcl	1 rq			aligned based(rqp),	/* args for upd_install_task_ call */
	  2 temp			ptr init (null),	/* pointer to his internal temps */
	  2 taskp			ptr init (null),	/* his task pointer */
	  2 ap (3)		ptr init ((3) null),/* acl array pointers */
	  2 np (3)		ptr init ((3) null),/* name array pointers */
	  2 an (3)		fixed bin init ((3) 0),	/* acl counts */
	  2 nn (3)		fixed bin init ((3) 0),	/* name counts */
	  2 code			fixed bin(35) init (0),	/* status code */
	  2 sev			fixed bin init (0),	/* severity code */
	  2 seqno			fixed bin init (0),	/* sequence no. (no ordering) */
	  2 dir (3)		char(168) unal,	/* dirname array */
	  2 seg (3)		char(32) unal,	/* entryname array */
	  2 rb (3)		fixed bin(5),	/* ring brackets for target seg */
	  2 maxlen		fixed bin(18),	/* max length attribute */
	  2 options		bit(36);		/* installation options (-archive, -oldnames, etc.) */

     dcl	1 log			aligned based (logp),	/* installation log */
	  2 version		char(4) aligned,	/* updater version number */
	  2 init_id		bit(36),		/* process id of process which initialized it last */
	  2 selfp			ptr,		/* pointer to self, to remember segment no. */
	  2 areap			ptr,		/* addr (log.area) */
	  2 linkp			ptr,		/* task linkage table root pointer */
	  2 listp			ptr,		/* task list root pointer */
	  2 processp		ptr,		/* copy of listp, modified by upd_subtask_ */
	  2 nullp			ptr,		/* static null pointer */
	  2 lock,					/* items related to locking io seg while its in use */
	    3 word		bit(36) aligned,	/* lock word */
	    3 group_id		char(32) aligned,	/* process group id of user who locked log */
	  2 fcn (4),				/* items related to groups of update_seg functions */
	    3 group_id		char(32) aligned,	/* process group id of last user to perform one */
						/* of the functions in this group on this log. */
	    3 date		fixed bin(35),	/* date on which function was performed. */
	  2 sw			aligned,		/* random switches */
	   (3 full_recovery		bit(1),		/* on if segs can be deleted in de_installation 	*/
	    3 special_segs		bit(1),		/* on if special segs are being installed */
	    3 error		bit(1),		/* on if errors occurred in install/de_install */
	    3 logging_sw		bit(1)) unal,	/* on if any documentation is being performed */
	  2 d,					/* defaults for this installation */
	    3 log_directory		char (168) aligned, /* default documentation dir */
	    3 rb (3)		fixed bin,	/* default ring brackets */
	    3 acl,				/* default access control list for new segments */
	      4 n			fixed bin,	/* number of entries in default acl */
	      4 a (30),				/* out of a maximum of 30 */
	        5 userid		char(32),		/* user name for this entry */
	        5 mode		bit(36),		/* mode */
	        5 bits		bit(36),		/* padding */
	        5 code		fixed bin(35),	/* error code */
	  2 description		ptr,		/* ptr to documentation reason description */
	  2 t,					/* args for task call to upd_subtask_ */
	    3 taskp		ptr,		/* his task pointer */
	    3 temp		ptr,		/* pointer to his internal temps */
	    3 code		fixed bin(35),	/* status code for him */
	    3 sev			fixed bin,	/* severity code */
	    3 seqno		fixed bin,	/* task sequence number (=32767) */
	  2 area			area;		/* rest of segment */

     dcl	function_table (20)		char(16) aligned int static init (
				"set_defaults",	/*  (1) */
				"print_defaults",	/*  (2) */
				"initiate",	/*  (3) */
				"print",		/*  (4) */
				"add",		/*  (5) */
				"replace",	/*  (6) */
				"move",		/*  (7) */
				"delete",		/*  (8) */
				"install",	/*  (9) */
				"de_install",	/* (10) */
				"clear",		/* (11) */
				"list",		/* (12) */
				"sd",		/* (13) (1) */
				"pd",		/* (14) (2) */
				"in",		/* (15) (3) */
				"pr",		/* (16) (4) */
				"rp",		/* (17) (6) */
				"mv",		/* (18) (7) */
				"dl",		/* (19) (8) */
				"ls");		/* (20)(12) */

     dcl	function_index (20)		fixed bin int static init (
				1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
				1, 2, 3, 4,    6, 7, 8,            12);

     dcl	option_table (44)		char(16) aligned int static init (
				"-acl",		/* (1) */
				"-delete_acl",	/* (2) */
				"-set_acl",	/* (3) */
				"-ring_brackets",	/* (4) */
				"-name",		/* (5) */
				"-delete_name",	/* (6) */
				"-add_name",	/* (7) */
				"-old_name",	/* (8) */
				"-archive",	/* (9) */
				"-severity",	/* (10) */
				"-restart",	/* (11) */
				"-stop",		/* (12) */
				"-error",		/* (13) */
				"-brief",		/* (14) */
				"-long",		/* (15) */
				"-special_seg",	/* (16) */
				"-log",		/* (17) */
				"-defer",		/* (18) */
				"-uid",		/* (19) */
				"-set_log_dir",	/* (20) */
				"-max_length",	/* (21) */
				"-da",		/* (22) (2) */
				"-sa",		/* (23) (3) */
				"-rb",	 	/* (24) (4) */
				"-nm",		/* (25) (5) */
				"-dn",		/* (26) (6) */
				"-an",		/* (27) (7) */
				"-onm",		/* (28) (8) */
				"-ac",		/* (29) (9) */
				"-sv",		/* (30) (10) */
				"-rt",		/* (31) (11) */
				"-er",		/* (32) (13) */
				"-bf",		/* (33) (14) */
				"-lg",		/* (34) (15) */
				"-ss",		/* (35) (16) */
				"-df",		/* (36) (18) */
				"-sld",		/* (37) (20) */
				"-ml",		/* (38) (21) */
	/* The next 6 control arguments don't follow the above ordering. */
	/* Too many unecessary changes would have been required.         */
				"-initial_acl",	/* (39) (22) */
				"-iacl",		/* (40) (22) */
				"-fill",		/* (41) (23) */
				"-fi",		/* (42) (23) */
				"-no_fill",	/* (43) (24) */
				"-nfi");		/* (44) (24) */

     dcl	option_index (44)		fixed bin int static init (
	1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21,
	   2, 3, 4, 5, 6, 7, 8, 9, 10, 11,     13, 14, 15, 16,     18,     20, 21, 
	22, 22, 23, 23, 24, 24);

     dcl	option_matrix (24, 12)	fixed bin int static init (
				1,  0,  1,  0,  1,  1,  1,  0,  0,  0,	0,  0,  /*  (1) -acl */
				0,  0,  0,  0,  2,  2,  2,  0,  0,  0,	0,  0,  /*  (2) -deleteacl */
				0,  0,  0,  0,  3,  3,  3,  0,  0,  0,	0,  0,  /*  (3) -setacl */
				4,  0,  4,  0,  4,  4,  4,  0,  0,  0,	0,  0,  /*  (4) -ring_brackets */
				0,  0,  0,  0,  5,  5,  5,  0,  0,  0,	0,  0,  /*  (5) -names */
				0,  0,  0,  0,  6,  6,  6,  0,  0,  0,	0,  0,  /*  (6) -deletenames */
				0,  0,  0,  0,  7,  7,  7,  0,  0,  0,	0,  0,  /*  (7) -addnames */
				0,  0,  0,  0,  0,  8,  0,  0,  0,  0,	0,  0,  /*  (8) -oldnames */
				0,  0,  0,  0,  9,  9,  9,  0,  0,  0,	0,  0,  /*  (9) -archive */
				0,  0,  0,  0,  0,  0,  0,  0, 10, 10,	0,  0,  /* (10) -severity */
				0,  0, 11,  0,  0,  0,  0,  0,  0,  0,	0,  0,  /* (11) -restart */
				0,  0,  0,  0,  0,  0,  0,  0, 12, 12,	0,  0,  /* (12) -stop */
				0,  0,  0, 13,  0,  0,  0,  0,  0,  0, 13,  0,  /* (13) -error */
				0,  0,  0, 14,  0,  0,  0,  0,  0,  0,	0, 14,  /* (14) -brief */
				0,  0,  0, 15,  0,  0,  0,  0,  0,  0,	0, 15,  /* (15) -long */
				0,  0,  0,  0, 16, 16, 16, 16,  0,  0,	0,  0,  /* (16) -special_seg */
				0,  0, 17, 17, 17, 17, 17, 17,  0,  0,	0,  0,  /* (17) -log */
				0,  0,  0,  0, 18, 18, 18, 18,  0,  0, 	0,  0,  /* (18) -defer */
				0,  0,  0,  0,  0,  0,  0,  0,  0,  0, 19,  0,  /* (19) -uid */
			         20,  0, 20,  0,  0,  0,  0,  0,  0,  0,  0,  0,  /* (20) -set_log_dir */
				0,  0,  0,  0, 21, 21, 21,  0,  0,  0,  0,  0,  /* (21) -max_length */
			          0,  0,  0,  0, 22, 22, 22,  0,  0,  0,  0,  0,  /* (22) -initial_acl */
			          0,  0, 23,  0,  0,  0,  0,  0,  0,  0,  0,  0,  /* (23) -fill */
			          0,  0, 24,  0,  0,  0,  0,  0,  0,  0,  0,  0); /* (24) -no_fill */

     dcl	path_matrix (12, 3)		fixed bin int static init (
				0, 0, 0,		/* set_defaults */
				1, 0, 0,		/* print_defaults */
				1, 0, 0,		/* init */
				1, 0, 0,		/* print */
				1, 3, 0,		/* add */
				1, 2, 3,		/* replace */
				2, 3, 0,		/* move */
				2, 0, 0,		/* delete */
				1, 0, 0,		/* install */
				1, 0, 0, 		/* de_install */
				1, 0, 0,		/* clear */
				1, 0, 0);		/* list */

     dcl	pmax (12)			fixed bin int static init (0, 1, 1, 1, 2, 3, 2, 1, 1, 1, 1, 1),
	pmin (12)			fixed bin int static init (0, 0, 0, 0, 2, 2, 2, 1, 0, 0, 0, 0);

     dcl	fail_max			fixed bin(35) int static init (5),
	fail_min			fixed bin(35) int static init (1);

     dcl	1 query_info		aligned int static,	/* command_query_ info structure. */
	  2 version		fixed bin init (2),
	  2 yes_no_sw		bit(1) unal init ("1"b),
	  2 suppress_name		bit(1) unal init ("0"b),
	  2 status		fixed bin(35) init (0),
	  2 code			fixed bin(35) init (0);

     dcl	cleanup			condition;	/* capture this condition */

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

	owp = addr(sws);

	call cu_$arg_count (nargs);			/* get number of arguments */
	if nargs = 0 then do;			/* no arguments, tell user format */
	     call com_err_ (error_table_$wrong_no_of_args, (proc),
		"^/Calling sequence is:^-^a <function> <args> <options>",
		(proc));
	     return;				/* exit to user */
	     end;
	argi = 1;					/* first arg */
	call cu_$arg_ptr (argi, fp, fl, code);		/* get pointer and length */
	if code ^= 0 then				/* unlikely */
	     go to argerr;				/* but check anyway */
	do i = 1 to dim (function_table, 1);		/* first arg is updater function */
	     if function = function_table(i) then do;	/* search table for a match */
		f = function_index(i);		/* found; get function code; */
		on cleanup begin;			/* set up handler to unlock log and detach streams */
		     call ios_$detach ( "installation_list_", "", "", status);
		     call ios_$detach ( "installation_error_", "", "", status);
		     call unlock_log;
		     end;
		go to init(f);			/* and go process call */
		end;
	     end;
	call com_err_(error_table_$badcall, (proc), "Unknown updater function specified. ""^a""", function);
	return;					/* return to user */


init(1):     					/* "set_defaults" function */
join0:	p = addr (t);				/* will be used to overlay "default" */
	q = addr (global_default);			/* copy current defaults for this process */
	p -> default = q -> default;			/* .. so arg processor can update them */
	go to join1;				/* go look at args */


init(2):	npath = 0;				/* "print_defaults" function, allow log pathname */
	go to join1;				/* go get args */


init(3):	npath = 0;				/* "initiate" function, we expect a pathname */
	rstrtsw = "0"b;				/* reset "-restart" switch */
	sws = "0"b;				/* reset switches */
	nofillsw = "0"b;				/* -log -fill is the default.			*/
	go to join0;				/* go get global defaults */

init(11):	endlabel = return;				/* "clear" function; return to user after processing */
init(4):						/* "print" function */
init(12):	sws = "0"b;				/* "list" function; reset option switches */
	npath = 0;				/* assume no log pathname supplied */
	go to join1;				/* skip to argument processor */


init(5):						/* "add" function */
init(6):						/* "replace" function */
init(7):						/* "move" function */
init(8):	npath = 0;				/* "delete" function */
	fail = 1;					/* make any error a fatal error. */
	call init_log ("1"b);			/* make sure there is an installation object segment. */
	do i = 1 to 3;				/* three of everything, by sheer coincidence */
	     dir(i), seg(i) = "";			/* blank out all pathname args */
	     t.acl(i).n, t.names(i).n = 0;		/* no names or acls yet */
	     end;
	p = addr (t);				/* first part overlaid by "default" */
	q = addr (log.d);				/* will use installation defaults */
	p -> default = q -> default;			/* copies default ringbrackets and acl */
	if f ^= 5 then				/* want acl only for add function */
	     t.acl(1).n = 0;			/* zero acl count for any other */
	if (f = 6) | (f = 7) then do i = 1 to 3;	/* if "replace" or "move", then we'll  */
	     t.rb(i) = 0;				/* determine default rings via upd_ring_task_$list   */
	     end;					/* for the "old" segment, unless "-rb" option appears later */
	npath = 0;				/* no pathnames yet */
	sws = "0"b;				/* no options either */
	maxl = sys_info$default_max_length;		/* default  */
	go to join1;				/* skip to arg processor */


init(9):	stopsw = "0"b;				/* "install" function; reset "-stop" switch */
init(10):	npath = 0;				/* "de_install" function. */
	fail = 1;					/* any error is fatal, by default. */


join1:	option = 0;				/* here to process argument list; zero option code */
	eqsw = "0"b;				/* first pathname can't have "=" */
nxtarg:	argi = argi + 1;				/* increment arg counter */
	if argi > nargs then			/* that's all there are */
	     go to aend(option);			/* go finish up current option if any */
	call cu_$arg_ptr (argi, argp, argl, code);	/* get pointer, length for this arg */
	if code ^= 0 then do;			/* unlikely error */
	     argp = addr (dummy);			/* avoid null pointer reference */
	     argl = 0;				/* didn't get nothin' */
argerr:	     call com_err_(code, (proc), """^a"" (arg ^d)", arg, argi);	/* complain to user */
	     go to return;				/* and let him figure it out */
	     end;
	if substr (arg, 1, 1) = "-" then		/* argument is option specifier */
	     go to aend(option);			/* go finish up last option */
	else					/* not a control arg, */
	     go to aarg(option);			/* go process normal arg */

ckopt:	if argi > nargs then			/* reenter here after aend(i), check arg count again */
	     go to start(f);			/* exit from arg processor if done */
	do i = 1 to dim (option_table, 1);		/* search option table for this control arg */
	     if arg = option_table(i) then do;		/* found it */
		option = option_matrix(option_index(i), f);/* very table-driven program */
		if option = 0 then			/* option not permitted for this function */
		     go to badopt;			/* pretend we never heard of it */
		go to abgn(option);			/* ok option, go process */
		end;
	     end;
badopt:	call com_err_(error_table_$badopt, (proc), "^a", arg);/* unknown updater option */
	go to return;				/* go unlock log segment, if its locked */

logerr:	call com_err_(error_table_$out_of_sequence, (proc), "^/^a.^/^a^a ^a.", 
	     "No installation object (io) segment is active", "Type:  """,
	     (proc), "initiate <io_path_name>""  to initiate an io segment");
						/* error return after log initiation failure */
return:	call unlock_log;				/* standard return point from update_seg; unlock log */
return_without_unlocking:
	return;
/**/

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


aarg(0):	npath = npath + 1;				/* here for pathname argument */
	if npath > pmax(f) then			/* is that too many? */
	     go to path_err;			/* then tell user. */
	if arg ^= "" then do;			/* leave hooks for funny functions */
	     j = path_matrix (f, npath);		/* find out where to put it */
	     dir(j), seg(j) = "";			/* clear the place, cause expand_path_ doesn't */
	     call expand_path_(argp, argl, addr (dir(j)), addr (seg(j)), code);
	     if code ^= 0 then			/* bad pathname syntax */
		go to argerr;			/* go tell user */
	     i = index (seg(j), "=");			/* see if entryname includes "=" components */
	     if i ^= 0 then if eqsw then do;		/* ahaa! */
		tseg = seg(j);			/* copy entryname (equal_ blows it otherwise) */
		call equal_(addr (eqseg), addr (tseg), addr (seg(j)), code);
		if code ^= 0 then			/* bad "=" syntax */
		     go to argerr;			/* go complain */
		end;
	     eqseg = seg(j);			/* following args may use "=" option, if not already */
	     eqsw = "1"b;				/* cheaper to test than eqseg ^= "" */
	     end;
	go to nxtarg;				/* go process next argument */

aend(0):	go to ckopt;				/* no deferrred processing, go check new arg */


abgn(1):						/* "-acl" option */
abgn(2):						/* "-deleteacl" option */
abgn(3):	a = option;				/* "-setacl" option; get index for which acl (1, 2, 3) */
	state = 0;				/* first arg to option is mode */
	n = 0;					/* nothing yet */
	go to nxtarg;				/* and jump back in again */

aarg(1):						/* "-acl" option arg */
aarg(2):						/* "-deleteacl" option arg */
aarg(3):	if state = 0 then do;			/* "-setacl" option arg */
	     n = n + 1;				/* starts a new acl entry */
	     if n > dim (t.acl.a, 2) then do;		/* limit number of ACLe's to max we can store */
		call com_err_(error_table_$too_many_acl_entries, (proc),
		     "^/Only  ^d  acl entries may be specified after the  ^a  control argument.",
		     dim (t.acl.a, 2), (option_table(option)));
		go to return;			/* unlock log, if necessary, and return to user */
		end;
	     t.acl(a).a(n).code = 0;			/* reset status code */
	     if a = 2 then do;			/* is this "-deleteacl"? */
		t.acl(a).a(n).mode = "0"b;		/* yes, no mode arg */
		go to aarg2a;			/* arg is userid each time */
		end;
	     call cv_mode_(arg, t.acl(a).a(n).mode, code);/* go convert mode to binary */
	     if code ^= 0 then			/* bad mode specification */
		go to argerr;			/* go complain */
	     t.acl(a).a(n).userid = "*.*.*";		/* assume *.*.* in case no userid specified */
	     state = 1;				/* next arg should be userid */
	     end;
	else do;					/* arg is userid */
aarg2a:	     t.acl(a).a(n).userid = cv_userid_(arg);	/* get userid in standard format */
	     state = 0;				/* next arg will be mode again */
	     end;
	go to nxtarg;				/* go get next argument */

aend(1):						/* "-acl" option terminated */
aend(2):						/* "-deleteacl" option terminated */
aend(3):	t.acl(a).n = n;				/* "-setacl" option terminated; record acl size */
	go to ckopt;				/* and go check new option */


abgn(4):	n = 0;					/* "-ring_brackets", tell the rest */
	go to nxtarg;				/* go get next argument */

aarg(4):	n = n + 1;				/* should be a ring bracket */
	r = cv_dec_check_(arg, code);			/* go convert to binary */
	if code ^= 0 then do;			/* conversion error */
	     code = error_table_$bad_conversion;
	     go to argerr;				/* gripe bitch complain */
	     end;
	if r <= 0 then				/* we don't allow ring brackets of 0 or less */
	     go to rberr;				/* save hardcore the trouble */
	if r > 7 then				/* and nobody allows ringbrackets bigger than 7 */
	     go to rberr;				/* gripe */
	if n ^= 1 then if r < t.rb(n-1) then do;	/* better not be smaller than last one */
rberr:	     code = error_table_$bad_ring_brackets;	/* set error code */
	     go to argerr;				/* and go tell user what he can do with them */
	     end;
	t.rb(n) = r;				/* record ring bracket */
	if n = 3 then 				/* -rb option is self-terminating */
	     option = 0;				/* pathname may follow */
	go to nxtarg;				/* go get next argument */

aend(4):	if n = 0					/* "-ring_bracket" option terminated */
	     then do;				/* bit he didn't give us any rings! */
		n = 1;				/* start him off at ring 1 */
		t.rb(n) = max((cu_$level_get()), 5);	/* default him to highest he can handle */
		end;
	if n < 3					/* finish up the three rings */
	     then do i = n+1 to 3;
		t.rb(i) = max((cu_$level_get()), t.rb(i-1), 5);/* default him to highest */
		end;
	option = 0;				/* finished with the rings */
	go to ckopt;				/* go check next option */


abgn(5):						/* "-names" option */
abgn(6):						/* "-deletenames" option */
abgn(7):	a = option - 4;				/* "-addnames" option; get array index (1, 2, 3) */
	n = 0;					/* nobody home yet */
	go to nxtarg;				/* go get next arg */

aarg(5):						/* "-names" option arg */
aarg(6):						/* "-deletenames" option arg */
aarg(7):	n = n + 1;				/* "-addnames" option arg; increment count */
	if n > dim (t.names.a, 2) then do;		/* limit number of names to max we can store */
	     call com_err_(error_table_$too_many_names, (proc),
		"^/Only  ^d  names may be specified after the  ^a  control argument.",
		dim (t.names.a, 2), (option_table (option)));
	     go to return;				/* unlock log and return to user */
	     end;
	t.names(a).a(n).name = arg;			/* put name in array */
	t.names(a).a(n).pcode = error_table_$not_done;	/* initialize install code */
	t.names(a).a(n).rcode = 0;			/* and de_install code */
	go to nxtarg;				/* go process next argument */

aend(5):						/* "-names" option terminated */
aend(6):						/* "-deletenames" option terminated */
aend(7):	t.names(a).n = n;				/* "-addnames" option terminated; record array size */
	go to ckopt;				/* and go check up on new option */


abgn(8):	old_namesw = "1"b;				/* "-oldnames" */
	go to endopt;				/* skip */


abgn(9):	archivesw = "1"b;				/* "-archive" */
	go to endopt;


abgn(10):	go to nxtarg;				/* "-severity"; no initialization necessary */

aarg(10):	fail = cv_dec_check_ (arg, code);		/* convert severity to a number */
	if code ^= 0 then do;			/* conversion failed? Tell user. */
	     call com_err_(error_table_$bad_conversion, (proc), "Argument  ^a  ^a.",
		arg, "could not be converted to a severity number");
	     go to return;				/* unlock log and return to user */
	     end;
	go to nxtarg;

aend(10):	if (fail < fail_min) | (fail > fail_max) then do;	/* Severity outside allowable bounds. */
	     call com_err_(error_table_$out_of_bounds, (proc), "^d^/^a  ^d  to  ^d.", fail,
		"Failure severity must be a number from", (fail_min), (fail_max));
	     return;
	     end;
	go to ckopt;


abgn(11):	rstrtsw = "1"b;				/* "-restart" */
	substr (sws, 1, 1) = "1"b;
	go to endopt;


abgn(12):	stopsw = "1"b;				/* "-stop" */
	go to endopt;


abgn(13):	substr (sws, 1, 1) = "1"b;			/* "-error" */
	go to endopt;


abgn(14):	briefsw = "1"b;				/* "-brief" */
	go to endopt;


abgn(15):	longsw = "1"b;				/* "-long" */
	go to endopt;


abgn(16):	spec_segsw = "1"b;				/* "-special_seg" */
	go to endopt;


abgn(17):	substr (sws, 4, 1) = "1"b;			/* "-log" */
	if f = 3					/* if "initiate" function, then possible pathname follows*/
	     then go to nxtarg;			/* optional pathname argument may follow */
	     else go to endopt;			/* else no pathname is allowed */

						/* opt. pathname of "initiate" function*/
aarg(17):	init_log_segment = "";			/* set 1st to null */
	call expand_path_ ( argp, argl, addr(init_log_segment), null, code);
	if code ^= 0
	     then go to argerr;
	go to endopt;				/* terminate this option */

aend(17):	init_log_segment = "";			/* no pathname was supplied */
	go to ckopt;				/* find out what arg really is */
	     
abgn(18):	defersw = "1"b;				/* "-defer" */
	go to endopt;


abgn(19):	uidsw = "1"b;				/* "-uid" */
	go to endopt;


abgn(20):	goto nxtarg;				/* "-set_log_dir" option */
						/* go pick up pathname of documentation dir. */

aarg(20): doc_dir = "";				/* get ready to test expected path */
	if arg ^= "" then
	     call expand_path_(argp, argl, addr(doc_dir), null, code);
	if code ^= 0
	     then goto argerr;			/* bad pathname syntax */
	t.log_directory = doc_dir;			/* update our temporary */
	docsw = "1"b;
	goto endopt;


aend(20):	code = error_table_$wrong_no_of_args;		/* means we didn't get expected arg */
	goto argerr;


abgn(21):	mlsw = "1"b;				/* "-max_length" */
	go to nxtarg;


aarg(21):	maxl = cv_dec_check_ (arg, code);		/* check for numeric arg */
	if code ^= 0 then do;
	     call com_err_ (error_table_$bad_conversion, (proc), "Argument  ^a  ^a.",
		arg,  "could not be converted to a proper length" );
	     go to return;
	     end;
	go to endopt;				/* self terminating */


aend(21):	maxl = sys_info$max_seg_size;			/* default to highest */
	go to ckopt;				/* check new option */


abgn(22):	substr(sws, 7, 1) = "1"b;			/* "-initial_acl" */
	if f = 5					/* if "add" function then */
	     then t.acl(1).n = 0;			/* reset default acl */
	go to endopt;				/* self-terminating option */


abgn(23): nofillsw = "0"b;				/* "-fill" */
	go to endopt;
	

abgn(24): nofillsw = "1"b;				/* "-no_fill" */
	go to endopt;


endopt:	option = 0;				/* self-terminating options */
	go to nxtarg;				/* go get next argument if any */

/**/

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


start(1):	p = addr (global_default);			/* "set_defaults" function */
	q = addr (t);				/* copy updated defaults back to static storage */
	p -> default = q -> default;			/* quick copy */
	return;					/* done */


						/* "print_defaults" function */
start(2):	call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
	faultlabel = start2a;			/* recover from a segment fault error in case */
						/* someone deleted the "current" installation */
						/* object segment from under our noses. */
	call init_log ((npath > 0));			/* validate current log pointer, unless user specified */
						/* his own object seg as an option. */
	if logp = null then				/* if no log is "current", then */
	     go to start2a;				/* we can't very well print its defaults. */
	p = addr (log.d);				/* otherwise, print its path name and defaults */
	call ioa_$ioa_stream ("installation_list_",
	     "^/Defaults for  ^a>^a^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
	     logdir, logseg, p->default.rb(1), p->default.rb(2), p->default.rb(3));
	call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
	if p->default.log_directory ^= ""		/* if default log dir was set */
	     then call ioa_$ioa_stream ("installation_list_", /* then tell the user */
		"^5xdocumentation directory:^/^-^a", p->default.log_directory);
start2a:	p = addr (global_default);			/* print the global defaults, at the very least */
	call ioa_$ioa_stream ("installation_list_",
	     "^/Global defaults^/^5xring brackets:^/^-^d,^d,^d^/^5xACL:",
	     p->default.rb(1), p->default.rb(2), p->default.rb(3));
	call upd_print_acl_ (addr (p->default.acl.a), p->default.acl.n, "100"b);
	if p->default.log_directory ^= ""		/* if global default log dir was set */
	     then call ioa_$ioa_stream ("installation_list_", /* then tell the user */
		"^5xdocumentation directory:^/^-^a", p->default.log_directory);
	call ioa_$ioa_stream ("installation_list_", "");	/* space up paper */
	go to clean_up;				/* detach streams, and quit. */


start(3):	call init_log (rstrtsw);			/* "init" function, see about log */
	p = addr (log.d);				/* copy acl, rb defaults into log segment */
	q = addr (t);				/* consist of global defaults updated by args */
	p -> default = q -> default;			/* quick copy */
	log.fcn(1).date = fs_date();			/* record date that log was changed. */
	log.fcn(1).group_id = log.lock.group_id;	/* record installer's name in create-log slot */
	if docsw then				/* we're going to change the documentation dir */
	     if log.processp ^= null then		/* if we've already "installed" then */
						/* we can't change it.		*/
		call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
		     "Installation object (io) segment", logdir, logseg, "has previously been installed",
		     "The documentation directory has not be changed");
	if logsw then do;				/* there's a description coming... */
	     if log.processp ^= null then 		/* if desc. task already allocated, then can't change it */
		call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a^/^a",
		     "Installation object (io) segment", logdir, logseg, "has previously been installed",
		     "The installation description cannot be changed.",
		     "As a result, the ""-log"" argument has been ignored.");
	     else 
		call get_reason(Pmsa_ptr, nofillsw, log.description);
						/* pick up the typed lines */
						/* we'll allocate the task at "install" time */
	     end;
	go to return;				/* unlock log and return to installer */


start(4):	call init_log ("1"b);			/* "print" function, see about log */
	call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
	call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
						/* attach the installation output streams 	*/
	if logsw then do;				/* print the documentation description only */
	     if log.description ^= null then		/* looks like something's there */
						/* pass only minimum args */
		call upd_describe_task_ ( "000001"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
		     log.nullp, log.d.log_directory, log.description, log.fcn(3).date);
	     goto skip_print;			/* skip other print functions */
	     end;
	ctlw = substr("000001"b || sws,1, length(ctlw));	/* form print control word */
	call condition_("task_linkage_err_", linkage_err);/* set up handler for linkage errors */
	call upd_task_("0"b, (log.listp), upd_gen_call_, addr (ctlw));
						/* go process task list */
skip_print:
	call ioa_$ioa_stream ("installation_list_", "");	/* insert a blank line after the output. */
	go to clean_up;


start(5):						/* "add" function */
start(6):						/* "replace" function */
start(7):						/* "move" function */
start(8):	if log.processp ^= null then do;		/* "delete" function; make sure installation */
						/* requests can still be added to log */
	     call com_err_ (error_table_$out_of_sequence, (proc), "^/^a ^a>^a^/^a.^/^a.",
		"Installation object (io) segment", logdir, logseg, "has previously been installed",
		"No more installation requests may be added to the segment");
	     go to return;				/* unlock log and return to installer */
	     end;
	if npath < pmin(f) then do;			/* check minimum pathname count */
path_err:	     if pmin(f) = pmax(f) then		/* specialize form of error msg. */
		eqseg = "^/^a^/^a  ""^a""  ^a:  ^d.";	/* min # of paths = max # */
	     else
		eqseg = "^/^a^/^a  ""^a""  ^a:  ^d  or  ^d.";	/* min # of paths < max # paths */
	     call com_err_(error_table_$wrong_no_of_args, (proc), eqseg,
		"The number of path names which must be specified",
		"with the", (function_table(f)), "function is", (pmin(f)), (pmax(f)));
	     go to return;				/* unlock log and return to installer */
	     end;
	if f = 6 then if npath = 2 then do;		/* third arg is optional for replace */
	     dir(3) = dir(2);			/* if omitted, third path becomes directory part	*/
	     seg(3) = seg(1);			/* of second path, and entryname part of first	*/
	         					/* path, meaning put new seg in old directory.	*/
	     end;
	if ( f = 5 | f = 6) then if npath = 2 then	/* if we're adding/replacing and only 2 paths given,	*/
	     if t.names(1).n ^= 0 then		/* and  "-name" option was issued,		*/
		seg(3) = t.names(1).a(1).name;	/* then entryname part of third path becomes	*/
						/* first name in "-name" array"		*/
	call condition_ ("area", msa_manager_$area_handler );
						/* set up handler for "area" condition	*/
	allocate rq in (area);			/* get some space to put things for this call */
	do i = 1 to 3;				/* three of everything (coincidence?) */
	     rq.dir(i) = dir(i);			/* dirname */
	     rq.seg(i) = seg(i);			/* entryname */
	     rq.rb(i) = t.rb(i);			/* ring brackets */
	     n = t.acl(i).n;			/* get count for this acl entry */
	     if n ^= 0 then do;			/* anything there? */
		allocate acl in (area) set (p);	/* yes, make us an acl */
		q = addr (t.acl(i).a(1));		/* get pointer to temporary one */
		p -> acl = q -> acl;		/* copy acl into log segment */
		rq.ap(i) = p;			/* set pointer and length in request block */
		rq.an(i) = n;			/* for call to upd_install_task_ */
		end;
	     n = t.names(i).n;			/* get count for name array entry */
	     if n ^= 0 then do;			/* same as for acl */
		allocate names in (area) set (p);	/* we got one, allocate space in log */
		q = addr (t.names(i).a(1));		/* get pointer to names array */
		p -> names = q -> names;		/* copy names */
		rq.np(i) = p;			/* set pointer */
		rq.nn(i) = n;			/* and size */
		end;
	     end;
	rq.options = sws;				/* copy option switches */
	rq.maxlen = maxl;				/* max length */
	ctlw = "01"b;				/* allocating task only, no processing */
	errlabel = command_ignored;			/* no error recovery either */
	call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
						/* attach error stream in case one occurs.	*/
	call condition_("task_error_", task_error);	/* set up condition handler for task errors */
	call condition_("task_linkage_err_", linkage_err);/* .. for linkage errors */
	call condition_("thread_task_", thread_task);	/* .. for task threading */
	call upd_add_task_$init (Pmsa_ptr, log.linkp);	/* tell tasker where area and link list are */
	call upd_install_task_(ctlw, Pmsa_ptr, log.nullp, rq.code, rq.sev, rq.taskp, rq.seqno,
	     rq.dir, rq.seg, rq.rb, rq.ap, rq.an, rq.np, rq.nn, rq.options, rq.temp, rq.maxlen,
	     log.sw.full_recovery, log.d.log_directory, log.fcn(3).date, log.fcn(4).date);
	log.sw.special_segs = log.sw.special_segs | substr (sws, 3, 1); /* if we're installing a special segment */
	log.sw.logging_sw = log.sw.logging_sw | substr (sws, 4, 1);    /* if there's documenting... */
	log.fcn(1).date = fs_date();			/* record date that log was changed. */
	log.fcn(1).group_id = log.lock.group_id;	/* record who changed the log last */
	go to cleanerr;				/* do some cleanup work, then quit */
command_ignored:
	call com_err_ (error_table_$fatal_error, (proc),
	     "^/As a result, the  ""^a ^a""  command has been ignored.",
	     (proc), (function_table(f)));
	log.sw.error = "0"b;			/* ignore this error in any listing. */
	go to cleanerr;				/* see, we had an error. Detach error stream. */


start(9):	call init_log ("1"b);			/* "install" function; make sure log exists 	*/
	if log.listp = null then do;			/* no listp -> no tasks in list		*/
nolistp:	     call com_err_(error_table_$out_of_sequence, (proc), "^/Installation log is empty.  ^a>^a.",
		logdir, logseg );			/* let user figure this one out !		*/
	     goto return;				/* and exit stage do_nothing			*/
	     end;
	if log.processp = log.listp then		/* if log was installed before, but completely	*/
	     if log.sw.error then do;			/* de_installed, and if errors occurred during	*/
	 	endlabel = start9a;			/* installation, then clear these errors by	*/
		ctlw = "00000000010"b;		/* calling "update_seg clear -error" function as	*/
		go to start11a;			/* internal subroutine.			*/
		end;
start9a:	endlabel = full_recovery_off;			/* if installation completes successfully, then	*/
						/* installation can never be fully-de_installed	*/
	ctlw = "00101"b;				/* set up a "compile" and "task_run" control word	*/
	xxx = "Installation";			/* set up directional variable for com_err_ msg	*/
	log.fcn(3).date = fs_date();			/* set date and time of installation. 		*/
	log.fcn(3).group_id = log.lock.group_id;	/* record who installed the log.		*/
	log.fcn(4).date = 0;			/* clear date for possible future de_installation.*/
	go to start9b;				/* skip initialization for "de_install" function	*/

start(10):call init_log ("1"b);			/* "de_install" function; make sure log exists	*/
	if log.listp = null 			/* and make sure listp -> a list of tasks	*/
	     then goto nolistp;			/* no listp -> no task list			*/
	if log.fcn(3).date = 0 then do;		/* zero install date means we can't "de_install"	*/
	     call com_err_(error_table_$out_of_sequence, (proc),
		"^/Installation Object segment ^a>^a has NOT been ""installed"".",
		logdir, logseg );			/* tell user the good news			*/
	     goto return;				/* and exit				*/
	     end;
	endlabel = clean_up;			/* cleanup when done.			*/
	ctlw = "10101"b;				/* set "reverse", "compile", & "task_run" control	*/
	xxx = "De-installation";			/* set reverse direction in var for com_err_ msg	*/
	log.fcn(4).date = fs_date();			/* set date and time of de_installation.	*/
	log.fcn(4).group_id = log.lock.group_id;	/* record who de_installed the log.		*/

start9b:	if stopsw then				/* user doesn't want error recovery */
	     errlabel = abort;			/* customer always knows best */
	else					/* he didn't say, */
	     errlabel = recover;			/* so do it for him */
	call ios_$attach ("installation_list_", "syn", "user_output", "w", status);
	call ios_$attach ("installation_error_", "syn", "error_output", "w", status);
						/* Here We GO!  Attach installation streams first */
	call condition_("task_error_", task_error);	/* set up condition handlers */
	call condition_("task_linkage_err_", linkage_err);/* for all kinds of errors */
	call condition_("thread_task_", thread_task);	/* set up handler for task threading */
	call condition_ ("area", msa_manager_$area_handler);
						/* handler for "area" condition.	*/
          call condition_ ( "any_other", default_handler );	/* handle all conditions and treat them as */
						/* fatal errors unless they're very special. */
	call upd_add_task_$init (Pmsa_ptr, log.linkp);	/* initialize task allocator */
	if log.processp = null then do;		/* is this the very first time we've "process"ed log? */
	     allocate in in (area);			/* get some space to put things in for initialize call */
	     in.io_name = logseg;			/* copy name of current io seg */
	     call upd_install_task_$init ("01"b, Pmsa_ptr, log.nullp, in.code, in.sev, in.taskp, in.seqno,
		log.sw.special_segs, log.sw.full_recovery, in.temp, in.io_name);
						/* add installer message routine to task list. */
	     log.processp = log.listp;		/* copy task list root pointer */
	     if log.description ^= null then		/* at least we're writing a description */
		log.sw.logging_sw = "1"b;		/* make sure the switch is set */
	     if log.sw.logging_sw then do;		/* add description task, (if logging anything) */
		allocate desc in (area);		/* grab space for description call */
		call upd_describe_task_ ("01"b, Pmsa_ptr, log.nullp, desc.code, desc.sev, 
		     desc.taskp, desc.seqno, desc.temp, log.d.log_directory, log.description, log.fcn(3).date);
		end;
	     end;
rerun:	call upd_subtask_(ctlw, Pmsa_ptr, log.nullp, log.t.code, log.t.sev, log.t.taskp, log.t.seqno,
	     log.processp, log.t.temp);		/* process task list */
	go to endlabel;				/* "full_recovery_off" or "clean_up" */

recover:	call reversion_ ("any_other");				/* stop handling conditions */
	substr (ctlw, 1, 1) = ^(substr (ctlw, 1, 1));	/* here for error recovery, do it backward now */
	call com_err_(error_table_$fatal_error, (proc), "^/^a aborted. The installation will be de-installed.", xxx);
	errlabel = abort;				/* avoid infinite error recovery loop */
	endlabel = clean_up;			/* after recovery; don't unset full_recovery sw */
	xxx = "Error recovery";			/* for com_err_ call */
	log.fcn(4).date = fs_date();			/* set date of restoration and		*/
	log.fcn(4).group_id = log.lock.group_id;	/* record who is restoring the installation	*/
	go to rerun;				/* and call task dispatcher again */

abort:	call reversion_ ("any_other");				/* stop handling conditions */
	call com_err_(error_table_$fatal_error, (proc), "^a aborted.", xxx);
	go to clean_up;				/* cleanup, then return to user */

full_recovery_off:
	log.sw.full_recovery = "0"b;			/* once installation is complete, we cannot	*/
	go to clean_up;				/* cleanup io streams and return. */
						/* fully recover (by deleting new segs) during a	*/
						/* de_installation operation.	*/


start(11):call init_log("1"b);			/* "clear" function; make sure log exists 	*/
	if cerrorsw then				/* are we clearing errors? */
	     if log.listp ^= null then		/* if log has been installed before, */
		if log.processp ^= log.listp then do;	/* but hasn't been completely de-installed... */
		     call com_err_ (error_table_$out_of_sequence, (proc),
			"^/Performing the ""^a ^a -error"" function at this time^/will render ^a>^a unusable.", 
			(proc), (function_table(f)), logdir, logseg);
		     goto return;
		     end;
	ctlw = substr("000000000"b || sws,1,length(ctlw));/* do nothing but clearing task indicated by user */
start11a:	call condition_("task_linkage_err_", linkage_err);/* resolve our special linkage errors 		*/
	call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
						/* process all upd_install_task_'s in task list 	*/
	log.fcn(2).date = fs_date();			/* record date clear operation was performed. */
	log.fcn(2).group_id = log.lock.group_id;	/* record who cleared the log.		*/
	if ctlw & "00000000010"b then			/* if errors have been cleared, then		*/
	     log.sw.error = "0"b;			/* reset global error switch.			*/
	go to endlabel;


start(12):call init_log("1"b);			/* "list" function, log must exist */
	call suffixed_name_$new_suffix (logseg, "io", "il", listseg, code);
						/* store name of listing segment */
	listdir = get_wdir_();			/* put listing segment in working directory */
	Llistdir = mod (index (listdir, " ")+168, 169);	/* calculate length of non-blank part of dir */
	call msf_manager_$open (listdir, listseg, fcbp, code);
	if code = 0 then do;			/* if it already exists, truncate it */
	     call msf_manager_$adjust (fcbp, 0, 0, "111"b, code);
	     if code ^= 0 then
		go to listerr;
	     end;
	else if code = error_table_$noentry then;	/* if it doesn't exist yet, all is well */
	else do;
listerr:	     call com_err_ (code, (proc), 		/* report other errors to user */
		"^/Installation list (il) segment  ^a>^a  cannot be created.", listdir, listseg);
	     go to return;				/* unlock the log and return to installer.	*/
	     end;
	call msf_manager_$close (fcbp);		/* close msf to conserve space in system_free_ */

	call ios_$attach ("installation_list_", "file_", substr (listdir, 1, Llistdir) || ">" || listseg,
	     "w", status);				/* attach I/O streams to installation list segment */
	if stat.code ^= 0 then do;
	     code = stat.code;
	     go to listerr;
	     end;
	call ios_$attach ("installation_error_", "syn", "installation_list_", "w", status);
						/* write error messages into the segment, too */
	call condition_ ("task_linkage_err_", linkage_err);	/* resolve task linkage errors */

	call date_time_ (clock(), date);		/* write header of listing segment */
	call ioa_$ioa_stream ("installation_list_", "^|^/^a^2x^a>^a^2/^20a^a",
	     "INSTALLATION OBJECT SEGMENT", logdir, logseg,
	     "Listed on:", date);

	call date_time_$fstime (log.fcn(1).date, date);
	call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a (^a ^a)^/^20a^a",
	     "Created by:", log.fcn(1).group_id,
	     "Created with:", (proc), "MIS Version", log.version,
	     "Created on:", date);

	if log.fcn(2).date ^= 0 then do;		/* if log has been cleared, tell about that. */
	     call date_time_$fstime (log.fcn(2).date, date);
	     call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
		"Cleared by:", log.fcn(2).group_id,
		"Cleared on:", date);
	     end;

	if log.fcn(3).date ^= 0 then do;		/* if log has been installed, tell about that. 	*/
	     call date_time_$fstime (log.fcn(3).date, date);
	     call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
		"Installed by:", log.fcn(3).group_id,
		"Installed on:", date);
	     end;

	if log.fcn(4).date ^= 0 then do;		/* if log has been de_installed, tell about that 	*/
	     call date_time_$fstime (log.fcn(4).date, date);
						/* emphasize the fact of de-installation */
	     call ioa_$ioa_stream ("installation_list_", "^/INSTALLATION HAS BEEN DE-INSTALLED");
	     call ioa_$ioa_stream ("installation_list_", "^20a^a^/^20a^a",
		"De-installed by:", log.fcn(4).group_id,
		"De-installed on:", date);
	     end;


	if log.description ^= null then do;		/* documentation description follows: */
	     call ioa_$ioa_stream ("installation_list_", "^/DOCUMENTATION DESCRIPTION FOLLOWS:");
						/* pass only minimum args. */
	     call upd_describe_task_ ( "00000100100"b, log.nullp, log.nullp, 0, 0, log.nullp, 0,
		log.nullp, "", log.description, log.fcn(3).date);
	     end;

	call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF THE INSTALLATION:");
	ctlw = "00000101000"b;			/* output in brief mode */
	call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
						/* let installation primitives generate output */

	if log.sw.error then do;			/* if errors occurred, list them next */
	     call ioa_$ioa_stream ("installation_list_", "^3/SUMMARY OF ERRORS WHICH OCCURRED DURING INSTALLATION:");
	     ctlw = "00000110000"b;			/* output errors only */
	     call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
	     end;
	else if log.fcn(3).date ^= 0 then		/* if no errors occurred during installation, tell user */
	     call ioa_$ioa_stream ("installation_list_", "^3/NO ERRORS OCCURRED DURING INSTALLATION.");
	else					/* otherwise, tell user log hasn't been installed */
	     call ioa_$ioa_stream ("installation_list_",
		"^3/INSTALLATION OBJECT SEGMENT HAS N_O_T_ BEEN INSTALLED.");

	if ^briefsw then do;			/* if ^"-brief" mode, then print normal output */
	     call ioa_$ioa_stream ("installation_list_",
		"^5/A DESCRIPTION OF THE INSTALLATION FOLLOWS.^|^/INSTALLATION DESCRIPTION:");
	     ctlw = "00000100000"b;			/* output in normal mode */
	     call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
	     end;

	if longsw then do;				/* if "-long" mode, then print details */
	     call ioa_$ioa_stream ("installation_list_", "^5/INSTALLATION DETAILS FOLLOW:");
	     ctlw = "00000100100"b;			/* output in detailed mode */
	     call upd_task_ ("0"b, (log.listp), upd_gen_call_, addr (ctlw));
	     end;


clean_up:	call ios_$detach ("installation_list_", "", "", status);
cleanerr:	call ios_$detach ("installation_error_", "", "", status);
						/* detach streams as a cleanup measure. */
	go to return;				/* unlock the log and return to installer.	*/

/**/

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


init_log:		procedure (sw);			/* initialize installation log segment 		*/


     dcl	sw			bit(1) aligned;	/* non-zero if reinitiating old segment 	*/

     dcl	process_id		bit(36) aligned;	/* process id.				*/

     dcl	seg_fault_error		condition;	/* condition				*/


	if npath = 0 then do;			/* no log specified as argument 		*/
	     on seg_fault_error begin;		/* trap condition where io seg deleted without	*/
		logp = null;			/* telling update_seg.			*/
		go to faultlabel;
		end;
	     if logp ^= null then			/* validate our log pointer as best we can.	*/
		if logp = log.selfp then do;
		     revert seg_fault_error;		/* stop handling this condition		 */
		     call validate_user;
		     return;
		     end;
	     logp = null;				/* already null, or inconsistent 		*/
	     go to faultlabel;			/* go bitch at user 			*/
	     end;
	logp = null;				/* make sure pointer, name not inconsistent 	*/
	msa_ptr = null;				/* ditto					*/
	logdir = dir(1);				/* copy dirname of segment specified 		*/
	call suffixed_name_$find (logdir, seg(1), "io", logseg, type, mode, code);
						/* find the io seg if it exists, or create	*/
						/* properly-suffixed path name from the one given	*/
						/* to us by the user.			*/
	if sw then do;				/* perform re-initiation processing.		*/
	     if code ^= 0 then do;			/* if we're re-init-ing a seg which doesn't exist,*/
re_init_fail:	call com_err_ (code, (proc),
		     "^/Installation object (io) segment ^a>^a cannot be re-initiated.", logdir, seg(1));
	 	go to return_without_unlocking;	/* then tell installer about it, and return.	*/
		end;
	     if type = 2 then do;			/* if a directory was found, then		*/
		call com_err_ (error_table_$dirseg, (proc), "^/^a>^a ^a.^/^a.", logdir, logseg,
		     "is a directory",
		     "It cannot be re-initiated as an installation object (io) segment");
		go to return_without_unlocking;
		end;
	     if mod (mode, 4) = 0 then do;		/* if user can't useio seg, then complain.	*/
		code = error_table_$moderr;
		go to re_init_fail;
		end;
	     call msa_manager_$initiate (logdir, logseg, msa_ptr, (size(log)), logp, code);
	     if code ^= 0 then do;			/* Oh, Boy!  An error during initialization.	*/
		if code = error_table_$segno_in_use then 
						/* Component of io seg couldn't be initiated	*/
						/* with segno which was used before.  Tell the	*/
						/* user he must free this segno.		*/
		     call com_err_ (code, (proc), "^/^a ^a>^a^/^a ^o (octal).^/^a^/^a ^a again.",
			"A component of the installation object (io) segment", logdir, logseg,
			"must be initiated with the segment number", fixed (baseno(msa_ptr), 35),
			"Please terminate the segment which is now known",
			"by this number, and re-initiate", logseg);
		else
		     if code = error_table_$noentry then do;
						/* The first SSA of the MSA was not found.	*/
			call com_err_ (code, (proc), "^/^a ^a>^a^/^a.^/^a.",
			     "The first component of the installation object (io) segment", logdir, logseg,
			     "was discovered to be missing",
			     "The installation object (io) segment cannot be re-initiated");
			go to return_without_unlocking;
			end;
		else
		     if code = error_table_$seg_not_found then
						/* An SSA, other than the first SSA of MSA, was	*/
						/* discovered to be missing.  A new SSA is	*/
						/* created to replace the old SSA.		*/
			call com_err_ ( code, (proc), "^/^a ^a>^a^/^a.^/^a.",
			     "A component of the installation object (io) segment", logdir, logseg,
			     "was discovered to be missing.  A new component was created to replace it",
			     "Some data may be missing" );
		else
		     if code = error_table_$improper_data_format then
						/* an attempt was made to initiate an MSA which	*/
						/* was found to not be an MSA.		*/
		     call com_err_ (code, (proc), "^/^a>^a ^a.^/^a.",
			logdir, logseg, "does not have the format of an installation object (io) segment",
			"Please check its consistency" );
		else 				/* otherwise, it was another error.		*/
		     call com_err_ ( code, (proc), "^a>^a", logdir, logseg);
		go to return;
		end;
	     if msa_ptr = null then			/* initiation failed.			*/
		go to re_init_fail;
	     if log.init_id = "0"b then do;		/* if this segment was never initiated before,	*/
		call msa_manager_$terminate (msa_ptr, code);
						/* terminate it, and go initiate it with a high number. */
		logp, msa_ptr = null;		/* null ptr's, because terminate_seg doesn't.	*/
		go to init_high;
		end;
	     call validate_user;			/* make sure this user knows what he's doing.	*/
	     process_id = get_process_id_();
	     if log.init_id ^= process_id then		/* has log been initialized by this process?	*/
		call upd_add_task_$reset (log.linkp);	/* no, reset procedure entry pointers.		*/
	     log.init_id = process_id;		/* leave out mark.				*/
	     end;

	else do;					/* otherwise, we're creating the io seg.	*/
	     if code = 0 then do;			/* zero code means log already exists. Tell user.	*/
		call com_err_ (error_table_$namedup, (proc),
		     "^/Installation object (io) segment ^a>^a already exists.", logdir, logseg);
		go to return_without_unlocking;	/* quit.					*/
		end;
	     if code ^= error_table_$noentry then do;	/* any other errors are somewhat serious.	*/
randomerr:	call com_err_ (code, (proc),
		     "^/^a  ^a>^a  ^a", "Installation object segment", logdir, seg(1),
		     "cannot be initiated.");
		go to return_without_unlocking;	/* quit.					*/
		end;
init_high:     call msa_manager_$make_special (256, logdir, logseg, msa_ptr, (size(log)), logp, code);
	     if code ^= 0 then do;
		msa_ptr = null;			/* make sure it's null */
		if sw then go to randomerr;		/* re-initting old one */
		if code = error_table_$segno_in_use then do;/* msa_man_ has this gross bug */
						/* which leaves new seg hanging around */
		     call hcs_$delentry_file ( logdir, logseg, (0) );
	     	     call com_err_ (code, (proc), "^/^a.  ^a>^a ^a.^/^a.",
		          "No high segment numbers are available", logdir, logseg,
		          "cannot be initiated",
			"Type:  ""new_proc""  and try again");

	     	     go to return_without_unlocking;
		     end;
		go to randomerr;			/* something else */
	          end;

	     log.lock.word = "0"b;			/* lock the new installation object segment.	*/
	     log.lock.group_id = get_group_id_$tag_star();
	     log.version = Version_No;		/* initialize the io seg header.		*/
	     call validate_user;
	     log.areap = msa_ptr;
	     log.d.log_directory = "";
	     log.init_id = "0"b;			/* make sure it's 0				*/
	     log.selfp = logp;			/* save copy of log pointer in log segment	*/
	     log.linkp,				/* initialize linkage list ptr.		*/
	     log.listp,				/* no task list...				*/
	     log.processp,				/* no task-last-processed.			*/
	     log.nullp,
	     log.description,
	     log.t.taskp,
	     log.t.temp = null;
	     log.fcn.group_id = log.lock.group_id;	/* record creator of io seg.  Only he can build,	*/
						/* install, de_install, or clear seg w/o questions*/

	     log.fcn.date,
	     log.d.rb(1),
	     log.d.rb(2),
	     log.d.rb(3),
	     log.d.acl.n,
	     log.t.code,
	     log.t.sev = 0;

	     log.t.seqno = 32767;			/* highest seqno means append upd_subtask_ to the	*/
						/* very end of the primary task list.		*/
	     log.sw.full_recovery = "1"b;		/* to start with, full recoveries are allowed.	*/
	     log.sw.special_segs,			/* to start with, there are no special segs 	*/
	     log.sw.error,				/* there are no errors,			*/
	     log.sw.logging_sw = "0"b;		/* and, to start, there's no documentation 	*/

	     log.init_id = get_process_id_();		/* leave our mark.				*/
	     end;

	end init_log;


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


/**/

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


validate_user:	procedure;			/* This procedure validates the current user	*/

	if log.version ^= Version_No then do;		/* first, check version numbers		*/
						/* if not same, tell user the bad news		*/
		call com_err_ (error_table_$fatal_error, (proc),
		     "^a>^a was created with MIS Version ^a.^/^a ^a.^/^a ^a ^a ^a.", logdir, logseg,
		     log.version, "The version you are now using is MIS Version ", Version_No,
		     "As a result, the", (proc), (function_table(f)), "command has been ignored");
		logp = null;
		go to return;			/* can't use this log */
		end;

	call set_lock_$lock (log.lock.word, 0, code);	/* lock the installation object segment.	*/
	if code ^= 0 then
	     if code = error_table_$invalid_lock_reset then;
						/* somebody bombed out while processing io seg?	*/
						/* ignore him.				*/
	     else if code = error_table_$locked_by_this_process then
		call com_err_ (code, (proc), "^/^a  ^a>^a.^/^a ^a ^a function.",
		     "Non-fatal error encountered while locking", logdir, logseg,
		     (proc), "will continue performing the", (function_table(f)));
	     else if code = error_table_$lock_wait_time_exceeded then do;
lockerr:		call com_err_ (error_table_$seglock, (proc), "^/^a  ^a>^a^/^a ^a.^/The  ""^a ^a""  ^a.",
		     "Installation object (io) segment", logdir, logseg,
		     "is already being manipulated by", log.lock.group_id,
		     (proc), (function_table(f)), "command cannot be performed");
		go to return_without_unlocking;	/* don't unlock seg; just return.		*/
		end;
	     else					/* report any other errors.			*/
	 	go to lockerr;
	if log.lock.group_id ^= get_group_id_$tag_star() then do;
						/* if another installer last referenced this log	*/
						/* then ask this installer if he knows what he's	*/
						/* doing.					*/
	     call command_query_ (addr (query_info), answer, (proc), 
		"^a>^a ^a ^a.^/^a  ""^a ^a""  command?",
		logdir, logseg, "was created by", log.lock.group_id,
		"Do you still wish to issue the", (proc), (function_table(f)));
		     				/* make sure this user wants to do his thing.	*/
	     if answer = "yes" then
		log.lock.group_id = get_group_id_$tag_star();
	     	     				/* now this guy owns the io seg.		*/
	     else do;
		logp = null;			/* forget the initialization done so far. 	*/
		go to return;
		end;
	     end;
	end validate_user;				/* return to init_log, if user is OK.		*/

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


unlock_log:	procedure;			/* unlock io segment, if it is locked.		*/

	if logp ^= null then if log.lock.word then do;	/* if we have an io seg which is locked, then	*/
	     call set_lock_$unlock (log.lock.word, code);	/* unlock it.				*/
	     if code ^= 0 then
		call com_err_ (code, (proc), "^/While unlocking  ^a>^a.", logdir, logseg);
	     end;
	end unlock_log;				/* return to caller.			*/

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

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


fs_date:		procedure returns (fixed bin(35));	/* return current fs_time value.		*/

     dcl	date			fixed bin(35),	/* the fs_date value.			*/
	date_str			bit(36) aligned based (addr (date)),
	time			fixed bin(71),	/* the current time.			*/
	time_str			bit(72) aligned based (addr (time));

	time = clock();				/* The time is now ...			*/
	date_str = substr (time_str, 21, 36);		/* The fs_time is now...			*/
	return (date);

	end fs_date;

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

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


thread_task:	procedure (mcp, name, wcp, taskp, csw);	/* handler for "thread_task_" condition */


     dcl	mcp			ptr,		/* machine conditions pointer */
	name			char(*),		/* condition name */
	wcp			ptr,		/* crawl-out data pointer */
	taskp			ptr,		/* pointer to allocated task */
	csw			bit(1) aligned;	/* continue switch */

	call upd_thread_task_(log.listp, taskp);	/* add task to current task list */
	end thread_task;				/* and return to signaller. */

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


task_error:	procedure (mcp, name, wcp, sp, csw);	/* "task_error_" handler */

     dcl	mcp			ptr,		/* machine conditions pointer */
	name			char(*),		/* condition name signalled */
	wcp			ptr,		/* crawl-out data pointer */
	sp			ptr,		/* status block pointer */
	csw			bit(1) aligned;	/* continue switch */

     dcl	1 s			aligned based (sp),	/* status block for task error */
	  2 proc			char(32) unal,	/* name of procedure causing error */
	  2 entry			char(32) unal,	/* entry point name */
	  2 code			fixed bin(35),	/* status code */
	  2 sev			fixed bin,	/* severity code */
	  2 string		char(200);	/* optional message */


	log.sw.error = "1"b;			/* record the fact that some error occurred 	*/
	if s.sev >= fail then do;			/* if the error is fatal, then attempt to recover	*/
	     call upd_print_err_(s.code, s.sev, "Error", "", s.proc, s.entry, s.string);
	     go to errlabel;			/* unwind stack and begin error recovery */
	     end;
	else					/* report non-fatal errors to user & continue.	*/
	     call upd_print_err_ (s.code, s.sev, "Warning", "", s.proc, s.entry, s.string);
	end task_error;				/* continue installing/de_installing 		*/


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


linkage_err:	procedure (mcp, name, wcp, sp, csw);	/* handler for "task_linkage_err_" condition */


     dcl	mcp			ptr,		/* machine conditions pointer */
	name			char(*),		/* condition name */
	wcp			ptr,		/* crawl-out data pointer */
	sp			ptr,		/* pointer to status block */
	csw			bit(1) aligned;	/* continue switch */

     dcl	1 s			aligned based (sp),	/* n.b. not same as for "error", above */
	  2 proc			char(32),		/* name of procedure signalling error */
	  2 entry			char(32),		/* entry point name */
	  2 code			fixed bin(35),	/* status code */
	  2 sev			fixed bin,	/* severity code */
	  2 rname			char(32),		/* refname of referenced procedure */
	  2 ename			char(32);		/* entryname of referenced procedure */


	call upd_print_err_(s.code, s.sev, "Task linkage error", "", s.proc, s.entry,
	     "Entry point referenced was ^a$^a", s.rname, s.ename);
	call cu_$cl;				/* reenter command level, let user fix it */
	end linkage_err;				/* return to try again */

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


default_handler:	procedure;			/* handler for "unknown" conditions		*/


     dcl	1  cond_info aligned,			/* condition info */
	   2 mcptr	ptr,
	   2 version	fixed bin,
	   2 condition_name char(32) var,
	   2 infop	ptr,
	   2 wcptr	ptr,
	   2 loc_ptr	ptr,
	   2 flags	aligned,
	     3 crawlout	bit(1) unal,
	     3 pad1	bit(35) unal,
	   2 pad_word	bit(36) aligned,
	   2 user_loc	ptr,
	   2 pad(4)	bit(36) aligned;

	call find_condition_info_ ( null, addr(cond_info), code);
	if code ^= 0 then do;
	     call ioa_$ioa_stream ("error_output", "Error:  Unknown signal has been received." );
	     go to errlabel;				/* if call fails then try to back up */
	     end;

	if cond_info.condition_name = "alrm" then do;
continue:	     call continue_to_signal_ (code);			/* pass this error on to another handler. */
	     return;
	     end;
	if cond_info.condition_name = "signal_io_" then 
	     go to continue;

	if cond_info.condition_name = "cput" then		/* ditto					*/
	     go to continue;
	if cond_info.condition_name = "linkage_error" then	/* let system's default handler handle these	*/
	     go to continue;
	if cond_info.condition_name = "mme2" then		/* let debug intercept breakpoints.		*/
	     go to continue;
	if cond_info.condition_name = "quit" then		/* let system quit handler handle them.		*/
	     go to continue;
	if cond_info.condition_name = "command_error" then	/* if our own error handler passed, 	*/
	     go to continue;				/* pass it on.  */
	if cond_info.condition_name = "finish" then		/* means it's all over anyway 	*/
	     go to continue;
	if cond_info.condition_name = "stack" then		/* we're coming close to the end	*/
	     go to continue;
	if cond_info.condition_name = "program_interrupt" then	/* ignore program interrupts.			*/
	     return;
	if cond_info.condition_name = "stringsize" then do;	/* handle stringsize by reporting it. */
	     call ioa_$ioa_stream ("error_output", "Error: stringsize condition occurred.");
	     go to STOP;					/* condition_interpreter_ ignores these */
	     end;						/*  conditions.			*/

	call condition_interpreter_ (null(), null(), 0, 3, cond_info.mcptr, (cond_info.condition_name),
	      cond_info.wcptr, cond_info.infop);
	if stopsw then do;
STOP:	     call ioa_$ioa_stream ("error_output",
		"Returning to command level.  Type: ""start"" to begin recovery operations.");
	     call cu_$cl();
	     go to recover;
	     end;

	go to errlabel;					/* treat them as fatal errors.		*/

	end default_handler;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/**/
get_reason:	proc (areap, nofillsw, rcp);		/* this proc accepts typed line input for */
						/* documentation later */
	/* As of March, 1980, the "reason" may be contained in a segment
	   rather than always asking the user to type it in.  The variable
	   init_log_segment is the pathname of that segment.	      */

dcl
     areap	ptr,				/* area ptr for allocation */
     nofillsw	bit(1) aligned,			/* on if reason is NOT to be filled.		*/
     rcp		ptr;				/* ptr to description within area */

dcl						/* misc. error codes */
    (error_table_$end_of_info,
     error_table_$short_record,
     error_table_$not_detached)	ext static fixed bin(35);
dcl
     code		fixed bin(35),
     i		fixed bin,
     total	fixed bin,			/* total no. of chars in area */
     null		builtin,
     substr	builtin,
     break_sw	bit (1),
     tab_sw	bit(1),
     nelemt	fixed bin(21),			/* no. of elements read */
     blockp	ptr,				/* ptr to allocated block */
     buffp	ptr;				/* ptr to input buffer */

dcl  buffer	char (512) aligned;			/* input buffer */

dcl  out_buffer	char (16384) aligned;		/* output buffer */

dcl  Area		area based (areap);			/* allocation area */

dcl  1 block	based (blockp),			/* block to be allocated */
       2 editsw	bit(1),				/* edit sw, "on" if already editted */
       2 no_chars	fixed bin(35),			/* # of chars in this block */
       2 string	char (total refer (block.no_chars));	/* the character string */

dcl  term_line (4)	char (1) init (
	".",
	"?",
	":",
	";");

dcl  HT		char (1) int static options(constant) init("	");
dcl  NL		char (1) int static options(constant) init ("
");						/* new_line char */

dcl
     ioa_			entry options (variable),
     iox_$attach_name	entry (char(*), ptr, char(*), ptr, fixed bin(35)),
     iox_$find_iocb		entry ( char(*), ptr, fixed bin(35)),
     iox_$open		entry ( ptr, fixed bin, bit(1) aligned, fixed bin(35)),
     iox_$get_line		entry ( ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
     iox_$detach_iocb	entry ( ptr, fixed bin(35)),
     iox_$close		entry ( ptr, fixed bin(35));
dcl
     iocb_ptr		ptr,			/* ptr to the I/O control block */
     atd			char(256),		/* attach description */
     switch_name		char(32),
     Path			bit(1),			/* ON = look for segment */
     ref_ptr		ptr;

	total = 0;
	out_buffer = "";
	ref_ptr = null;
	buffp = addr(buffer);

	if init_log_segment ^= ""			/* means look for a segment */
	     then Path = "1"b;
	     else	Path = "0"b;			/* otherwise, ask from the terminal */

	if Path then do;
	     switch_name = "upd_init_log_sw_";
	     atd = "vfile_ " || init_log_segment;	/* build attach description */
	     call iox_$attach_name ( switch_name, iocb_ptr, atd, ref_ptr, code);
	     if ( code ^= 0 ) & (code ^= error_table_$not_detached) then do;
		call com_err_ (code, (proc), "Attaching ^a.^/^a",
		     init_log_segment,
		     "The ""log"" information remains unchanged.");
		return;
	     end;

	     call iox_$open ( iocb_ptr, 1, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, (proc), "Opening ^a^/^a",
		     init_log_segment,
		     "The ""log"" information remains unchanged.");
		go to DETACH_ILS;
	     end;
	end;
	else do;
	     call iox_$find_iocb ( "user_input", iocb_ptr, code );
	     if code ^=0 then do;
		call com_err_ ( code, (proc),
		     "Attaching ""user_input"".^/^a",
		     "the ""log"" information remains unchanged.");
	     end;
	     call ioa_ ("Input");			/* tell user to type */
	end;

read:	call iox_$get_line (iocb_ptr, buffp, length(buffer), nelemt, code);
	if code = error_table_$end_of_info
	     then go to process;
	if (code ^= 0) & (code ^= error_table_$short_record) then do;
	     call com_err_ (code, (proc), "Reading ""log"" information.^/^a",
		"The ""log"" information remains unchanged.");
	     go to RETURN;
	end;
	if nelemt = 2
	     then if substr(buffer,1,1) = "."
		then goto process;			/* end of input reached */
	if nelemt < 2 then do;
	     nelemt = 3;				/* just so we don't lose a NL char */
	     substr(buffer,2,1) = NL;			/* takes 2 NL's to make a blank line */
	     end;
	if (total + (nelemt-1)) >= length(out_buffer)
	     then goto warn;			/* too many chars read */
	if nofillsw then;
	else do;
	     tab_sw = "0"b;
tab:	     i = index(substr (buffer, 1, nelemt), HT);
						/* look for tabs */
	     if i ^= 0 then do;			/* found one */
	          substr( buffer,i,1) = " ";		/* convert to single char */
		tab_sw = "1"b;			/* tell the user later. */
		go to tab;
		end;
	     break_sw = "0"b;
	     do i = 1 to 4;				/* search for end of sentence chars */
		if substr(buffer,(nelemt-1),1) = term_line(i)
		     then break_sw = "1"b;
		end;
	     if break_sw then do;
		substr(buffer,nelemt,2) = "  ";	/* add 2 blanks */
		nelemt = nelemt + 2;
		end;
	     end;

	if substr(buffer, 1, 1) = " " then 		/* start on new line */
	     if total ^= 0 then do;
	     total = total + 1;
	     substr(out_buffer,total,1) = NL;		/* append new_line to out buffer */
	     end;
	if total ^= 0
	     then if substr(out_buffer,total,1) ^= NL
		then if substr(out_buffer,total,1) ^= " " then do; /* add a blank between words */
		     total = total + 1;
		     substr(out_buffer,total,1) = " ";
		     end;
						/* copy buffer into temp storage */
	substr(out_buffer,(total+1),(nelemt-1)) = substr(buffer,1,(nelemt-1));
	total = total + (nelemt -1);			/* reset total */
	if total >= length(out_buffer)		/* check total again */
	     then goto warn;
	goto read;

process:						/* allocate in area for keeping */
	if total = 0 then do;			/* someone wanted to zap previous desc. */
	     rcp = null;				/* null the pointer */
	     go to RETURN;;				/* and xfer out */
	     end;
	allocate block in (Area) set (blockp);		/* grab the storage */
	blockp->block.editsw = nofillsw;		/* not editted yet */
	blockp->block.no_chars = total;		/* copy the number of characters */
	blockp->block.string = substr(out_buffer,1,total); /* and copy the characters */
	rcp = blockp;				/* finally, the return ptr */
	if tab_sw then				/* tell the user about any conversion */
	     call ioa_ ( "Warning:  tabs have been converted to single blanks.^/");
RETURN:	code = 0;
	if Path
	     then call iox_$close ( iocb_ptr, code);
	if code ^= 0
	     then call com_err_ (code, (proc), "Closing ""log"" info.");
DETACH_ILS:
	if Path
	     then call iox_$detach_iocb ( iocb_ptr, code);
	if code ^= 0
	     then call com_err_ (code, (proc), "Detaching ""log"" info.");
	return;					/* finished */

warn:						/* too many characters entered */
	call ioa_("Maximum number of characters have been entered.^/""Input"" mode is terminated");
	goto process;
	end;

	end update_seg;


		    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