


		    gtss_dump_kin_.pl1              12/11/84  1354.3rew 12/10/84  1043.9       55431


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

gtss_dump_kin_: proc (il);

/* Store caller's kin input line on Multics file.

   Author: Dave Ward	12/05/80
*/
dcl  il                       aligned char(*) parm;
	lc = lc+1;				/* Line count. */
	p6 = lc;					/* Count of lines. */
	p3 = length (il);				/* Length of kin line. */
	prefix = NL||"<<"||char (p6)||":"||char (p3)||">>";
	tl = prefix||il;
	n = length (tl);
	k = 0;
	if (l+length (tl)) > (255*1024*4) then do;	/* Complete segment. */
	     k = (255*1024*4)-l;
	     substr (p (c) -> S, l+1, k) = substr (tl, 1, k);
	     c = c+1;
	     if c>hbound (p, 1) then do;
		call com_err_ (
		     0
		     , "gtss_dump_kin_"
		     , "Exhausted ^i segments for kin dump file, reusing."
		     , hbound (p, 1)
		     );
		c = 0;
	     end;
	     else do;				/* Open next MSF component. */
		call msf_manager_$get_ptr (		/* Obtain next msf component. */
		     fcbp				/* (input) mfs control block pointer. */
		     , c				/* (input) component number. */
		     , "1"b			/* (input) create component if necessary. */
		     , p (c)			/* (output) pointer to component. */
		     , (0)			/* (output) bit count [not of interest]. */
		     , code			/* (ourtput) status code. */
		     );
		if code ^= 0 then do;
		     if (code ^= error_table_$namedup)
		     & (code ^= error_table_$segknown) then
			call com_err_ (		/* msf get_ptr failure. */
			code
			, "gtss_dump_kin_"
			, "Attempting to open component ^i of"
			||"^/^a>^a"
			, c
			, dir
			, ent
			);
		     if p (c) = null () then signal cond (gtss_fail);
		end;
	     end;
	     l = 0;
	     n = length (tl)-k;
	end;
	substr (p (c) -> S, l+1, n) = substr (tl, k+1, n);
	l = l+n;
	return;

init:	entry returns (bit (1));

/* Query caller for file to store
   kin lines in.
*/

/* Ask caller for name of file in which
   kin lines can be stored.
*/
	dir, ent = " ";
	fcbp, aclp, p = null ();
	lc, l, c = 0;
	yes_or_no_sw = "0"b;			/* Not requesting yes or no. */
	suppress_name_sw = "0"b;			/* Print caller's name. */
	status_code = 0;
	call command_query_ (
	     addr (query_info)
	     , ans
	     , "gtss"
	     , "Name of file to dump kin lines to? "
	     );

/* Obtain directory and entry. */
	call expand_pathname_ (
	     (ans)				/* (input) dump file pathname. */
	     , dir				/* (output) directory. */
	     , ent				/* (output) entry. */
	     , code				/* (output) status code. */
	     );
	if code ^= 0 then do;
	     call com_err_ (			/* pathname failed. */
		code
		, "gtss_dump_kin_"
		, "Can not expand ""^a"""
		, ans
		);
	     return ("1"b);				/* Fail. */
	end;

/* Obtain multi-segment file. */
	call tssi_$get_file (			/* Obtain dump file. */
	     dir					/* (input) directory. */
	     , ent				/* (input) entry name. */
	     , p (0)				/* (output) component 0. */
	     , aclp				/* (output) ACL info. */
	     , fcbp				/* (output) msf control block pointer. */
	     , code				/* (output) status. */
	     );
	if code ^= 0 then do;
	     call com_err_ (			/* tssi failed. */
		code
		, "gtss_dump_kin_"
		, "^/^a>^a"
		, dir
		, ent
		);
	     return ("1"b);				/* Failed. */
	end;

	return ("0"b);				/* Successful. */

fin:	entry;

/* Close the collection file. */
	call tssi_$finish_file (
	     fcbp					/* (input) msf control block pointer. */
	     , c					/* (input) component. */
	     , l*9				/* (input) bit count (9 times # characters. */
	     , "101"b				/* (input) read and write access. */
	     , aclp				/* (input) pointer to ACL info. */
	     , code				/* (output). */
	     );
	if code ^= 0 then
	     call com_err_ (			/* close failed. */
	     code
	     , "gtss_dump_kin_"
	     , "^/^a>^a"
	     ||"^/fcb-ptr=^p acl-info-ptr=^p"
	     , dir
	     , ent
	     , fcbp
	     , aclp
	     );
	dir, ent = " ";
	fcbp, aclp, p = null ();
	lc, l, c = 0;
	return;

clean:	entry;

/* For cleanup condition processing. */
	call tssi_$clean_up_file (fcbp, aclp);
	return;

/*   IDENTIFIER		ATTRIBUTES	*/
/*   Variables for gtss_dump_kin_		*/
dcl  aclp                     ptr static int;
dcl  ans                      char(256)var;
dcl  c                        fixed bin static int;
dcl  char                     builtin;
dcl  code                     fixed bin(35);
dcl  command_query_           entry() options(variable);
dcl  com_err_                 entry() options(variable);
dcl  dir                      char(168) static int;
dcl  ent                      char(32) static int;
dcl  error_table_$namedup     fixed bin(35) ext static;
dcl  error_table_$segknown    fixed bin(35) ext static;
dcl  expand_pathname_         entry (char(*), char(*), char(*), fixed bin(35));
dcl  fcbp                     ptr static int;
dcl  gtss_fail                condition ext;
dcl  ioa_                     entry() options(variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24)static int;
dcl  lc                       fixed bin(24)static int;
dcl  length                   builtin;
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl  n                        fixed bin(24);
dcl  p                        (0:9)ptr static int;
dcl  p3                       pic "(3)9";
dcl  p6                       pic "(6)9";
dcl  prefix                   char(15);
dcl  S                        char(1044480)aligned based;
dcl  tl                       char(400)var;
dcl  tssi_$clean_up_file      entry (ptr, ptr);
dcl  tssi_$finish_file        entry (ptr, fixed bin, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));
dcl  tssi_$get_file           entry (char(*), char(*), ptr, ptr, ptr, fixed bin(35));

dcl  NL                       char(1)static int options(constant) init("
");

%include query_info;
     end gtss_dump_kin_;
 



		    gtss_dump_program_stack_.pl1    12/11/84  1354.3rew 12/10/84  1043.9       17253


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_dump_program_stack_: dps: proc;

/* Program to dump program and callss stacks for debugging purposes.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
*/

dcl  i fixed bin (24);
dcl  j fixed bin (24);
dcl  k fixed bin (24);
dcl  l fixed bin (24);
dcl  ioa_ entry options (variable);

	i = gtss_ust.lxxx.b0_17 - fixed (rel (addr (gtss_ust.lxxx)))
	     + fixed (rel (addr (gtss_ust)));
	call ioa_ ("^/Program Stack:");
	call ioa_ ("current depth = ^i.", i);
	do j = 1 to i;
	     k = lprgs.b0_17 (j);
	     l = lprgs.b18_35 (j);
	     call ioa_ ("Descriptor: ^a  Primitive: ^o", ss_name (k), l);
	end;
	call ioa_ ("^/CALLSS Stack:");
	i = divide (gtss_ust.lcals.b0_17 - fixed (rel (addr (gtss_ust.lcals))) +
	     fixed (rel (addr (gtss_ust))), 2, 24, 0);
	call ioa_ ("current depth = ^i.", i);
	do j = 1 to i;
	     call ioa_ ("Program stack reference = ^i; ss_flags = ^o.",
		subsystems (j).tally_address
		-fixed (rel (addr (gtss_ust.lxxx)))+fixed (rel (addr (gtss_ust))),
		fixed (subsystems (j).ss_flags));
	end;
	call ioa_ ("gtss_ext_$stack_level_ = ^i.",
	     gtss_ext_$stack_level_);
%include gtss_prgdes_;
%include gtss_ust_ext_;
%include gtss_ext_;
     end gtss_dump_program_stack_;
   



		    gtss_edit_dsd_.pl1              12/11/84  1354.3rew 12/10/84  1043.9       16641


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

gtss_edit_dsd_: proc (bp, bl) returns (fixed bin (24));

/**	This function is called to edit certain lines
	that do not appear in the output stream.
	e.g. the $*$talk request line.
	It will return a value of 1 if the buffer
	contains a line which should not
	appear in the stream, else it will return 0.

	Author: Al Dupuis 05/16/79.


**/
	i = index (cs, "$*$");			/* is it a request line */
	if i = 0 then do;
	     i = index (cs, "cout");			/* or the cout command */
	     if i = 0 then i = index (cs, "COUT");
	     if i ^= 0 then return (1);
	end;
	if i = 0 then return (0);			/* no, then it's normal input */
	rls = substr (cs, i + 3);			/* all of line after $*$  */
	rls = substr (rls, 1, length (rls) - 1);	/* get rid of NL */
	rls = ltrim (rls);				/* get rid of any leading blanks */
	if (length (rls) > 3) then request = substr (rls, 1, 4); /* pick up the keyword */
	else request = substr (rls, 1, 3);
	request = translate (request, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", /* convert to upper */
	     "abcdefghijklmnopqrstuvwxyz");

	if (gtss_dsd_lookup_ (request) ^= 0) then return (1);
	else return (0);

/**  **/

dcl bp ptr parm;
dcl bl fixed bin (21) parm;
dcl cs char (bl) based (bp);
dcl (substr, ltrim, length, index, translate) builtin;
dcl request char (8) varying;
dcl rls char (252) varying;
dcl i fixed bin (24);
/**  **/

%include gtss_entry_dcls;

     end						/* gtss_edit_dsd_ */;
   



		    gtss_expand_pathname_.pl1       12/11/84  1354.3rew 12/10/84  1043.9       58914


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_expand_pathname_: proc (np, dn, en, rs);

/*	Translate a GCOS catalog/file description
   list of names to a Multics directory and
   entry name.

   The translation is regulated by the convention
   specified through the $set..mode entries
   (of gtss_expand_pathname_).

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	08/16/79 db entry and #CMD/#LIB sensitive.
   Change:  Dave Ward	08/21/79 trace to path name, db result.
   Change:  Bob Alvarado	09/25/79 Added goto complete at case-b(3).
   Change:  Paul Benjamin	11/27/79 Added verify_umc entrypoint.
   Change:  Paul Benjamin     12/17/79 Store gtss_ext_$drm_path.
   Change:  Paul Benjamin	04/03/80 Fix bug when accessing thru link.
   */
dcl  np                       ptr parm		/* Pointer to ascii_cat_file structure (input). */;
dcl  dn                       char (*)parm	/* Multics directory name (output). */;
dcl  en                       char (*)parm	/* Multics file entry name (output). */;
dcl  rs                       fixed bin (35)parm	/* Multics/gcos_et error status (output). */;

	verifying = "0"b;
	goto main_entry;

verify_umc: entry (np, dn, en, sc, rs);
	verifying = "1"b;

main_entry:
	acfp = np;

	if db_expand_pathname then do;
	     call ioa_ ("gtss_expand_pathname_ (input):");
	     do i = 1 to acf.nn;
		call ioa_ ("^2i. ""^a""", i, acf.name (i));
	     end;
	end;

	rs = 0;

/* Determine if cat/file description => #CMD or #LIB
*/
	if (acf.name (1) = "cmdlib") | (acf.name (1) = "library") then do;
	     dnv = ">udd>";
	     dnv = dnv||rtrim (acf.name (1));
	     do i = 1 to (acf.nn-1);
		dnv = dnv||">";
		dnv = dnv||rtrim (acf.name (i));
	     end;
	     dn = dnv;
	     en = acf.name (acf.nn);
	     goto complete;
	end;

/* Determine the root directory corresponding to the USERID
   in this catalog/file string. */

	umc_name = rtrim (acf.name (1));
	go to case_A (gse_ext_$drm_rule);
case_A (1): ;					/* umc_dir_mode */
	directory = ">udd>"||umc_name||">"||umc_name;
	go to end_case_A;

case_A (2): ;					/* working_dir_mode */
	call get_wdir_ (wd);
	directory = rtrim (wd);
	go to end_case_A;
case_A (3): ;					/* smc_dir_mode */
	smc_name = rtrim (gse_ext_$smc_pathname);
	directory = smc_name||">"||umc_name;

end_case_A: ;

	gtss_ext_$drm_path = directory;		/* gtss_verify_access_ will need this */
	if substr(gtss_ext_$drm_path,1,14) = ">user_dir_dir>" then gtss_ext_$drm_path = ">udd>"||substr(gtss_ext_$drm_path,15);
	if acf.nn = 1 then do;			/* Only USERID in cat/file descr. */
	     go to case_B (gse_ext_$drm_rule);
case_B (1):    ;					/* umc_dir_mode */
	     dn = ">udd>"||umc_name;
	     en = umc_name;
	     goto complete;

case_B (2):    ;					/* working_dir_mode */
	     dl = search (reverse (wd), ">");
	     if dl<2 then do;
		rs = error_table_$badpath;
		return;
	     end;
	     nl = search (substr (wd, length (wd)-dl+2), " ");
	     if nl = 0 then nl = dl;
	     dn = substr (wd, 1, length (wd)-dl);
	     en = substr (wd, length (wd)-dl+2, nl-1);
	     if dn = "" then dn = ">";
	     goto complete;
case_B (3):    ;					/* smc_dir_mode */
	     dn = smc_name;
	     en = umc_name;
	     goto complete;
	end;

	if ^verifying then do;
/* Append any additional catalogs onto the Multics pathname. */
	     do i = 2 to acf.nn-1;
		directory = directory||">";
		directory = directory||rtrim (acf.name (i));
	     end;

	     dn = directory;
	     en = acf.name (acf.nn);

complete:	     ;

/* Obtain the pathname of the Multics file
   specified by directory, acf.name.
*/
	     call hcs_$get_link_target (
		(dn)
		, (en)
		, dnr
		, enr
		, ec
		);
	     if ec = 0 then do;			/* Return pathname found. */
		if substr (dnr, 1, 14) = ">user_dir_dir>" then
		dn = ">udd>"||substr (dnr, 15); else
		dn = dnr;
		en = enr;
/* If accessing thru link, then make gtss_verify_access_ just look at containing dir. */
		if substr(dn,1,length(rtrim(gtss_ext_$drm_path))) ^= gtss_ext_$drm_path
		     then gtss_ext_$drm_path = dn;
	     end;
	end;
	else do;
	     umc_dir = substr (directory, 1, (length (directory)-index (reverse (directory), ">")));
	     umc_entry = substr (directory, (length (directory)-index (reverse (directory), ">")+2));
	     call hcs_$get_link_target (
		umc_dir
		, umc_entry
		, dnr
		, enr
		, ec
		);
	     if ec = error_table_$no_dir then sc = "4001"b3;
	     else sc = "4005"b3;
	end;

	if db_expand_pathname then
	     call com_err_ (
	     ec
	     , "gtss_expand_pathname_"
	     , "Result ""^a"" ""^a"""
	     , dn
	     , en
	     );
	return;

/* Variables for gtss_expand_pathname_
   IDENTIFIER		ATTRIBUTES	*/
dcl dnr char(168);
dcl enr char(32);
dcl  acfp                     ptr init(null());
dcl  com_err_                 entry options(variable);
dcl  directory                char (168)varying;
dcl  dl                       fixed bin;
dcl  dnv                      char(168)var;
dcl  ec			fixed bin(35);
dcl  error_table_$badpath     fixed bin (35)ext;
dcl  error_table_$no_dir	fixed bin (35)ext;
dcl  get_wdir_                entry (char (168));
dcl  hcs_$get_link_target     entry(char(*),char(*),char(*),char(*),fixed bin(35));
dcl  i                        fixed bin;
dcl  ioa_                     entry options(variable);
dcl  n                        char (12);
dcl  nl                       fixed bin;
dcl  rtrim                    builtin;
dcl  sc			bit (18);
dcl  smc_name                 char (168)varying int static;
dcl  translate                builtin;
dcl  umc_dir		char (168);
dcl  umc_entry		char (032);
dcl  umc_name                 char (12)varying;
dcl  verifying		bit(1);
dcl  wd                       char (168);

dcl 1 acf aligned based (acfp) like ascii_cat_file;
%include gtss_ascii_file_names;

%include gse_ext_;

%include gtss_db_names;

%include gtss_ext_;
     end						/* gtss_expand_pathname_ */;
  



		    gtss_ext_.cds                   12/11/84  1354.3rew 12/10/84  1043.9       39177


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_ext_:proc;

/* Generate object for "gtss_ext_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_ext_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_ext_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_ext_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_ext_";

	cds_args_ptr -> cds_args.seg_name = "gtss_ext_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_ext_");
	   else 
	      call com_err_( 0,"gtss_ext_","Object for gtss_ext_ created [^i words].",size(gtss_ext_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_ext_.incl.pl1 **/

dcl 1 gtss_ext_ aligned,
     2 aem                    fixed bin,
     2 bad_drl_rtrn           label,
     2 db                     (72) bit (1) unal,
     2 deferred_catalogs_ptr  ptr,
     2 dispose_of_drl         label,
     2 drl_rtrn               (4) label,
     2 drm_path               char (168),
     2 drun_jid               char (5),
     2 event_channel          fixed bin (71),
     2 finished               label,
     2 gdb_name               char (8),
     2 get_line               entry (ptr,ptr,fixed bin(21),fixed bin(21),fixed bin(35))variable,
     2 gtss_slave_area_seg    (4) ptr,
     2 hcs_work_area_ptr      ptr,
     2 homedir                char (64),
     2 last_k_was_out         bit (1) aligned,
     2 pdir                   char (168) varying,
     2 popup_from_pi          label,
     2 process_type           fixed bin (17),
     2 put_chars              entry (ptr,ptr,fixed bin(24),fixed bin(35)) variable,
     2 restart_from_pi        label,
     2 restart_seg_ptr        ptr,
     2 sig_ptr                ptr,
     2 stack_level_           fixed bin,
     2 suspended_process      bit (1),
     2 SYstarstar_file_no     fixed bin (24),
     2 user_id                char (26) var,
     2 work_area_ptr          ptr,

     2 CFP_bits aligned       like gtss_ext_$CFP_bits,

     2 com_reg aligned        like gtss_ext_$com_reg,

     2 flags aligned          like gtss_ext_$flags,

     2 statistics aligned     like gtss_ext_$statistics,

     2 aft aligned            like gtss_ext_$aft,

     2 ppt                    ptr,

     2 fast_lib aligned       like gtss_ext_$fast_lib,

     2 mcfc	  aligned like gtss_ext_$mcfc;

%page;
%include gtss_ext_;
%page;
%include cds_args;
end;
   



		    gtss_fault_processor_.pl1       12/11/84  1354.3rew 12/10/84  1027.5      145386


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_fault_processor_: proc;

/* *
   This procedure handles all faults occurring in  a  gtss  program
   except  the  DRL.  Once the fault cause is interpreted, the gtss
   slave program prefix fault vector is examined to see if the gtss
   program  has  set up a handler for this fault. Each fault vector
   consists of two words except for lockup. The first word is  used
   to  store  the instruction counter and indicators at the time of
   the fault. The second word contains the address of where  to  go
   in  the gtss program to process the fault. If the location is 0,
   the program will be aborted. If a fault  processing  routine  is
   specified,  the  scu  data  will be modified to cause control to
   return to the gtss program at that location.

   (gcos contributors:)
   WRITTEN BY DICK SNYDER OCTOBER 2, 1970
   MODIFIED BY T. CASEY SEPTEMBER 1973, FEBRUARY 1974, APRIL 1974
   MODIFIED BY D. KAYDEN  JUNE 1974, DECEMBER 1974
   MODIFIED BY T. CASEY AUGUST 1975
   Modified by M. R. Jordan, October 1977

   (gtss contributors:)
   Modified by R. J. Grimes, Spring 1978
   Modified by D. B. Ward, June 25, 1978
   Modified by D. B. Ward, July 9, 1978
   Modified by A. N. Kepner, July 19, 1978
   (Pass appropriate error messages to gtss_abort_subsystem_)
   Modified by A. N. Kepner, July 24, 1978
   Modified by Al Dupuis, Oct 12, 1979
   (Re-implemented timer_runout entry)
   Authors:	Robert J. Grimes	Created
   Albert N. Kepner	  1978
   Robert M. May
   David B. Ward
  Changed: Ron Barstad  10/25/82  fixed string range error in substr of condition_name
   Modified: Ron Barstad  84-05-31  Added RSW simulation to IPR fault handling.
   * */

	cond_info.version = 1;			/* expect version 1 of info structure */
	call find_condition_info_ (null, addr (cond_info), code);
	if code ^= 0 then do;
	     call com_err_ (code, "gtss_fault_processor_",
		"Can't find condition info.");
	     signal cond (gtss_fail);
	end;
	if cond_info.mcptr = null () then go to pass_it_on; /* Not a fault so pass it on */

	scup = addr (cond_info.mcptr -> mc.scu);	/* get pointer to scu data */
	mcp = cond_info.mcptr;

/* Update saved machine registers in user's slave prefix. */
	call gtss_update_safe_store_ (mcptr);

	if substr (condition_name||"         ", 1, 9) = "simfault_" then go to pass_it_on; /* can't check for all simfaults in my array */
	do i = 1 to hbound (faults, 1);		/* see if we have a match in our array */
	     if condition_name = faults (i).type then do; /* found it */

		if scu.ppr.psr ^= substr (baseno (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_)), 4, 15) then
		     goto pass_it_on;		/* abort if fault occurred outside gtss segment */

		faultv.ic = fixed (scu.ilc)+1;	/* get IC */
		faultv.ind = string (scu.ir);		/* and I */

		go to fault (i);			/* handle fault if we want */
	     end;
	end;
/* 	Come here on a wide class of faults we won't take specific action on */
fault (10): ;					/* page fault */
pass_it_on: ;
	call continue_to_signal_ (code);		/* let's pass it on */
	if code ^= 0 then do;
	     call com_err_ (code, "gtss_fault_processor_",
		"Can't continue to signal.");
	     signal cond (gtss_fail);
	end;
	return;


/*	Come here on IPR					*/
fault (5): ;
	 /* if the IPR instruction was a RSW, this can be simulated */
	 if substr(fault_word,16,12) = RSW2
	      then do;
	      mc.regs.a = "0"b;                             /* return zero */
	      scu.ilc = bit(fixed(scu.ilc,17) + 1,18);
	      scu.rfi, scu.if = "1"b;			/* make sure cpu refetches instr from where ilc says */
	      call gtss_update_safe_store_(mcp);
	      return;					/* return to the gtss program */
	 end;
	 /* all other IPRs */
	pnterr_mess = gtss_pnterr.err55;
	gcos_error_code = 55;
	fault_type = 3;
	fault_vector = 0;
	goto user_fault;

/* 	Come here on fault tag 1				 */
fault (4): ;
	pnterr_mess = gtss_pnterr.err19;
	gcos_error_code = 19;
	fault_type = 2;
	fault_vector = 4;				/* vector offset */
	go to user_fault;				/* see if user has handler */

/* 	Come here on illegal op code				 */
fault (21): ;					/* illegal_opcode */
	if gse_ext_$modes.gdb then do;
	     gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	     i_ptr = addrel (gseg, scu.ilc);
	     if i_opcode = "005"b3			/* mme 3 fault */
	     then do;
		call gcos_debug_$breaktime;
		return;
	     end;
	end;


fault (6): ;					/* illegal_modifier */
fault (7): ;					/* linkage_error */
fault (8): ;					/* fault_tag_3 */
fault (9): ;					/* seg_fault_error */
fault (11): ;					/* gate_error */
	pnterr_mess = gtss_pnterr.err17;
	gcos_error_code = 17;
	fault_type = 6;
	fault_vector = 0;				/* vector offset */
	go to user_fault;				/* see if user has handler */

/* 	Come here on attempt to read or write out of partition bounds 	 */
fault (12): ;
fault (20): ;
	pnterr_mess = gtss_pnterr.err18;
	gcos_error_code = 18;
	fault_type = 1;
	fault_vector = 2;				/* vector offset */
	go to user_fault;				/* see if user has handler */

/* 	Come here on overflow				 */
fault (16): ;
	fault_flags = "000010000000000000"b;		/* turn on bit 22 of accum. fault status */
	goto common_flow;

/*	Come here on fixedoverflow */
fault (15): ;
	fault_flags = "000100000000000000"b;		/* turn on bit 21 of accum. fault status */
	goto common_flow;

/* 	Come here on underflow */
fault (14): ;
	fault_flags = "000001000000000000"b;		/* turn on bit 23 of accum. fault status */

common_flow: ;
	pnterr_mess = gtss_pnterr.err16;
	gcos_error_code = 16;
	fault_type = 8;
	fault_vector = 8;				/* vector offset */
	go to user_faultx;				/* see if user has handler */

/* 	Come here on op_not_complete				 */
fault (19): ;
	pnterr_mess = gtss_pnterr.err53;
	gcos_error_code = 53;
	fault_type = 7;
	fault_vector = 0;				/* say where to put IC and I */
	goto user_fault;				/* and go do it */

/* 	Come here on lockup					 */
fault (18): ;
	pnterr_mess = gtss_pnterr.err44;
	gcos_error_code = 44;
	fault_type = 5;
	fault_vector = 0;				/* say where to put IC and I */
	goto user_fault;

/* 	Come here on zero divide 				 */
fault (17): ;
	pnterr_mess = gtss_pnterr.err20;
	gcos_error_code = 20;
	fault_type = 9;
	fault_vector = 6;				/* vector offset */
	fault_flags = "000000000001000000"b;		/* turn on bit 29 of accum. fault status */
	goto user_faultx;

/* 	Come here on mme fault 				*/
fault (1): ;					/* mme 1 */
fault (2): ;					/* mme 3 */
fault (3): ;					/* mme 4 */
fault (22): ;					/* mme 2 */
	pnterr_mess = gtss_pnterr.err27;
	gcos_error_code = 27;
	fault_type = 0;
	fault_vector = 0;				/* vector offset */
	go to user_fault;				/* see is user has handler */


/* 	Come here with a fault which the gtss user can potentially handle. 		*/
/* 	"fault_vector" holds the offset from the base of the gtss segment where	 */
/* 	the user's fault vector for the particular fault which occurred is located.	 */

/* Put the accumulated fault status into word 25 of prefix */

user_faultx: ;
	p = addrel (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_), 25); /* get pointer to it */
	accum_stat = accum_stat | ((18)"0"b || fault_flags); /* or in the flags */

user_fault: ;

	p = addrel (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_), 25); /* get pointer to it */
	substr (accum_stat, 31, 6) = bit (fault_type, 6);
	prefix_vector (fault_vector) = ic_i;		/* copy ic and indicators into fault vector */


	lower_limit = bit (binary (100, 18), 18);
	upper_limit = gtss_ust.lsize.limit;
	if transfer.tra_addr < lower_limit | transfer.tra_addr >= upper_limit then do; /* if no valid fault_vector, abort the job */

abrt:	     ;
	     call condition_interpreter_ (null, p, i, 3, mcptr, (condition_name), wcptr, infoptr);
	     call gtss_abort_subsystem_ (mcptr,
		"gtss_fault_processor_",
		gcos_error_code,
		pnterr_mess,
		fixed (scu.ilc, 18));
	     scu.rfi, scu.if = "1"b;			/* Make cpu refetch new instruction */
	     return;				/* just in case */
	end;

/* 	Fiddle the scu data to cause processor to resume execution at the 	 */
/*	second word of the fault vector. This is done by setting the ilc to	*/
/*	the address of that word and turning on "rfi" and "if "in the	*/
/*	scu data, to force the cpu to refetch the instruction from the	*/
/*	word pointed to by the ilc.					*/

	fault_vector = fault_vector + 1;		/* get loc'n of word 2 of vector */
	scu.ilc = substr (unspec (fault_vector), 19, 18); /* force transfer to the tra in that word */
	scu.rfi, scu.if = "1"b;			/* make sure cpu refetches instr from where ilc says */
	return;					/* return to the gtss program */

/* HANDLERS FOR FAULTS THAT THE USER'S FAULT VECTOR CAN NOT HANDLE */

/*	Come here on parity */
fault (13): ;
	pnterr_mess = gtss_pnterr.err63;
	gcos_error_code = 63;
	fault_type = 11;
	call condition_interpreter_ (null, p, i, 3, mcptr, (condition_name), wcptr, infoptr);
	call gtss_abort_subsystem_ (mcptr,
	     "gtss_fault_processor_",
	     gcos_error_code,
	     pnterr_mess);
	scu.rfi, scu.if = "1"b;			/* Make cpu refetch new instruction */
	return;					/* just in case */


/* 	Come here if fault is a timer runout				 */
timer_runout: entry (mcpp, fault_name);


	on cput;
	mcp = mcpp;
	if gtss_ust.lcjid ^= "0"b			/* reset proc that checks for DABT request */
	then call timer_manager_$reset_cpu_call (gtss_abs_$dabt_check);
	if gtss_ext_$flags.timer_ranout
	then goto shut_down;
	else gtss_ext_$flags.timer_ranout = "1"b;
	if lflg2.b8
	then do;					/* set COUT sector and term code */
	     gtss_ust.lcfst.start_term = 10;
	     gtss_ust.lcfio.sect_in = gtss_ust.lcfst.initial_sect_out - 1;
	end;
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	scup = addr (mc.scu);
	if scu.ppr.psr = substr (baseno (gtss_ext_$gtss_slave_area_seg
	(gtss_ext_$stack_level_)), 4, 15) then;
	else do;
	     mcp = gtss_find_cond_frame_ ("derail");
	     if mcp = null ()
	     then do;				/* can't even find the slave frame */
		call com_err_ (0, "",
		     "^/064-EXECUTE TIME LIMIT EXCEEDED.");
		revert cput;
		call gtss_interp_prim_$sysret ();
		return;
	     end;
	     else derail_in_progress = "1"b;
	end;

	scup = addr (mc.scu);
	call gtss_update_safe_store_ (mcp);
	gtss_spa.lsztm.b35 = "1"b;
	faultv.ic = fixed (scu.ilc) + 1;
	faultv.ind = string (scu.ir);
	fault_flags = "100000000000000000"b;
	gcos_error_code = 43;
	fault_type = 10;
	p = addrel (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_), 25);
	accum_stat = accum_stat | ((18)"0"b || fault_flags);
	substr (accum_stat, 31, 6) = bit (fault_type, 6);
	if gtss_spa.lsztm.tra ^= "0"b
	then if ((substr (gtss_spa.lsztm.tra, 1, 18) >= bit (binary (100, 18), 18))
	     & (substr (gtss_spa.lsztm.tra, 1, 18) <= gtss_ust.lsize.limit))
	     then do;
		gtss_spa.lsztm.ic_ir.IC = string (bit (faultv.ic, 18));
		gtss_spa.lsztm.ic_ir.IR = substr (faultv.ind, 1, 16);
		scu.ilc = substr (gtss_spa.lsztm.tra, 1, 18);
		scu.rfi, scu.if = "1"b;
		call gtss_update_safe_store_ (mcp);
		revert cput;
		if ((^derail_in_progress)
		| (gtss_ext_$dispose_of_drl ^= gtss_ext_$bad_drl_rtrn))
		then do;				/* give user one second to conclude */
		     call timer_manager_$cpu_call (1, "11"b,
			gtss_fault_processor_$timer_runout);
		     if ^derail_in_progress
		     then return;
		     else goto gtss_ext_$dispose_of_drl;
		end;
		else do;
		     call com_err_ (0, "",
			"The subsystem timer runout code was not executed",
			"^/064-EXECUTE TIME LIMIT EXCEEDED");
		     call gtss_interp_prim_$sysret ();
		     return;
		end;
	     end;

shut_down: ;


/* reset any CRUN/DRUN timers that may go off */
	call timer_manager_$reset_cpu_call (gtss_abs_$cpu_runout);
	call com_err_ (0, "",
	     "^/064-EXECUTE TIME LIMIT EXCEEDED");
	revert cput;
	call gtss_interp_prim_$sysret ();
	return;


/* *  Declarations for gtss_fault_processor_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  RSW2 bit(12) internal static options (constant) init ("2231"b3);
dcl  abort_code char (20) varying aligned		/* abort code for this fault */;
dcl  accum_stat bit (36) aligned based (p)		/* overlay for accumulated */;
dcl  addr builtin;
dcl  addrel builtin;
dcl  answer char (4) varying;
dcl  code fixed bin (35);
dcl  command_query_ entry options (variable);
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  cput condition ext;
dcl  derail_in_progress bit (1) init ("0"b);
dcl  fault_flags bit (18)				/* flags to set accumulated */;
dcl  fault_name char (*)				/* fault name from fim */;
dcl  fault_type fixed bin (6);						/* Fault type to be filled in last 6 bits of .LFTST */
dcl  fault_vector fixed bin				/* offset from base of gtss segment where fault vector is located. */;
dcl  fault_word bit(36) based (cond_info.loc_ptr);          /* the faulting instruction */
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl find_condition_frame_ entry(ptr) returns(ptr);
dcl  fixed builtin;
dcl  gcos_error_code fixed bin (18);						/* .LABRT type error code */
dcl  gcos_debug_$breaktime entry ();
dcl  gseg ptr;						/* ptr to slave segment */
dcl  gtss_fail condition ext;
dcl  hbound builtin;
dcl  i fixed bin;
dcl  i_ptr ptr;						/* ptr to instruction where fault occurred */
dcl  ic_i bit (36) aligned;
dcl  initialized bit (1) int static init ("0"b);
dcl  ioa_ entry options (variable);
dcl  j fixed bin;
dcl  lower_limit bit(18) unal;
dcl  mcpp ptr parm;
dcl  nop bit (36) aligned int static init ("000000011003"b3) /* nop instruction */;
dcl  null builtin;
dcl  p pointer;
dcl  pnterr_mess char (70) varying init ("FAULT ERROR ");
dcl  prefix_vector (0:11) bit (36) aligned based (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_));
dcl  sp ptr;						/* ptr to current stack frame being searched */
dcl  string builtin;
dcl  substr builtin;
dcl  timer_manager_$cpu_call entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call entry (entry);
dcl  unspec builtin;
dcl  upper_limit bit(18) unal;

dcl 1 transfer aligned based (addr(prefix_vector(fault_vector+1))), /* overlay for transfer instruction of fault vector */
    2 tra_addr bit (18) unal,
    2 tra_op bit (18) unal;

dcl 1 faultv aligned based (addr (ic_i)),		/* overlay for ic_i */
    2 ic fixed bin (17) unaligned,			/* instruction counter */
    2 ind bit (18) unaligned;						/* indicators */

dcl 1 instruction aligned based (i_ptr),		/* overlay for examining instruction */
    2 i_address bit (18) unal,			/* where fault occurred */
    2 i_opcode bit (9) unal,
    2 i_addr_mod bit (9) unal;


dcl 1 faults (22) internal static aligned,
    2 type char (32) init (
     "mme1",					/* 1 */
     "mme3",					/* 2 */
     "mme4",					/* 3 */
     "fault_tag_1",					/* 4 */
     "illegal_procedure",				/* 5 */
     "illegal_modifier",				/* 6 */
     "linkage_error",				/* 7 */
     "fault_tag_3",					/* 8 */
     "seg_fault_error",				/* 9 */
     "page_fault_error",				/* 10 */
     "gate_error",					/* 11 */
     "store",					/* 12 */
     "parity",					/* 13 */
     "underflow",					/* 14 */
     "fixedoverflow",				/* 15 */
     "overflow",					/* 16 */
     "zerodivide",					/* 17 */
     "lockup",					/* 18 */
     "op_not_complete",				/* 19 */
     "out_of_bounds",				/* 20 */
     "illegal_opcode",				/* 21 */
     "mme2"					/* 22 */
     );

dcl 1 cond_info aligned,
%include cond_info;

%include query_info_;

%include gtss_pnterr;

%include mc;

%include gtss_ext_;

%include gtss_entry_dcls;

%include gtss_ust_ext_;

%include gse_ext_;

%include gtss_spa;
     end gtss_fault_processor_ ;
  



		    gtss_filact_error_status_.pl1   12/11/84  1354.3rew 12/10/84  1043.9       21393


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

/* *************************************************************
   *                                                           *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *                                                           *
   ************************************************************* */


/* Written by Mel Wilson      November 1979
   Modified by Stew Putt      November 1979 adding error_table_$moderr
*/

gtss_filact_error_status_: proc (code) returns (bit (12));

dcl  code fixed bin (35);

	if code = 0 then return ("4000"b3);		/* no error */

	if code = error_table_$bad_ring_brackets
	| code = error_table_$incorrect_access
	| code = error_table_$moderr
	| code = error_table_$no_s_permission
	| code = error_table_$no_info then return ("4003"b3); /* permissions denied */

	if code = error_table_$dirseg
	| code = error_table_$no_dir
	| code = error_table_$noentry
	| code = error_table_$nondirseg
	| code = error_table_$not_seg_type
	| code = error_table_$notadir then return ("4005"b3); /* incorrect cat/file description */

	if code = error_table_$namedup
	| code = error_table_$segnamedup then return ("4011"b3); /* duplicate name */

	if code = error_table_$logical_volume_not_connected
	| code = error_table_$pvid_not_found then return ("4025"b3); /* requested entry not on-line */

	return ("4047"b3);				/* unaccountable error */

dcl (
     error_table_$bad_ring_brackets,
     error_table_$dirseg,
     error_table_$incorrect_access,
     error_table_$logical_volume_not_connected,
     error_table_$moderr,
     error_table_$namedup,
     error_table_$no_dir,
     error_table_$no_info,
     error_table_$no_s_permission,
     error_table_$noentry,
     error_table_$nondirseg,
     error_table_$not_seg_type,
     error_table_$notadir,
     error_table_$segnamedup,
     error_table_$pvid_not_found
     ) ext static fixed bin (35);

     end gtss_filact_error_status_;
   



		    gtss_filact_funct02_.pl1        12/11/84  1354.3rew 12/10/84  1043.9      147294


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_filact_funct02_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 02 (CC - Create Catalog).

	All parameters are input parameters except code.

	code returned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Alvarado	Created	1979
   Change:  Paul Benjamin	10/08/79	Enable setting of permissions
   Change:  Paul Benjamin     12/14/79  New acls for propagation of permissions
   Change:  Ron Barstad       06/11/82  Fixed stringsize conditions on assign to pstr
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 fixed bin(18)unsigned unal parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	mem_top = high_val;
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain create catalog arglist. */
	if (CC_args.L_arglist < mem_bottom) |
	((CC_args.L_arglist +3) > mem_top) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, CC_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (CC_arglist.L_status_return, status_ptr);

	if CC_arglist.L_permissions ^= 0 then
	     if (CC_arglist.L_permissions < mem_bottom)
	     | (CC_arglist.L_permissions > mem_top) then
		goto return_err4;

	if get_ascii_file_name ("0"b, CC_arglist.L_cat_filedescr, addr (ascii_cat_file)) then do;
	     status_word.status = "4005"b3;
could_not_create_catalog: ;
	     call bcd_message (
		status2.L_bcd_message
		, status2.message_words
		, buffer_ptr
		, "Could not create catalog."||rtrim (gtss_file_values.dname)||">"||rtrim (gtss_file_values.ename)
		);
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = "400500"b3;		/* Could not access catalog specified. */
ret:	     ;
	     return;
	end;


	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , code
	     );
	if code ^= 0 then goto could_not_create_catalog;
/**  Create Catalog now **/

	call hcs_$append_branchx (
	     dname
	     , ename
	     , fixed ("01011"b, 5)
	     , rings
	     , "*.*.*"
	     , 1b
	     , 0
	     , 0
	     , code
	     );
	if code ^= 0 then
	     goto could_not_create_catalog;

/** NOTE: permissions are not being checked with this release, however
SMA will be set for *.*.*		**/
	call set_general_permissions;

	call set_specific_permissions;


	status_word.status = "400000"b3;
	goto ret;

set_general_permissions: proc;

/* Set general permissions
   => Multics *.*.* access.
*/

/**	Obtain permissions.	**/
	     if CC_arglist.L_permissions = 0 then return;
	     if (CC_arglist.L_permissions < mem_bottom) |
	     (CC_arglist.L_permissions > mem_top) then goto return_err4;
	     pp = addrel (gseg, CC_arglist.L_permissions);
	     if pp -> b36 = (36)"1"b then return;
	     if pp -> fb18 = 0 then;

/* Deletes ignored for create catalog */
	     else do;

/* => Set specific general permissions. */
		if code ^= 0 then goto could_not_create_catalog;
		pstr = substr(char (pp -> b36),1,10);
		access_name = pstr||".*.g";		/* Create propagation acl. */
		modes = "0"b;
		status_code = 0;
		call hcs_$add_dir_acl_entries (
		     dname
		     , ename
		     , addr (dir_acl)
		     , 1
		     , code
		     );
		if code ^= 0 then goto could_not_create_catalog;
	     end;
	     return;

dcl  pp                       ptr;
dcl  fb18                     fixed bin(18)unsigned unal based;
dcl  b36                      bit(36)aligned based;
dcl  bits                     (0:35)bit(1)unal based;
dcl  pstr char(10);

dcl 1 dir_acl,
      2 access_name char(32),
      2 modes       bit(36),
      2 status_code fixed bin(35);
	end					/* set_general_permissions */;

set_specific_permissions: proc;
	     if (L_options<mem_bottom) |
	     ((L_options+2)>mem_top) then goto return_err4;
	     op = addrel (gseg, L_options);

/* Determine number of specific user permissions. */
	     do n = 0 by 1 while (end_of_list ^= -1);
		if (L_options + 3 + (3*n))>mem_top then goto could_not_create_catalog;
	     end;

	     if n < 1 then return;

/* User specific permissions. */
	     acl_count = n;
	     allocate dir_acl set (acl_ptr);
	     acl_count = 0;
	     rp_sw = "0"b;
	     a = empty ();
	     call hcs_$list_dir_acl (
		dname
		, ename
		, gtss_ext_$hcs_work_area_ptr
		, da_ptr
		, null ()
		, da_count
		, code
		);
	     if code ^= 0 then goto could_not_create_catalog;
	     c = da_count;
	     do k = 1 to n;
		found_sw = "0"b;
		pp = addr (user (k).specific_permission);
		if pp -> b36 ^= (36)"1"b then do;
		     call gtss_bcd_ascii_ (
			addr (user.id (k))
			, 12
			, addr (ascii_id)
			);
		     if pp -> fb18 = 0 then do i = 1 to da_count; /* delete */
			if index (da_name (i), "."||rtrim (ascii_id)||".g") ^= 0 then do;
			     acl_count = acl_count + 1;
			     del_name (acl_count) = da_name (i);
			     i = da_count;
			end;
		     end;
		     else do i = 1 to c;		/* Replace */
			if index (da_name (i), "."||rtrim (ascii_id)||".g") ^= 0 then do;
			     found_sw = "1"b;
			     pstr = substr(char (pp -> b36),1,10);
			     da_name (i) = pstr||"."||rtrim (ascii_id)||".g";
			     rp_sw = "1"b;
			     i = c;
			end;
		     end;
		     if pp -> fb18 ^= 0 & found_sw = "0"b then do;
			da_count = da_count + 1;
			pstr = substr(char (pp -> b36),1,10);
			da_name (da_count) = pstr||"."||rtrim (ascii_id)||".g";
			da_modes (da_count) = "0"b;
			rp_sw = "1"b;
		     end;
		end;
	     end;					/* of do k = 1 to n ... */
	     if rp_sw = "1"b then do;
		call hcs_$replace_dir_acl (
		     dname
		     , ename
		     , da_ptr
		     , da_count
		     , "1"b
		     , code
		     );
		if code ^= 0 then goto could_not_create_catalog;
	     end;
	     if acl_count ^= 0 then do;
		call hcs_$delete_dir_acl_entries (
		     dname
		     , ename
		     , acl_ptr
		     , acl_count
		     , code
		     );
		if code ^= 0 then goto could_not_create_catalog;
	     end;
	     free dir_acl;
	     return;

dcl a area(1000) based (gtss_ext_$hcs_work_area_ptr);

dcl da_ptr ptr;

dcl da_count fixed bin;

dcl 1 da_array (da_count) based (da_ptr),
     2 da_name char(32),
     2 da_modes bit(36),
     2 da_code fixed bin(35);
dcl  acl_count                fixed bin;
dcl  acl_ptr                  ptr init(null());
dcl  ascii_id                 char(12);
dcl  b36                      bit(36)aligned based;
dcl  c                        fixed bin;
dcl  fb18                     fixed bin(18)unsigned unal based;
dcl  found_sw		bit(1);
dcl  k                        fixed bin;
dcl  n                        fixed bin(24);
dcl  op                       ptr;
dcl  pp                       ptr;
dcl  pstr			char(10);
dcl  rp_sw		bit(1);

dcl 1 option_args aligned based(op)
,     2 word1
,       3 opt (0:35)bit(1)unal
,     2 word2
,       3 initial_size fixed bin(18)unsigned unal
,       3 max_size     fixed bin(18)unsigned unal
,     2 user (n)
,       3 id           bit(72)
,       3 specific_permission bit(36)
,     2 end_of_list    fixed bin(35)
,     2 user_attributes bit(36)
;

dcl 1 delete_acl  (acl_count) aligned based(acl_ptr),
      2 del_name char(32),
      2 status_code2 fixed bin(35);

dcl 1 dir_acl (acl_count)aligned based(acl_ptr),
      2 access_name char(32),
      2 modes       bit(36),
      2 status_code fixed bin(35);
	end					/* set_specific_permissions */;

/*	(CC) Create Catalog Declarations.	*/
dcl  new_name_ptr             ptr init(null());

dcl 1 CC_new_name		aligned based(new_name_ptr)
,     3 newname		bit(72)
,     3 newpassword		bit(72)
;

dcl 1 CC_args		aligned based(arg_ptr)
,     3 word1
,       4 zero		fixed bin(18)unsigned unal
,       4 L_arglist		fixed bin(18)unsigned unal
,     3 word2
,       4 CC_function_no	fixed bin(18)unsigned unal
,       4 L_buffer		fixed bin(18)unsigned unal
;

dcl 1 CC_arglist		aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	fixed bin(18)unsigned unal
,       4 zero		fixed bin(18)unsigned unal
,     3 word2
,       4 L_cat_filedescr	fixed bin(18)unsigned unal
,       4 L_permissions	fixed bin(18)unsigned unal
,     3 word3
,       4 L_options		fixed bin(18)unsigned unal
,       4 L_newname		fixed bin(18)unsigned unal
;

%include gtss_filact_intp3x;

%include gtss_filact_intp7x;


%include gtss_filact_intp2x;

%include gtss_filact_intp1x;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  fcb_ptr                  ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit72                    bit(72)aligned based;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset fixed bin(18)unsigned unal ;
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       fixed bin(18)unsigned unal ;
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_name_in_ascii       bit(1);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$delete_dir_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$list_dir_acl	entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$replace_dir_acl	entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  mem_top                  fixed bin(18)unsigned aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  mem_bottom               fixed bin(18)unsigned aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  path_name                char (168) varying;
dcl  permission_word          bit(36)aligned based;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		fixed bin(18)unsigned unal
,     3 word2
,       4 L_bcd_message	bit(18) unal
,       4 message_words	fixed bin(18)unsigned unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;


dcl 1 status_word aligned based (status_ptr),
    2 status bit(18) unal,
    2 pd fixed bin(18)unsigned unal,
    2 null_bit bit (1) unal,
    2 user_attributes bit (35) unal;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include gtss_filact_options;

%include gse_ext_;

%include gtss_db_names;
     end						/* gtss_filact_funct02_ */;
  



		    gtss_filact_funct03_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      143973


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct03_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 03 (CF - Create File).

	All parameters are input parameters except code.

	code returned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Dave Ward	06/21/79 faulty error &
				distinguish 4026 return.
   Change:  Paul Benjamin     12/17/79 Change acls to upper case &
				permission mapping to closer resemble GCOS.
Change: Dave Ward	08/18/81 minor cleanup.
**/
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
dcl  gseg_val                 ptr parm;
dcl  high_val                 bit(18)parm;
dcl  mcp_val                  ptr parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain create file arglist. */
	if					/* (CF_args.L_arglist < low_b) | */
	((fixed (CF_args.L_arglist, 18) +3) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, CF_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (CF_arglist.L_status_return, status_ptr);

	file_name_in_ascii = (CF_args.file_name_in_bcd ^= -1);
	if get_ascii_file_name (
	file_name_in_ascii
	, CF_arglist.L_cat_filedescr
	, addr (ascii_cat_file)
	, gsc
	) then do;
	     call could_not_create_file ("0"b, gsc);	/* Could not access file. */
	     return;
	end;

/**	Obtain permissions.	**/
	if					/* (CF_arglist.L_permissions < low_b) | */
	(CF_arglist.L_permissions > high_b) then goto return_err4;
	permissions_ptr = addrel (gseg, CF_arglist.L_permissions);
	if substr (unspec (permissionsx), 1, 10) = "0000000010"b | unspec (permissionsx) = "0"b then
	     multics_access_mode = "0"b;
	else multics_access_mode = "1"b||permissionsx.e||permissionsx.w;

	call get_options ("1"b, CF_arglist.L_options, now);

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.new_ename
	     , code
	     );
	if code ^= 0 then do;
	     call could_not_create_file ("0"b, "400500"b3); /* Could not access file. */
	     return;
	end;

	if optionsx.option_bit.k then block_factor = 1;	/* => sizes in llinks (320 words @). */
	else block_factor = 12;			/* => sizes in links (3840=12*320 words @). */

/* create the file */
	call msf_manager_$open (			/* Create caller's data segment. */
	     gtss_file_values.dname
	     , gtss_file_values.new_ename
	     , fcb_ptr
	     , code);
	if code ^= error_table_$noentry & code ^= 0 then do;
	     if db_filact_funct03 then
		call com_err_ (
		code
		, "gtss_filact_funct03_"
		, """^a>^a"" is a Multics file, not a GCOS file."
		, gtss_file_values.dname
		, gtss_file_values.ename
		);
	     call could_not_create_file ("0"b, "402500"b3); /* Could not access file. */
	     return;
	end;

	call msf_manager_$get_ptr (
	     fcb_ptr
	     , 0
	     , "1"b
	     , sptr
	     , sbc
	     , code
	     );
	if code ^= 0 then do;
	     call could_not_create_file ("0"b, "402500"b3);
	     return;
	end;
	segment_acl_space.access_name (1) =
	     "*."
	     ||translate (gtss_ext_$user_id, "QWERTYUIOPASDFGHJKLZXCVBNM", "qwertyuiopasdfghjklzxcvbnm")
	     ||".*";
	segment_acl_space.modes (1) = "111"b;
	k = 1;
	if multics_access_mode ^= "0"b then do;
	     segment_acl_space.access_name (2) = "*.*.*";
	     segment_acl_space.modes (2) = multics_access_mode;
	     k = 2;
	end;

	if now > 0 then call get_multics_seg_acl (
	     now
	     , addr (optionsx.optional_specific_permissions)
	     , addr (segment_acl_space)
	     );
	call msf_manager_$acl_add (
	     fcb_ptr
	     , addr (segment_acl_space)
	     , k
	     , code);
	if code ^= 0 then do;
	     call could_not_create_file ("1"b, "400500"b3); /* Could not access file. */
	     return;
	end;

	call msf_manager_$close (fcb_ptr);

	gtss_file_values.set_switch = "0"b;
	gtss_file_values.set_switch.mode_random
	     , gtss_file_values.set_switch.maxll
	     , gtss_file_values.set_switch.curll
	     , gtss_file_values.set_switch.busy
	     , gtss_file_values.set_switch.attr
	     , gtss_file_values.set_switch.null_file
	     , gtss_file_values.set_switch.number_allocations
	     , gtss_file_values.set_switch.creation_date
	     = "1"b;

	gtss_file_values.version = 1;
	gtss_file_values.change_name = "0"b;
	gtss_file_values.ename = " ";			/* => Initial setting. */

	gtss_file_values.data_flags.mode_random = optionsx.option_bit.b; /* "1"=>random | "0"=>linked. */
	gtss_file_values.data_fields.maxll = fixed (optionsx.max_file_size, 18)*block_factor;
	gtss_file_values.data_fields.curll = fixed (optionsx.initial_file_size, 18)*block_factor;
	gtss_file_values.data_flags.busy = "0"b ;	/* set file not data_flags.busy? */
	if optionsx.option_bit.i then
	     gtss_file_values.attributes.attr = optionsx.user_specified_attributes;
	else
	gtss_file_values.attributes.attr = "0"b;
	gtss_file_values.data_flags.null_file = "1"b;
	gtss_file_values.data_fields.number_allocations = 0;
	string (date_val) = date ();
	gtss_file_values.creation_date = mm||dd||yy;

	call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	if code ^= 0 then do;
	     call could_not_create_file ("1"b, "400500"b3); /* Could not access file. */
	     return;
	end;

/**	Following check not in use by GCOS.
	if optionsx.option_bit.c = "0"b then
	     status_word.status = "402600"b3;
	else
**/
	if optionsx.option_bit.d then
	     status_word.status = "403100"b3;
	else
	status_word.status = "400000"b3;
	return;

/**	(CF) Create File Declarations.	**/

dcl 1 CF_args		aligned based(arg_ptr)
,     3 word1
,       4 file_name_in_bcd	fixed bin(17)unal	/* -1 => file name in BCD.*/
,       4 L_arglist		bit(18)unal
,     3 word2
,       4 CF_function_no	fixed bin(17)unal
,       4 L_buffer		bit(18)unal
;

dcl 1 CF_arglist		aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	bit(18)unal
,       4 zero		bit(18)unal
,     3 word2
,       4 L_cat_filedescr	bit(18)unal
,       4 L_permissions	bit(18)unal
,     3 word3
,       4 L_options		bit(18)unal
,       4 zero2		bit(18)unal
;

%include gtss_filact_intp1;

%include gtss_filact_intp2;

%include gtss_filact_intp3;

%include gtss_filact_intp5;

could_not_create_file: proc (df, rsc);

/* Could not create gcos file. */
dcl  df                       bit(1)parm;
dcl  rsc                      bit(18)parm;
	     if df then
		call hcs_$delentry_file (
		gtss_file_values.dname
		, gtss_file_values.new_ename
		, (code)				/* Don't set. */
		);
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = rsc;
	     return;
	end					/* could_not_create_file */;

get_options: proc (cfua, L_options, n);

/**	Isolate the options list.
	Variables "options_ptr" and "now" set.
**/
dcl  cfua                     bit(1)parm	/* "1"b => Check that user attributes word available. */;
dcl  L_options                bit(18)parm;
dcl  n                        fixed bin parm	/* = now global veriable. */;

	     options_ptr = null ();
	     n = 0;
	     mnw = fixed (L_options, 18)+3;		/* min word offset for options structure. */

/**	Obtain options. **/
	     if					/* (L_options < low_b) | */
	     (mnw > high_i) then goto return_err4;
	     options_ptr = addrel (gseg, L_options);

	     do now = 0 by 1;
		if optionsx.end_of_list = -1 then do;
		     if cfua then
			if optionsx.option_bit.i then /* Verify user attributes within memory. */
			     if (mnw+ (now*3)+1)>high_i then goto return_err4;
		     n = now;
		     return;
		end;
		if (mnw+ ((now+1)*3))>high_i then goto return_err4;
	     end;

dcl  mnw                      fixed bin(24);
	end					/* get_options */;


/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit72                    bit(72)aligned based;
dcl  bit_count                fixed bin (24);
dcl  block_factor             fixed bin;
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  date                     builtin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  fcb_ptr                  ptr;
dcl  file_name_in_ascii       bit(1);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gsc                      bit(18);
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin;
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msf_manager_$acl_add     entry (ptr, ptr, fixed bin, fixed bin(35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$open        entry (char(*), char(*), ptr, fixed bin(35));
dcl  msp                      float bin;
dcl  multics_access_mode      bit(3);
dcl  nic                      fixed bin(24);
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  sbc                      fixed bin(24);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  sptr                     ptr;
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  translate                builtin;
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 date_val,
      2 yy char(2)unal,
      2 mm char(2)unal,
      2 dd char(2)unal;

dcl 1 segment_acl_space (max_options) like segment_acl;

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl  1 status_word		aligned based(status_ptr)
,      3 status		bit(18)unal
,      3 pd		bit(18)unal
,      3 null_bit		bit(01)unal
,      3 user_attributes	bit(35)unal
;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include gtss_filact_options;

%include gse_ext_;

%include gtss_db_names;
     end						/* gtss_filact_funct03_ */;
   



		    gtss_filact_funct04_.pl1        12/11/84  1354.3rew 12/10/84  1027.5      150885


/* *************************************************************
   *                                                           *
   * Copyright, (C) Honeywell Information Systems Inc., 1984   *
   *                                                           *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *                                                           *
   ************************************************************* */

gtss_filact_funct04_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/* *	Derail FILACT function 04 (AF - Access File).

   All parameters are input parameters except code.

   code retuurned 0 => Successful.
   code returned 4 => GCOS err4 (see gtss_pnterr structure).
   code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 db_ debug switch.
   Change:  Dave Ward	08/14/79 does not exist return.
   Change:  Dave Ward	08/31/79 ret status from ascii_file_name.
   Change:  Paul Benjamin     09/26/79 "Permissions denied" in lower half of 1st status word
   Change:  Bob Alvarado	10/25/79 added check to aft, files cannot be accessed if already busy.
   Change:  Mel Wilson	11/20/79  Reworked optimized hash function eliminating overflow with BCD name
   Change:  Paul Benjamin	11/27/79 to call gtss_expand_pathname_$verify_umc
   Change:  Bob Alvarado	12/14/79 Re-coded the check to the aft, files
   cannot be accessed if already busy.
   Change:  Mel Wilson	01/18/80 Changed busy-in-aft check to use modified mcfc
   Change:  Bilal Qureshi     80 02 12  if any file is grown, it is reflected in aft.
   Change:  Sandy Bartlet	80 03 14  move verify_umc to correct place
   Change:  Bilal Qureshi     80 02 12  to pass file size in blocks instead of links.
   Change:  Bilal Qureshi	80 03 24  call gtss_expand_pathname_$verify instead of gtss_expand_pathname_
   Change:  Dave Perks	80 04 18	handle temp files properly.
   Change:  Sandy Bartlet	80 05 22  handle pd properly.
   Change:  Sandy Bartlet	80 06 10	size = 0 if current_size > 16383 llinks.
   Change:  Bilal Qureshi	80 08 28  while setting runtime attributes structure for ios also set
   gtss_file_attributes.descriptor.fill to "0"b.
   Change:  R. Barstad        82-06-10  removed stringsize condition by inserting substr function in arglist of call put_in_aft
   Change:  R. Barstad	84-02-17  Fixed resave of file in sub-cat giving busy message
                                        fixed condition where file removed from aft but not closed
   * */
%page;
dcl  mcp_val ptr parm;
dcl  high_val bit (18)parm;
dcl  gseg_val ptr parm;
dcl  arg_ptr_val ptr parm;
dcl  buffer_ptr_val ptr parm;
dcl  code fixed bin (35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	status, code = 0;				/* Successful. */
	mc.regs.a = "0"b;				/* Clear the A register. */

/* *	Obtain access file arglist. */
	if					/* (AF_args.L_arglist < low_b) | */
	((fixed (AF_args.L_arglist, 18) +2) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, AF_args.L_arglist);

/* *	Obtain return status.	* */
	call validate_status (AF_arglist.L_status_return, status_ptr);

/* *	Obtain permissions.		* */
	if					/* (AF_arglist.L_permissions < low_b) | */
	(AF_arglist.L_permissions > high_b) then goto return_err4;
	permissions_ptr = addrel (gseg, AF_arglist.L_permissions);

	access_mode = permissions.read ||
	     permissions.write ||
	     permissions.append ||
	     permissions.execute ||
	     permissions.test ||
	     permissions.query;
	if access_mode = "0"b then
	     access_mode = "000001"b;			/* zero req. permissions defaults to query */

	if AF_args.L_altname ^= "0"b then do;		/* Altname is available. */
	     if AF_args.L_altname > high_b then
		goto return_err4;			/* 2 word altname not within memory. */
	     altnp = addrel (gseg, AF_args.L_altname);	/* Set pointer to altname. */
	     if altnp -> bit36 = "0"b then goto no_altname;
						/* There is an altname. */
	     altnl = search (altn8, " ")-1;
	     if altnl = -1 then altnl = length (altn8);


	     file_name_in_ascii = "0"b;		/* Name is in BCD. */
	end;
	else
no_altname:
	file_name_in_ascii = "1"b;

	if get_ascii_file_name (
	file_name_in_ascii
	, AF_arglist.L_cat_filedescr
	, addr (ascii_cat_file)
	, status_word.status
	) then do;
	     if status_word.status = "4034"b3 then
		status_word.status = "4000"b3;
	     else goto could_not_open;
	end;

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , code
	     );
	if code ^= 0 then return;


	if file_name_in_ascii then			/* => There was not an altname. */
	     call put_in_aft
                   ((substr((ascii_cat_file.name (ascii_cat_file.nn)),1,8)));
	else call put_in_aft ((altn));
	if substr (status_word.status, 2, 11) ^= "0"b then
	     goto could_not_open;

	gtss_file_values.version = 1;
	gtss_file_values.change_name = "0"b;
	gtss_file_values.new_ename = " ";

	call gtss_attributes_mgr_$get (addr (gtss_file_values), code);
	if code ^= 0 then do;
	     if code = error_table_$no_dir | code = error_table_$noentry
	     then call gtss_expand_pathname_$verify_umc (
		addr (ascii_cat_file)
		, gtss_file_values.dname
		, gtss_file_values.ename
		, status_word.status
		, code
		);
	     else status_word.status = gtss_filact_error_status_ (code);
	     goto could_not_open;
	end;

	gtss_file_values.set_switch = "0"b;
	gtss_file_values.set_switch.number_allocations = "1"b;
	gtss_file_values.data_fields.number_allocations = 1; /* Increment by one. */
	call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	if code ^= 0 then do;
	     status_word.status = gtss_filact_error_status_ (code);
	     goto could_not_open;
	end;

	if gtss_file_values.catalog then do;
	     code = error_table_$not_seg_type;
	     status_word.status = "4005"b3;
	     goto could_not_open;
	end;

/* *	Set runtime attributes structure for ios. * */
	gtss_file_attributes_ptr = addr (gtss_tfa_ext_$file_attributes.temp_file (file_no));
	gtss_file_attributes.max_size = gtss_file_values.data_fields.maxll;
	gtss_file_attributes.current_size = gtss_file_values.data_fields.curll;
	gtss_file_attributes.user_attributes.non_null = ^gtss_file_values.data_flags.null_file;
	gtss_file_attributes.user_attributes.user_attr = gtss_file_values.attributes.attr;
	gtss_file_attributes.descriptor.device_type = "64"b3; /* => disk. */
	if gtss_file_values.data_flags.mode_random then
	     gtss_file_attributes.descriptor.words_block = "0100"b3; /* 64 (100oct) words per block. */
	else
	gtss_file_attributes.descriptor.words_block = "0500"b3; /* 320 (500oct) words per block. */
	gtss_file_attributes.descriptor.llink_flag = "1"b; /* size is in llinks (320words) */
	gtss_file_attributes.descriptor.mode = gtss_file_values.data_flags.mode_random | (AF_arglist.random_linked ^= "0"b);
	gtss_file_attributes.descriptor.perm = "1"b;	/* Permanent file. */
	gtss_file_attributes.descriptor.fill = "0"b;
	call gtss_adjust_size_ (gtss_file_attributes_ptr);

	call gtss_ios_open_ (
	     file_no
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , access_mode
	     , (gtss_file_attributes.descriptor.mode)
	     , gtss_file_attributes_ptr
	     , addr (status_word)
	     , code);
	if addr (status_word) -> bit12 ^= "4000"b3 then do;
could_not_open: ;
	     call gtss_aft_$delete (aft_name, file_no, aft_code);
	     if status_word.status = "4000"b3 then
		status_word.status = gtss_filact_error_status_ (code);
	     if status_word.pd = "0"b then status_word.pd = get_faulty_cat_file_entry ();
	     if code ^= error_table_$noentry then
		if db_filact_funct04 then
		     call com_err_ (
		     code
		     , "gtss_filact_funct04_"
		     , "AFT (^i) ""^a"" gtss_ios_open_ status ^w"
		     , file_no
		     , aft_name
		     , status_word
		     );
	     goto ret;
	end;

	status_word.status = "400000"b3;		/* set status as ok */
	mc.regs.a = unspec (gtss_file_attributes.descriptor);
	status_word.null_bit = gtss_file_attributes.user_attributes.non_null; /* set null bit */
	status_word.user_attributes = gtss_file_attributes.user_attributes.user_attr; /* set attribute word */
ret:
	if db_filact_funct04 then
	     call ioa_ ("filact_funct04 return status ^6o^6o", status_word.status, status_word.pd);
	return;

%page;
/* *	Access File Declarations.	* */
dcl  altnp ptr init (null ());
dcl  altnl fixed bin (24);
dcl  altn8 char (8)based (altnp);
dcl  altn char (altnl)based (altnp);
dcl  file_name_in_ascii bit (1);
dcl  bit72 bit (72)aligned based;
dcl  bit36 bit (36)aligned based;
dcl  nic fixed bin (24);

dcl 1 AF_args aligned based (arg_ptr)
     , 3 word1
     , 4 L_altname bit (18)unal
     , 4 L_arglist bit (18)unal
     , 3 word2
     , 4 AF_function_no fixed bin (17)unal
     , 4 L_buffer bit (18)unal
     ;

dcl 1 AF_arglist aligned based (arglist_ptr)
     , 3 word1
     , 4 L_status_return bit (18)unal
     , 4 random_linked bit (18)unal
     , 3 word2
     , 4 L_cat_filedescr bit (18)unal
     , 4 L_permissions bit (18)unal
     ;
%page;
%include gtss_filact_intp1;
%page;
%include gtss_filact_intp2;
%page;
%include gtss_filact_intp3;
%page;
put_in_aft: proc (n);

/* *	Put name n in aft (or return from derail).
   * */
dcl  n char (8)parm;
	     call gtss_aft_$add (
		n
		, file_no
		, code
		);

	     if code = 1 then do;			/* name already in aft */

/* *	Make sure permissions that user is asking for are a subset of those
   he already has. */
		status_word.status = "403700"b3;	/* File in aft */
		gtss_file_attributes_ptr = gtss_disk.attributes_ptr (file_no);
		call gtss_adjust_size_ (gtss_file_attributes_ptr);
		mc.regs.a = unspec (gtss_file_attributes.descriptor);
		status_word.null_bit = gtss_file_attributes.user_attributes.non_null; /* set null bit */
		status_word.user_attributes = gtss_file_attributes.user_attributes.user_attr; /* set attribute word */
		if ((access_mode & gtss_disk (file_no).access_mode) = "0"b)
		& ^(substr (access_mode, 6, 1) & substr (gtss_disk (file_no).access_mode, 1, 1))
		then
		     status_word.pd = "400300"b3;	/* But permission denied */
						/* Put 400300 in LOWER HALF of status word */
		if db_filact_funct04 then
		     call ioa_ ("""^a"" Req. access ^b   AFT access ^b", n, access_mode, gtss_disk (file_no).access_mode);
		goto ret;
	     end;

	     if code = 2 then do;			/* aft full */
		status_word.status = "403600"b3;
		goto ret;
	     end;
	     aft_name = n;				/* Record last name placed in aft. */
	     return;

	end put_in_aft;
%page;
/* * Declarations for gtss_drl_filact_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  access_mode bit (6);
dcl  addr builtin;
dcl  addrel builtin;
dcl  aft_code fixed bin (35);
dcl  aft_name char (8);
dcl  altname char (8) aligned based (altname_ptr);
dcl  altname_ptr ptr init (null ());
dcl  arglist_ptr ptr init (null ());
dcl  arg_ptr ptr init (null ());
dcl  attribute_segment_ptr ptr init (null ());
dcl  bit builtin;
dcl  bit12 bit (12)aligned based;
dcl  cat_filedescr_name_offset bit (18);
dcl  descriptor_ptr ptr init (null ());
dcl  entry_name char (12) init (" ");
dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$no_dir fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin (35)ext;
dcl  file_no fixed bin (24);
dcl  fixed builtin;
dcl  FMS_block_ptr ptr init (null ());
dcl  gseg ptr init (null ());
dcl  high_b bit (18)aligned;
dcl  high_i fixed bin (18)aligned;
dcl  i fixed bin (24);
dcl  ioa_ entry options (variable);
dcl  length builtin;
dcl  low_i fixed bin (18)aligned static int options (constant)init (100);
dcl  null builtin;
dcl  p ptr init (null ());
dcl  rings (3) fixed bin (3) static int options (constant)init (4, 4, 4);
dcl  rtrim builtin;
dcl  search builtin;
dcl  smc_entry_ptr ptr init (null ());
dcl  status fixed bin (24);
dcl  status_ptr ptr init (null ());
dcl  string builtin;
dcl  substr builtin;
dcl  translate builtin;
dcl  two_words bit (72) based;
dcl  unspec builtin;
dcl  verify builtin;
dcl  words380 bit (13680)aligned based;
%page;
/* * Structures:	* */

dcl 1 status2 aligned based (status_ptr)
     , 3 word1
     , 4 status_code bit (12)unal
     , 4 zero1 bit (06)unal
     , 4 zero2 bit (18)unal
     , 3 word2
     , 4 L_bcd_message bit (18)unal
     , 4 message_words fixed bin (17)unal
     ;

dcl 1 bcdname aligned based (p),
    2 first8 bit (48)unal,
    2 last4 bit (24)unal;


dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;
%page;
%include gtss_tfa_ext_;
%page;
%include gtss_dfd_ext_;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_ext_;
%page;
%include gtss_filact_status;
%page;
%include gtss_pnterr;
%page;
%include mc;
%page;
%include gtss_entry_dcls;
%page;
%include gtss_ascii_file_names;
%page;
%include gtss_file_values;
%page;
%include gtss_FMS_catalog;
%page;
%include status_info;
%page;
%include gtss_filact_options;
%page;
%include gse_ext_;
%page;
%include gtss_db_names;
     end						/* gtss_filact_funct04_ */;
   



		    gtss_filact_funct05_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      151983


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct05_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 05 (Special Access To Subroutine Library).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Dave Ward	01/08/80 setting gtss_ext_$drm_path.

**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain the argument list. **/
	if					/* (filact_args.arglist_address < low_b) | */
	(fixed (filact_args.arglist_address, 18)+2 > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, filact_args.arglist_address);

	call validate_status (lib_arglist.status_address, status_ptr); /* and also status word */

/*	Set pointer to ascii name. */
	if					/* (filact_args.altname_address < low_b) | */
	(filact_args.altname_address > high_b) then goto return_err4; /* ascii name out of memory. */
	altname_ptr = addrel (gseg, filact_args.altname_address);
	call gtss_aft_$add (ascii_name, file_no, code);

	if code = 1 then do;			/* name already in aft */
	     status_word.status = "403700"b3;		/* file in aft */
ret:	     ;
	     return;
	end;

	if code = 2 then do;			/* aft full */
	     status_word.status = "403600"b3;
	     goto ret;
	end;

dummy_label: ;					/* Get directory where code is currently executing. */
	me_ptr = codeptr (dummy_label);
	call hcs_$fs_get_path_name (me_ptr,
	     installation_directory,
	     0,
	     "",
	     code);
	if code ^= 0 then do;
	     call com_err_ (code, "gtss_filact_funct05_",
		"Can not obtain directory containing L* library.");
	     go to no_lib_available;
	end;

	if (lib_arglist.file_code = "4354"b3) then do;	/* 4354oct = L* */
	     gtss_ext_$drm_path, lib_dir_name = installation_directory;
	     lib_entry_name = gtss_install_values_$Lstar_msf;
	end;
	else
	if (lib_arglist.file_code = "5443"b3) then do;	/* 5443oct = *L */
	     gtss_ext_$drm_path, lib_dir_name = installation_directory;
	     lib_entry_name = gtss_install_values_$starL_msf;
	end;
	else do;
no_lib_available: ;
	     call gtss_aft_$delete (ascii_name, file_no, aft_code);
	     status_word.status = "400500"b3;
	     goto ret;
	end;

	if lib_entry_name = " " then goto no_lib_available;

	status_word.status = "400000"b3;		/* set status as ok */

/**	Obtain the library file. **/
	if lib_arglist.mode then do;			/* Access the library as a random file. */
	     gtss_file_values.version = 1;
	     gtss_file_values.change_name = "0"b;
	     gtss_file_values.dname = lib_dir_name;
	     gtss_file_values.ename = lib_entry_name;
	     gtss_file_values.new_ename = " ";

	     call gtss_attributes_mgr_$get (addr (gtss_file_values), code);
	     if (code ^= 0) | gtss_file_values.catalog then do;
		call gtss_aft_$delete (ascii_name, file_no, aft_code);
		call gtss_abort_subsystem_ (
		     mcp
		     , "gtss_drl_filact_"
		     , 4
		     , "Could not establish attributes for lib (^a)."
		     , ascii_name
		     );
		goto ret;
	     end;

/**	Set runtime attributes structure for ios. **/
	     gtss_file_attributes_ptr = addr (gtss_tfa_ext_$file_attributes.temp_file (file_no));
	     gtss_file_attributes.max_size = gtss_file_values.data_fields.maxll;
	     gtss_file_attributes.current_size = gtss_file_values.data_fields.curll;
	     gtss_file_attributes.user_attributes.non_null = ^gtss_file_values.data_flags.null_file;
	     gtss_file_attributes.user_attributes.user_attr = gtss_file_values.attributes.attr;
	     gtss_file_attributes.descriptor.device_type = "64"b3; /* => disk. */
	     gtss_file_attributes.descriptor.words_block = "0500"b3; /* 320 (500oct) words per block. */
	     gtss_file_attributes.descriptor.llink_flag = "1"b; /* size is in llinks (320words) */
	     gtss_file_attributes.descriptor.mode = gtss_file_values.data_flags.mode_random;
	     gtss_file_attributes.descriptor.perm = "1"b; /* Permanent file. */
	     gtss_file_attributes.descriptor.size = bit (fixed (gtss_file_values.data_fields.curll, 14)); /* Size in llinks */

	end;
	else do;					/* Linked library file. */
	     call gtss_aft_$delete (ascii_name, file_no, aft_code);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_filact_"
		, 4
		, "Linked subroutine libraries not implemented (^a)."
		, ascii_name
		);
	     goto ret;
	end;

	if code ^= 0 then
	     if (code ^= error_table_$namedup) & (code ^= error_table_$segknown) then
		goto no_lib_available;

	call gtss_ios_open_ (
	     file_no
	     , lib_dir_name
	     , lib_entry_name
	     , "100000"b				/* Read. */
	     , "1"b				/* Only random libraries currently allowed. */
	     , gtss_file_attributes_ptr
	     , addr (status_word)
	     , code
	     );
	if status_word.status ^= "400000"b3 then do;
	     call com_err_ (
		code
		, "gtss_filact_funct05_"
		, "ios open status = ^4o"
		, status_word.status
		);
	     call gtss_aft_$delete (
		ascii_name
		, file_no
		, aft_code
		);
	     goto ret;
	end;

	code = 0;
	goto ret;


%include gtss_filact_intp1;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  ascii_name               char(8) based(altname_ptr);
dcl  lib_dir_name             char(168);
dcl  lib_entry_name           char(32);
dcl  p                        ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$fs_get_path_name	entry (ptr, char(*), fixed bin, char(*), fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  installation_directory	char(168);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  me_ptr	ptr init(null());
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;

/** Structures:	**/
dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;

%include gtss_tfa_ext_;

%include gtss_dfd_ext_;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_install_values_;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include acls;

%include gtss_filact_options;

%include gtss_db_names;
     end						/* gtss_filact_funct05_ */;
 



		    gtss_filact_funct08_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      138645


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct08_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 08 (PURGE CATALOG).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Author:  Robert J. Alvarado	Created	1979
   Change:  Dave Ward	08/31/79 ret status from ascii_file_name.
   Change:  Bob Alvarado	09/27/79 added call to aft_$delete.
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain purge|release catalog arglist. */
	if					/* (Purge_Release_args.L_arglist < low_b) | */
	((fixed (Purge_Release_args.L_arglist, 18) +3) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, Purge_Release_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (Purge_Release_arglist.L_status_return, status_ptr);

	if get_ascii_file_name (
	"0"b
	, Purge_Release_arglist.L_cat_filedescr
	, addr (ascii_cat_file)
	, grc
	) then do;
could_not_purge_release_catalog: ;
	     call bcd_message (
		status2.L_bcd_message
		, status2.message_words
		, buffer_ptr
		, "Could not purge/release file."||rtrim (gtss_file_values.dname)||">"||rtrim (gtss_file_values.ename)
		);
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = grc;		/* Could not access file specified. */
ret:	     ;
	     return;
	end;

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , code
	     );
	if code ^= 0 then goto could_not_purge_release_catalog;
	if gse_ext_$drm_rule = 2 then do;
	     ascii_cat_file.nn = 1;
	     ascii_cat_file.name = "dummy";
	     call gtss_expand_pathname_ (
		addr (ascii_cat_file)
		, dummy_path.dname
		, dummy_path.ename
		, code
		);
	     if dummy_path.ename = gtss_file_values.ename & dummy_path.dname = gtss_file_values.dname then do;
		call gtss_abort_subsystem_ (
		     mcp
		     , "gtss_filact_funct08_"
		     , "400000"b3
		     , "MULTICS:  Attempt to delete working directory.  REQUEST DENIED"
		     );
	     end;
	end;
	directory = rtrim (gtss_file_values.dname)||
	     ">"||
	     rtrim (gtss_file_values.ename);
	sub_catalog = rtrim (gtss_file_values.ename)||">";
	do i = lbound (aft_entry, 1) to hbound (aft_entry, 1);
	     if aft_entry (i).used then do;
		if rtrim (gtss_disk (i).dir_name) = directory |
		index (rtrim (gtss_disk (i).dir_name), sub_catalog)
		^= 0 then do;
		     call gtss_aft_$delete (
			(aft_entry (i).altname)
			, (i)
			, rs
			);
		     if rs ^= 0 then goto could_not_purge_release_catalog;
		end;
	     end;
	end;

	call delete_$path (
	     gtss_file_values.dname
	     , gtss_file_values.ename
	     , "0"b
	     ||"1"b
	     ||"1"b
	     ||"0"b
	     ||"0"b
	     ||"0"b
	     , "gtss_filact_funct08_"
	     , code
	     );
	if code ^= 0 then goto could_not_purge_release_catalog;

	status_word.status = "400000"b3;
	goto ret;

/**	(PC,PF,RF) Purge/Release Catalog/File Declarations.	**/

dcl 1 Purge_Release_args	aligned based(arg_ptr)
,     3 word1
,       4 zero		bit(18)unal
,       4 L_arglist		bit(18)unal
,     3 word2
,       4 Purge_Release_function_no	fixed bin(17)unal
,       4 L_buffer		bit(18)unal
;

dcl 1 Purge_Release_arglist	aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	bit(18)unal
,       4 zero		bit(18)unal
,     3 word2
,       4 L_cat_filedescr	bit(18)unal
,       4 zero		bit(18)unal
;
/** local variables **/
dcl  sub_catalog              char(33)var;
dcl  directory                char(168)var;
dcl  rs                       fixed bin(35);

/*		(MC) Modify Catalog			*/


%include gtss_dfd_ext_;

%include gtss_filact_intp3;


%include gtss_filact_intp2;

%include gtss_filact_intp7;

%include gtss_filact_intp1;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  file_name_in_ascii       bit(1);
dcl  bit72                    bit(72)aligned based;
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  grc                      bit(18)init("400400"b3);
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;

/** Structures:	**/
dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 dummy_path,
2 dname char(168)unal,
2 ename char(032)unal;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include acls;

%include gtss_filact_options;

%include gse_ext_;

%include gtss_db_names;
     end						/* gtss_filact_funct08_ */;
   



		    gtss_filact_funct10_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      123246


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_filact_funct10_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 10 (MC - Modify Catalog).

	All parameters are input parameters except code.

	code returned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Author:  Paul W. Benjamin		10/02/79

   Change:  Paul Benjamin	10/08/79	Enable setting of permissions
   Change:  Paul Benjamin     12/17/79  Deal with propagation acls.
   Change:  Ron Barstad       06/11/82  Fix stringsize condition on pstr
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 fixed bin(18)unsigned unal parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	mem_top = high_val;
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain modify catalog arglist. */
	if (MC_args.L_arglist < mem_bottom) |
	((MC_args.L_arglist +3) > mem_top) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, MC_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (MC_arglist.L_status_return, status_ptr);

	if get_ascii_file_name ("0"b, MC_arglist.L_cat_filedescr, addr (ascii_cat_file)) then do;
could_not_modify_catalog:
	     if substr (status_word.status, 2, 11) = "0"b then
		status_word.status = gtss_filact_error_status_ (code);
	     call bcd_message (
		status2.L_bcd_message
		, status2.message_words
		, buffer_ptr
		, "Could not modify catalog."||rtrim (dname)||">"||rtrim (ename)
		);
	     status_word.pd = get_faulty_cat_file_entry ();
ret:	     ;
	     return;
	end;


	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , dname
	     , ename
	     , code
	     );
	if code ^= 0 then goto could_not_modify_catalog;

/**	Obtain new name (if any).	**/
	if (MC_arglist.L_newname < mem_bottom) |
	(MC_arglist.L_newname+4 > mem_top) then goto return_err4;
	new_name_ptr = addrel (gseg, MC_arglist.L_newname);

	if MC_new_name.newname.left_word ^= (36)"1"b then /* New name desired. */
	     call gtss_bcd_ascii_$lc (
	     addr (MC_new_name.newname)
	     , 12
	     , addr (new_ename)
	     );

	call set_general_permissions;
	call set_specific_permissions;
	if new_ename ^= "" then do;
	     call hcs_$chname_file (dname, ename, ename, new_ename, code);
	     if code ^= 0 then do;
		if code = error_table_$namedup | code = error_table_$segnamedup
		then status_word.status = "401100"b3;
		else status_word.status = "400500"b3;
		goto could_not_modify_catalog;
	     end;
	     old_dir = rtrim (dname) || ">" || ename;
	     new_dir = rtrim (dname) || ">" || new_ename;
	     do i = 1 to 20;
		if aft_entry.used (i) = "1"b then do;
		     if substr (gtss_disk.dir_name (i), 1, length (old_dir)) = rtrim (old_dir) then
			gtss_disk.dir_name (i) = rtrim (new_dir)||substr (gtss_disk.dir_name (1), length (old_dir)+1);
		end;
	     end;
	end;
	status_word.status = "400000"b3;
	return;

set_general_permissions: proc;


/**	Obtain permissions.	**/
	     if MC_arglist.L_permissions = 0 then return;
	     if (MC_arglist.L_permissions < mem_bottom) |
	     (MC_arglist.L_permissions > mem_top) then goto return_err4;
	     pp = addrel (gseg, MC_arglist.L_permissions);
	     if substr (pp -> b36, 1, 18) = (18)"1"b then return;
	     a = empty ();
	     call hcs_$list_dir_acl (
		dname
		, ename
		, gtss_ext_$hcs_work_area_ptr
		, da_ptr
		, null ()
		, acl_count
		, code
		);
	     if code ^= 0 then goto could_not_modify_catalog;
	     if pp -> fb18 = 0 then			/* Delete general permissions. */
		do i = 1 to acl_count;
		if index (da_name (i), ".*.g") ^= 0 then do; /* Found propagation acl, delete it. */
		     del_name = da_name (i);
		     call hcs_$delete_dir_acl_entries (
			dname
			, ename
			, addr (delete_acl)
			, 1
			, code
			);
		     if code ^= 0 then goto could_not_modify_catalog;
		     i = acl_count;
		end;
	     end;
	     else

/* => Set specific general permissions. */
	     do i = 1 to acl_count;
		if index (da_name (i), ".*.g") ^= 0 then do; /* Replace acl if propagation acl found. */
		     pstr = substr(char (pp -> b36),1,10);
		     da_name (i) = pstr||".*.g";
		     call hcs_$replace_dir_acl (
			dname
			, ename
			, da_ptr
			, acl_count
			, "1"b
			, code
			);
		     if code ^= 0 then goto could_not_modify_catalog;
		     i = acl_count;
		end;
		else if i = acl_count then do;	/* Add propagation acl if not found. */
		     pstr = substr(char (pp -> b36),1,10);
		     access_name = pstr||".*.g";
		     modes = "0"b;
		     status_code = 0;
		     call hcs_$add_dir_acl_entries (
			dname
			, ename
			, addr (dir_acl)
			, 1
			, code
			);
		     if code ^= 0 then goto could_not_modify_catalog;
		end;
	     end;
	     return;

dcl  acl_count fixed bin;
dcl  a area (255*1024) based (gtss_ext_$hcs_work_area_ptr);
dcl  pp ptr;
dcl  fb18 fixed bin (18)unsigned unal based;
dcl  b36 bit (36)aligned based;
dcl  pstr char (10);

dcl 1 delete_acl,
    2 del_name char (32),
    2 status_code2 fixed bin (35);

dcl 1 dir_acl,
    2 access_name char (32),
    2 modes bit (36),
    2 status_code fixed bin (35);

dcl  da_ptr ptr;

dcl 1 da_array (acl_count) based (da_ptr),
	2 da_name char(32),
	2 da_modes bit(36),
	2 da_code fixed bin(35);
	end					/* set_general_permissions */;

set_specific_permissions: proc;
	     if (L_options<mem_bottom) |
	     ((L_options+2)>mem_top) then goto return_err4;
	     op = addrel (gseg, L_options);

/* Determine number of specific user permissions. */
	     do n = 0 by 1 while (end_of_list ^= -1);
		if (L_options + 3 + (3*n))>mem_top then goto could_not_modify_catalog;
	     end;

	     if n < 1 then return;

/* User specific permissions. */
	     acl_count = n;
	     allocate dir_acl set (acl_ptr);
	     acl_count = 0;
	     rp_sw = "0"b;
	     a = empty ();
	     call hcs_$list_dir_acl (
		dname
		, ename
		, gtss_ext_$hcs_work_area_ptr
		, da_ptr
		, null ()
		, da_count
		, code
		);
	     if code ^= 0 then goto could_not_modify_catalog;
	     c = da_count;
	     do k = 1 to n;
		found_sw = "0"b;
		pp = addr (user (k).specific_permission);
		if pp -> b36 ^= (36)"1"b then do;
		     call gtss_bcd_ascii_ (
			addr (user.id (k))
			, 12
			, addr (ascii_id)
			);
		     if pp -> fb18 = 0 then do i = 1 to da_count; /* delete */
			if index (da_name (i), "."||rtrim (ascii_id)||".g") ^= 0 then do;
			     acl_count = acl_count + 1;
			     del_name (acl_count) = da_name (i);
			     i = da_count;
			end;
		     end;
		     else do i = 1 to c;		/* Replace */
			if index (da_name (i), "."||rtrim (ascii_id)||".g") ^= 0 then do;
			     found_sw = "1"b;
			     pstr = substr(char (pp -> b36),1,10);
			     da_name (i) = pstr||"."||rtrim (ascii_id)||".g";
			     rp_sw = "1"b;
			     i = c;
			end;
		     end;
		     if pp -> fb18 ^= 0 & found_sw = "0"b then do;
			da_count = da_count + 1;
			pstr = substr(char (pp -> b36),1,10);
			da_name (da_count) = pstr||"."||rtrim (ascii_id)||".g";
			da_modes (da_count) = "0"b;
			rp_sw = "1"b;
		     end;
		end;
	     end;
	     if rp_sw = "1"b then do; /* If replacing then do that first. */
		call hcs_$replace_dir_acl (
		     dname
		     , ename
		     , da_ptr
		     , da_count
		     , "1"b
		     , code
		     );
		if code ^= 0 then goto could_not_modify_catalog;
	     end;
	     if acl_count ^= 0 then do; /* If deleting then do that now. */
		call hcs_$delete_dir_acl_entries (
		     dname
		     , ename
		     , acl_ptr
		     , acl_count
		     , code
		     );
		if code ^= 0 then goto could_not_modify_catalog;
	     end;
	     free dir_acl;
	     return;

dcl a area(1000) based (gtss_ext_$hcs_work_area_ptr);

dcl da_ptr ptr;

dcl da_count fixed bin;

dcl 1 da_array (da_count) based (da_ptr),
     2 da_name char(32),
     2 da_modes bit(36),
     2 da_code fixed bin(35);
dcl  acl_count                fixed bin;
dcl  acl_ptr                  ptr init(null());
dcl  ascii_id                 char(12);
dcl  b36                      bit(36)aligned based;
dcl  c                        fixed bin;
dcl  fb18                     fixed bin(18)unsigned unal based;
dcl  found_sw		bit(1);
dcl  k                        fixed bin;
dcl  n                        fixed bin(24);
dcl  op                       ptr;
dcl  pp                       ptr;
dcl  pstr		char(10);
dcl  rp_sw		bit(1);

dcl 1 option_args aligned based(op)
,     2 word1
,       3 opt (0:35)bit(1)unal
,     2 word2
,       3 initial_size fixed bin(18)unsigned unal
,       3 max_size     fixed bin(18)unsigned unal
,     2 user (n)
,       3 id           bit(72)
,       3 specific_permission bit(36)
,     2 end_of_list    fixed bin(35)
,     2 user_attributes bit(36)
;

dcl 1 delete_acl  (acl_count) aligned based(acl_ptr),
      2 del_name char(32),
      2 status_code2 fixed bin(35);

dcl 1 dir_acl (acl_count)aligned based(acl_ptr),
      2 access_name char(32),
      2 modes       bit(36),
      2 status_code fixed bin(35);
	end					/* set_specific_permissions */;

/**	(MC) Modify Catalog Declarations.	**/
dcl  new_name_ptr             ptr init(null());

dcl 1 MC_new_name		aligned based(new_name_ptr)
,     3 newname
,         4 left_word	bit(36)
,         4 right_word	bit(36)
,     3 newpassword		bit(72)
;

dcl 1 MC_args		aligned based(arg_ptr)
,     3 word1
,       4 zero		fixed bin(18)unsigned unal
,       4 L_arglist		fixed bin(18)unsigned unal
,     3 word2
,       4 MC_function_no	fixed bin(18)unsigned unal
,       4 L_buffer		fixed bin(18)unsigned unal
;

dcl 1 MC_arglist		aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	fixed bin(18)unsigned unal
,       4 zero		fixed bin(18)unsigned unal
,     3 word2
,       4 L_cat_filedescr	fixed bin(18)unsigned unal
,       4 L_permissions	fixed bin(18)unsigned unal
,     3 word3
,       4 L_options		fixed bin(18)unsigned unal
,       4 L_newname		fixed bin(18)unsigned unal
;

%include gtss_filact_intp3x;

%include gtss_filact_intp7x;


%include gtss_filact_intp2x;

%include gtss_filact_intp1x;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  msf_manager_$acl_replace entry(ptr,ptr,fixed bin,bit(1),fixed bin(35));
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit72                    bit(72)aligned based;
dcl  cat_filedescr_name_offset fixed bin(18)unsigned unal ;
dcl  descriptor_ptr           ptr init(null());
dcl  divide                   builtin;
dcl  dname		char (168) unal;
dcl  ename		char (32) unal;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$segnamedup  fixed bin (35) ext;
dcl  get_system_free_area_ entry returns (ptr);
dcl  gseg                     ptr init(null());
dcl  hcs_$add_dir_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
dcl  hcs_$chname_file	entry (char(*), char(*),char(*),char(*),fixed bin(35));
dcl  hcs_$delete_dir_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
dcl  hcs_$list_dir_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
dcl  hcs_$replace_dir_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35));
dcl  mem_top                  fixed bin(18)unsigned aligned;
dcl  i                        fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  mem_bottom               fixed bin(18)unsigned aligned static int options(constant)init(103);
dcl  mod                      builtin;
dcl  new_ename		char (32) unal init ("");
dcl  nic                      fixed bin(24);
dcl new_dir char(168);
dcl old_dir char(168);
dcl  p                        ptr init(null());
dcl  rel                      builtin;
dcl  status_ptr		ptr init(null());
dcl  substr                   builtin;

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		fixed bin(18)unsigned unal
,     3 word2
,       4 L_bcd_message	bit(18) unal
,       4 message_words	fixed bin(18)unsigned unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;


dcl 1 status_word aligned based (status_ptr),
    2 status bit(18) unal,
    2 pd fixed bin(18)unsigned unal,
    2 null_bit bit (1) unal,
    2 user_attributes bit (35) unal;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_FMS_catalog;

%include gtss_dfd_ext_;

%include gse_ext_;
     end						/* gtss_filact_funct10_ */;
  



		    gtss_filact_funct11_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      180288


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_filact_funct11_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 11 (MF - Modify File).

	All parameters are input parameters except code.

	code returned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Dave Ward	07/13/79 Converted to unsigned fixed bin(18).
			       Corrected options interpretation.
   Change:  Bob Alvarado	09/06/79 changed MF_new_name.name to two words.
   Change:  Dave Ward	09/06/79 Set disk_data for certain file changes.
   Change:  Dave Ward	09/18/79 Return status for dup name.
   Change:  Paul Benjamin     10/01/79 Check status for dup name on same file.
   Change:  Paul Benjamin     12/17/79 ACLs now upper case &
				permissions more closely resemble GCOS.
   Change:  Ron Barstad       02/04/83 fix stringsize error in call to gtss_aft_$find
                                        was trying to pass char(32) in char(8) field
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 fixed bin(18)unsigned unal parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	mem_top = high_val;
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain modify file arglist. */
	if (MF_args.L_arglist < mem_bottom) |
	((MF_args.L_arglist +3) > mem_top) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, MF_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (MF_arglist.L_status_return, status_ptr);

	if get_ascii_file_name ("0"b, MF_arglist.L_cat_filedescr, addr (ascii_cat_file)) then do;
could_not_modify_file: ;
	     status_word.status = "400500"b3;		/* Could not access file specified. */
could_not_modify_status_set: ;
	     call bcd_message (
		status2.L_bcd_message
		, status2.message_words
		, buffer_ptr
		, "Could not modify file."||rtrim (gtss_file_values.dname)||">"||rtrim (gtss_file_values.ename)
		);
	     status_word.pd = get_faulty_cat_file_entry ();
ret:	     ;
	     if fcb_ptr ^= null () then
		call msf_manager_$close (fcb_ptr);
	     return;
	end;

	gtss_file_values.version = 1;
	gtss_file_values.new_ename = " ";
	gtss_file_values.change_name = "0"b;
	gtss_file_values.set_switch = "0"b;

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , code
	     );
	if code ^= 0 then goto could_not_modify_file;

/**	Obtain new name (if any).	**/
	if (MF_arglist.L_newname < mem_bottom) |
	(MF_arglist.L_newname+4 > mem_top) then goto return_err4;
	new_name_ptr = addrel (gseg, MF_arglist.L_newname);

	if MF_new_name.newname.left_word ^= (36)"1"b then do; /* New name desired. */
	     gtss_file_values.change_name = "1"b;
	     call gtss_bcd_ascii_$lc (
		addr (MF_new_name.newname)
		, 12
		, addr (gtss_file_values.new_ename)
		);
	end;

/* Obtain pointer to msf file control block
   (i.e., open the file).
*/
	call msf_manager_$open (
	     gtss_file_values.dname
	     , gtss_file_values.ename
	     , fcb_ptr
	     , code
	     );
	if code ^= 0 then goto could_not_modify_file;

	call set_general_permissions;

	call set_options;

	if gtss_file_values.change_name |
	(unspec (gtss_file_values.set_switch) ^= "0"b) then do;
	     call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	     if code ^= 0 then do;
		if code = error_table_$namedup | code = error_table_$segnamedup then do;
		     status_word.status = "4011"b3;	/* non-unique name. */
		     goto could_not_modify_status_set;
		end;
		goto could_not_modify_file;
	     end;

	     if gtss_file_values.change_name |
	     set_switch.mode_random |
	     set_switch.maxll |
	     set_switch.curll then do;		/* Adjust ios runtime values for the file. */

/* Obtain aft index for the file. */
		aft_name = substr(gtss_file_values.ename,1,8);
		call gtss_aft_$find (
		     aft_name
		     , file_no
		     , ec
		     );
dcl ec fixed bin(35);
		if ec = 0 then do;			/* File name is in aft => change values. */
		     gtss_file_attributes_ptr = gtss_disk (file_no).attributes_ptr;
		     if gtss_file_values.change_name then
			gtss_disk (file_no).entry_name = gtss_file_values.new_ename;
		     if set_switch.mode_random then
			gtss_file_attributes.descriptor.mode,
			gtss_disk (file_no).pat_body.random
			= gtss_file_values.data_flags.mode_random;
		     if set_switch.maxll then
			gtss_file_attributes.max_size
			= gtss_file_values.data_fields.maxll;
		     if set_switch.curll then
			gtss_file_attributes.max_size
			= gtss_file_values.data_fields.curll;
		end;
	     end;
	end;

	status_word.status = "400000"b3;
	goto ret;

set_options: proc;

/* Process options.
*/

	     if (L_options<mem_bottom) |
	     ((L_options+2)>mem_top) then goto return_err4;
	     op = addrel (gseg, L_options);

/* Determine number of specific user permissions. */
	     do n = 0 by 1 while (end_of_list ^= -1);
		if (L_options+3+ (3*n))>mem_top then goto could_not_modify_file;
	     end;

	     if opt (4) then do;			/* New max size. */
		if unspec (max_size) = (18)"1"b then do; /* Set unlimited. */
		     gtss_file_values.set_switch.maxll = "1"b;
		     gtss_file_values.data_fields.maxll = 0;
		end;
		else
		if max_size ^= 0 then do;		/* Set to specified size. */
		     gtss_file_values.set_switch.maxll = "1"b;
		     gtss_file_values.data_fields.maxll = max_size;
		end;
	     end;

	     if opt (8) then do;			/* User attributes. */
		gtss_file_values.set_switch.attr = "1"b;
		gtss_file_values.attributes.attr = substr (user_attributes, 2);
	     end;

	     if opt (9) then do;			/* New mode. */
		gtss_file_values.set_switch.mode_random = "1"b;
		gtss_file_values.data_flags.mode_random = opt (1);
	     end;

	     if n<1 then return;

/* User specific permissions. */
	     acl_count = n;
	     allocate segment_acl set (acl_ptr);

/* Process deletes. */
	     c, d = 0;
	     do k = 1 to n;
		if addr (user (k).specific_permission) -> fb18 = 0 then do;
		     d = d+1;
		     call gtss_bcd_ascii_ (
			addr (user (k).id)
			, 12
			, addr (ascii_id)
			);
		     del_name (d) = "*."||rtrim (ascii_id)||".*";
		end;
	     end;
	     if d>0 then do;			/* There were names to delete. */
		call msf_manager_$acl_delete (
		     fcb_ptr
		     , acl_ptr
		     , d
		     , code
		     );
		if code ^= 0 then do;
		     free segment_acl;
		     goto could_not_modify_file;
		end;

/* Convert acl names not found to be
   add names with null.
*/
		do k = 1 to d;
		     if status_code2 (k) = error_table_$user_not_found then do;
			c = c+1;
			access_name (c) = del_name (k);
			modes (c) = "0"b;
			zero_pad (c) = "0"b;
		     end;
		end;
	     end;

	     if (c>0) | (d<n) then do;

/* Process non-deletes. */
		do k = 1 to n;
		     pp = addr (user (k).specific_permission);
		     if pp -> b36 ^= (36)"1"b then
			if pp -> fb18 ^= 0 then do;
			     c = c+1;
			     call gtss_bcd_ascii_ (
				addr (user (k).id)
				, 12
				, addr (ascii_id)
				);
			     access_name (c) = "*."||rtrim (ascii_id)||".*";
			     modes (c) = get_modes (addr (user (k).specific_permission));
			     if modes (c) = "111111111111111111111111111111111111"b then c = c - 1;
						/* Create permission, forget this one. */
			end;
		end;

		if c>0 then do;
		     call msf_manager_$acl_add (
			fcb_ptr
			, acl_ptr
			, c
			, code
			);
		     if code ^= 0 then do;
			free segment_acl;
			goto could_not_modify_file;
		     end;
		end;
	     end;

	     free segment_acl;
	     return;

dcl  acl_count                fixed bin;
dcl  acl_ptr                  ptr init(null());
dcl  ascii_id                 char(12);
dcl  b36                      bit(36)aligned based;
dcl  c                        fixed bin;
dcl  d                        fixed bin;
dcl  error_table_$user_not_found	fixed bin(35)ext;
dcl  fb18                     fixed bin(18)unsigned unal based;
dcl  k                        fixed bin;
dcl  n                        fixed bin(24);
dcl  op                       ptr;
dcl  pp                       ptr;

dcl 1 optiob_args aligned based(op)
,     2 word1
,       3 opt (0:35)bit(1)unal
,     2 word2
,       3 initial_size fixed bin(18)unsigned unal
,       3 max_size     fixed bin(18)unsigned unal
,     2 user (n)
,       3 id           bit(72)
,       3 specific_permission bit(36)
,     2 end_of_list    fixed bin(35)
,     2 user_attributes bit(36)
;

dcl 1 delete_acl  (acl_count) aligned based(acl_ptr),
      2 del_name char(32),
      2 status_code2 fixed bin(35);

dcl 1 segment_acl (acl_count)aligned based(acl_ptr),
      2 access_name char(32),
      2 modes       bit(36),
      2 zero_pad    bit(36),
      2 status_code fixed bin(35);
	end					/* set_options */;

set_general_permissions: proc;

/* Set general permissions
   => Multics *.*.* access.
*/

/**	Obtain permissions.	**/
	     if MF_arglist.L_permissions = 0 then return;
	     if (MF_arglist.L_permissions < mem_bottom) |
	     (MF_arglist.L_permissions > mem_top) then goto return_err4;
	     pp = addrel (gseg, MF_arglist.L_permissions);
	     if pp -> b36 = (36)"1"b then return;
	     if pp -> fb18 = 0 then do;		/* Delete general permissions. */
		del_name = "*.*.*";
		call msf_manager_$acl_delete (
		     fcb_ptr
		     , addr (delete_acl)
		     , 1
		     , code
		     );
	     end;
	     else do;

/* => Set specific general permissions. */
		access_name = "*.*.*";
		modes = get_modes (pp);
		status_code = 0;
		if modes ^= "111111111111111111111111111111111111"b then do; /* Ignore create */
		     call msf_manager_$acl_add (
			fcb_ptr
			, addr (segment_acl)
			, 1
			, code
			);
		end;
	     end;
	     if code ^= 0 then goto could_not_modify_file;
	     return;

dcl  pp                       ptr;
dcl  fb18                     fixed bin(18)unsigned unal based;
dcl  b36                      bit(36)aligned based;
dcl  bits                     (0:35)bit(1)unal based;

dcl 1 delete_acl,
      2 del_name char(32),
      2 status_code2 fixed bin(35);

dcl 1 segment_acl,
      2 access_name char(32),
      2 modes       bit(36),
      2 zero_pad    bit(36),
      2 status_code fixed bin(35);
	end					/* set_general_permissions */;

get_modes: proc (pp)returns (bit (36));

/* Interpret GCOS permissions as
   Multics accesses.
*/
dcl  pp                       ptr parm;
	     r = "0"b;
dcl  r			bit(36)unal;
dcl  b                        (0:35)bit(1)unal based;
dcl  b0_9		bit(10) based;
	     if pp -> b0_9 = "0000000010"b then return ("111111111111111111111111111111111111"b);
						/* Create permission doesn't apply to files */
	     if pp -> b (17) then return ("0"b);	/* exclude => null */
	     r = "1"b||pp -> b (3)||pp -> b (1);
	     return (r);
	end					/* get_modes */;

/**	(MF) Modify File Declarations.	**/
dcl  new_name_ptr             ptr init(null());

dcl 1 MF_new_name		aligned based(new_name_ptr)
,     3 newname		
,	4 left_word	bit(36)
,	4 right_word	bit(36)
,     3 newpassword		bit(72)
;

dcl 1 MF_args		aligned based(arg_ptr)
,     3 word1
,       4 zero		fixed bin(18)unsigned unal
,       4 L_arglist		fixed bin(18)unsigned unal
,     3 word2
,       4 MF_function_no	fixed bin(18)unsigned unal
,       4 L_buffer		fixed bin(18)unsigned unal
;

dcl 1 MF_arglist		aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	fixed bin(18)unsigned unal
,       4 zero		fixed bin(18)unsigned unal
,     3 word2
,       4 L_cat_filedescr	fixed bin(18)unsigned unal
,       4 L_permissions	fixed bin(18)unsigned unal
,     3 word3
,       4 L_options		fixed bin(18)unsigned unal
,       4 L_newname		fixed bin(18)unsigned unal
;

%include gtss_filact_intp3x;

%include gtss_filact_intp7x;


%include gtss_filact_intp2x;

%include gtss_filact_intp1x;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  msf_manager_$acl_replace entry(ptr,ptr,fixed bin,bit(1),fixed bin(35));
dcl  msf_manager_$close       entry(ptr);
dcl  msf_manager_$open        entry(char(*),char(*),ptr,fixed bin(35));
dcl  msf_manager_$acl_add     entry(ptr,ptr,fixed bin,fixed bin(35));
dcl  msf_manager_$acl_delete  entry(ptr,ptr,fixed bin,fixed bin(35));
dcl  fcb_ptr                  ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit72                    bit(72)aligned based;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset fixed bin(18)unsigned unal ;
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       fixed bin(18)unsigned unal ;
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$segnamedup  fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_name_in_ascii       bit(1);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  mem_top                  fixed bin(18)unsigned aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  mem_bottom               fixed bin(18)unsigned aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  path_name                char (168) varying;
dcl  permission_word          bit(36)aligned based;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		fixed bin(18)unsigned unal
,     3 word2
,       4 L_bcd_message	bit(18) unal
,       4 message_words	fixed bin(18)unsigned unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;


dcl 1 status_word aligned based (status_ptr),
    2 status bit(18) unal,
    2 pd fixed bin(18)unsigned unal,
    2 null_bit bit (1) unal,
    2 user_attributes bit (35) unal;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include gtss_filact_options;

%include gse_ext_;

%include gtss_db_names;

%include gtss_dfd_ext_;

%include gtss_file_attributes;
     end						/* gtss_filact_funct11_ */;



		    gtss_filact_funct14_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      127521


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct14_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 14 (ZZZZZ).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */
/**	Obtain the argument list. **/
	if					/* (filact_args.arglist_address < low_b) | */
	(fixed (filact_args.arglist_address, 18)+2 > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, filact_args.arglist_address);

	call validate_status (smc_arglist.status_address, status_ptr); /* check status address */

	if (smc_arglist.entry_address > high_b) |
	((fixed (smc_arglist.entry_address, 18) +12) > high_i) then goto return_err4;
	smc_entry_ptr = addrel (gseg, smc_arglist.entry_address); /* set up pointer for the smc area */

	if substr (smc_entry.userid, 1, 36) = minus_one then smc_entry.userid = gtss_ust.lid; /* Get it from his ust */
						/* fill in the non important things with zeros */
	smc_entry.fill1,
	     smc_entry.fill2,
	     smc_entry.fill3,
	     smc_entry.fill4,
	     smc_entry.reserved,
	     smc_entry.fill5 = "0"b;

	ascii_cat_file.nn = 1;
	call gtss_bcd_ascii_$lc (
	     addr (smc_entry.userid)
	     , 12
	     , addr (ascii_cat_file.name (1))
	     );

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , dir_name
	     , entry_name				/* (not used) */
	     , code
	     );
	if code ^= 0 then do;
could_not_get_smc: ;
/**MORE**/
	     status_word.status = "400100"b3;
ret:	     ;
	     return;
	end;

	call hcs_$quota_read (dir_name, quota, trp, tup, sons_lvid, tacc_sw, used, code); /* get info */
	if code ^= 0 then goto could_not_get_smc;
						/* find out about resources used */
	call user_info_$limits (mlim, clim, cdate, crf, shlim, msp, csp, shsp);

	smc_entry.llinks_used = divide ((used * 1024)+319, 320, 24, 0); /* get the llinks in use */
	smc_entry.llinks_allowed = divide ((quota * 1024)+319, 320, 24, 0); /* get max allowed */
	if clim = 1.0e37 then			/* set to some max if none given */
	     smc_entry.resources = max_resources;

	else
	smc_entry.resources = fixed (clim*100, 17);	/* get the dollar amount allowed */
	smc_entry.resources_used = fixed (csp*100, 25);	/* get the amount used */
						/* fill in some default values */
	smc_entry.lodx,
	     smc_entry.cardin,
	     smc_entry.talk,
	     smc_entry.lods = "1"b;
	smc_entry.urgency = "0400"b3;			/* bcd 40 for urgency */
						/* blank out the password area */
	smc_entry.password = (12)"20"b3;		/* BCD blank the password. */

	goto ret;


%include gtss_filact_intp1;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  file_name_in_ascii       bit(1);
dcl  bit72                    bit(72)aligned based;
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit_count                fixed bin (24);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;

/** Structures:	**/
dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include acls;

%include gtss_filact_options;

%include gtss_db_names;
     end						/* gtss_filact_funct14_ */;
   



		    gtss_filact_funct18_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      244440


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct18_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 18 (Get Current).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned othr => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Bob Alvarado	08/08/79 reworked gcos_catalog proc.
   Change:  Dave Ward	08/31/79 ret status from ascii_file_name.
   Change:  Paul Benjamin     09/12/79 reinit deferred_catalog.nl to zero.
   Change:  Paul Benjamin	10/25/79 change status returned when expand_path says some directory non-existent
   Change:  Paul Benjamin	10/29/79 return "DSK" as device_name, and fill in some catalog information
   Change:  Paul Benjamin     11/05/79 Fix bug when doing cata when need both type1 and type 4 records
   Change:  Paul Benjamin	12/17/79 Interpret propagation acls.
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain get current catalog or file arglist. */
	if					/* (Get_Current_args.L_arglist < low_b) | */
	((fixed (Get_Current_args.L_arglist, 18) +1) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, Get_Current_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (Get_Current_arglist.L_status_return, status_ptr);

	if get_ascii_file_name (
	"0"b
	, Get_Current_arglist.L_cat_filedescr
	, addr (ascii_cat_file)
	, grc
	) then do;
could_not_get_current_file: ;
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = grc;		/* Could not access file specified. */
	     return;
	end;

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , gtss_file_values.dname
	     , gtss_file_values.ename
	     , code
	     );
	if code ^= 0 then
	     goto could_not_get_current_file;

/**	Return catalog or file FMS description in caller's buffer. **/

	FMS_cat_ptr = addr (callers_buffer.W43_FSBFER);
	Get_Current_arglist.L_record = rel (FMS_cat_ptr);

	Get_Current_arglist.device_name = "246242"b3;	/* DSK */

	gtss_file_values.version = 1;

	call gtss_attributes_mgr_$get (addr (gtss_file_values), code);
	if code ^= 0 then do;
	     if code = error_table_$no_dir then grc = "400100"b3;
	     goto could_not_get_current_file;
	end;
	info_ptr = gtss_file_values.info_ptr;

	if gtss_file_values.catalog then call gcos_catalog;
	else call gcos_file;

	code = 0;
	status_word.status = "400000"b3;
	return;


store_temp_name: proc (c, n);

/**	Store name (n) in compact name list, of type (c).
**/
dcl  c                        bit(1)parm;
dcl  n                        char(*)parm;

	     deferred_catalog.cat = c;
	     deferred_catalog.rec_type = 2;		/* => FMS file description record (to result). */
	     deferred_catalog.nl = length (n);
	     deferred_catalog.ns = n;
	     deferred_catalog.next_nl = 0;		/* Marks end of list. */
	     def_cat_fill_len = def_cat_fill_len+1+divide (length (n)+3, 4, 17); /* Position to next name available. */
	     return;
	end					/* store_temp_name */;

gcos_catalog: proc;


/**	Accumulate the names of all Multics directories
	as GCOS catalog entries (store in temporary name list).
**/

/**	Initialize compact name list.	**/
	     def_cat_ptr = gtss_ext_$deferred_catalogs_ptr;
	     def_cat_fill_len = 0;
	     deferred_catalog.nl = 0;			/* make sure not to re-cycle old stuff */
	     name_info = empty ();
	     call hcs_$star_ (
		(rtrim (gtss_file_values.dname)||">"||gtss_file_values.ename)
		, "**"				/* All segments and directories. */
		, 3				/* Directories and segments (and links). */
		, addr (name_info)
		, entry_count
		, entry_ptr
		, n_ptr
		, code);
	     if code ^= 0 then do;
		if code = error_table_$nomatch then goto get_files;
star_failed:	;
		call com_err_ (
		     code
		     , "gtss_drl_filact_|function(18)"
		     , "dname=^a ename=^a"
		     , gtss_file_values.dname
		     , gtss_file_values.ename
		     );
		goto could_not_get_current_file;
	     end;

dcl  cat_file_string          bit(cfdl)aligned based;
dcl  cfdl                     fixed bin(35);

/**	Move caller's catalog/file description to the
	deferred catalog store.
**/
	     cfdl = 4*36*ascii_cat_file.nn;
	     deferred_catalog.cat_file_len = ascii_cat_file.nn;
	     addr (deferred_catalog.cat_file) -> cat_file_string =
		addrel (gseg, Get_Current_arglist.L_cat_filedescr) -> cat_file_string;

/**	Calculate total number of names. **/
	     total_names = 0;

get_files:
	     do i = 1 to entry_count;
		total_names = total_names+entries (i).nnames;
	     end;

/** locate gcos file  and catalog entries and store in temporary name list **/
/** this section should be re-written to use gtss_attributes_mgr_ because it is
    sloppy and because it could show a non-gcos msf as a catalog **/
	     do i = 1 to entry_count;
		if entries (i).nnames = 9 then do;	/* if added names not 9 don`t bother checking */
		     do k = entries (i).nindex to entries (i).nindex + entries (i).nnames;
			file_name = names (k);
			ll = search (reverse (file_name), "."); /* find first occurence of . */
			if ll = 0 then goto not_add_name;
			ll = length (file_name) - ll;
			file_name = substr (file_name, 1, ll); /* drop last two chars  */
			ll = search (reverse (file_name), "."); /* find next occurence of . */
			if ll = 0 then goto not_add_name;
			ll = length (file_name) - ll + 2;
			if substr (file_name, ll, 4) = "mode" then do;
			     file_name = substr (file_name, 1, ll-2); /* save name only */
			     call store_temp_name ("0"b, rtrim (file_name));
			     goto next_entry;
			end;			/* end file name entry */
not_add_name:
		     end;				/* end get file name */
		end;
/*  store entry if it is a directory */
		if entries (i).type = "10"b then
		     call store_temp_name ("1"b, rtrim (names (entries (i).nindex)));
next_entry:
	     end;

names_accumulated: ;

	     FSnTYP_0.bits00_05 = "00"b3;		/* => catalog. */
	     call gtss_ascii_bcd_ (
		addr (ascii_cat_file.name (ascii_cat_file.nn))
		, 12
		, addr (FS0_CNM_06_07)
		);
	     FS0_MOD_15 = BCD_date (branch.dtbm);

	     number_of_catalog_entries = 0;
	     cont_ptr = addr (FS0_CBK_04);		/* Location sector number of continuation record. */
	     last_sector_no = 0;

/**	Store names in type 0 record and for up to
	4 type 1 records as is necessary.
**/
	     def_cat_type_1_ptr = addrel (def_cat_ptr, size (deferred_catalog));
	     def_cat_fill_len = 0;
	     do while (deferred_catalog.nl>0);
		call catalog_entry (
		     deferred_catalog.cat
		     , deferred_catalog.ns
		     , rel (addr (deferred_catalog.type2_3))
		     );
		def_cat_fill_len = def_cat_fill_len+1+divide (deferred_catalog.nl+3, 4, 17); /* Next name. */
	     end;
catalog_finished: ;
	     FS0_ORG_10_11 = author (gtss_file_values.dname, gtss_file_values.ename);
	     call get_permissions (
		gtss_file_values.dname
		, gtss_file_values.ename
		, FS0_PER_17.bits00_11
		, FS0_PBK_05.bits00_17
		);
	     return;

catalog_entry: proc (c, n, dsn);

/**	Add name (n) to GCOS catalog record names list.
	Parameter (c)=1 => entry is a catalog | (c)=0 => entry is file.
	Parameter (dsn) is the deferred record sector number.
**/
dcl  c                        bit(1)parm;
dcl  n                        char(*)parm;
dcl  dsn                      bit(18)parm;
		number_of_catalog_entries = number_of_catalog_entries+1;
		if db_filact_funct18 then
		     call ioa_ ("^3i. ^1b ^a", number_of_catalog_entries, c, n);
		if number_of_catalog_entries <= hbound (FS0_VAR_22_76, 1) then do; /* Name for initial catalog record. */
		     FS0_VAR_22_76 (number_of_catalog_entries).FS0_SNM_00_01 = (12)"20"b3;
		     call gtss_ascii_bcd_ (
			addr (n)
			, min (length (n), 12)
			, addr (FS0_VAR_22_76 (number_of_catalog_entries).FS0_SNM_00_01)
			);
		     FS0_VAR_22_76 (number_of_catalog_entries).FS0_SPT_02.bit01 = c;
		     FS0_VAR_22_76 (number_of_catalog_entries).FS0_SPT_02.bits18_35 = dsn;
		end;
		else do;				/* Name for continuation catalog record. */
		     j = number_of_catalog_entries-hbound (FS0_VAR_22_76, 1)-1;
		     i = divide (j, hbound (FS1_VAR_06_76, 1), 17)+1; /* Current sector no. 0,1,... */
		     if i>4 then do;		/* Remaining names provided in deferred type 1 record. */
			cont_ptr -> bit18,		/* Link last type 1 record to 1st llink (deferred type 1 rec). */
			     FS0_NLL_01.bits00_17 = rel (def_cat_type_1_ptr); /* Link type 0 record to 1st llink. */
			def_cat_type_1.cat = "1"b;
			def_cat_type_1.zero = "0"b;
			def_cat_type_1.rec_type = 1;
			def_cat_type_1.sn = dsn;
			goto catalog_finished;
		     end;
		     j = mod (j, hbound (FS1_VAR_06_76, 1))+1; /*  Name index 1,2,...,19 */
		     if j = 1 then do;		/* Another catalog continuation record required. */
			Type_1_ptr = addrel (FMS_cat_ptr, size (Type_0_Catalog)+ ((i-1)*size (Type_1_Catalog)));
			cont_ptr -> bit18 = bit (fixed (i, 18)); /* Sector number (0,1,2,...). */
			cont_ptr = addr (FS1_CBK_04); /* Reset to continuation link. */
			FS1_PTP_03.bits00_17 = last_sector_no;
			last_sector_no = i;
			Type_1_ptr -> FSnTYP_0.bits00_05 = "01"b3; /* => catalog continuation. */
		     end;
		     FS1_VAR_06_76 (j).FS1_SNM_00_01 = (12)"20"b3;
		     call gtss_ascii_bcd_ (
			addr (n)
			, min (length (n), 12)
			, addr (FS1_VAR_06_76 (j).FS1_SNM_00_01)
			);
		     FS1_VAR_06_76 (j).FS1_SPT_02.bit01 = c;
		     FS1_VAR_06_76 (j).FS1_SPT_02.bits18_35 = dsn;
		end;
		return;

dcl  i                        fixed bin;
dcl  j                        fixed bin;
dcl  k                        fixed bin;
	     end					/* catalog_entry */;

dcl  file_name		char(32);
	end					/* gcos_catalog */;

gcos_file: proc;
	     FSnTYP_0.bits00_05 = "02"b3;		/* => file. */
	     call gtss_ascii_bcd_ (addr (ascii_cat_file.name (ascii_cat_file.nn)), 12, addr (FS2_FNM_06_07));
	     FS2_ORG_10_11 = author (gtss_file_values.dname, gtss_file_values.ename);
	     FS2_PWD_12_13 = (12)"20"b3;		/* Password is (BCD) blanks. */
	     call gtss_ascii_bcd_ (addr (gtss_file_values.creation_date), 6, addr (FS2_CDT_14));
	     FS2_MOD_15 = BCD_date (branch.dtbm);
	     call get_permissions (
		gtss_file_values.dname
		, gtss_file_values.ename
		, FS2_PER_17.bits00_11
		, FS2_PBK_05.bits00_17
		);
	     FS2_PER_17.bits18_35 = gfv.maxll18_35;
	     call gtss_ascii_bcd_ (addr (ascii_cat_file.name (1)), 12, addr (FS2_MTR_20_21));
	     FS2_FU1_22.bit01 = gtss_file_values.data_flags.mode_random;
	     FS2_FU1_22.bit04 = "1"b;			/* => Max. file size in llinks. */
	     FS2_FU1_22.bit05 = "0"b;			/* File on structured device (see VAR field). */
	     if gtss_file_values.attributes.attr ^= "0"b then do;
		FS2_FU1_22.bit08 = "1"b;
		FS2_FU1_22.bits12_17 = "64"b3;	/* => Disk. */
		FS2_USI_24.bits01_35 = gtss_file_values.attributes.attr;
	     end;
	     FS2_FU1_22.bits18_35 = gfv.noal18_35;	/* Number of allocations. */
	     FS2_FUS_23.bits30_35 = "05"b3;		/* Sectors in page. */
	     FS2_USI_24.bit00 = ^gtss_file_values.data_flags.null_file;
	     FS2_FU2_25.bit16 = "1"b;			/* Catalog or file on removable device. */
	     FS2_FU2_25.bits18_35 = millsec512 (branch.dtm);
	     FS2_LCD_26 = BCD_date (branch.dtm);
	     FS2_LAD_27 = BCD_date (branch.dtu);
	     FS2_VAR_44_75.Device_descriptor.bits00_03 = "0101"b; /* => device descriptor. */
	     FS2_VAR_44_75.Device_descriptor.bits06_35 = device_name (branch.device_id);
	     FS2_VAR_44_75.Space_descriptor.bit00 = "0"b; /* => Last space device. */
	     FS2_VAR_44_75.Space_descriptor.bit01 = "0"b; /* Differentiates space from device descriptor. */
	     FS2_VAR_44_75.Space_descriptor.bit02 = "0"b; /* Space is NOT defective. */
	     FS2_VAR_44_75.Space_descriptor.bits03_17 = gfv.curll21_35;
	     FS2_VAR_44_75.Space_descriptor.bits18_35 = "0"b; /* Starting llink number. */
	     return;
	end					/* gcos_file */;

device_name: proc (did)returns (bit (30));

/**	Convert Multics divice id to GCOS device name. **/
dcl  did                      bit(4)parm;
/**	Multics does not provide device type.
	     c5 = char (did);
	     call gtss_ascii_bcd_ (addr (c5), 5, addr (bcd5));
	     return (bcd5);
dcl  c5                       char(5);
dcl  bcd5                     bit(30);
**/
	     return ("2431624220"b3);			/* => "DISK " bcd */

	end					/* device_name */;

get_permissions: proc (dn, en, gp, sps);

/**	Obtain GCOS general permissions (gp) from
	Multics segment access for *.*.*.
	Obtain GCOS specific permissions as GCOS catalog
	type 4 (permissions) record from the
	Multics accesses set for particular projects, *.proj.*.
	Set (sps) to appropriate sector (of caller's return buffer catalog records)
	if there are specifiec permissions.
	Ignore all other Multics access.
**/
dcl  dn                       char(*)parm;
dcl  en                       char(*)parm;
dcl  gp                       bit(12)parm;
dcl  sps                      bit(18)parm;

	     acl_ptr = null ();
	     gp = "0"b;
	     sps = "0"b;
	     a = empty ();
	     if gtss_file_values.catalog then do;
		call hcs_$list_dir_acl (
		     dn
		     , en
		     , addr (a)
		     , acl_ptr
		     , null ()
		     , acl_count
		     , code
		     );
		if code ^= 0 then do;
		     call com_err_ (
			code
			, "gtss_drl_filact_|get_permissions",
			"""^a>^a""", dn, en);
		     return;
		end;
	     end;
	     else do;
		call hcs_$list_acl (
		     dn
		     , en
		     , addr (a)
		     , acl_ptr			/* Pointer to start of ACL list. */
		     , null ()			/* Not requesting particular access. */
		     , acl_count			/* Number of access entries on segment. */
		     , code
		     );
		if code ^= 0 then do;
		     if code = error_table_$dirseg then
			call hcs_$list_acl (
			rtrim (dn)||">"||en
			, "0"			/* Use msf 0 component. */
			, addr (a)
			, acl_ptr			/* Pointer to start of ACL list. */
			, null ()			/* Not requesting particular access. */
			, acl_count		/* Number of access entries on segment. */
			, code
			);
		     if code ^= 0 then do;
			call com_err_ (code
			     , "gtss_drl_filact_/get_permissions",
			     """^a>^a""", dn, en);
			return;
		     end;
		end;
	     end;
	     spx = 0;
	     do i = 1 to acl_count;
		if gtss_file_values.catalog then do;
		     if dir_acl.status_code (i) ^= 0 then do;
			call com_err_ (
			     dir_acl.status_code (i)
			     , "gtss_drl_filact_|get_permissions");
			goto next;
		     end;
		     n32 = dir_acl.access_name (i);
		end;
		else do;
		     if segment_acl.status_code (i) ^= 0 then do;
			call com_err_ (
			     segment_acl.status_code (i)
			     , "gtss_drl_filact_|get_permissions");
			goto next;
		     end;
		     n32 = segment_acl.access_name (i);
		end;
						/* Isolate Multics access person, project and tag names. */
		l1 = search (n32, ".");
		l2 = search (reverse (n32), ".");
		if (l1 = 0)| (l2 = 0) then do;
		     call com_err_ (0, "gtss_drl_filact_|get_permissions", "Bad name, ""^a""", n);
		     goto next;
		end;
		l3 = l2-verify (reverse (n32), " ");
		l2 = length (n32)-l2-l1;
		l1 = l1-1;

							/* Ignore lower case acls */
		if n.person = "*" & ^gtss_file_values.catalog & search(n.project,"qwertyuiopasdfghjklzxcvbnm") = 0 then do;
		     string (m) = segment_acl.modes (i);
		     if n.project = "*" then do;	/* => GCOS general permissions. */
			gp = m.read||m.write||"0"b||m.execute;
			goto next;
		     end;
		     spx = spx+1;
		     if spx<23 then do;
			if spx = 1 then do;		/* First specific permission. */
			     if Type_1_ptr = null () then var_ptr = FMS_cat_ptr;
			     else var_ptr = Type_1_ptr;
			     Type_4_ptr = addrel (var_ptr, size (Type_2_Catalog));
			     unspec (Type_4_Catalog) = "0"b;
			     Type_4_ptr -> FMS_catalog = FMS_catalog; /* First 5 words from file record. */
			     FS4_CBK_04 = "0"b;
			     Type_4_ptr -> FSnTYP_0.bits00_05 = "04"b3; /* => permissions. */
			     sps = bit ((fixed (rel (Type_4_ptr), 17, 0)-fixed (rel (FMS_cat_ptr), 17, 0))/64);
			     upp = addr (Type_4_Catalog.FS4_VAR_07_75); /* Pointer to 1st specific permissions name pair. */
			end;

			if mod (spx, 2) = 1 then do;	/* 1st of name pair. */
			     user_permission.n1 = (12)"20"b3; /* 12 bcd blanks. */
			     call gtss_ascii_bcd_ (
				addr (n.project)
				, min (12, l2)
				, addr (user_permission.n1)
				);
			     user_permission.n1p = m.read||m.write||"0"b||m.execute;
			end;
			else do;			/* 2nd of name pair */
			     user_permission.n2 = (12)"20"b3; /* 12 bcd blanks. */
			     call gtss_ascii_bcd_ (
				addr (n.project)
				, min (12, l2)
				, addr (user_permission.n2)
				);
			     user_permission.n2p = m.read||m.write||"0"b||m.execute;
			     upp = addr (user_permission.nxn); /* Next name pair. */
			end;

		     end;
		     else				/* Over 22 names. */
		     if spx = 23 then		/* Issue error message once. */
			call com_err_ (
			0
			, "gtss_drl_filact_|get_permissions"
			, "Exceeded 22 specific permissions, remainder ignored."
			);
		end;
		else if verify (n.person, "10") = 0 & gtss_file_values.catalog then do;
		     string (m) = dir_acl.dir_modes (i);
		     if n.tag ^= "g" then goto next;
		     if n.project = "*" then do;
			gp = bit (person); /* personid contains GCOS permissions. */
			goto next;
		     end;
		     spx = spx+1;
		     if spx<23 then do;
			if spx = 1 then do;		/* First specific permission. */
			     if Type_1_ptr = null () then var_ptr = FMS_cat_ptr;
			     else var_ptr = Type_1_ptr;
			     Type_4_ptr = addrel (var_ptr, size (Type_2_Catalog));
			     unspec (Type_4_Catalog) = "0"b;
			     Type_4_ptr -> FMS_catalog = FMS_catalog; /* First 5 words from file record. */
			     FS4_CBK_04 = "0"b;
			     Type_4_ptr -> FSnTYP_0.bits00_05 = "04"b3; /* => permissions. */
			     sps = bit ((fixed (rel (Type_4_ptr), 17, 0)-fixed (rel (FMS_cat_ptr), 17, 0))/64);
			     upp = addr (Type_4_Catalog.FS4_VAR_07_75); /* Pointer to 1st specific permissions name pair. */
			end;

			if mod (spx, 2) = 1 then do;	/* 1st of name pair. */
			     user_permission.n1 = (12)"20"b3; /* 12 bcd blanks. */
			     call gtss_ascii_bcd_ (
				addr (n.project)
				, min (12, l2)
				, addr (user_permission.n1)
				);
			     user_permission.n1p = bit (person);
			end;
			else do;			/* 2nd of name pair */
			     user_permission.n2 = (12)"20"b3; /* 12 bcd blanks. */
			     call gtss_ascii_bcd_ (
				addr (n.project)
				, min (12, l2)
				, addr (user_permission.n2)
				);
			     user_permission.n2p = bit (person);
			     upp = addr (user_permission.nxn); /* Next name pair. */
			end;

		     end;
		     else				/* Over 22 names. */
		     if spx = 23 then		/* Issue error message once. */
			call com_err_ (
			0
			, "gtss_drl_filact_|get_permissions"
			, "Exceeded 22 specific permissions, remainder ignored."
			);
		end;
next:		;
	     end;
	     return;

dcl  hcs_$list_acl            entry(char(*),char(*),ptr,ptr,ptr,fixed bin,fixed bin(35));
dcl  hcs_$list_dir_acl        entry(char(*),char(*),ptr,ptr,ptr,fixed bin,fixed bin(35));
dcl  upp                      ptr init(null());
dcl  i                        fixed bin;
dcl  spx                      fixed bin;
dcl  spe                      (100)fixed bin;
dcl  a                        area(261120)aligned based(gtss_ext_$hcs_work_area_ptr);
dcl  l1                       fixed bin;
dcl  l2                       fixed bin;
dcl  l3                       fixed bin;
dcl  n32                      char(32)aligned;

dcl  1 m aligned,
    2 read	bit(01)unal,
    2 execute	bit(01)unal,
    2 write	bit(01)unal,
    2 zero	bit(33)unal;

dcl  1 n aligned based(addr(n32)),
    2 person	char(l1)unal,
    2 period1	char(1)unal,
    2 project	char(l2)unal,
    2 period2	char(1)unal,
    2 tag		char(l3)unal;

dcl 1 user_permission aligned based(upp),
    2 n1	bit(72),
    2 n1p	bit(18)unal,
    2 n2p bit(18)unal,
    2 n2	bit(72),
    2 nxn	bit(36);
	end					/* get_permissions */;

millsec512: proc (d)returns (bit (18));

/**	Given the date (d) in Multics 36bit storage system time
	format calculate the number of milliseconds / 512
	since midnight (return value).
**/
dcl  d                        bit(36)parm;

	     cv = 0;
	     cv36 = d;

	     call datebin_$preceding_midnight (cv, mcv);
	     return (bit (divide (cv-mcv, 512000, 18)));

dcl  datebin_$preceding_midnight entry(fixed bin(71),fixed bin(71));
dcl  mcv                      fixed bin(71)	/* Preceding midnight clock value. */;
dcl  cv                       fixed bin(71)aligned	/* Multics clock value. */;

dcl 1 cv2 aligned based(addr(cv)),
    2 fill20	bit(20)unal,
    2 cv36	bit(36)unal,
    2 fill16	bit(16)unal;
	end					/* millsec512 */;

author:	proc (dn, en)returns (bit (72));

/**	Obtain file originator from Multics author value. **/
dcl  dn                       char(168)parm;
dcl  en                       char(032)parm;

	     call hcs_$get_author (
		dn
		, en
		, 1b				/* Chase link. */
		, a				/* Multics author (returned). */
		, code
		);
	     if code ^= 0 then
no_name:		r = "4046513127314521634651"b3;	/* "^ORIGINATOR"bcd */
	     else do;
		p1 = search (a, ".");
		if p1 = 0 then goto no_name;
		p2 = search (reverse (a), ".");
		if p2 = 0 then goto no_name;
		al = length (a)-p1-p2;
		if al<1 then goto no_name;
		call gtss_ascii_bcd_ (addr (ac (p1+1)), al, addr (r));
	     end;
	     return (r);

dcl  r                        bit(72)init((12)"20"b3);
dcl  p1                       fixed bin;
dcl  p2                       fixed bin;
dcl  ac                       (32)char(1)unal based(addr(a));
dcl  hcs_$get_author          entry(char(*),char(*),fixed bin(1),char(*),fixed bin(35));
dcl  a                        char(32);
dcl  al                       fixed bin;
	end					/* author */;

BCD_date:	proc (md)returns (bit (36));

/**	Convert Multics (36 bit) date value
	to GCOS bcd MMDDYY.
**/
dcl  md                       bit(36)parm;
	     call date_time_$fstime ((md), d24);
	     d6 = mm||dd||yy;
dcl  d24                      char(24);
dcl 1 d24_0vl based(addr(d24)),
    2 mm char(2),
    2 slash1 char(1),
    2 dd char(2),
    2 slash2 char(1),
    2 yy char(2);
dcl  d6                       char(6);
dcl  b36                      bit(36);
	     call gtss_ascii_bcd_ (addr (d6), 6, addr (b36));
	     return (b36);

dcl  date_time_$fstime        entry(bit(36)aligned, char(*));
	end					/* BCD_date */;

%include gtss_filact_intp1;

%include gtss_filact_intp2;

%include gtss_filact_intp3;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  bit                      builtin;
dcl  bit18                    bit(18)based;
dcl  bit72                    bit(72)aligned based;
dcl  cat_filedescr_name_offset bit(18);
dcl  cont_ptr                 ptr init(null());
dcl  descriptor_ptr           ptr init(null());
dcl  divide                   builtin;
dcl  empty                    builtin;
dcl  entry_count              fixed bin;
dcl  entry_ptr                ptr init(null());
dcl  error_table_$dirseg      fixed bin (35) ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  fixed                    builtin;
dcl  grc			bit(18)init("400500"b3);
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  hbound                   builtin;
dcl  hcs_$star_               entry(char(*),char(*),fixed bin(2),ptr,fixed bin,ptr,ptr,fixed bin(35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  last_sector_no           fixed bin;
dcl  length                   builtin;
dcl  ll			fixed bin(17);
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  min                      builtin;
dcl  mod                      builtin;
dcl  names                    (total_names)char(32)aligned based(n_ptr);
dcl  name_info                area(261120)aligned based(gtss_ext_$hcs_work_area_ptr);
dcl  nic                      fixed bin(24);
dcl  null                     builtin;
dcl  number_of_catalog_entries fixed bin;
dcl  n_ptr                    ptr init(null());
dcl  rel                      builtin;
dcl  reverse                  builtin;
dcl  search                   builtin;
dcl  size                     builtin;
dcl  status_ptr               ptr init(null());
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  rtrim		builtin;
dcl  total_names              fixed bin;
dcl  unspec                   builtin;
dcl  var_ptr		pointer;
dcl  verify                   builtin;

dcl 1 entries (entry_count)aligned based(entry_ptr),
    2 type	bit(2)unal,
    2 nnames	fixed bin(15)unal,
    2 nindex	fixed bin(17)unal;

dcl 1 gfv aligned based(addr(gtss_file_values.data_fields)),
    2 curll_val,
      3 curll00_20 bit(21)unal,
      3 curll21_35 bit(15)unal,
    2 maxll_val,
      3 maxll00_17 bit(18)unal,
      3 maxll18_35 bit(18)unal,
    2 nail_val,
      3 noal00_17  bit(18)unal,
      2 noal18_35 bit(18)unal;

dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;

%include gtss_filact18_args;

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

/**	>ldd>include>status_info.incl.pl1	**/
%include status_info;

%include acls;

%include gtss_filact_options;

%include gtss_filact_status;

%include  gtss_deferred_catalog;

%include gse_ext_;

%include gtss_db_names;
     end						/* gtss_filact_funct18_ */;



		    gtss_filact_funct19_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      162927


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_filact_funct19_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 19 (ZZZZZ).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Ron Barstad       06/11/82  Fixed stringsize condition in assignment of entry_name to aft_name
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

/** Following 2 statements provided to
    assure no compilation errors. Code involved
    is being replaced. **/
	altname_ptr = null ();
	cat_filedescr_name_offset = "0"b;

	code = 0;					/* Successful. */


/**	Obtain the argument list. **/
	if					/* (filact_args.arglist_address < low_b) | */
	(fixed (filact_args.arglist_address, 18)+2 > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, filact_args.arglist_address);

	call validate_status (arglist.status_address, status_ptr); /* and also for status word */

	call build_cat_file_descriptors ();		/* build_ the pathnames from the cat file descriptors */

	arglist.record_address = "0"b;		/* set to eof for now */
	status_word.status = "400000"b3;

ret:	;
	return;


/*		System Master Catalog Query		*/


%include gtss_filact_intp3;

%include gtss_filact_intp1;

build_cat_file_descriptors: proc ();

/**	Obtain descriptor.		**/
	     if (arglist.descriptor_address > high_b) |
	     ((fixed (arglist.descriptor_address, 18) +4) > high_i) then goto return_err4;
	     descriptor_ptr = addrel (gseg, arglist.descriptor_address);

/* set up pointer to cat file descriptor */
/* look for the minus_one for the userid */
	     if substr (descriptor (0).name, 1, 36) = minus_one then do;

/* set the userid to that of the default logon */
		descriptor (0).name = gtss_ust.lid;
		descriptor (0).password = (12)"20"b3;
	     end;

	     ascii_cat_file.nn = 1;
	     call gtss_bcd_ascii_$lc (
		addr (descriptor (0).name)
		, 12
		, addr (ascii_cat_file.name (1))
		);

	     call gtss_expand_pathname_ (
		addr (ascii_cat_file)
		, dir_name
		, entry_name			/* (not used) */
		, code
		);
	     if code ^= 0 then do;
fail_build:	;
/**MORE**/
		status_word.status = "400100"b3;
		goto ret;
	     end;

/**	Obtain deblanked path_name.	**/
	     k = search (dir_name, " ")-1;
	     if k<0 then k = length (dir_name);
	     path_name = substr (dir_name, 1, k);


/* look for the minus_one for end of cat file descriptors and check address */
/* check for nothing given */
	     if substr (descriptor (1).name, 1, 36) = minus_one then do; /* look for minus_one then (-1) */
		status_word.pd = get_faulty_cat_file_entry ();
		status_word.status = "400500"b3;
		return;
	     end;

	     do i = 1 to hbound (descriptor, 1);
		if substr (descriptor (i+1).name, 1, 36) = minus_one /* look for minus_one (-1) */ then goto fence_found_1;
		call gtss_bcd_ascii_$lc (addr (descriptor (i).name), 12, addr (entry_name)); /* convert the path
						   element to ascii */
		k = search (entry_name, " ") -1;	/* look for end of name */
		if k < 0 then k = length (entry_name);	/* if no blanks found, then set to max size */
		path_name = path_name || ">" || substr (entry_name, 1, k); /* start concatination */
		if (fixed (arglist.descriptor_address, 18) + (i+1)*4) > high_i then goto return_err4;
	     end;

/* Too many levels given - give him an error */
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = "400500"b3;
	     return;

fence_found_1: ;
	     FMS_data_block.restore_switch = "0"b;	/* indicate the file name is in bcd */
	     descriptor_address = rel (addr (descriptor (i).name)); /* find a address of the
						   last entry on the descriptor stack */
	     if substr (filact_args.altname_address, 1, 1) = "1"b then
		call gtss_bcd_ascii_$lc (addr (descriptor (i).name), 12, addr (entry_name)); /* convert the path
						   element to ascii */
	     else
	     if filact_args.altname_address = "0"b then do;
		if function_no = 3 | function_no = 4 then do; /* keeping up with the inconsistencies of tss */
		     addr (entry_name) -> two_words = addr (descriptor (i).name) -> two_words; /* get the name
						   in ascii directly */
		     entry_name = translate (entry_name
			, "abcdefghijklmnopqrstuvwxyz"
			, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
			);			/* put name to lower case only */
		     FMS_data_block.restore_switch = "1"b; /* indicate the file name is in ascii */
		end;
		else
		call gtss_bcd_ascii_$lc (addr (descriptor (i).name), 12, addr (entry_name)); /* convert the path
						   element to ascii */
	     end;
	     else
	     if substr (filact_args.altname_address, 1, 1) = "0"b then do;
		if function_no = 4 then		/* for altname processing */
		     if substr (altname, 1, 4) ^= four_NULS then do; /* look also for empty altname given */
			call gtss_bcd_ascii_$lc (addr (descriptor (i).name), 12, addr (entry_name));
						/* convert the path element to ascii */

			aft_name = translate (altname
			     , "abcdefghijklmnopqrstuvwxyz"
			     , "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
			     );
						/* put name to lower case only */

		     end;
		     else do;
			addr (entry_name) -> two_words = addr (descriptor (i).name) -> two_words; /* get the name in ascii directly */
			entry_name = translate (entry_name
			     , "abcdefghijklmnopqrstuvwxyz"
			     , "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
			     );
			FMS_data_block.restore_switch = "1"b; /* indicate the file name is in ascii */
			aft_name = substr(entry_name,1,8);	/* save for access function 4 */
		     end;
	     end;
	     else do;
		addr (entry_name) -> two_words = addr (descriptor (i).name) -> two_words; /* get the name in ascii directly */
		entry_name = translate (entry_name
		     , "abcdefghijklmnopqrstuvwxyz"
		     , "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		     );
						/* Translate entry name to lower case. */
	     end;
	     k = search (entry_name, " ") -1;		/* look for end of name */
	     if k < 0 then k = length (entry_name);	/* if no blanks found, then set to max size */
	     dir_name = path_name;			/* save path_name up to this point for append_branchx */
	     path_name = path_name || ">" || substr (entry_name, 1, k); /* start concatination */
	     /* arglist.record_address = rel (addr (FMS_data_block.record_type)); */ /* indicate the info
						   is placed at the beginning of the buffer */
	     FMS_data_block.file_id = substr (entry_name, 1, 8); /* put in the ascii name of the file or catalog */
	     return;
	end					/* build_cat_file_description */;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  file_name_in_ascii       bit(1);
dcl  bit72                    bit(72)aligned based;
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18);
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;

/** Structures:	**/
dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

%include status_info;

%include acls;

%include gtss_filact_options;

%include gtss_db_names;
     end						/* gtss_filact_funct19_ */;
 



		    gtss_filact_funct21_.pl1        12/11/84  1354.3rew 12/10/84  1044.0      134676


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct21_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 21 (Get Specific).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned othr => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Bob Alvarado      08/22/79 commented out lines 106-108 as temp fix.
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain get specific catalog or file arglist. */
	if					/* (Get_Specific_args.L_arglist < low_b) | */
	((fixed (Get_Specific_args.L_arglist, 18) +3) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;
	arglist_ptr = addrel (gseg, Get_Specific_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (Get_Specific_arglist.L_status_return, status_ptr);

	if					/* (Get_Specific_arglist.L_sector_arg<low_b) | */
	(Get_Specific_arglist.L_sector_arg>high_b) then goto return_err4;
	sector_ptr = addrel (gseg, Get_Specific_arglist.L_sector_arg);

	if db_filact_funct21 then do;
	     i = fixed (sector_number, 18);
	     call ioa_ ("filact21: sector_number=^6o (^i) L_eor=^6o.", i, i, fixed (L_end_of_record, 18));
	end;

	if (sector_number<"000005"b3) |
	(sector_number>"777777"b3) then do;
	     call com_err_ (0, "gtss_filact_funct21_",
		"Sector number (^i) out of range.", i);
could_not_get_specific_file: ;
	     status_word.status = "404300"b3;		/* Invalid catalog block address. */
	     return;
	end;

	def_cat_ptr = gtss_ext_$deferred_catalogs_ptr;
	def_cat_type_1_ptr = addrel (def_cat_ptr, sector_number);
	if db_filact_funct21 then
	     call ioa_ ("filact21: cat=^b type=^i sn=^6o (^i)."
	     , def_cat_type_1.cat
	     , def_cat_type_1.rec_type
	     , fixed (def_cat_type_1.sn, 18)
	     , fixed (def_cat_type_1.sn, 18)
	     );

	if def_cat_type_1.rec_type = 1 then do;		/* Provide catalog continuation record type 1. */
	     Type_1_ptr = addr (callers_buffer.W43_FSBFER);
	     Type_1_ptr -> FSnTYP_0.bits00_05 = "01"b3;	/* => catalog continuation. */
	     def_cat_fill_len = fixed (def_cat_type_1.sn, 18)-201; /* 201=> words for cat/file descr.var). */

	     i = 0;				/* Index to type 1 record names. */
	     do while (deferred_catalog.nl>0);
		i = i+1;
		if i>hbound (FS1_VAR_06_76, 1) then do; /* Type 1 record exhausted. */
		     FS1_CBK_04.bits00_17,
			FS1_NLL_01.bits00_17 = sector_number;
		     def_cat_type_1.sn = rel (addr (deferred_catalog.type2_3));
		     goto finished;
		end;
		FS1_VAR_06_76 (i).FS1_SNM_00_01 = (12)"20"b3;
		call gtss_ascii_bcd_ (
		     addr (deferred_catalog.ns)
		     , min (deferred_catalog.nl, 12)
		     , addr (FS1_VAR_06_76 (i).FS1_SNM_00_01)
		     );
		FS1_VAR_06_76 (i).FS1_SPT_02.bit01 = deferred_catalog.cat;
		FS1_VAR_06_76 (i).FS1_SPT_02.bits18_35 = rel (addr (deferred_catalog.type2_3));
		def_cat_fill_len = def_cat_fill_len+1+divide (deferred_catalog.nl+3, 4, 17);
	     end;
	     goto finished;
	end;
	if def_cat_type_1.rec_type = 2 then do;		/* Provide description record. */
	     if def_cat_type_1.cat then do;		/* Provide type 0 catalog record. */
	/*	call ioa_ ("filact21: rec_type 2 for cat at ^6o.", fixed (sector_number, 18));
		goto could_not_get_specific_file;	*/
	  /* This is a temp fix. this area needs reviewing */
/**MORE**/
	     end;

/**	Provide type 2 file description record. **/
	     if db_filact_funct21 then
		call ioa_ ("filact21: rec_type 2 for file at ^6o.", fixed (sector_number, 18));

dcl 1 filact18_call		aligned
,     3 sas		(102)bit(36)
,     3 args		aligned like Get_Current_args
,     3 arglist		aligned like Get_Current_arglist
,     3 stat		bit(72)
,     3 cat_file		(200)bit(36)
;

	     unspec (filact18_call) = "0"b;

	     args.L_arglist = rel (addr (filact18_call.arglist));
	     args.Get_Current_function_no = 18;
	     arglist.L_status_return = rel (addr (stat));
	     arglist.L_cat_filedescr = rel (addr (filact18_call.cat_file));

/**	Prepare a catalog/file description by catenating
	the file name to the cat/filedescr in the deferred
	catalog store.
**/
dcl 1 move_string		aligned based(addr(filact18_call.cat_file)),
    2 cat_file_string	bit(cfdl),
    2 file_string		char(8),
    2 file_perm		bit(72),
    2 minus_one		fixed bin(35);
dcl  cfdl                     fixed bin(35);

	     cfdl = cat_file_len*4*36;
	     cat_file_string = addr (deferred_catalog.cat_file) -> cat_file_string;
dcl 1 file_name	aligned based(def_cat_type_1_ptr),
      3 fill	bit(18)unal,
      3 name_len	fixed bin(17)unal,
      3 name	char(file_name.name_len)unal;
	     file_string = file_name.name;
	     file_perm = (12)"20"b3;
	     minus_one = -1;

	     call gtss_filact_funct18_ (
		mcp
		, (6)"7"b3
		, addr (filact18_call)
		, addr (args)
		, buffer_ptr
		, code
		);
	     if code ^= 0 then goto could_not_get_specific_file;
	     goto finished;
	end;
	call com_err_ (0, "gtss_filact_funct21_",
	     "Deferred FMS catalog records of type ^i not provided for.", def_cat_type_1.rec_type);
	goto could_not_get_specific_file;

finished:	;

	code = 0;
	Get_Specific_arglist.L_record = rel (Type_1_ptr);
	sector.sector_number = bit (fixed (fixed (Get_Specific_arglist.L_record, 18)+size (Type_1_Catalog)-2, 18));
	status_word.status = "400000"b3;
	return;


%include gtss_filact_intp1;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  names                    (total_names)char(32)aligned based(n_ptr);
dcl  hcs_$star_               entry(char(*),char(*),fixed bin(2),ptr,fixed bin,ptr,ptr,fixed bin(35));
dcl  total_names              fixed bin;
dcl  name_info                area(261120)aligned based(gtss_ext_$hcs_work_area_ptr);
dcl  entry_count              fixed bin;
dcl  entry_ptr                ptr init(null());
dcl  n_ptr                    ptr init(null());
dcl  directory                char(168)var;
dcl  brp                      ptr init(null());
dcl  sector_ptr               ptr init(null());
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit18                    bit(18)based;
dcl  bit72                    bit(72)aligned based;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  cont_ptr                 ptr init(null());
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  fixed_bin17              fixed bin(17)unal based;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  index                    builtin;
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  last_sector_no           fixed bin;
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 sector	aligned based(sector_ptr),
      3 sector_number	bit(18)unal,
      3 L_end_of_record	bit(18)unal;

dcl 1 entries (entry_count)aligned based(entry_ptr),
    2 type	bit(2)unal,
    2 nnames	fixed bin(15)unal,
    2 nindex	fixed bin(17)unal;

dcl 1 bm based(addr(branch.mode)),
    2 zero	bit(1)unal,
    2 read	bit(1)unal,
    2 execute	bit(1)unal,
    2 write	bit(1)unal,
    2 append	bit(1)unal;

dcl 1 gfv aligned based(addr(gtss_file_values.data_fields)),
    2 curll_val,
      3 curll00_20 bit(21)unal,
      3 curll21_35 bit(15)unal,
    2 maxll_val,
      3 maxll00_17 bit(18)unal,
      3 maxll18_35 bit(18)unal,
    2 nail_val,
      3 noal00_17  bit(18)unal,
      2 noal18_35 bit(18)unal;

dcl 1 Get_Specific_args	aligned based(arg_ptr)
,     3 word1
,       4 zero		bit(18)unal
,       4 L_arglist		bit(18)unal
,     3 word2
,       4 Get_Specific_function_no	fixed bin(17)unal
,       4 L_buffer		bit(18)unal
;

dcl 1 Get_Specific_arglist	aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	bit(18)unal
,       4 L_record		bit(18)unal
,     3 word2
,       4 L_sector_arg	bit(18)unal
,       4 device_name	bit(18)unal
;

dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_file_values;

%include gtss_FMS_catalog;

/**	>ldd>include>status_info.incl.pl1	**/
%include status_info;

%include acls;

%include gtss_filact_options;

%include gtss_filact_status;

%include gtss_deferred_catalog;

%include gtss_filact18_args;

%include gtss_db_names;
     end						/* gtss_filact_funct21_ */;



		    gtss_filact_funct22_.pl1        12/11/84  1354.3rew 12/10/84  1044.1      134226


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_filact_funct22_: proc (mcp_val, high_val, gseg_val, arg_ptr_val, buffer_ptr_val, code);

/**	Derail FILACT function 09 (File Purge).
	Derail FILACT function 22 (File Release).

	All parameters are input parameters except code.

	code retuurned 0 => Successful.
	code returned 4 => GCOS err4 (see gtss_pnterr structure).
	code returned other => multics error code.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Bob Alvarado	07/22/79 removed deletion of directories.
   Change:  Dave Ward	08/14/79 Restricted to gtss files.
   Change:  Dave Ward	08/31/79 ret status from ascii_file_name.
   Change:  Dave Ward	11/02/79 Deletion of files under concurrent access.
   Change:  Dave Ward	12/18/79 Index to gtss_disk gtss_mcfc_$delete.
**/
dcl  mcp_val                  ptr parm;
dcl  high_val                 bit(18)parm;
dcl  gseg_val                 ptr parm;
dcl  arg_ptr_val              ptr parm;
dcl  buffer_ptr_val           ptr parm;
dcl  code                     fixed bin(35)parm;
	mcp = mcp_val;
	high_b = high_val;
	high_i = fixed (high_b, 18);
	gseg = gseg_val;
	arg_ptr = arg_ptr_val;
	buffer_ptr = buffer_ptr_val;

	code = 0;					/* Successful. */

/**	Obtain purge|release catalog|file arglist. */
	if					/* (Purge_Release_args.L_arglist < low_b) | */
	((fixed (Purge_Release_args.L_arglist, 18) +3) > high_i) then do;
return_err4:   ;
	     code = 4;
	     return;
	end;

	arglist_ptr = addrel (gseg, Purge_Release_args.L_arglist);

/**	Obtain return status.	**/
	call validate_status (Purge_Release_arglist.L_status_return, status_ptr);

	if get_ascii_file_name (
	"0"b
	, Purge_Release_arglist.L_cat_filedescr
	, addr (ascii_cat_file)
	, gsc
	) then do;
could_not_purge_release_file: ;
	     call bcd_message (
		status2.L_bcd_message
		, status2.message_words
		, buffer_ptr
		, "Could not purge/release file."||rtrim (file_dir)||">"||rtrim (file_entry)
		);
	     status_word.pd = get_faulty_cat_file_entry ();
	     status_word.status = gsc;		/* Could not access file specified. */
	     if db_filact_funct22 then
		call com_err_ (
		code
		, "gtss_filact_funct22_"
		, "Could not purge/release file ""^a>^a"""
		, file_dir
		, file_entry
		);
ret:	     ;
	     return;
	end;

	call gtss_expand_pathname_ (
	     addr (ascii_cat_file)
	     , file_dir
	     , file_entry
	     , code
	     );
	if code ^= 0 then goto could_not_purge_release_file;

/* Determine if any entry of gtss_disk pertains to
   the file we are about to delete.
*/
	rx = 0;					/* => No gtss_disk entry corresponds. */
	do i = 1 to hbound (aft_entry, 1);
	     if aft_entry (i).used then
		if gtss_disk (i).entry_name = file_entry then
		     if gtss_disk (i).dir_name = file_dir then
			rx = i;			/* Corresponds to i-th entry. */
	end;

	call gtss_mcfc_$delete (
	     rx
	     , file_dir
	     , file_entry
	     , gtss_ext_$mcfc.multics_lock_id
	     , addr (gsc)
	     , code
	     );
	if code>0 then goto could_not_purge_release_file;
	status_word.status = "400000"b3;
	goto ret;

/**	(PC,PF,RF) Purge/Release Catalog/File Declarations.	**/

dcl 1 Purge_Release_args	aligned based(arg_ptr)
,     3 word1
,       4 zero		bit(18)unal
,       4 L_arglist		bit(18)unal
,     3 word2
,       4 Purge_Release_function_no	fixed bin(17)unal
,       4 L_buffer		bit(18)unal
;

dcl 1 Purge_Release_arglist	aligned based(arglist_ptr)
,     3 word1
,       4 L_status_return	bit(18)unal
,       4 zero		bit(18)unal
,     3 word2
,       4 L_cat_filedescr	bit(18)unal
,       4 zero		bit(18)unal
;


/*		(MC) Modify Catalog			*/


%include gtss_filact_intp3;


%include gtss_filact_intp2;

%include gtss_filact_intp7;

%include gtss_filact_intp1;

/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  access_mode              bit (6);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  aft_code                 fixed bin (35);
dcl  aft_name                 char (8);
dcl  altname                  char (8) aligned based (altname_ptr);
dcl  altname_ptr              ptr init(null());
dcl  append_mode              bit (36) static int options(constant)init ("100000000000"b3);
dcl  arglist_ptr              ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  attribute_segment_ptr    ptr init(null());
dcl  bit                      builtin;
dcl  bit72                    bit(72)aligned based;
dcl  bit_count                fixed bin (24);
dcl  cat_filedescr_name_offset bit(18);
dcl  cdate                    fixed bin (71);
dcl  clim                     float bin;
dcl  crf                      fixed bin(24);
dcl  csp                      float bin;
dcl  descriptor_address       bit (18);
dcl  descriptor_ptr           ptr init(null());
dcl  dir_name                 char (168);
dcl  divide                   builtin;
dcl  entry_name               char (12) init (" ");
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35) ext;
dcl  error_table_$nomatch     fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$no_dir      fixed bin (35) ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  execute_mode             bit (36) static int options(constant)init ("200000000000"b3);
dcl  file_dir                 char(168);
dcl  file_entry               char(32);
dcl  file_name_in_ascii       bit(1);
dcl  file_no                  fixed bin (24);
dcl  fixed                    builtin;
dcl  FMS_block_ptr            ptr init(null());
dcl  four_NULS                char (4)static int options (constant)init ((4)" ") /* 4 octal 000's */;
dcl  gsc                      bit(18)init("400500"b3);
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  have_file                bit(1);
dcl  hbound                   builtin;
dcl  hcs_$add_acl_entries     entry (char (*), char (*), ptr, fixed bin(24), fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_inacl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
dcl  hcs_$append_branchx      entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry_file       entry(char(*),char(*),fixed bin(35));
dcl  hcs_$initiate            entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$quota_read          entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35));
dcl  hcs_$status_long         entry (char (*), char (*), fixed bin (1), ptr,ptr, fixed bin (35));
dcl  high_b                   bit(18)aligned;
dcl  high_i                   fixed bin(18)aligned;
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24);
dcl  ioa_                     entry options (variable);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  lbound                   builtin;
dcl  low_b                    bit(18)aligned static int options(constant)init("000147"b3) /* 103 dec. */;
dcl  low_i                    fixed bin(18)aligned static int options(constant)init(103);
dcl  max_options              fixed bin static int options(constant)init (100);
dcl  max_resources            fixed bin static int options(constant)init (99999);
dcl  minus_one                bit (36) static int options(constant)init ((36)"1"b);
dcl  mlim                     float bin;
dcl  mod                      builtin;
dcl  modify_mode              bit (36) static int options(constant)init ("200000000000"b3);
dcl  msp                      float bin;
dcl  multics_access_mode      fixed bin(5);
dcl  nic                      fixed bin(24);
dcl  p                        ptr init(null());
dcl  path_name                char (168) varying;
dcl  person_id                char (22);
dcl  quota                    fixed bin (18);
dcl  read_mode                bit (36) static int options(constant)init ("400000000000"b3);
dcl  rel                      builtin;
dcl  rings                    (3) fixed bin (3) static int options(constant)init (4, 4, 4);
dcl  rx                       fixed bin(24);
dcl  seg_acl_count            fixed bin;
dcl  shlim                    (0:7) float bin;
dcl  shsp                     (0:7) float bin;
dcl  size                     builtin;
dcl  smc_entry_ptr            ptr init(null());
dcl  sons_lvid                bit (36);
dcl  status                   fixed bin (24);
dcl  status_mode              bit (36) static int options(constant)init ("400000000000"b3);
dcl  status_ptr               ptr init(null());
dcl  substr                   builtin;
dcl  switches                 bit (6) static int options(constant)init ("37"b3);
dcl  tacc_sw                  fixed bin (1);
dcl  trp                      fixed bin (71);
dcl  tup                      bit (36) aligned;
dcl  two_words                bit (72) based;
dcl  type                     fixed bin (2);
dcl  used                     fixed bin (18);
dcl  user_attribute_word      bit (35);
dcl  user_info_$limits        entry (float bin, float bin, fixed bin (71), fixed bin(24), (0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  words380                 bit(13680)aligned based;
dcl  write_mode               bit (36) static int options(constant)init ("100000000000"b3);

dcl 1 status2		aligned based(status_ptr)
,     3 word1
,       4 status_code	bit(12)unal
,       4 zero1		bit(06)unal
,       4 zero2		bit(18)unal
,     3 word2
,       4 L_bcd_message	bit(18)unal
,       4 message_words	fixed bin(17)unal
;

dcl 1 bcdname aligned based(p),
    2 first8 bit(48)unal,
    2 last4  bit(24)unal;

/** Structures:	**/
dcl 1 filact_args aligned based (arg_ptr),
    2 altname_address bit (18) unaligned,
    2 arglist_address bit (18) unaligned,
    2 function_no fixed bin (17) unaligned,
    2 buffer_address bit (18) unaligned;


dcl 1 arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 record_address bit (18) unaligned,
    2 descriptor_address bit (18) unaligned,
    2 permissions_address bit (18) unaligned,
    2 options_address bit (18) unaligned,
    2 fill1 bit (18) unaligned;


dcl 1 lib_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 fill bit (17) unaligned,
    2 mode bit (1) unaligned,
    2 fill1 bit (24) unaligned,
    2 file_code bit (12) unaligned;


dcl 1 status_word aligned based (status_ptr),
    2 status bit (18) unaligned,
    2 pd bit (18) unaligned,
    2 null_bit bit (1) unaligned,
    2 user_attributes bit (35) unaligned;


dcl 1 descriptor (0:8) aligned based (descriptor_ptr),
    2 name bit (72) aligned,
    2 password bit (72) aligned;

dcl 1 FMS_block aligned based (FMS_block_ptr),
    2 address bit (18) unaligned;


dcl 1 FMS_data_block aligned based (buffer_ptr),
    2 restore_switch bit (36) aligned,
    2 file_id char (8) aligned,
    2 fill (3:24) bit (36) aligned,
    2 record_type fixed bin (5) unaligned,
    2 fill2 bit (30) unaligned;

dcl 1 permissions aligned based (permissions_ptr),
    2 read bit (1) unaligned,
    2 write bit (1) unaligned,
    2 append bit (1) unaligned,
    2 execute bit (1) unaligned,
    2 purge bit (1) unaligned,
    2 modify bit (1) unaligned,
    2 lock bit (1) unaligned,
    2 fill bit (1) unaligned,
    2 create bit (1) unaligned,
    2 recovery bit (1) unaligned,
    2 fill1 bit (8) unaligned,
    2 test bit (1) unaligned,
    2 query bit (1) unaligned,
    2 fill2 bit (16) unaligned;


dcl 1 options aligned based (options_ptr),
    2 contigous bit (1) unaligned,
    2 random bit (1) unaligned,
    2 TSS_create bit (1) unaligned,
    2 I_D_S bit (1) unaligned,
    2 llink_allocated bit (1) unaligned,
    2 nostructured_device bit (1) unaligned,
    2 fill1 bit (1) unaligned,
    2 attribute_present bit (1) unaligned,
    2 user_attribute bit (1) unaligned,
    2 fill2 bit (4) unaligned,
    2 FMS_protection bit (1) unaligned,
    2 fill3 bit (4) unaligned,
    2 device_name bit (18) unaligned,
    2 initial_size bit (18) unaligned,
    2 max_size bit (18) unaligned,
    2 specific_permissions (0:max_options) aligned,
      3 userid bit (72) aligned,
      3 read bit (1) unaligned,
      3 write bit (1) unaligned,
      3 append bit (1) unaligned,
      3 execute bit (1) unaligned,
      3 purge bit (1) unaligned,
      3 modify bit (1) unaligned,
      3 lock bit (1) unaligned,
      3 fill bit (1) unaligned,
      3 create bit (1) unaligned,
      3 recovery bit (1) unaligned;


dcl 1 smc_arglist aligned based (arglist_ptr),
    2 status_address bit (18) unaligned,
    2 entry_address bit (18) unaligned;


dcl 1 smc_entry aligned based (smc_entry_ptr),
    2 userid bit (72) unaligned,
    2 fill1 bit (36) aligned,
    2 fill2 bit (36) aligned,
    2 space_time fixed bin (35) aligned,
    2 llinks_used fixed bin (17) unaligned,
    2 llinks_allowed fixed bin (17) unaligned,
    2 fill3 bit (36) aligned,
    2 resources fixed bin (17) unaligned,
    2 lodx bit (1) unaligned,
    2 cardin bit (1) unaligned,
    2 talk bit (1) unaligned,
    2 lods bit (1) unaligned,
    2 fill4 bit (2) unaligned,
    2 urgency bit (12) unaligned,
    2 password bit (72) unaligned,
    2 reserved bit (36) aligned,
    2 fill5 bit (10) unaligned,
    2 resources_used fixed bin (25) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_filact_status;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ascii_file_names;

%include gtss_FMS_catalog;

%include status_info;

%include acls;

%include gtss_filact_options;

%include gse_ext_;

%include gtss_db_names;

%include gtss_dfd_ext_;
     end						/* gtss_filact_funct22_ */;
  



		    gtss_find_cond_frame_.pl1       12/11/84  1354.3rew 12/10/84  1044.1       15741


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_find_cond_frame_: proc (cond_arg) returns (ptr);

/**
   Author:	Al Dupuis 10/15/79


   arg_1 input		the condition name.
   returns		ptr to the machine conditions if the condition
			was found in the current slave seg.
**/


	sp = find_condition_frame_ (null ());
	do while (sp ^= null ());
	     call find_condition_info_ (sp, addr (cond_info), code);
	     if condition_name = cond_arg
	     then do;
		scup = addr (cond_info.mcptr -> mc.scu);
		if scu.ppr.psr = substr (baseno (gtss_ext_$gtss_slave_area_seg
		(gtss_ext_$stack_level_)), 4, 15) then	/* have found fault in slave segment */
		     return (cond_info.mcptr);
	     end;
	     sp = find_condition_frame_ (sp);
	end;
	return (null ());


/* gtss_find_cond_frame_ declares			*/
dcl code fixed bin (35);
dcl cond_arg char (32) varying parm;
dcl find_condition_frame_ entry (ptr) returns (ptr);
dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl sp ptr init (null());
dcl 1 cond_info aligned,
%include cond_info;

%include gtss_ext_;

%include mc;
     end;						/* gtss_find_cond_frame */
   



		    gtss_get_user_state_.pl1        12/11/84  1354.3rew 12/10/84  1044.1       13797


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


gtss_get_user_state_: proc (u_state_p);
dcl  u_state_p parm ptr;


/** Return a pointer to the gtss user_state segment in the
user's home directory, creating and initializing the segment if
it does not exist. 

	Author: Mel Wilson 	26mar79
*/

	call user_info_$homedir (home_path);

	call hcs_$make_seg (home_path, "gtss_user_state_.gtss", "gtss_user_state_",
	     fixed ("01010"b), u_state_ptr, c);
	if u_state_ptr = null () then do;
	     call com_err_ (c, "gtss_get_user_state_",
		"Error in hcs_$make_seg.");
	     u_state_p = null ();
	     return;
	end;

	u_state_p = u_state_ptr;

	if c = 0 then do;				/* newly created segment must be initialized */
	     snumb_sequence = 1;
	     entry_count = 0;
	end;

	return;

dcl  home_path char (128);
dcl  c fixed bin (35);

dcl  com_err_ entry options (variable);
dcl  error_table_$name_not_found ext;
dcl  error_table_$segknown ext;
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5),
     ptr, fixed bin (35));
dcl  user_info_$homedir entry (char (*));

%include gtss_snumb_xref_;

     end gtss_get_user_state_;
   



		    gtss_install_values_.cds        12/11/84  1354.3rew 12/10/84  1044.1       28098


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_install_values_:proc;

/* Generate object for "gtss_install_values_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_install_values_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_install_values_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_install_values_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_install_values_";

	cds_args_ptr -> cds_args.seg_name = "gtss_install_values_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_install_values_");
	   else 
	      call com_err_( 0,"gtss_install_values_","Object for gtss_install_values_ created [^i words].",size(gtss_install_values_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_install_values_.incl.pl1 **/

dcl 1 gtss_install_values_ aligned,
      2 fast_msf     char(32)var	init("gtss_fast_library_"),
      2 Lstar_msf    char(32)var	init("gtss_Lstar_"),
      2 starL_msf    char(32)var	init("gtss_starL_"),
      2 memory_limit fixed bin(24)	init(261120),
      2 time_limit   fixed bin(24)	init(1000);

%include gtss_install_values_;
%page;
%include cds_args;
end;
  



		    gtss_interp_prim_.pl1           12/11/84  1354.3rew 12/10/84  1044.2      252360


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_interp_prim_: proc;

/*	Routine to interpret primitives--patterned after SCAN3 in TSSH.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Al Dupuis	06/21/79 add call to gtss_CFP_break_
   Change:  Paul Benjamin	09/21/79 change popup_primitive to allow ..init command file
   Change:  Paul Benjamin	10/24/79 remove call to popup_primitive from t_goto
   Change:  Paul Benjamin	10/25/79 turn off logon bit in callss and t_goto to avoid recursively executing ..init
   Change:  Al Dupuis	11/10/79 reset drun indicators
   -			         h* ..init when executing drun.
   Change: Dave Ward	08/17/81 reorganized source.
   Change: Dave Wardd	08/17/81 assure system name lowere case.
   Change: Ron Barstad        12/09/82 fix bug: switchword_bit >35 is actually in gtss_ust.lswt2
*/
%page;
/* Initialization for primary entry only */
	on quit call gtss_fix_tty_modes_ ();		/* Don't want the primitive interpreter to be interrupted */
	my_level = 1;
	current_level (1) = interp;
	tty_line_ptr = addr (characters_transmitted);
	conclude_gtss = "0"b;
	cl_ptr = addr (gtss_prgdes_ext_$primitives (2));
	cp_ptr = addrel (cl_ptr, 2*gtss_prgdes_ext_$common_cmd_num);
	initial_lcals = fixed (rel (addr (gtss_ust.lcals)))-fixed (rel (addr (gtss_ust)));
	initial_lxxx = fixed (rel (addr (gtss_ust.lxxx)))-fixed (rel (addr (gtss_ust)));


/* Start user at system level. */
	call system;
	comm = "cmdl";

interp:	;

/* At this point the number of active invocations of gtss_interp_prim_
   must be equal to the stack_level_ or the program is in error. */
	if my_level ^= gtss_ext_$stack_level_ then do;
	     call com_err_ (0, "gtss_interp_prim_",
		"current invocation = ^i not syncronized with stack_level_ = ^i.",
		my_level, gtss_ext_$stack_level_);
	     signal condition (gtss_fail);
	end;

/* At this point the internal static variable comm contains the
   ASCII name of the subsystem to be invoked */
	call startp;

interp2:	;

/* Set loop counter to zero. */
	loop_count = 0;
	pop_callss_stack = "0"b;

interp_loop: ;

/* At this point next_prim is the index in gtss_prgdes_ext_$primitives
   of the next primitive to interpret and primitive is the primitive to
   interpret.
*/
/* Store pointer to current primitive in program stack. */
	i = gtss_ust.lxxx.b0_17-initial_lxxx;
	gtss_ust.lprgs (i).b18_35 = next_prim;
	if db_interp_prim then call gtss_dump_program_stack_;
	loop_count = loop_count + 1;
	if loop_count > 50 then do;			/* Loop in primitives */
	     call com_err_ (0, "", gtss_pnterr.err8);
	     go to break;
	end;
	if (prim_op<lbound (case, 1)) | (prim_op>hbound (case, 1)) then do;
	     call com_err_ (0, "gtss_interp_prim_",
		"Primitive index ^i (<^i or >^i).",
		prim_op,
		lbound (case, 1),
		hbound (case, 1));
	     signal cond (gtss_fail);
	end;
	go to case (prim_op);

case (5):	;
case (6):	;
	call com_err_ (
	     0
	     , "gtss_interp_prim_"
	     , "^/Bad Primitive ^i at ^i."
	     , prim_op
	     , next_prim
	     );
	call com_err_ (0, "", gtss_pnterr.err1);
	signal condition (gtss_fail);
case (1):	;					/* CALLP */
	call callp_primitive;
	go to interp_loop;
case (2):	;					/* EXEC */
	call exec_primitive;
	if conclude_gtss then go to gtss_ext_$finished;	/* Return to gtss command to conclude execution */
	go to interp_loop;
case (3):	;					/* BIN */
	call bin_primitive;
	go to interp_loop;
case (4):	;					/* POPUP */
	call popup_primitive;
	if pop_callss_stack then return;		/* Return to gtss_drl_callss_ */
	go to interp_loop;
case (7):	;					/* SYSTM */
	call systm_primitive;
	go to current_level (1);			/* Unwind to primitive interpreter at
						   outermost level */
case (8):	;					/* IFALSE */
	call ifalse_primitive;
	go to interp_loop;
case (9):	;					/* IFTRUE */
	call iftrue_primitive;
	go to interp_loop;
case (10): ;					/* STFALS */
	call stfals_primitive;
	go to interp_loop;
case (11): ;					/* STRUE */
	call strue_primitive;
	go to interp_loop;

break:	;
	gtss_ext_$restart_from_pi = gtss_ext_$bad_drl_rtrn;
	gtss_ext_$popup_from_pi = gtss_ext_$bad_drl_rtrn;
	gtss_ext_$dispose_of_drl = gtss_ext_$bad_drl_rtrn;
	call popup_primitive;
	if pop_callss_stack then return;		/* Return to gtss_drl_callss_ */
	go to interp2;

ret:	;
	return;					/* return to gtss_drl_callss_ */
%page;
callss:	entry (subsystem_name, mcpp);

/* This entry point is called by the DRL CALLSS (gtss_drl_callss_)
   to invoke the primitive interpreter recursively for a specified
   subsystem.
*/
dcl  mcpp                     ptr parm	/* pointer to machine conditions for DRL CALLSS */;
dcl  subsystem_name           char(4) parm	/* Subsystem to be called */;
	on quit call gtss_fix_tty_modes_ ();
	comm = translate (subsystem_name, lower, upper);	/* use local static variable */
	mcp = mcpp;

/* If this was called from within a ..init file we
   have to turn off the logon bit or the ..init file will
   be called recursively.
*/
	gtss_ust.lflg2.b6 = "1"b;

/* Check for stack overflow */
	if gtss_ext_$stack_level_ > hbound (gtss_ext_$gtss_slave_area_seg, 1) then do;
	     call gtss_abort_subsystem_ (mcp, "gtss_interp_prim_", 6, err6); /* level of control too deep */
	     return;
	end;

/* Push slave_area_seg on stack */
	my_level, gtss_ext_$stack_level_ = gtss_ext_$stack_level_ + 1;
	current_level (my_level) = interp;

/* Add entry to CALLSS stack */
	gtss_ust.lcals.b0_17 = gtss_ust.lcals.b0_17 + 2;

/* Save current program stack index on CALLSS stack.
   This will later be used to decide whether to pop the CALLSS stack
   during interpretation of the POPUP primitive.
*/
	i = divide (gtss_ust.lcals.b0_17-initial_lcals, 2, 17, 0);
	subsystems (i).tally_address = gtss_ust.lxxx.b0_17;

/* Save content of .LSWAP (program size) on CALLSS stack.
   This is necessary so that program size can be determined when
   returning from DRL CALLSS.
*/
	gtss_ust.subsystems (i).content_lswap = gtss_ust.lswap;

/* Clear IC and abort code in SPA */
	gseg = gtss_ext_$gtss_slave_area_seg (my_level);
	unspec (gtss_spa.labrt) = "0"b;

/* If subsystem was doing its own break processing
   or executing user code save appropriate indicators
   in the CALLSS stack.
*/
	gtss_ust.ss_flags (i) = "0"b;
	substr (gtss_ust.ss_flags (i), 18, 1) = gtss_ust.lswth.b7; /* Break processing */
	substr (gtss_ust.ss_flags (i), 17, 1) = gtss_ust.lflg2.b14; /* User code executing */
	go to interp;
%page;
t_goto:	entry (subsystem_name);

/* This entry point is called by DRL T.GOTO (gtss_drl_t_goto_) or
   by DRL CALLSS (gtss_drl_callss_) when a nonrecursive invocation
   of the primitive interpreter is needed. */

/* If this was called from within a ..init file we
   have toturn off the logon bit or the ..init file will
   be called recursively. */
	gtss_ust.lflg2.b6 = "1"b;

	on quit call gtss_fix_tty_modes_ ();
	comm = translate (subsystem_name, lower, upper);	/* use local static variable */
	call gtss_run_subsystem_$finish;		/* Wrap up current subsystem */
	go to current_level (gtss_ext_$stack_level_);	/* Unwind one invocation of
						   gtss_interp_prim_ */
%page;
sysret:	entry;

/* This entry point is called by DRL SYSRET to return to system level. */


	on quit call gtss_fix_tty_modes_ ();

/* Turn off compiler identifier bits. */
	string (gtss_ust.lswth) = string (gtss_ust.lswth) & lswth_reset;

/* Reset "user prog in control" indicator. */
	gtss_ust.lflg2.b14 = "0"b;

/* Return to system level */
	call system;
	go to current_level (1);			/* Unwind to first invocation of
						   gtss_interp_prim_ */
%page;
bin_primitive: proc;

/* SET SY** block count to -1 */
	     gtss_ust.lsybc.b0_17 = -1;
	     gtss_ust.lsybc.b18_35 = -1;

/* Reset switch that says we have data on the
   collector file */
	     gtss_ust.lswth.b17 = "0"b;

/* Reset loop counter for primitives. */
	     loop_count = 0;

	     call gtss_build_;
	     call scan1;
	     return;

	end bin_primitive;
%page;
callp_primitive: proc;

/* If the switchword_flag bit is set then the
   new_subsystem will be called only if the specified bit of
   the combined switch  words .LSWTH and .LSWT2 is on
*/

	     if switchword_flag then do;
		i = fixed (switch_ov_bit);
		if i > 35 then do;
		     if ^(addr (gtss_ust.lswt2) -> switch_word (i-36)) then goto next;
		end;
		else
		if ^switch_word (i) then goto next;
	     end;

/* Check for program stack about to overflow */
	     i = gtss_ust.lxxx.b0_17-initial_lxxx;
	     if i >= hbound (gtss_ust.lprgs, 1) then do;
		if gtss_ext_$stack_level_ <= 1 then do;
		     call ioa_ ("^/"||err6);		/* level of control too deep */
		     call system;			/* Reestablish system level. */
		     go to interp;
		end;
		else do;
		     i = divide (gtss_ust.lcals.b0_17-initial_lcals, 2, 17, 0);
		     gtss_ust.lxxx.b0_17 = subsystems (i).tally_address+1;
		     call popup_primitive;
		     call gtss_abort_subsystem_ (mcp, "gtss_interp_prim_", 6, err6); /* level of control too deep */
		     go to ret;
		end;
	     end;
	     gtss_ust.lxxx.b0_17 = gtss_ust.lxxx.b0_17 + 1;
	     i = i+1;

/* Store index of program descriptor
   in program stack. */
	     gtss_ust.lprgs (i).b0_17 = callp_desc;

/* Reset "Pass break" bit in case CALLP is
   result of CALLSS. */
	     gtss_ust.lswth.b7 = "0"b;

/* Don't pass stuff related to wrapup along. */
/* See SCAN3 in TSSH */
	     substr (string (gtss_ust.lflg3), 34, 3) = "0"b3 ;
	     gtss_ust.lopts = "0"b;
	     unspec (gtss_ust.licec) = "0"b;

/* Keep number of calls in 5th cell of program descriptor. */
	     calls (callp_desc) = calls (callp_desc) + 1;

/* Locate command language for this subsystem */
	     cmd_list_len = gtss_prgdes_ext_$prgdes (callp_desc).cmd_lang_len;
	     cmd_list_ptr = addr (gtss_prgdes_ext_$primitives
		(gtss_prgdes_ext_$prgdes (callp_desc).cmd_lang_offset));
	     cmd_prim_list_ptr = addrel (cmd_list_ptr, 2*cmd_list_len);

/* Locate start_up primitive sequence for this subsystem. */
	     next_prim = primitive_ptr (cmd_list_len+1);

/* get new primitive */
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;

next:	     ;
	     i = gtss_ust.lxxx.b0_17-initial_lxxx;
	     next_prim = gtss_ust.lprgs (i).b18_35+1;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;

dcl  i                        fixed bin(17);
	end callp_primitive;
%page;
exec_primitive: proc;

/* Get index of current program descriptor */
	     i = gtss_ust.lprgs (gtss_ust.lxxx.b0_17-initial_lxxx).b0_17;

/* Keep number of loads in program descriptor */
	     loads (i) = loads (i) + 1;

	     load_sz = gtss_prgdes_ext_$prgdes (i).load_size;
	     if load_sz <= 0 then do;			/* Unknown system */
		call com_err_ (0, "", gtss_pnterr.err9);
		call system;
		go to current_level (1);
	     end;
	     load_address = gtss_prgdes_ext_$prgdes (i).initial_load_address;

/* Make sure load address is not in prefix. */
	     if load_address < 100 then do;		/* Unknown system */
		call com_err_ (0, "", gtss_pnterr.err9);
		call system;
		go to current_level (1);
	     end;

/*	Examine for  ".TSLOG" being executed => Conclude gtss execution.	*/
	     if gtss_prgdes_ext_$prgdes.bci_catalog_name (i) = period_TSLOG then conclude_gtss = "1"b;

/* Execute subsystem */
	     gtss_ext_$popup_from_pi = break;
	     on quit begin;
		on quit call gtss_fix_tty_modes_ ();
		gtss_ext_$restart_from_pi = restart;
		gtss_ext_$last_k_was_out = "0"b;
		gtss_ust.lbuf.tally = "0"b;
		call gtss_fix_tty_modes_ ();
/* if in command file processing and break label specified set it's sector no */
		if gtss_ust.lflg2.b8 then call gtss_CFP_break_;
		if gse_ext_$modes.mquit then do;
		     call ioa_ ("QUIT");
		     call cu_$cl ();
		end;
		else signal program_interrupt;
restart:		;
		gtss_ext_$restart_from_pi = gtss_ext_$bad_drl_rtrn;
	     end;

	     on program_interrupt begin;

/* Determine if the subsystem has provided a transfer vector for
   line breaks. */
		if ^gtss_break_vector_$status () then do;
		     if (^gtss_ext_$flags.drl_in_progress) |
		     gtss_ext_$flags.dispose_of_drl_on_pi then goto gtss_ext_$popup_from_pi;
		     gtss_ext_$flags.popup_from_pi = "1"b;
		     go to gtss_ext_$restart_from_pi;
		end;

		if ^gtss_break_vector_$drl_in_progress () then do;
		     call gtss_break_vector_ ();
		     goto gtss_ext_$restart_from_pi;
		end;

		if gtss_ext_$flags.dispose_of_drl_on_pi then do;
		     gtss_ext_$flags.unfinished_drl = "1"b;
		     go to gtss_ext_$dispose_of_drl;
		end;

		gtss_ext_$flags.unfinished_drl = "1"b;
		go to gtss_ext_$restart_from_pi;

	     end;					/* end of on program_interrupt condition block */

	     call gtss_run_subsystem_ ((i));
	     revert program_interrupt;
	     revert quit;
	     gtss_ext_$popup_from_pi = gtss_ext_$bad_drl_rtrn;

/* If CALLSS stack is empty then
   initialize user time limit. */
	     if gtss_ust.lcals.b0_17-initial_lcals <= 0 then do;
		if gtss_ext_$flags.ss_time_limit_set then do;
		     gtss_ust_ext_$ust.gtss_ust.limit = 0;
		     gtss_ext_$flags.timer_ranout = "0"b;
		     gtss_ext_$flags.ss_time_limit_set = "0"b;
		     call timer_manager_$reset_cpu_call (gtss_fault_processor_$timer_runout); /* turn off timeout  */
		end;
		if gtss_ext_$process_type = 2
		then do;
		     if ((gtss_ust.lcjid = "0"b)
		     & (gtss_ext_$drun_jid ^= " ")
		     & (^gtss_ust.lflg2.b8))
		     then do;
			gtss_ust.lcfst.start_term = 17;
			call gtss_ascii_bcd_ (addr (gtss_ext_$drun_jid), 5, addr (gtss_ust.lcjid));
		     end;
		end;
	     end;

/* Reset "user program in control" indicator */
	     gtss_ust.lflg2.b14 = "0"b;

	     i = gtss_ust.lxxx.b0_17-initial_lxxx;
	     next_prim = gtss_ust.lprgs (i).b18_35+1;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;

dcl  i                        fixed bin(17);
dcl  load_address             fixed bin(17);
dcl  load_sz                  fixed bin(17);
	end exec_primitive;
%page;
ifalse_primitive: proc;
	     if switchword_bit < 36
	        then do;
		 if ^switch_word (switchword_bit)
		    then next_prim = prim_address;
	              else next_prim = next_prim + 1;
	              end;
	        else do; /* switchword_bit >= 36 */
		 if ^(addr(gtss_ust.lswt2) -> switch_word(switchword_bit-36))
		    then next_prim = prim_address;
	              else next_prim = next_prim + 1;
		    end;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;
	end ifalse_primitive;
%page;
iftrue_primitive: proc;
	     if switchword_bit < 36
	        then do;
		 if switch_word (switchword_bit)
		    then next_prim = prim_address;
	              else next_prim = next_prim + 1;
	              end;
	        else do; /* switchword_bit >= 36 */
		 if addr(gtss_ust.lswt2) -> switch_word(switchword_bit-36)
		    then next_prim = prim_address;
	              else next_prim = next_prim + 1;
	              end;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;
	end iftrue_primitive;
%page;
popup_primitive: proc;

/* Pop item off program stack and test for stack empty. */
	     gtss_ust.lxxx.b0_17 = gtss_ust.lxxx.b0_17 - 1;
	     if gtss_ust.lxxx.b0_17-initial_lxxx <= 0 then do;
		if gtss_ust.lflg2.b6 = "0"b then do;	/* just logging in--make sure not to clobber init processing */
		     if comm = "cmdl" then do;	/* No ..init file -- just turn off bit */
			gtss_ust.lflg2.b6 = "1"b;
			call system;
		     end;
		     else do;			/* Special handling for ..init file */
			save_comm = comm;
			call system;
			comm = save_comm;
			gtss_ust.lbuf.tally = "0"b;	/* Fool crun into checking for input */
			gtss_ust.lflg2.b6 = "1"b;	/* turn off LOGON bit */
		     end;
		end;
		else call system;
		call startp;
		return;
	     end;

/* If the CALLSS stack is empty simply advance
   to the next primitive at new level. */
	     i = divide (gtss_ust.lcals.b0_17-initial_lcals, 2, 17, 0);
	     if i <= 0 then go to next;

/* Determine if current entry in CALLSS stack
   corresponds to current entry in program stack.
   If so, there is a swapped subsystem to restart.
   Otherwise simply advance to the next primitive
   at new level. */
	     if gtss_ust.lxxx.b0_17 = gtss_ust.subsystems (i).tally_address then do;

/* Restart previous SS */

/* Pop slave_area_seg off stack */
		gtss_ext_$stack_level_ = gtss_ext_$stack_level_ - 1;
		gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

		if gtss_ust.licec.b18_35 ^= 0 then do;

/* Move .LICEC into prefix. */
		     gtss_spa.labrt = gtss_ust.licec;
		end;

/* Restore program size from CALLSS stack */

		gtss_ust.lswap = subsystems (i).content_lswap;
		gtss_ust.lsize.limit = gtss_ust.lswap.size;
		gtss_ust.lsize.bar = divide (fixed (gtss_ust.lsize.limit, 18), 512, 17, 0);
		call gtss_set_slave_$load_bar (fixed (gtss_ust.lsize.bar, 18, 0)); /* Reset BAR register. */

/* Was subsystem doing its own break processing? */
		if substr (gtss_ust.ss_flags (i), 18, 1) then

/* If so turn on .LSWTH BIT 7 (GCOS numbering) */
		     gtss_ust.lswth.b7 = "1"b;

/* Does pushed SS belong to user? */
		if substr (gtss_ust.ss_flags (i), 17, 1) then

/* If so, mark user code executing. */
		     gtss_ust.lflg2.b14 = "1"b;

/* Pop item off CALLSS stack */
		gtss_ust.lcals.b0_17 = gtss_ust.lcals.b0_17-2;
		pop_callss_stack = "1"b;		/* Set flag to return to caller */
		return;
	     end;

next:	     ;
	     i = gtss_ust.lxxx.b0_17-initial_lxxx;
	     next_prim = gtss_ust.lprgs (i).b18_35 + 1;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);

/* Locate command language for this subsystem */
	     i = gtss_ust.lprgs (i).b0_17;
	     cmd_list_len = gtss_prgdes_ext_$prgdes (i).cmd_lang_len;
	     cmd_list_ptr = addr (gtss_prgdes_ext_$primitives
		(gtss_prgdes_ext_$prgdes (i).cmd_lang_offset));
	     cmd_prim_list_ptr = addrel (cmd_list_ptr, 2*cmd_list_len);

	     return;

dcl  i                        fixed bin(17);
dcl  save_comm                char(4);
	end popup_primitive;
%page;
scan1:	proc;

/* This procedure is patterned after SCAN1 of TSSH.
   It searches for the first four characters of the current input
   line first in the common command list and then in the private list
   of the current subsystem.  If the command is
   found, next_prim and primitive are updated to the first primitive
   in the sequence for the command.   If the command is not found
   the first primitive in the sequence for the command loader is selected.
*/

/* Pickup first 4 characters of command line. */
	     command = first4;

/* Translate to lower case */
	     comm = translate (command, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");

/* Determine number of commands to use from the
   common list. */
	     i = gtss_ust.lprgs (gtss_ust.lxxx.b0_17-initial_lxxx).b0_17;
	     common_cmds = 0;
	     if substr (parameters (i), 13, 1) then	/* BASIC command list flag */
		common_cmds = gtss_prgdes_ext_$basic_cmd_num;
	     else
	     if substr (parameters (i), 14, 1) then	/* Common command list flag */
		common_cmds = gtss_prgdes_ext_$common_cmd_num;

/* Search for command in common list */
	     do i = 1 to common_cmds;
		l = cl_len (i);
		if substr (comm, 1, l) = substr (cl_word (i), 1, l) then do;
		     next_prim = com_prim_ptr (i);
		     primitive = gtss_prgdes_ext_$primitives (next_prim);
		     return;
		end;
	     end;
/* Search for command in private list of this subsystem. */

	     do i = 1 to cmd_list_len;
		l = cmd_len (i);
		if substr (comm, 1, l) = substr (cmd_word (i), 1, l) then do;
		     next_prim = primitive_ptr (i);
		     primitive = gtss_prgdes_ext_$primitives (next_prim);
		     return;
		end;
	     end;

/* The command was not found, so call the command loader. */
	     next_prim = gtss_prgdes_ext_$cmlcl;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;

dcl  common_cmds              fixed bin(17);
dcl  i                        fixed bin(17);
dcl  l                        fixed bin(17);
	end scan1;
%page;
startp:	proc;

/* This routine selects the subsystem specified
   by the variable comm.
   This routine is patterned after STARTP in TSSI.
*/
	     name = "";
	     do i = 1 to 4;
		c = substr (comm, i, 1);		/* Pick up character */
		if c = "," then go to enough;
		if c < """" then goto enough;
		substr (name, i, 1) = c;
		if c = """" | c = "-" then go to enough;
	     end;

enough:	     ;

/* Look up system name in program descriptors. */
	     do i = 1 to hbound (gtss_prgdes_ext_$prgdes, 1);
		if gtss_prgdes_ext_$prgdes (i).ss_name = name then go to found;
	     end;
	     i = i -1;

found:	     ;					/* Check for system level. */
	     if gtss_ust.lxxx.b0_17-initial_lxxx = 0 then do;

/* Make sure this subsystem can be called at
   system level. If not call the command loader instead. */
		if substr (gtss_prgdes_ext_$prgdes (i).parameters, 9, 1) then i = hbound (gtss_prgdes_ext_$prgdes, 1);
	     end;

/* Make CALLP primitive. */
	     primitive = "0"b;
	     callp_desc = i;			/* index of program descriptor */
	     prim_op = 1;				/* Code for CALLP */
	     call callp_primitive;
	     return;

dcl  c                        char(1);
dcl  i                        fixed bin(17);
dcl  name                     char(4);
	end startp;
%page;
stfals_primitive: proc;
	     if db_interp_prim then
		call com_err_ (
		0
		, "gtss_interp_prim_"
		, "switch word bit off ^i."
		, switchword_bit
		);
	     if switchword_bit < 36
	        then
		switch_word (switchword_bit) = "0"b;
	        else /* switchword_bit >= 36 */
		addr(gtss_ust.lswt2) -> switch_word(switchword_bit-36) ="0"b;
	     next_prim = prim_address;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;
	end stfals_primitive;
%page;
strue_primitive: proc;
	     if db_interp_prim then
		call com_err_ (
		0
		, "gtss_interp_prim_"
		, "switch word bit on  ^i."
		, switchword_bit
		);
	     if switchword_bit < 36
	        then
		switch_word (switchword_bit) = "1"b;
	        else /* switchword_bit >= 36 */
		addr(gtss_ust.lswt2) -> switch_word(switchword_bit-36) ="1"b;
	     next_prim = prim_address;
	     primitive = gtss_prgdes_ext_$primitives (next_prim);
	     return;
	end strue_primitive;
%page;
system:	proc;					/* System level */

/* This routine brings the user back to system level and selects the default
   subsystem "NONE". It is patterned after SYS in TSSI.
*/

/* Turn off compiler identifier bits. */
/* See SYS in TSSI. */
	     string (gtss_ust.lswth) = string (gtss_ust.lswth) & lswth_reset;

/* Reset flag indicating that user code is executing. */
	     gtss_ust.lflg2.b14 = "0"b;

/* Indicate that program stack is empty. */
	     gtss_ust.lxxx.b0_17 = initial_lxxx;

/* Indicate that CALLSS stack is empty. */
	     gtss_ust.lcals.b0_17 = initial_lcals;
	     gtss_ext_$stack_level_ = 1;

/* Select Default system "NONE" */
	     comm = "none";
	end system;
%page;
systm_primitive: proc;
/* Turn off compiler identifier bits. */
	     string (gtss_ust.lswth) = string (gtss_ust.lswth) & lswth_reset;

/* Reset "user prog in control" indicator. */
	     gtss_ust.lflg2.b14 = "0"b;

/* If there is no input then re-init system level. */
	     if substr (comm, 1, 1) = carriage_return then go to sysx;

/* Test for "SYST(EM)" present.
   If not, must be system name. */
	     if comm ^= "syst" then do;
		j = 0;
		go to name_found;
	     end;

/* Find length of command line. */
	     l = search (tty_line, carriage_return);
	     if l <= 0 then go to sysx;

/* Find end of "SYST..." */
	     do i = 5 to l-1;
		if characters_transmitted (i) <= " " then go to end_found;
	     end;

/* If we fall through we are at end of line so
   re-init system level */
	     go to sysx;

end_found:     ;

/* Find beginning of system name. */
	     do j = i+1 to l-1;
		if characters_transmitted (j)>" " then go to name_found;
	     end;

/* If we fall through re-init system level. */

sysx:	     ;
	     call system;
	     return;

name_found:    ;

	     if j > 1 then do;
		count_of_characters_transmitted = count_of_characters_transmitted-j+1;
		tty_line = substr (tty_line, j);
		command = first4;
		comm = translate (command, "abcdefghijklmnopqrstuvwxyz",
		     "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	     end;

/* Indicate that program stack is empty. */
	     gtss_ust.lxxx.b0_17 = initial_lxxx;

/* Indicate that CALLSS stack is empty. */
	     gtss_ust.lcals.b0_17 = initial_lcals;
	     gtss_ext_$stack_level_ = 1;

dcl  i                        fixed bin(17);
dcl  j                        fixed bin(17);
dcl  l                        fixed bin(17);
	end systm_primitive;
%page;
/*   Variables for gtss_interp_prim_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  cl_ptr                   ptr static;
dcl  comm                     char(4) static;
dcl  command                  char(4);
dcl  conclude_gtss            bit(1) static int;
dcl  cp_ptr                   ptr static;
dcl  current_level            (4) label static;
dcl  cu_$cl                   entry ();
dcl  first4                   char(4)aligned based (tty_line_ptr)	/* Left 4 chars of line. */;
dcl  first6                   char(6)aligned based (tty_line_ptr)	/* Left 6 chars of line. */;
dcl  gseg                     ptr init(null());
dcl  gtss_dump_program_stack_ entry;
dcl  gtss_fail                condition;
dcl  gtss_fix_tty_modes_      entry ext;
dcl  gtss_prgdes_ext_$cmlcl   fixed bin(17)ext /* gtss_prgdes_ext_$primitives offset of 1st primitive for command loader. */;
dcl  hbound                   builtin;
dcl  i                        fixed bin(17);
dcl  initial_lcals            fixed bin(17) static;
dcl  initial_lxxx             fixed bin(17) static;
dcl  ioa_                     entry options (variable);
dcl  lbound                   builtin;
dcl  loop_count               fixed bin(17);
dcl  lower                    char(26)static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  lswth_reset              bit(18)static int options(constant) init("041363"b3           );
dcl  my_level                 fixed bin(24) automatic;
dcl  next_prim                fixed bin(17);
dcl  pop_callss_stack         bit(1);
dcl  program_interrupt        condition;
dcl  quit                     condition;
dcl  search                   builtin;
dcl  switch_word              (0:35)bit(1)unal based(addr(gtss_ust.lswth));
dcl  timer_manager_$reset_cpu_call entry (entry);
dcl  translate                builtin;
dcl  tty_line                 char(244)aligned based (tty_line_ptr);
dcl  tty_line_ptr             ptr init (null ()) static;
dcl  upper                    char(26)static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

dcl 1 common_list (gtss_prgdes_ext_$common_cmd_num) aligned based (cl_ptr),
    2 cl_word char(4),
    2 cl_len fixed bin(17);

dcl 1 com_prim_list (gtss_prgdes_ext_$common_cmd_num) aligned based (cp_ptr),
    2 com_prim_ptr fixed bin(17) unal,
    2 filler bit(18) unal;

dcl  carriage_return          char(1) static int options (constant) init ("");

dcl  period_TSLOG             bit(36)static int options (constant) init ("336362434627"b3);						/* =. bcd for ".TSLOG". */
%page;
%include gtss_prgdes_;
%page;
%include gtss_primitives_;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_ext_;
%page;
%include gtss_spa;
%page;
%include gtss_pnterr;
%page;
%include gtss_entry_dcls;
%page;
%include mc;
%page;
%include gse_ext_;
%page;
%include gtss_db_names;
%page;
%include gtss_starCF_;
     end gtss_interp_prim_;



		    gtss_ios_change_size_.pl1       12/11/84  1354.3rew 12/10/84  1044.2      160380


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

gtss_ios_change_size_: proc (file_no, size_change, link_indicator, status, code);

/*
   "			 This entry point is used to grow a permanent file up to  its
   "		maximum  size  limit  and to change the size of a temporary file.
   "		The caller should ensure that this entry point is not  called  to
   "		reduce the size of a permanent file.

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
dcl  code                     fixed bin (35) parm;
dcl  file_no                  fixed bin (24) parm;
dcl  link_indicator           bit (1) parm;
dcl  size_change              fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	fn = file_no;				/* Use local variables */
	sc = size_change;
	li = link_indicator;
	ap = gtss_disk.attributes_ptr (fn);
	fcb_ptr = gtss_disk (fn).fcb_ptr;

	status = 0;				/* Initialize status to indicate no error */
	code = 0;

	if bad_file_status (fn, gsc) then do;
/* FIX ** 	     if gsc = 15 then gcos_status = "4042"b3; */	/* Bad file number. */
/* FIX ** 	     else */					/* => 14. */
/* FIX ** 	     gcos_status = "4025"b3; */			/* File not open. */
status=gsc;
	     return;
	end;

	if li then sc = sc * 12;			/* convert to llinks */

	if sc = 0 then do;				/* Grow file by unspecified amount */
	     if pat_body.perm (fn) then do;		/* Perm file */

/* Grow a perm file by approx. 1/8 of its current size. */
		sc = divide (ap -> current_size, 8, 24, 0)+1;
		if ap -> max_size > 0
		then sc = min (sc, ap -> max_size - ap -> current_size);
	     end;
	     else do;				/* Temp file */
		sc = min (ap -> current_size, 1365*12-ap -> current_size);
	     end;
	     if sc <= 0 then do;
		status = 1;			/* file size is unchanged */
		sc = 0;
	     end;
	end;
	else do;					/* change file size by specified amount */
	     if pat_body.perm (fn) then do;		/* Perm File */
		if ap -> max_size > 0 then do;
		     max_change = ap -> max_size - ap -> current_size;
		     if sc > max_change then do;
			sc = max_change;
			if sc <= 0
			then do;
			     status = 1;		/* file size is unchanged */
			     sc = 0;
			end;
			else status = 2;		/* file size increased by
						   less than requested amount */
		     end;
		end;
	     end;
	     else do;				/* Temp File */

/* Make sure the size change is a multiple of a full link (12 llinks) */
		if mod (sc, 12) ^= 0 then do;
		     if sc > 0 then sc = sc + 12 - mod (sc, 12);
		     else sc = sc - mod (sc, 12);
		end;
	     end;
	end;					/* End of change file size by
						   specified amount. */

/* Change size of file */
	ap -> current_size = ap -> current_size + sc;

/* Do not exceed implementation restriction of 500 components per file */
	largest_file = divide (sys_info$max_seg_size*500, 320, 24, 0); /* max number of llinks */
	if ap -> current_size > largest_file then do;
	     status = 3;				/* implementation restriction of 500 components per file */
	     ap -> current_size = largest_file;
	end;

/* Make sure a temp file is not reduced below one link */
	if ^pat_body.perm (fn) then
	     ap -> current_size = max (12, ap -> current_size);

/* Call an internal procedure to set file_size, no_components, and the msf flag. */
/* Remember if the file was an msf before the size change. */
	msf_save = msf (fn);
	no_components_save = no_components (fn);
	call fix_size (status);

/*   If a temp file is reduced from an msf to
   a single segment, free the array of component pointers. */
	if sc < 0
	then do;
	     if msf_save & ^msf (fn) then do;
		single_segment_ptr (fn) = msf_array_ptr (fn) -> msf_components (0);
		free msf_array_ptr (fn) -> msf_components;
	     end;

/* If the number of components in a file is reduced,
   set the unused pointers to null */
	     else
	     if no_components (fn) < no_components_save then
		do i = no_components (fn) to no_components_save - 1;
		msf_array_ptr (fn) -> msf_components (i) = null ();
	     end;
	end;

/* If the file has just been grown from a single segment to an msf
   then allocate an array of component pointers. */
	if ^msf_save & msf (fn) then do;
	     allocate msf_components in (work_area) set (msf_array_ptr (fn));
	     msf_array_ptr (fn) -> msf_components (0) = single_segment_ptr (fn);
	     single_segment_ptr (fn) = null ();
	end;

/* If the number of components in a file is increased
   then get pointers to the new components */
	if no_components (fn) > no_components_save then
	     do i = no_components_save to no_components (fn) - 1;
	     call msf_manager_$get_ptr (fcb_ptr, (i), "1"b,
		msf_array_ptr (fn) -> msf_components (i), bc, code);
	     if code ^= 0 then do;
		status = 5;			/* error detected by msf_manager_$get_ptr */
		free msf_array_ptr (fn) -> msf_components;
		call msf_manager_$close (gtss_disk (fn).fcb_ptr);
		return;
	     end;
	end;

/* Call msf_manager_$adjust to set the bit count
   and free any excess file space. */
	bit_count = 36 * (mod (file_size (fn)-1, sys_info$max_seg_size)+1);

	on cond (record_quota_overflow) begin;
	     gtss_disk (fn) = gtss_disk (41);		/* Restore file fn to state before change_size. */
	     if db_ios then
		call ioa_ ("gtss_ios_change_size_: record quota overflow.");
	     status = 4;				/* ?? */
	     code = error_table_$rqover;
	     goto fin_change_size;
	end;
	gtss_disk (41) = gtss_disk (fn);		/* Save state of file fn. */

	call msf_manager_$adjust (fcb_ptr, no_components (fn)-1, bit_count, "110"b, code);
	if code ^= 0 & status = 0
	then status = 4;				/* error detected by msf_manager_$adjust */

	if pat_body.perm (fn) then do;		/* Perm File */
	     gtss_file_attributes_ptr = gtss_dfd_ext_$disk_file_data (fn).gtss_disk.attributes_ptr;
	     gtss_file_values.version = 1;
	     gtss_file_values.change_name = "0"b;
	     gtss_file_values.dname = gtss_dfd_ext_$disk_file_data (fn).gtss_disk.dir_name;
	     gtss_file_values.ename = gtss_dfd_ext_$disk_file_data (fn).gtss_disk.entry_name;
	     gtss_file_values.new_ename = " ";		/* Set values for current entry. */
	     string (gtss_file_values.set_switch) = "0"b;
	     gtss_file_values.set_switch.curll = "1"b;
	     gtss_file_values.data_fields.curll = gtss_file_attributes.current_size;

	     call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	     if code ^= 0 then status = 6;		/* $set failed. */
	end;

fin_change_size: ;

	return;					/* End of gtss_ios_change_size_ */


/* INTERNAL PROCEDURES */

bad_file_status: proc (fn, status) returns (bit (1));

/* This routine is called to verify that
   the file number input parameter corresponds
   to a valid open file.  If so, "0"b is returned.
   Otherwise , "1"b is returned. */

dcl  fn                       fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	     if fn < lbound (gtss_disk, 1) | fn >= hbound (gtss_disk, 1) then do;
		status = 15;			/* Bad file number */
		return ("1"b);
	     end;
	     if gtss_disk.fcb_ptr (fn) = null () then do;
		status = 14;			/* File not open  */
		return ("1"b);
	     end;
	     return ("0"b);
	end bad_file_status;

fix_size:	proc (status);

/* This routine is called from within the open and change_size entry points
   to set file_size, no_components, and the msf flag. */
dcl  status                   fixed bin(24)parm;

	     gtss_disk.file_size (fn) = 320 * ap -> gtss_file_attributes.current_size;
	     gtss_disk.no_components (fn) =
		divide (file_size (fn)-1, sys_info$max_seg_size, 24, 0)+1;
	     gtss_disk.msf (fn) = (no_components (fn) > 1);
	     if no_components (fn) > 500 then do;
		no_components (fn) = 500;
		file_size (fn) = 500*1024*255;
		status = 3;			/* Size of file requested exceeds 500 components */
	     end;
	end fix_size;

/* VARIABLES FOR GTSS_IOS_ */
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl file_dir char(168);
dcl file_dir_len fixed bin;
dcl file_ent char(32);
dcl  gcos_status              bit(12)aligned based(gsp);
dcl  bit72                    bit(72)aligned based;
dcl  gsp                      ptr;

dcl  acl_ptr                  ptr	/* pointer to segment_acl passed
				as a parameter to msf_manager_$acl_list */;
dcl  ap                       ptr	/* Pointer to the attributes structure for the current file */;
dcl  bc                       fixed bin (24)	/* Used as a sink for bit counts returned by
				msf_manager_$get_ptr */;
dcl  bit_count                fixed bin (24)	/* The bit count of the last segment of an msf.
				Passed as a parameter to msf_manager_$adjust. */;
dcl  bksp_sw                  bit (1)	/* Distinguishes between backspacing
				"1"b and forward spacing "0"b a linked file. */;
dcl  cmd_word                 bit (36) aligned	/* temp */;
dcl  count                    fixed bin (24)	/* Counts io commands processed
				for current io select sequence */;
dcl  da_residue               fixed bin	/* Address of last memory location
				accessed during I/O.  Used in building
				return status words for I/O. */;
dcl  data_moved               fixed bin (24)	/* number of words moved or skipped over by
				the current read or write operation. */;
dcl  dcw_number               fixed bin (24)	/* Used to count DCW's in
				the current select sequence */;
dcl  dcw_offset               fixed bin (24)	/* slave offset of current dcw */;
dcl  dcw_ptr                  ptr	/* Multics pointer to the current dcw */;
dcl  disconnect               bit (1)	/* Indicator that the last DCW has been encountered. */;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  fcb_ptr                  ptr init (null ())	/* pointer to file control block
				used by msf_manager_ */;
dcl  file_ptr                 ptr	/* pointer to current positoion in file */;
dcl  fn                       fixed bin (24)	/* Index in gtss_ext_$disk_file_data of
				information about the file to be processed. */;
dcl  get_mode                 fixed bin (5)	/* User's access mode to segment as
				returned by hcs_$fs_get_mode */;
dcl  gsc                      fixed bin(24);
dcl  i                        fixed bin (24);
dcl  idptr                    ptr	/* Pointer to the current id
				word of the I/O select sequence. */;
dcl  j                        fixed bin (24);
dcl  l                        fixed bin (24)	/* The length in words of the current
				piece of data to be moved to or from the file */;
dcl  largest_file             fixed bin (24)	/* Max no. of llinks a file can grow to */;
dcl  last_component           bit (1)	/* When on, indicates that the
				current component is the last component of the file */;
dcl  li                       bit (1)	/* variable for the parameter link_indicator */;
dcl  M                        char (l*4) based	/* A template used for moving data
				to or from the file. */;
dcl  max_change               fixed bin (24)	/* The maximum amount that
				the size of a file can be increased
				expressed in llinks (320 word blocks) */;
dcl  msf_components           (0:499) ptr based	/* An array of pointers for each msf.
				Each component which has been accessed has a
				corresponding initialized pointer. */;

dcl  msf_save                 bit (1)	/* A flag used to remember whether
				the file was a msf before its size
				was changed. */;
dcl  no_components_save       fixed bin (24)	/* Used to remember the number
				of components a file had before its
				size was changed */;
dcl  pat_body_overlay         bit (180) based	/* used for initializing the
				pat body to all zeros */;
dcl  opptr                    ptr	/* Pointer to the current operation
				word of the I/O select sequence. */;
dcl  rec_ct_residue           fixed bin (24)	/* holds no of unskipped records */;
dcl  record_quota_overflow    condition ext;
dcl  sc                       fixed bin (24)	/* local variable for the parameter size_change */;
dcl  scratch_status           bit (72) aligned	/* temp */;
dcl  seek_address             fixed bin (24) based	/* user seek address for disk or drum */;
dcl  seek_ptr                 ptr	/* Pointer to the word containing
				the io seek address */;
dcl  seeksw                   bit (1)	/* sw controlling disk or drum seeks */;
dcl  seg_length               fixed bin (24)	/* length in words of current component of file */;
dcl  select_seg_ptr           ptr	/* Pointer to beginning of
				segment containing select sequence */;
dcl  select_seq_in_memory     bit (1)	/* 1 => the select sequence is in the
				same segment that is used for Gcos memory.
				In this case the addresses of DCW's, seek address data word, and
				status return words will be checked against the
				memory_limit parameter. */;
dcl  slave_status             bit (36) aligned;
dcl  sp                       ptr	/* Pointer to user's select sequence for this I/O */;
dcl  storlimit                fixed bin (24)	/* slave core boundary */;
dcl  sptr                     ptr	/* pointer to return word of select sequence */;
dcl  swptr                    ptr	/* Pointer to status return words */;
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  ta_offset                fixed bin (24)	/* Offset in the user's slave memory
				of the transmission area for the current DCW. */;
dcl  ta_ptr                   ptr	/* pointer to the transmission area for
				the current DCW. */;
dcl  ta_seg_ptr               ptr	/* pointer to the user's slave
				memory segment */;
dcl  tdcw_previous            bit (1)	/* Indicator that the last DCW processed was a TDCW */;
dcl  tfp                      fixed bin (71);
dcl  wc_residue               fixed bin (24)	/* Number of words remaining to be transferred
				in the current dcw when eof or
				memory fault occurs. Used in building
				return status words for I/O. */;
dcl  work_area                area (sys_info$max_seg_size) aligned
		     based (gtss_ext_$work_area_ptr)	/* Area used to store arrays of pointers to
			components of msf's. */;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  ioa_                     entry options (variable);
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));

/* STRUCTURES */

dcl 1 dcw aligned based (dcw_ptr),			/* dcw model */
    2 data_addr bit (18) unaligned,			/* data address */
    2 zero bit (3) unaligned,				/* fill */
    2 action bit (3) unaligned,			/* action */
    2 count bit (12) unaligned;						/* word count for transfer */

dcl 1 id_word aligned based (idptr),			/* model of identification word */
    2 filep bit (18) unaligned,			/* file control block pointer */
    2 dcwp bit (18) unaligned;						/* dcw list pointer */


dcl 1 op_word aligned based (opptr),			/* model of operation word */
    2 dev_com bit (6) unaligned,			/* device command */
    2 zero1 bit (12) unaligned,			/* zeros */
    2 ioc_com bit (5) unaligned,			/* ioc command */
    2 zero2 bit (1) unaligned,			/* zero */
    2 control bit (6) unaligned,			/* control */
    2 count bit (6) unaligned;						/* count */

dcl 1 return_word aligned based (sptr),			/* model of status return word */
    2 status_return bit (18) unaligned,			/* pointer to return words */
    2 courtesy_call bit (18) unaligned;						/* pointer to courtesy call rtn */

dcl 1 stat_words aligned based (swptr),			/* model of status words */
    2 sw1 bit (36) aligned,				/* word 1 */
    2 sw2 bit (36) aligned;						/* word 2 */


dcl  decode_mode              (0:63) bit (3) aligned			/* Permissions are read, execute, write */
     static init (					/* OCTAL */
     "100"b,					/* 0 -- Zero access mode maps to Query permission */
     "100"b,					/* 1 */
    (2) (1)"000"b,					/* 2-3 */
     "110"b,					/* 4 */
    (3) (1)"000"b,					/* 5-7 */
     "100"b,					/* 10 */
    (7) (1)"000"b,					/* 11-17 */
    (2) (1)"101"b,					/* 20-21 */
    (2) (1) "000"b,					/* 22-23 */
     "101"b,					/* 24 */
    (11) (1)"000"b,					/* 25-37 */
    (2) (1) "100"b,					/* 40-41 */
    (6) (1)"000"b,					/* 42-47 */
     "100"b,					/* 50 */
    (3) (1)"000"b,					/* 51-53 */
     "100"b,					/* 54 */
    (3) (1)"000"b,					/* 55-57 */
    (2) (1)"101"b,					/* 60-61 */
    (10) (1)"000"b,					/* 62-73 */
     "101"b,					/* 74 */
    (3) (1)"000"b);						/* 75-77 */

dcl  io_commands              (8) bit (36) internal static aligned init (


/* 	Disk Command Table						 */

     "340000000002"b3,				/* 34 - seek disk address */
     "250000002400"b3,				/* 25 - read disk continuous */
     "310000002400"b3,				/* 31 - write disk continuous */
     "700000020001"b3,				/* 70 - rewind */
     "460000020001"b3,				/* 46 - backspace record(s) */
     "440000020001"b3,				/* 44 - forward space record(s) */
     "400000020001"b3,				/* 40 - reset status */
     "000000020001"b3);						/* 00 - request status */

%include gtss_dfd_ext_;

%include gtss_file_attributes;

%include gtss_ext_;

%include gtss_file_values;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_ios_change_size_ */;



		    gtss_ios_close_.pl1             12/11/84  1354.3rew 12/10/84  1027.5      140508


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


gtss_ios_close_: proc (file_no, status_ptr, code);

/*

   This  entry point is used to close a previously opened file.  The
   associated file number is made available for opening a new  file.
   If the file is temporary it is deleted on closing.

   Author:	Dave Ward		03/04/80	(derived from gtss_ios_)
   Modified:	Scott C. Akers	12/11/81	Set bitcounts when closing.
					Change "\014" to "%page;"
   Modified:        Ron Barstad         08/11/82  Fix set bitcounts only when
                                                  file was written to
   Modified:	Ron Barstad	11/29/84  Fix componet count in MSFs

*/
dcl  code                     fixed bin (35) parm;
dcl  file_no                  fixed bin (24) parm;
dcl  status_ptr               ptr parm			/* Pointer to gcos caller's 2 word status. */;

	fn = file_no;				/* Use local variables */
	fcb_ptr = gtss_disk.fcb_ptr (fn);

	gsp = status_ptr;				/* Reference gcos_status. */
	gcos_status = "4000"b3;			/* Initialize status to indicate no error */
	code = 0;

	gsc = 0;
	if bad_file_status (fn, gsc) then do;
	     if gsc = 15 then gcos_status = "4042"b3;	/* Bad file number. */
	     else					/* => 14. */
	     gcos_status = "4025"b3;			/* File not open. */
	     return;
	end;

	if pat_body.perm (fn) then do;		/* Perm file. */

/* Re-establish the pathname of the file
   to be closed (may have changed due to
   deletion of a concurrently accessed
   file).
*/
	     if msf (fn) then
		file_ptr = msf_array_ptr (fn) -> msf_components (0);
	     else
	     file_ptr = single_segment_ptr (fn);
	     call hcs_$fs_get_path_name (
		file_ptr
		, file_dir
		, file_dir_len
		, file_ent
		, code
		);
	     if code ^= 0 then do;
		if db_ios then
		     call com_err_ (
		     code
		     , "gtss_ios_"
		     , "File ^i ptr ^p"
		     , fn
		     , file_ptr
		     );
		gcos_status = "4100"b3;
		goto return_close;
	     end;

	     call gtss_verify_access_$check_forced_access (    /* We may have forced access, must remove acl. */
		file_dir
		, file_ent
		, fn
		);
	     if msf (fn) then do;

/* Extract pathname of directory
   of the msf, rather than the pathname
   of component 0.
*/
		j = index (reverse (file_dir), ">");
		if j = 0 then do;			/* Bad pathname. */
		     if db_ios then
			call com_err_ (
			0
			, "gtss_ios_"
			, "Could not get MSF pathname from ""^a"""
			, file_dir
			);
		     gcos_status = "4100"b3;
		     goto return_close;
		end;
		file_ent = substr (file_dir, length (file_dir)-j+2);
		substr (file_dir, length (file_dir)-j+1) = " ";
	     end;
	     call gtss_mcfc_$close (			/* Close the file. */
		file_dir
		, file_ent
		, gtss_ext_$mcfc.multics_lock_id
		, status_ptr
		, code
		);
	end;
	else do;					/* Delete temp file at closing. */
	     call delete_$path (
		gtss_disk.dir_name (fn)
		, gtss_disk.entry_name (fn)
		, "000100"b
		, "gtss_ios_"
		, code
		);
	     if code ^= 0 then
		gcos_status = "4100"b3;		/* error encountered by delete_$path */
	end;
%page;
return_close: ;
   /* If this is a perm file and have write permisssion, then reset bit ount */
	if pat_body.perm (fn)
            & gtss_dfd_ext_$disk_file_data(fn).gtss_disk.permissions.write
	then do;
	     size_ptr = gtss_dfd_ext_$disk_file_data(fn).gtss_disk.attributes_ptr;
	     file_size = size_ptr -> gtss_file_attributes.current_size;
	     if file_size ^= 0
	     then file_size = (mod (file_size-1, 816))+1;
	     final_bit_count = file_size * 36 * 320;	/* Make bitcounts modulo 320 words. */

	     if msf (fn)				/* Now, see who does the honors. */
	     then call msf_manager_$adjust (gtss_disk.fcb_ptr (fn),
				     gtss_dfd_ext_$disk_file_data(fn).gtss_disk.no_components-1,
				     final_bit_count, "110"b, code);
	     else call hcs_$set_bc_seg (single_segment_ptr (fn), final_bit_count, code);
	     if code ^= 0
	     then do;
		gcos_status = "4100"b3;
		if db_ios
		then call com_err_ (code, "gtss_ios_",
				"^/Could not set bit_count on file # ^i (^p)",
				fn, file_ptr);
		end;
	     end;

	call msf_manager_$close (gtss_disk.fcb_ptr (fn)); /* We do the close even if it's a temp file. */
	if msf (fn)
	then free msf_array_ptr (fn) -> msf_components;

	return;
%page;
/* INTERNAL PROCEDURES */

bad_file_status: proc (fn, status) returns (bit (1));

/* This routine is called to verify that
   the file number input parameter corresponds
   to a valid open file.  If so, "0"b is returned.
   Otherwise , "1"b is returned. */

dcl  fn                       fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	     if fn < lbound (gtss_disk, 1) | fn >= hbound (gtss_disk, 1) then do;
		status = 15;			/* Bad file number */
		return ("1"b);
	     end;
	     if gtss_disk.fcb_ptr (fn) = null () then do;
		status = 14;			/* File not open  */
		return ("1"b);
	     end;
	     return ("0"b);
	end bad_file_status;
%page;
/* VARIABLES FOR GTSS_IOS_ */

dcl file_dir char(168);
dcl file_dir_len fixed bin;
dcl file_ent char(32);
dcl  gcos_status              bit(12)aligned based(gsp);
dcl  bit72                    bit(72)aligned based;
dcl  gsp                      ptr;

dcl  acl_ptr                  ptr			/* pointer to segment_acl passed
						   as a parameter to msf_manager_$acl_list */;
dcl  ap                       ptr			/* Pointer to the attributes
						   structure for the current file */;
dcl  bc                       fixed bin (24)		/* Used as a sink for bit counts returned by
						   msf_manager_$get_ptr */;
dcl  bit_count                fixed bin (24)		/* The bit count of the last segment of an msf.
						   Passed as a parameter to
						   msf_manager_$adjust. */;
dcl  bksp_sw                  bit (1)			/* Distinguishes between backspacing
						   "1"b and forward spacing "0"b
						   a linked file. */;
dcl  cmd_word                 bit (36) aligned		/* temp */;
dcl  count                    fixed bin (24)		/* Counts io commands processed
						for current I/O select sequence */;
dcl  da_residue               fixed bin			/* Address of last memory location
						   accessed during I/O.  Used in building
						   return status words for I/O. */;
dcl  data_moved               fixed bin (24)		/* number of words moved or skipped over by
						   the current read or write operation. */;
dcl  dcw_number               fixed bin (24)		/* Used to count DCW's in
						   the current select sequence */;
dcl  dcw_offset               fixed bin (24)		/* slave offset of current dcw */;
dcl  dcw_ptr                  ptr			/* Multics pointer to the current dcw */;
dcl  disconnect               bit (1)			/* Indicator that the last DCW has been encountered. */;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  fcb_ptr                  ptr init (null ())		/* pointer to file control block
						   used by msf_manager_ */;
dcl  file_ptr                 ptr			/* pointer to current positoion in file */;
dcl (file_size,
     final_bit_count)	fixed bin (24);		/* Final file size in blocks and bits. */
dcl  fn                       fixed bin (24)		/* Index in gtss_ext_$disk_file_data of
						   information about the file to
						   be processed. */;
dcl  get_mode                 fixed bin (5)		/* User's access mode to segment as
						   returned by hcs_$fs_get_mode */;
dcl  gsc                      fixed bin(24);
dcl  i                        fixed bin (24);
dcl  idptr                    ptr			/* Pointer to the current id
						   word of the I/O select sequence. */;
dcl  j                        fixed bin (24);
dcl  l                        fixed bin (24)		/* The length in words of the current
						   piece of data to be moved to
						   or from the file */;
dcl  largest_file             fixed bin (24)		/* Max no. of llinks a file can grow to */;
dcl  last_component           bit (1)			/* When on, indicates that the
						   current component is the last component of the file */;
dcl  li                       bit (1)			/* variable for the parameter link_indicator */;
dcl  M                        char (l*4) based		/* A template used for moving data
						   to or from the file. */;
dcl  max_change               fixed bin (24)		/* The maximum amount that
						   the size of a file can be increased
						   expressed in llinks (320 word blocks) */;
dcl  msf_components           (0:499) ptr based		/* An array of pointers for each msf.
						   Each component which has been accessed
						   has a corresponding initialized pointer. */;

dcl  msf_save                 bit (1)			/* A flag used to remember whether
						   the file was a msf before its size
						   was changed. */;
dcl  no_components_save       fixed bin (24)		/* Used to remember the number
						   of components a file had before its
						   size was changed */;
dcl  pat_body_overlay         bit (180) based		/* used for initializing the
						   pat body to all zeros */;
dcl  opptr                    ptr			/* Pointer to the current operation
						   word of the I/O select sequence. */;
dcl  rec_ct_residue           fixed bin (24)		/* holds no of unskipped records */;
dcl  record_quota_overflow    condition ext;
dcl  sc                       fixed bin (24)		/* local variable for the parameter size_change */;
dcl  scratch_status           bit (72) aligned		/* temp */;
dcl  seek_address             fixed bin (24) based	/* user seek address for disk or drum */;
dcl  seek_ptr                 ptr			/* Pointer to the word containing
						   the io seek address */;
dcl  seeksw                   bit (1)			/* sw controlling disk or drum seeks */;
dcl  seg_length               fixed bin (24)		/* length in words of current component of file */;
dcl  select_seg_ptr           ptr			/* Pointer to beginning of
						   segment containing select sequence */;
dcl  select_seq_in_memory     bit (1)			/* 1 => the select sequence is in the
						   same segment that is used for Gcos memory.
						   In this case the addresses of DCW's, seek address data word, and
						   status return words will be checked against the
						   memory_limit parameter. */;
dcl  size_ptr		ptr;			/* Points to size atribute */
dcl  slave_status             bit (36) aligned;
dcl  sp                       ptr			/* Pointer to user's select sequence for this I/O */;
dcl  storlimit                fixed bin (24)		/* slave core boundary */;
dcl  sptr                     ptr			/* pointer to return word of select sequence */;
dcl  swptr                    ptr			/* Pointer to status return words */;
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  ta_offset                fixed bin (24)		/* Offset in the user's slave memory
						   of the transmission area for the current DCW. */;
dcl  ta_ptr                   ptr			/* pointer to the transmission area for
						   the current DCW. */;
dcl  ta_seg_ptr               ptr			/* pointer to the user's slave
						   memory segment */;
dcl  tdcw_previous            bit (1)			/* Indicator that the last DCW processed was a TDCW */;
dcl  tfp                      fixed bin (71);
dcl  wc_residue               fixed bin (24)		/* Number of words remaining to be transferred
						   in the current DCW when EOF or
						   memory fault occurs. Used in building
						   return status words for I/O. */;
dcl  work_area                area (sys_info$max_seg_size) aligned
		     based (gtss_ext_$work_area_ptr)	/* Area used to store arrays of pointers to
						components of MSFs. */;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg	entry (ptr, fixed bin(24), fixed bin(35));
dcl  ioa_                     entry options (variable);
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));
%page;
/* STRUCTURES */

dcl 1 dcw aligned based (dcw_ptr),			/* dcw model */
    2 data_addr bit (18) unaligned,			/* data address */
    2 zero bit (3) unaligned,				/* fill */
    2 action bit (3) unaligned,			/* action */
    2 count bit (12) unaligned;			/* word count for transfer */

dcl 1 id_word aligned based (idptr),			/* model of identification word */
    2 filep bit (18) unaligned,			/* file control block pointer */
    2 dcwp bit (18) unaligned;			/* dcw list pointer */


dcl 1 op_word aligned based (opptr),			/* model of operation word */
    2 dev_com bit (6) unaligned,			/* device command */
    2 zero1 bit (12) unaligned,			/* zeros */
    2 ioc_com bit (5) unaligned,			/* ioc command */
    2 zero2 bit (1) unaligned,			/* zero */
    2 control bit (6) unaligned,			/* control */
    2 count bit (6) unaligned;			/* count */

dcl 1 return_word aligned based (sptr),			/* model of status return word */
    2 status_return bit (18) unaligned,			/* pointer to return words */
    2 courtesy_call bit (18) unaligned;			/* pointer to courtesy call rtn */

dcl 1 stat_words aligned based (swptr),			/* model of status words */
    2 sw1 bit (36) aligned,				/* word 1 */
    2 sw2 bit (36) aligned;				/* word 2 */


%page;
dcl  decode_mode              (0:63) bit (3) aligned	/* Permissions are read, execute, write */
     static init (					/* OCTAL */
     "100"b,					/* 0 -- Zero access mode maps to Query permission */
     "100"b,					/* 1 */
    (2) (1)"000"b,					/* 2-3 */
     "110"b,					/* 4 */
    (3) (1)"000"b,					/* 5-7 */
     "100"b,					/* 10 */
    (7) (1)"000"b,					/* 11-17 */
    (2) (1)"101"b,					/* 20-21 */
    (2) (1) "000"b,					/* 22-23 */
     "101"b,					/* 24 */
    (11) (1)"000"b,					/* 25-37 */
    (2) (1) "100"b,					/* 40-41 */
    (6) (1)"000"b,					/* 42-47 */
     "100"b,					/* 50 */
    (3) (1)"000"b,					/* 51-53 */
     "100"b,					/* 54 */
    (3) (1)"000"b,					/* 55-57 */
    (2) (1)"101"b,					/* 60-61 */
    (10) (1)"000"b,					/* 62-73 */
     "101"b,					/* 74 */
    (3) (1)"000"b);					/* 75-77 */

dcl  io_commands              (8) bit (36) internal static aligned init (


/* 	Disk Command Table						 */

     "340000000002"b3,				/* 34 - seek disk address */
     "250000002400"b3,				/* 25 - read disk continuous */
     "310000002400"b3,				/* 31 - write disk continuous */
     "700000020001"b3,				/* 70 - rewind */
     "460000020001"b3,				/* 46 - backspace record(s) */
     "440000020001"b3,				/* 44 - forward space record(s) */
     "400000020001"b3,				/* 40 - reset status */
     "000000020001"b3);				/* 00 - request status */
%page;
%include gtss_dfd_ext_;
%page;
%include gtss_file_attributes;
%page;
%include gtss_ext_;
%page;
%include gtss_file_values;
%page;
%include gtss_entry_dcls;
%page;
%include gtss_db_names;

end gtss_ios_close_;



		    gtss_ios_exchange_names_.pl1    12/11/84  1354.3rew 12/10/84  1044.2      107199


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

gtss_ios_exchange_names_: proc (file_no1, file_no2, status, code);

/*
   "			 This  entry  point is used to exchange information about two
   "		temporary files.  It is provided for the  implementation  of  DRL
   "		SWITCH.

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
dcl  code                     fixed bin (35) parm;
dcl  file_no1                 fixed bin (24) parm;
dcl  file_no2                 fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	status = 0;				/* Set status to zero to indicate no error */
	code = 0;

	if bad_file_status (file_no1, status) then return;
	if bad_file_status (file_no2, status) then return;
	gtss_disk (hbound (gtss_disk, 1)) = gtss_disk (file_no1);
	gtss_disk (file_no1) = gtss_disk (file_no2);
	gtss_disk (file_no2) = gtss_disk (hbound (gtss_disk, 1));
	ap = gtss_disk.attributes_ptr (file_no1);
	gtss_disk.attributes_ptr (file_no1) = gtss_disk.attributes_ptr (file_no2);
	gtss_disk.attributes_ptr (file_no2) = ap;

	return;					/* End of gtss_ios_exchange_names_ */

/* INTERNAL PROCEDURES */

bad_file_status: proc (fn, status) returns (bit (1));

/* This routine is called to verify that
   the file number input parameter corresponds
   to a valid open file.  If so, "0"b is returned.
   Otherwise , "1"b is returned. */

dcl  fn                       fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	     if fn < lbound (gtss_disk, 1) | fn >= hbound (gtss_disk, 1) then do;
		status = 15;			/* Bad file number */
		return ("1"b);
	     end;
	     if gtss_disk.fcb_ptr (fn) = null () then do;
		status = 14;			/* File not open  */
		return ("1"b);
	     end;
	     return ("0"b);
	end bad_file_status;

/* VARIABLES FOR GTSS_IOS_ */
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl file_dir char(168);
dcl file_dir_len fixed bin;
dcl file_ent char(32);
dcl  gcos_status              bit(12)aligned based(gsp);
dcl  bit72                    bit(72)aligned based;
dcl  gsp                      ptr;

dcl  acl_ptr                  ptr	/* pointer to segment_acl passed
				as a parameter to msf_manager_$acl_list */;
dcl  ap                       ptr	/* Pointer to the attributes structure for the current file */;
dcl  bc                       fixed bin (24)	/* Used as a sink for bit counts returned by
				msf_manager_$get_ptr */;
dcl  bit_count                fixed bin (24)	/* The bit count of the last segment of an msf.
				Passed as a parameter to msf_manager_$adjust. */;
dcl  bksp_sw                  bit (1)	/* Distinguishes between backspacing
				"1"b and forward spacing "0"b a linked file. */;
dcl  cmd_word                 bit (36) aligned	/* temp */;
dcl  count                    fixed bin (24)	/* Counts io commands processed
				for current io select sequence */;
dcl  da_residue               fixed bin	/* Address of last memory location
				accessed during I/O.  Used in building
				return status words for I/O. */;
dcl  data_moved               fixed bin (24)	/* number of words moved or skipped over by
				the current read or write operation. */;
dcl  dcw_number               fixed bin (24)	/* Used to count DCW's in
				the current select sequence */;
dcl  dcw_offset               fixed bin (24)	/* slave offset of current dcw */;
dcl  dcw_ptr                  ptr	/* Multics pointer to the current dcw */;
dcl  disconnect               bit (1)	/* Indicator that the last DCW has been encountered. */;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  fcb_ptr                  ptr init (null ())	/* pointer to file control block
				used by msf_manager_ */;
dcl  file_ptr                 ptr	/* pointer to current positoion in file */;
dcl  fn                       fixed bin (24)	/* Index in gtss_ext_$disk_file_data of
				information about the file to be processed. */;
dcl  get_mode                 fixed bin (5)	/* User's access mode to segment as
				returned by hcs_$fs_get_mode */;
dcl  gsc                      fixed bin(24);
dcl  i                        fixed bin (24);
dcl  idptr                    ptr	/* Pointer to the current id
				word of the I/O select sequence. */;
dcl  j                        fixed bin (24);
dcl  l                        fixed bin (24)	/* The length in words of the current
				piece of data to be moved to or from the file */;
dcl  largest_file             fixed bin (24)	/* Max no. of llinks a file can grow to */;
dcl  last_component           bit (1)	/* When on, indicates that the
				current component is the last component of the file */;
dcl  li                       bit (1)	/* variable for the parameter link_indicator */;
dcl  M                        char (l*4) based	/* A template used for moving data
				to or from the file. */;
dcl  max_change               fixed bin (24)	/* The maximum amount that
				the size of a file can be increased
				expressed in llinks (320 word blocks) */;
dcl  msf_components           (0:499) ptr based	/* An array of pointers for each msf.
				Each component which has been accessed has a
				corresponding initialized pointer. */;

dcl  msf_save                 bit (1)	/* A flag used to remember whether
				the file was a msf before its size
				was changed. */;
dcl  no_components_save       fixed bin (24)	/* Used to remember the number
				of components a file had before its
				size was changed */;
dcl  pat_body_overlay         bit (180) based	/* used for initializing the
				pat body to all zeros */;
dcl  opptr                    ptr	/* Pointer to the current operation
				word of the I/O select sequence. */;
dcl  rec_ct_residue           fixed bin (24)	/* holds no of unskipped records */;
dcl  record_quota_overflow    condition ext;
dcl  sc                       fixed bin (24)	/* local variable for the parameter size_change */;
dcl  scratch_status           bit (72) aligned	/* temp */;
dcl  seek_address             fixed bin (24) based	/* user seek address for disk or drum */;
dcl  seek_ptr                 ptr	/* Pointer to the word containing
				the io seek address */;
dcl  seeksw                   bit (1)	/* sw controlling disk or drum seeks */;
dcl  seg_length               fixed bin (24)	/* length in words of current component of file */;
dcl  select_seg_ptr           ptr	/* Pointer to beginning of
				segment containing select sequence */;
dcl  select_seq_in_memory     bit (1)	/* 1 => the select sequence is in the
				same segment that is used for Gcos memory.
				In this case the addresses of DCW's, seek address data word, and
				status return words will be checked against the
				memory_limit parameter. */;
dcl  slave_status             bit (36) aligned;
dcl  sp                       ptr	/* Pointer to user's select sequence for this I/O */;
dcl  storlimit                fixed bin (24)	/* slave core boundary */;
dcl  sptr                     ptr	/* pointer to return word of select sequence */;
dcl  swptr                    ptr	/* Pointer to status return words */;
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  ta_offset                fixed bin (24)	/* Offset in the user's slave memory
				of the transmission area for the current DCW. */;
dcl  ta_ptr                   ptr	/* pointer to the transmission area for
				the current DCW. */;
dcl  ta_seg_ptr               ptr	/* pointer to the user's slave
				memory segment */;
dcl  tdcw_previous            bit (1)	/* Indicator that the last DCW processed was a TDCW */;
dcl  tfp                      fixed bin (71);
dcl  wc_residue               fixed bin (24)	/* Number of words remaining to be transferred
				in the current dcw when eof or
				memory fault occurs. Used in building
				return status words for I/O. */;
dcl  work_area                area (sys_info$max_seg_size) aligned
		     based (gtss_ext_$work_area_ptr)	/* Area used to store arrays of pointers to
			components of msf's. */;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  ioa_                     entry options (variable);
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));

/* STRUCTURES */

dcl 1 dcw aligned based (dcw_ptr),			/* dcw model */
    2 data_addr bit (18) unaligned,			/* data address */
    2 zero bit (3) unaligned,				/* fill */
    2 action bit (3) unaligned,			/* action */
    2 count bit (12) unaligned;						/* word count for transfer */

dcl 1 id_word aligned based (idptr),			/* model of identification word */
    2 filep bit (18) unaligned,			/* file control block pointer */
    2 dcwp bit (18) unaligned;						/* dcw list pointer */


dcl 1 op_word aligned based (opptr),			/* model of operation word */
    2 dev_com bit (6) unaligned,			/* device command */
    2 zero1 bit (12) unaligned,			/* zeros */
    2 ioc_com bit (5) unaligned,			/* ioc command */
    2 zero2 bit (1) unaligned,			/* zero */
    2 control bit (6) unaligned,			/* control */
    2 count bit (6) unaligned;						/* count */

dcl 1 return_word aligned based (sptr),			/* model of status return word */
    2 status_return bit (18) unaligned,			/* pointer to return words */
    2 courtesy_call bit (18) unaligned;						/* pointer to courtesy call rtn */

dcl 1 stat_words aligned based (swptr),			/* model of status words */
    2 sw1 bit (36) aligned,				/* word 1 */
    2 sw2 bit (36) aligned;						/* word 2 */


dcl  decode_mode              (0:63) bit (3) aligned			/* Permissions are read, execute, write */
     static init (					/* OCTAL */
     "100"b,					/* 0 -- Zero access mode maps to Query permission */
     "100"b,					/* 1 */
    (2) (1)"000"b,					/* 2-3 */
     "110"b,					/* 4 */
    (3) (1)"000"b,					/* 5-7 */
     "100"b,					/* 10 */
    (7) (1)"000"b,					/* 11-17 */
    (2) (1)"101"b,					/* 20-21 */
    (2) (1) "000"b,					/* 22-23 */
     "101"b,					/* 24 */
    (11) (1)"000"b,					/* 25-37 */
    (2) (1) "100"b,					/* 40-41 */
    (6) (1)"000"b,					/* 42-47 */
     "100"b,					/* 50 */
    (3) (1)"000"b,					/* 51-53 */
     "100"b,					/* 54 */
    (3) (1)"000"b,					/* 55-57 */
    (2) (1)"101"b,					/* 60-61 */
    (10) (1)"000"b,					/* 62-73 */
     "101"b,					/* 74 */
    (3) (1)"000"b);						/* 75-77 */

dcl  io_commands              (8) bit (36) internal static aligned init (


/* 	Disk Command Table						 */

     "340000000002"b3,				/* 34 - seek disk address */
     "250000002400"b3,				/* 25 - read disk continuous */
     "310000002400"b3,				/* 31 - write disk continuous */
     "700000020001"b3,				/* 70 - rewind */
     "460000020001"b3,				/* 46 - backspace record(s) */
     "440000020001"b3,				/* 44 - forward space record(s) */
     "400000020001"b3,				/* 40 - reset status */
     "000000020001"b3);						/* 00 - request status */

%include gtss_dfd_ext_;

%include gtss_file_attributes;

%include gtss_ext_;

%include gtss_file_values;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_ios_exchange_names */;
 



		    gtss_ios_initialize_.pl1        12/11/84  1354.3rew 12/10/84  1044.2        6696


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

gtss_ios_initialize_: proc;

/* Initialize disk file data base file control
   blocks structure to null pointers.

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
	gtss_disk.fcb_ptr = null ();
	return;

dcl null builtin;

%include gtss_dfd_ext_;
     end						/* gtss_ios_initialize_ */;



		    gtss_ios_open_.pl1              12/11/84  1354.3rew 12/10/84  1044.2      152280


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

gtss_ios_open_: proc (
	     file_no
	     , dir_name
	     , entry_name
	     , access_mode
	     , random_indicator
	     , attributes_ptr
	     , status_ptr
	     , code
	     );

/* This entry point is used to set  up  the  necessary  control
   information about the file being opened.

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
dcl  access_mode              bit (6) parm;
dcl  attributes_ptr           ptr parm;
dcl  code                     fixed bin (35) parm;
dcl  dir_name                 char (168) parm;
dcl  entry_name               char (32) parm;
dcl  file_no                  fixed bin (24) parm;
dcl  random_indicator         bit (1) parm;
	gsp = status_ptr;				/* Reference gcos_status. */
	gsp -> bit72 = "0"b;			/* Clear caller's status. */

	fn = file_no;				/* Use local variable */
	ap = attributes_ptr;

	gcos_status = "4000"b3;			/* Initialize status to indicate no error */
	code = 0;

/*  Verify that the file number input parameter
   corresponds to a valid input parameter and that
   the file is not already open. */

	if fn < lbound (gtss_disk, 1) | fn >= hbound (gtss_disk, 1) then do;
	     gcos_status = "4042"b3;			/* Bad file number */
	     return;
	end;
	if gtss_disk.fcb_ptr (fn) ^= null () then do;
	     gcos_status = "4037"b3;			/* File already open (i.e., in aft)  */
	     gtss_disk.fcb_ptr (fn) = null ();		/* Ensure file cannot be used again */
	     return;
	end;

/* Initialize gtss_disk entry for this file */
	gtss_disk (fn).fcb_ptr = null ();
	gtss_disk (fn).msf_array_ptr = null ();
	gtss_disk (fn).single_segment_ptr = null ();
	string (gtss_disk (fn).indicators) = "0"b;
	string (gtss_disk (fn).permissions) = "0"b;
	gtss_disk (fn).component = 0;
	gtss_disk (fn).offset = 0;
	gtss_disk (fn).file_position = 0;
	gtss_disk (fn).file_size = 0;
	gtss_disk (fn).no_components = 0;
	addr (gtss_disk (fn).pat_body) -> pat_body_overlay = "0"b;

/* Save information about file which must be remembered */
	gtss_disk.dir_name (fn) = dir_name;
	gtss_disk.entry_name (fn) = entry_name;
	gtss_disk.access_mode (fn) = access_mode;
	gtss_disk.attributes_ptr (fn) = ap;
	gtss_disk.pat_body.random (fn) = random_indicator | ap -> gtss_file_attributes.mode;
	gtss_disk.pat_body.write_performed (fn) = ap -> non_null;

/* Determine what permissions user wants
   on the file */

	substr (string (permissions (fn)), 1, 3) =
	     decode_mode (fixed (access_mode));
	pat_body (fn).perm = ap -> gtss_file_attributes.perm;
	if ^permissions (fn).read then do;
	     gcos_status = "4044"b3;
	     return;
	end;
	if pat_body (fn).perm = "0"b then do;
	     call hcs_$make_seg (
		dir_name
		, entry_name
		, ""
		, fixed ("0"b||substr (string (permissions (fn)), 1, 3)||"0"b)
		, null ()
		, code
		);
	     if code ^= 0 then do;
		gcos_status = "4100"b3;		/* error detected by hcs_$make_seg */
		return;
	     end;
	end;

/* Open the file using msf manager. */
	call msf_manager_$open (
	     dir_name
	     , entry_name
	     , fcb_ptr
	     , code
	     );
	if code ^= 0 then do;
	     gcos_status = "4100"b3;			/* Error detected by msf_manager_$open */
	     return;
	end;
	gtss_disk.fcb_ptr (fn) = fcb_ptr;

/* Determine the user's access to the file */
	if pat_body.perm (fn) ^= "0"b then do;
	     call gtss_verify_access_ (
		dir_name
		, entry_name
		, fn
		, access_mode
		, gcos_status
		);
	     if gcos_status ^= "4000"b3 then do;	/* 4000 means you have access */
		call msf_manager_$close (fcb_ptr);
		gtss_disk.fcb_ptr (fn) = null;
		return;
dcl status_ptr ptr parm;
	     end;
	end;


/* Get a pointer to first component of file */
	call msf_manager_$get_ptr (
	     fcb_ptr
	     , 0
	     , "0"b
	     , single_segment_ptr (fn)
	     , bc
	     , code
	     );
	if (code ^= 0) & (code ^= error_table_$segknown) & (code ^= error_table_$namedup) then do;
	     gcos_status = "4025"b3;			/* No 0 component. 4025 => entry not on-line. */
	     if db_ios then
		call com_err_ (
		code
		, "gtss_ios_open_"
		, "Could not get 0 component of ""^a>^a"" status ^w"
		, dir_name
		, entry_name
		, gcos_status
		);
	     call msf_manager_$close (gtss_disk (fn).fcb_ptr);
	     gtss_disk (fn).fcb_ptr = null;
	     return;
	end;


/* Call an internal procedure to set file_size, no_components, and the msf flag */
	gsc = 0;
	call fix_size (gsc);
	if gsc ^= 0 then do;
	     gcos_status = "4013"b3;			/* Too big. */
	     return;
	end;

/* Initialize size field in the PAT body */
	if gtss_disk.attributes_ptr (fn) -> current_size < 1024*16
	then pat_body.llink_size (fn) =
	     substr (unspec (gtss_disk.attributes_ptr (fn) -> current_size), 37-14, 14);

/* Get pointers to the components of the file */
	if msf (fn) then do;			/* Multisegment file */
	     allocate msf_components in (work_area) set (msf_array_ptr (fn));
	     do i = no_components (fn) to 499;
		msf_array_ptr (fn) -> msf_components (i) = null ();
	     end;
	     msf_array_ptr (fn) -> msf_components (0) = single_segment_ptr (fn);
	     single_segment_ptr (fn) = null ();
	     do i = 1 to no_components (fn)-1;
		call msf_manager_$get_ptr (
		     fcb_ptr
		     , (i)
		     , "1"b
		     , msf_array_ptr (fn) -> msf_components (i)
		     , bc
		     , code
		     );
		if code ^= 0 & code ^= error_table_$segknown & code ^= error_table_$namedup then do;
		     gcos_status = "4100"b3;		/* error detected by msf_manager_$get_ptr */
		     free msf_array_ptr (fn) -> msf_components;
		     call msf_manager_$close (gtss_disk (fn).fcb_ptr);
		     gtss_disk (fn).fcb_ptr = null;
		     return;
		end;
	     end;
	end;

/* Register caller in multiple caller
   file control (mcfc).
*/
	if ap -> gtss_file_attributes.perm then do;
	     call gtss_mcfc_$open (
		rtrim (dir_name)
		, rtrim (entry_name)
		, access_mode
		, gtss_ext_$mcfc.multics_lock_id
		, status_ptr
		, code
		);
	     if code ^= 0 then do;
		if db_ios then
		     call com_err_ (
		     code
		     , "gtss_ios_open_"
		     , "gtss_mcfc_$open status ^w"
		     , gcos_status
		     );
		return;
	     end;
	end;

/* Save pointer to file control block. */
	return;					/* End of gtss_ios_open_ */

fix_size:	proc (status);

/* This routine is called from within the open and change_size entry points
   to set file_size, no_components, and the msf flag. */
dcl  status                   fixed bin(24)parm;

	     gtss_disk.file_size (fn) = 320 * ap -> gtss_file_attributes.current_size;
	     gtss_disk.no_components (fn) =
		divide (file_size (fn)-1, sys_info$max_seg_size, 24, 0)+1;
	     gtss_disk.msf (fn) = (no_components (fn) > 1);
	     if no_components (fn) > 500 then do;
		no_components (fn) = 500;
		file_size (fn) = 500*1024*255;
		status = 3;			/* Size of file requested exceeds 500 components */
	     end;
	end fix_size;

/* VARIABLES FOR GTSS_IOS_ */
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl file_dir char(168);
dcl file_dir_len fixed bin;
dcl file_ent char(32);
dcl  gcos_status              bit(12)aligned based(gsp);
dcl  bit72                    bit(72)aligned based;
dcl  gsp                      ptr;

dcl  acl_ptr                  ptr	/* pointer to segment_acl passed
				as a parameter to msf_manager_$acl_list */;
dcl  ap                       ptr	/* Pointer to the attributes structure for the current file */;
dcl  bc                       fixed bin (24)	/* Used as a sink for bit counts returned by
				msf_manager_$get_ptr */;
dcl  bit_count                fixed bin (24)	/* The bit count of the last segment of an msf.
				Passed as a parameter to msf_manager_$adjust. */;
dcl  bksp_sw                  bit (1)	/* Distinguishes between backspacing
				"1"b and forward spacing "0"b a linked file. */;
dcl  cmd_word                 bit (36) aligned	/* temp */;
dcl  count                    fixed bin (24)	/* Counts io commands processed
				for current io select sequence */;
dcl  da_residue               fixed bin	/* Address of last memory location
				accessed during I/O.  Used in building
				return status words for I/O. */;
dcl  data_moved               fixed bin (24)	/* number of words moved or skipped over by
				the current read or write operation. */;
dcl  dcw_number               fixed bin (24)	/* Used to count DCW's in
				the current select sequence */;
dcl  dcw_offset               fixed bin (24)	/* slave offset of current dcw */;
dcl  dcw_ptr                  ptr	/* Multics pointer to the current dcw */;
dcl  disconnect               bit (1)	/* Indicator that the last DCW has been encountered. */;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  fcb_ptr                  ptr init (null ())	/* pointer to file control block
				used by msf_manager_ */;
dcl  file_ptr                 ptr	/* pointer to current positoion in file */;
dcl  fn                       fixed bin (24)	/* Index in gtss_ext_$disk_file_data of
				information about the file to be processed. */;
dcl  get_mode                 fixed bin (5)	/* User's access mode to segment as
				returned by hcs_$fs_get_mode */;
dcl  gsc                      fixed bin(24);
dcl  i                        fixed bin (24);
dcl  idptr                    ptr	/* Pointer to the current id
				word of the I/O select sequence. */;
dcl  j                        fixed bin (24);
dcl  l                        fixed bin (24)	/* The length in words of the current
				piece of data to be moved to or from the file */;
dcl  largest_file             fixed bin (24)	/* Max no. of llinks a file can grow to */;
dcl  last_component           bit (1)	/* When on, indicates that the
				current component is the last component of the file */;
dcl  li                       bit (1)	/* variable for the parameter link_indicator */;
dcl  M                        char (l*4) based	/* A template used for moving data
				to or from the file. */;
dcl  max_change               fixed bin (24)	/* The maximum amount that
				the size of a file can be increased
				expressed in llinks (320 word blocks) */;
dcl  msf_components           (0:499) ptr based	/* An array of pointers for each msf.
				Each component which has been accessed has a
				corresponding initialized pointer. */;

dcl  msf_save                 bit (1)	/* A flag used to remember whether
				the file was a msf before its size
				was changed. */;
dcl  no_components_save       fixed bin (24)	/* Used to remember the number
				of components a file had before its
				size was changed */;
dcl  pat_body_overlay         bit (180) based	/* used for initializing the
				pat body to all zeros */;
dcl  opptr                    ptr	/* Pointer to the current operation
				word of the I/O select sequence. */;
dcl  rec_ct_residue           fixed bin (24)	/* holds no of unskipped records */;
dcl  record_quota_overflow    condition ext;
dcl  sc                       fixed bin (24)	/* local variable for the parameter size_change */;
dcl  scratch_status           bit (72) aligned	/* temp */;
dcl  seek_address             fixed bin (24) based	/* user seek address for disk or drum */;
dcl  seek_ptr                 ptr	/* Pointer to the word containing
				the io seek address */;
dcl  seeksw                   bit (1)	/* sw controlling disk or drum seeks */;
dcl  seg_length               fixed bin (24)	/* length in words of current component of file */;
dcl  select_seg_ptr           ptr	/* Pointer to beginning of
				segment containing select sequence */;
dcl  select_seq_in_memory     bit (1)	/* 1 => the select sequence is in the
				same segment that is used for Gcos memory.
				In this case the addresses of DCW's, seek address data word, and
				status return words will be checked against the
				memory_limit parameter. */;
dcl  slave_status             bit (36) aligned;
dcl  sp                       ptr	/* Pointer to user's select sequence for this I/O */;
dcl  storlimit                fixed bin (24)	/* slave core boundary */;
dcl  sptr                     ptr	/* pointer to return word of select sequence */;
dcl  swptr                    ptr	/* Pointer to status return words */;
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  ta_offset                fixed bin (24)	/* Offset in the user's slave memory
				of the transmission area for the current DCW. */;
dcl  ta_ptr                   ptr	/* pointer to the transmission area for
				the current DCW. */;
dcl  ta_seg_ptr               ptr	/* pointer to the user's slave
				memory segment */;
dcl  tdcw_previous            bit (1)	/* Indicator that the last DCW processed was a TDCW */;
dcl  tfp                      fixed bin (71);
dcl  wc_residue               fixed bin (24)	/* Number of words remaining to be transferred
				in the current dcw when eof or
				memory fault occurs. Used in building
				return status words for I/O. */;
dcl  work_area                area (sys_info$max_seg_size) aligned
		     based (gtss_ext_$work_area_ptr)	/* Area used to store arrays of pointers to
			components of msf's. */;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  ioa_                     entry options (variable);
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));

/* STRUCTURES */

dcl 1 dcw aligned based (dcw_ptr),			/* dcw model */
    2 data_addr bit (18) unaligned,			/* data address */
    2 zero bit (3) unaligned,				/* fill */
    2 action bit (3) unaligned,			/* action */
    2 count bit (12) unaligned;						/* word count for transfer */

dcl 1 id_word aligned based (idptr),			/* model of identification word */
    2 filep bit (18) unaligned,			/* file control block pointer */
    2 dcwp bit (18) unaligned;						/* dcw list pointer */


dcl 1 op_word aligned based (opptr),			/* model of operation word */
    2 dev_com bit (6) unaligned,			/* device command */
    2 zero1 bit (12) unaligned,			/* zeros */
    2 ioc_com bit (5) unaligned,			/* ioc command */
    2 zero2 bit (1) unaligned,			/* zero */
    2 control bit (6) unaligned,			/* control */
    2 count bit (6) unaligned;						/* count */

dcl 1 return_word aligned based (sptr),			/* model of status return word */
    2 status_return bit (18) unaligned,			/* pointer to return words */
    2 courtesy_call bit (18) unaligned;						/* pointer to courtesy call rtn */

dcl 1 stat_words aligned based (swptr),			/* model of status words */
    2 sw1 bit (36) aligned,				/* word 1 */
    2 sw2 bit (36) aligned;						/* word 2 */


dcl  decode_mode              (0:63) bit (3) aligned			/* Permissions are read, execute, write */
     static init (					/* OCTAL */
     "100"b,					/* 0 -- Zero access mode maps to Query permission */
     "100"b,					/* 1 */
    (2) (1)"000"b,					/* 2-3 */
     "110"b,					/* 4 */
    (3) (1)"000"b,					/* 5-7 */
     "100"b,					/* 10 */
    (7) (1)"000"b,					/* 11-17 */
    (2) (1)"101"b,					/* 20-21 */
    (2) (1) "000"b,					/* 22-23 */
     "101"b,					/* 24 */
    (11) (1)"000"b,					/* 25-37 */
    (2) (1) "100"b,					/* 40-41 */
    (6) (1)"000"b,					/* 42-47 */
     "100"b,					/* 50 */
    (3) (1)"000"b,					/* 51-53 */
     "100"b,					/* 54 */
    (3) (1)"000"b,					/* 55-57 */
    (2) (1)"101"b,					/* 60-61 */
    (10) (1)"000"b,					/* 62-73 */
     "101"b,					/* 74 */
    (3) (1)"000"b);						/* 75-77 */

dcl  io_commands              (8) bit (36) internal static aligned init (


/* 	Disk Command Table						 */

     "340000000002"b3,				/* 34 - seek disk address */
     "250000002400"b3,				/* 25 - read disk continuous */
     "310000002400"b3,				/* 31 - write disk continuous */
     "700000020001"b3,				/* 70 - rewind */
     "460000020001"b3,				/* 46 - backspace record(s) */
     "440000020001"b3,				/* 44 - forward space record(s) */
     "400000020001"b3,				/* 40 - reset status */
     "000000020001"b3);						/* 00 - request status */

%include gtss_dfd_ext_;

%include gtss_file_attributes;

%include gtss_ext_;

%include gtss_file_values;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_ios_open_ */;



		    gtss_ios_position_.pl1          12/11/84  1354.3rew 12/10/84  1044.3      117000


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

gtss_ios_position_: proc (
	     file_no
	     , type
	     , n
	     , rcr
	     , status_ptr
	     );

/*
   "			 This  entry  point positions to the beginning of the file or
   "		allows the file to be spaced forward  or  backward  a  designated
   "		number of llinks (320 word blocks).

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
dcl  file_no                  fixed bin (24) parm;
dcl  n                        fixed bin (24) parm;
dcl  rcr                      bit (6)unal parm;
dcl  status_ptr               ptr parm	/* Pointer to gccos caller's 2 word status. */;
dcl  type                     fixed bin (24) parm;

	fn = file_no;				/* Use local variables */
	ap = gtss_disk.attributes_ptr (fn);

	gsp = status_ptr;				/* Reference gcos_status. */
	gcos_status = "4000"b3;			/* => Positioning successful. */

	gsc = 0;
	if bad_file_status (fn, gsc) then do;;
	     if gsc = 15 then gcos_status = "4042"b3;	/* Bad file number. */
	     else					/* => 14. */
	     gcos_status = "4025"b3;			/* File not open. */
	     return;
	end;

	if pat_body (fn).random then do;		/* abort if random */
	     gcos_status = "7776"b3;			/* attempt to space or rewind random file */
	     return;
	end;

	if type = -1 then do;			/* Rewind */
	     file_position (fn) = 0;			/* Rewind file */
	     gcos_status = "4002"b3;			/* Rewind => positioned at load point. */
	     return;
	end;

	if type ^= 0 then do;
	     gcos_status = "7777"b3;			/* unsupported positioning type */
	     return;
	end;

/* Position the file */
	tfp = file_position (fn) + (320 * n);		/* n can be large negative number. */

/* Allow for backspace too far */
	if tfp <= 0 then do;
	     rcr = bit (fixed (divide (file_position (fn) - tfp, 320, 24), 6));
	     file_position (fn) = 0;
	     gcos_status = "4002"b3;			/* File rewound to load point. */
	end;
	else
	if tfp > file_size (fn) then do;
	     rcr = bit (fixed (divide (tfp - file_position (fn), 320, 24), 6));
	     gcos_status = "5700"b3;			/* end of file encountered */
	     file_position (fn) = file_size (fn);
	end;
	else file_position (fn) = tfp;

	return;					/* End of gtss_ios_position_ */

/* INTERNAL PROCEDURES */

bad_file_status: proc (fn, status) returns (bit (1));

/* This routine is called to verify that
   the file number input parameter corresponds
   to a valid open file.  If so, "0"b is returned.
   Otherwise , "1"b is returned. */

dcl  fn                       fixed bin (24) parm;
dcl  status                   fixed bin (24) parm;

	     if fn < lbound (gtss_disk, 1) | fn >= hbound (gtss_disk, 1) then do;
		status = 15;			/* Bad file number */
		return ("1"b);
	     end;
	     if gtss_disk.fcb_ptr (fn) = null () then do;
		status = 14;			/* File not open  */
		return ("1"b);
	     end;
	     return ("0"b);
	end bad_file_status;

/* VARIABLES FOR GTSS_IOS_ */
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl file_dir char(168);
dcl file_dir_len fixed bin;
dcl file_ent char(32);
dcl  gcos_status              bit(12)aligned based(gsp);
dcl  bit72                    bit(72)aligned based;
dcl  gsp                      ptr;

dcl  acl_ptr                  ptr	/* pointer to segment_acl passed
				as a parameter to msf_manager_$acl_list */;
dcl  ap                       ptr	/* Pointer to the attributes structure for the current file */;
dcl  bc                       fixed bin (24)	/* Used as a sink for bit counts returned by
				msf_manager_$get_ptr */;
dcl  bit_count                fixed bin (24)	/* The bit count of the last segment of an msf.
				Passed as a parameter to msf_manager_$adjust. */;
dcl  bksp_sw                  bit (1)	/* Distinguishes between backspacing
				"1"b and forward spacing "0"b a linked file. */;
dcl  cmd_word                 bit (36) aligned	/* temp */;
dcl  count                    fixed bin (24)	/* Counts io commands processed
				for current io select sequence */;
dcl  da_residue               fixed bin	/* Address of last memory location
				accessed during I/O.  Used in building
				return status words for I/O. */;
dcl  data_moved               fixed bin (24)	/* number of words moved or skipped over by
				the current read or write operation. */;
dcl  dcw_number               fixed bin (24)	/* Used to count DCW's in
				the current select sequence */;
dcl  dcw_offset               fixed bin (24)	/* slave offset of current dcw */;
dcl  dcw_ptr                  ptr	/* Multics pointer to the current dcw */;
dcl  disconnect               bit (1)	/* Indicator that the last DCW has been encountered. */;
dcl  error_table_$namedup     fixed bin (35) ext;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin (35) ext;
dcl  fcb_ptr                  ptr init (null ())	/* pointer to file control block
				used by msf_manager_ */;
dcl  file_ptr                 ptr	/* pointer to current positoion in file */;
dcl  fn                       fixed bin (24)	/* Index in gtss_ext_$disk_file_data of
				information about the file to be processed. */;
dcl  get_mode                 fixed bin (5)	/* User's access mode to segment as
				returned by hcs_$fs_get_mode */;
dcl  gsc                      fixed bin(24);
dcl  i                        fixed bin (24);
dcl  idptr                    ptr	/* Pointer to the current id
				word of the I/O select sequence. */;
dcl  j                        fixed bin (24);
dcl  l                        fixed bin (24)	/* The length in words of the current
				piece of data to be moved to or from the file */;
dcl  largest_file             fixed bin (24)	/* Max no. of llinks a file can grow to */;
dcl  last_component           bit (1)	/* When on, indicates that the
				current component is the last component of the file */;
dcl  li                       bit (1)	/* variable for the parameter link_indicator */;
dcl  M                        char (l*4) based	/* A template used for moving data
				to or from the file. */;
dcl  max_change               fixed bin (24)	/* The maximum amount that
				the size of a file can be increased
				expressed in llinks (320 word blocks) */;
dcl  msf_components           (0:499) ptr based	/* An array of pointers for each msf.
				Each component which has been accessed has a
				corresponding initialized pointer. */;

dcl  msf_save                 bit (1)	/* A flag used to remember whether
				the file was a msf before its size
				was changed. */;
dcl  no_components_save       fixed bin (24)	/* Used to remember the number
				of components a file had before its
				size was changed */;
dcl  pat_body_overlay         bit (180) based	/* used for initializing the
				pat body to all zeros */;
dcl  opptr                    ptr	/* Pointer to the current operation
				word of the I/O select sequence. */;
dcl  rec_ct_residue           fixed bin (24)	/* holds no of unskipped records */;
dcl  record_quota_overflow    condition ext;
dcl  sc                       fixed bin (24)	/* local variable for the parameter size_change */;
dcl  scratch_status           bit (72) aligned	/* temp */;
dcl  seek_address             fixed bin (24) based	/* user seek address for disk or drum */;
dcl  seek_ptr                 ptr	/* Pointer to the word containing
				the io seek address */;
dcl  seeksw                   bit (1)	/* sw controlling disk or drum seeks */;
dcl  seg_length               fixed bin (24)	/* length in words of current component of file */;
dcl  select_seg_ptr           ptr	/* Pointer to beginning of
				segment containing select sequence */;
dcl  select_seq_in_memory     bit (1)	/* 1 => the select sequence is in the
				same segment that is used for Gcos memory.
				In this case the addresses of DCW's, seek address data word, and
				status return words will be checked against the
				memory_limit parameter. */;
dcl  slave_status             bit (36) aligned;
dcl  sp                       ptr	/* Pointer to user's select sequence for this I/O */;
dcl  storlimit                fixed bin (24)	/* slave core boundary */;
dcl  sptr                     ptr	/* pointer to return word of select sequence */;
dcl  swptr                    ptr	/* Pointer to status return words */;
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  ta_offset                fixed bin (24)	/* Offset in the user's slave memory
				of the transmission area for the current DCW. */;
dcl  ta_ptr                   ptr	/* pointer to the transmission area for
				the current DCW. */;
dcl  ta_seg_ptr               ptr	/* pointer to the user's slave
				memory segment */;
dcl  tdcw_previous            bit (1)	/* Indicator that the last DCW processed was a TDCW */;
dcl  tfp                      fixed bin (71);
dcl  wc_residue               fixed bin (24)	/* Number of words remaining to be transferred
				in the current dcw when eof or
				memory fault occurs. Used in building
				return status words for I/O. */;
dcl  work_area                area (sys_info$max_seg_size) aligned
		     based (gtss_ext_$work_area_ptr)	/* Area used to store arrays of pointers to
			components of msf's. */;
dcl  delete_$path             entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  ioa_                     entry options (variable);
dcl  msf_manager_$adjust      entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));

/* STRUCTURES */

dcl 1 dcw aligned based (dcw_ptr),			/* dcw model */
    2 data_addr bit (18) unaligned,			/* data address */
    2 zero bit (3) unaligned,				/* fill */
    2 action bit (3) unaligned,			/* action */
    2 count bit (12) unaligned;						/* word count for transfer */

dcl 1 id_word aligned based (idptr),			/* model of identification word */
    2 filep bit (18) unaligned,			/* file control block pointer */
    2 dcwp bit (18) unaligned;						/* dcw list pointer */


dcl 1 op_word aligned based (opptr),			/* model of operation word */
    2 dev_com bit (6) unaligned,			/* device command */
    2 zero1 bit (12) unaligned,			/* zeros */
    2 ioc_com bit (5) unaligned,			/* ioc command */
    2 zero2 bit (1) unaligned,			/* zero */
    2 control bit (6) unaligned,			/* control */
    2 count bit (6) unaligned;						/* count */

dcl 1 return_word aligned based (sptr),			/* model of status return word */
    2 status_return bit (18) unaligned,			/* pointer to return words */
    2 courtesy_call bit (18) unaligned;						/* pointer to courtesy call rtn */

dcl 1 stat_words aligned based (swptr),			/* model of status words */
    2 sw1 bit (36) aligned,				/* word 1 */
    2 sw2 bit (36) aligned;						/* word 2 */


dcl  decode_mode              (0:63) bit (3) aligned			/* Permissions are read, execute, write */
     static init (					/* OCTAL */
     "100"b,					/* 0 -- Zero access mode maps to Query permission */
     "100"b,					/* 1 */
    (2) (1)"000"b,					/* 2-3 */
     "110"b,					/* 4 */
    (3) (1)"000"b,					/* 5-7 */
     "100"b,					/* 10 */
    (7) (1)"000"b,					/* 11-17 */
    (2) (1)"101"b,					/* 20-21 */
    (2) (1) "000"b,					/* 22-23 */
     "101"b,					/* 24 */
    (11) (1)"000"b,					/* 25-37 */
    (2) (1) "100"b,					/* 40-41 */
    (6) (1)"000"b,					/* 42-47 */
     "100"b,					/* 50 */
    (3) (1)"000"b,					/* 51-53 */
     "100"b,					/* 54 */
    (3) (1)"000"b,					/* 55-57 */
    (2) (1)"101"b,					/* 60-61 */
    (10) (1)"000"b,					/* 62-73 */
     "101"b,					/* 74 */
    (3) (1)"000"b);						/* 75-77 */

dcl  io_commands              (8) bit (36) internal static aligned init (


/* 	Disk Command Table						 */

     "340000000002"b3,				/* 34 - seek disk address */
     "250000002400"b3,				/* 25 - read disk continuous */
     "310000002400"b3,				/* 31 - write disk continuous */
     "700000020001"b3,				/* 70 - rewind */
     "460000020001"b3,				/* 46 - backspace record(s) */
     "440000020001"b3,				/* 44 - forward space record(s) */
     "400000020001"b3,				/* 40 - reset status */
     "000000020001"b3);						/* 00 - request status */

%include gtss_dfd_ext_;

%include gtss_file_attributes;

%include gtss_ext_;

%include gtss_file_values;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_ios_position_ */;



		    gtss_mcfc_.pl1                  12/11/84  1354.3rew 12/10/84  1044.3      234009


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

gtss_mcfc_: proc;

/* Procedure to regulate a multiple number of callers
   to a gcos file (mcfc).

   Author: Dave Ward	07/28/79
   Change: Dave Ward	11/02/79 "delete" entry.
   Change: Dave Ward	12/03/79 Inserted use of debug switch "mcfc/del".
   Change: R. Barstad         11/03/82 Delete IDS2 concurrency control seg
                                       if it exists
*/

/* Declaration of parmameters. */
dcl  access                   bit(6)parm	/* See DD17, FILACT function 4. */;
dcl  code                     fixed bin(35)parm;
dcl  dirname                  char(*)parm;
dcl  diskx                    fixed bin(24)parm;
dcl  entname                  char(*)parm;
dcl  mlid                     bit(36)aligned parm;
dcl  statp                    ptr parm;
	return;					/* Non-used entry. */

open:	entry (
	     dirname				/* Multics directory of file. (input) */
	     , entname				/* Multics file entry name. (input). */
	     , access				/* GCOS access (runtime) mode requested (input). */
	     , mlid				/* Caller's multics lock id. (input). */
	     , statp				/* Pointer to callers's 2 word fms status value. (input). */
	     , code);				/* Return status code);. (output).
						   0 => successful.
						   >0 => failure (expand).
						   */
	ENTRY = "gtss_mcfc_$open";
	if db_mcfc then
	     call com_err_ (
	     0
	     , ENTRY
	     , """^a>^a"" mlid ^w"
	     , dirname
	     , entname
	     , mlid
	     );
	if get_uid (fuid) then return;

	h = mod (fuid, hbound (mcfc.start_list, 1)+1);

	if can_not_lock ("chain", h, mcfc.start_list (h).files.lock) then do;
busy:	     ;
	     fms_status.bit12 = "4004"b3;		/* File busy. */

conclude:	     ;

	     code = 1;				/* This caller can not use the file. */
	     if db_mcfc then
		call com_err_ (
		0
		, ENTRY
		, """^a>^a"" can not be opened by ^w at this time."
		, dirname
		, entname
		, mlid
		);
	     return;
	end;

	i = mcfc.start_list (h).files.first;
	do while (i>0);
	     if unspec (fuid) = file_entry (i).unique_id then do; /* File is currently accessed. */
		if can_not_lock ("file", i, file_entry (i).file_lock) then do;

/* IMPOSSIBLE! All files in chain are locked but can not lock
   particular file.
*/
		     call com_err_ (
			0
			, ENTRY
			, "ALL FILES LOCKED, BUT CAN NOT LOCK FILE (^i) ""^a>^a""."
			, i
			, dirname
			, entname
			);
		     signal cond (gtss_fail);
		end;
		call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
		if cant_use (i, mlid, access) then do;
		     call unlock_entry ("file", i, file_entry (i).file_lock);
		     goto conclude;
		end;
		call record_caller (i, mlid, access);
		code = 0;
		call unlock_entry ("file", i, file_entry (i).file_lock);
		return;
	     end;

	     i = file_entry (i).link;			/* Link to next file name in hash chain. */
	end;

/* File not currently accessed by any callers,
   obtain an entry. */
	call obtain_entry (h, u);

/* Record new file access. */
	fn = rtrim (dirname)||">"||entname;

	if can_not_lock ("name", u, mcfc_names.names_lock) then do;
	     call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
	     goto busy;
	end;
	allocate ns in (names) set (nsp);
	call unlock_entry ("name", u, mcfc_names.names_lock);

	nsp -> ns = fn;
	file_entry (u).link = mcfc.start_list (h).files.first;
	file_entry (u).nameo = offset (nsp, names);
	file_entry (u).namel = length (fn);
	file_entry (u).unique_id = unspec (fuid);
	file_entry (u).number_callers = 0;		/* This is 1st caller. */
	mcfc.start_list (h).files.first = u;
	if can_not_lock ("file", u, file_entry (u).file_lock) then do;

/* IMPOSSIBLE: Chain is locked, this is a new file entry,
   but it is locked?
*/
	     call com_err_ (
		0
		, ENTRY
		, "ALL FILES LOCKED, BUT CAN NOT LOCK FILE (^i) ""^a""."
		, u
		, fn
		);
	     signal cond (gtss_fail);
	end;
	call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
	call record_caller (u, mlid, access);
	call unlock_entry ("file", u, file_entry (u).file_lock);
	code = 0;
	return;

close:	entry (
	     dirname				/* Multics directory of file. (input) */
	     , entname				/* Multics file entry name. (input). */
	     , mlid				/* Caller's multics lock id. (input). */
	     , statp
	     , code);				/* Return status code);. (output).
						   0 => successful.
						   >0 => failure (expand).
						   */
	ENTRY = "gtss_mcfc_$close";
	if db_mcfc then
	     call com_err_ (
	     0
	     , ENTRY
	     , """^a>^a"" mlid ^w"
	     , dirname
	     , entname
	     , mlid
	     );
	if get_uid (fuid) then return;
	h = mod (fuid, hbound (mcfc.start_list, 1)+1);
	if can_not_lock ("chain", h, mcfc.start_list (h).files.lock) then goto busy;
	i = mcfc.start_list (h).files.first;
	li = -i;
	do while (i>0);
	     if unspec (fuid) = file_entry (i).unique_id then do; /* File is currently accessed. */
		if can_not_lock ("file", i, file_entry (i).file_lock) then do;

/* IMPOSSIBLE! All files locked bu can not lock
   particular file.
*/
		     call com_err_ (
			0
			, ENTRY
			, "ALL FILES LOCKED, BUT CAN NOT LOCK FILE (^i) ""^a>^a""."
			, i
			, dirname
			, entname
			);
		     signal cond (gtss_fail);
		end;

		call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
		call remove_caller (i, mlid, h, li, code);
		return;
	     end;

	     li = i;				/* Remember previous i. */
	     i = file_entry (i).link;			/* Link to next file name in hash chain. */
	end;

/* Closing a file that is not open. */
	call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
	code = 1;					/* file name not in mcfc data base. */
	fms_status.bit12 = "4100"b3;			/* ?? */
	if db_mcfc then
	     call com_err_ (
	     0
	     , ENTRY
	     , "Attempting to close (^w) ""^a>^a"" but it is not open."
	     , fuid
	     , dirname
	     , entname
	     );
	return;

delete:	entry (
	     diskx				/* >0 => index to gtss_disk to file. */
	     , dirname				/* Multics directory of file. (input) */
	     , entname				/* Multics file entry name. (input). */
	     , mlid				/* Caller's multics lock id. (input). */
	     , statp
	     , code);				/* Return status code);. (output).
						   0 => successful.
						   >0 => failure (expand).
						   */
	ENTRY = "gtss_mcfc_$delete";
	if db_mcfc then
	     call com_err_ (
	     0
	     , ENTRY
	     , """^a>^a"" mlid ^w"
	     , dirname
	     , entname
	     , mlid
	     );
	if get_uid (fuid) then return;
	h = mod (fuid, hbound (mcfc.start_list, 1)+1);
	if can_not_lock ("chain", h, mcfc.start_list (h).files.lock) then goto busy;
	i = mcfc.start_list (h).files.first;
	li = -i;
	do while (i>0);
	     if unspec (fuid) = file_entry (i).unique_id then do; /* File is currently accessed. */
		if can_not_lock ("file", i, file_entry (i).file_lock) then do;

/* IMPOSSIBLE! All files locked bu can not lock
   particular file.
*/
		     call com_err_ (
			0
			, ENTRY
			, "ALL FILES LOCKED, BUT CAN NOT LOCK FILE (^i) ""^a>^a""."
			, i
			, dirname
			, entname
			);
		     signal cond (gtss_fail);
		end;

		call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);

/* Deletion of file must be deferred.
   Mark mcfc data base to provide for
   deleting file at gtss_mcfc_$close,
   file renamed (Multics) to make name
   available for delete caller, while
   other (concurrent) callers retain
   reference to deleted file.
*/
		call defer_delete (i, mlid, code);
		return;
	     end;

	     li = i;				/* Remember previous i. */
	     i = file_entry (i).link;			/* Link to next file name in hash chain. */
	end;

/* File not currently accessed by any callers,
   delete the file immediately,
   the whole chain is locked during the file
   deletion process.
*/
	call delete_file;

	call unlock_entry ("chain", h, mcfc.start_list (h).files.lock);
	return;

delete_file: proc;

/* Delete the file. */

	     control_seg_ename = rtrim(entname)||".CONCURRENCY";
	     call delete_$path(dirname, control_seg_ename,
		"100100"b, "gtss", code /* irrelevant */);
	     code = 0;
	     call delete_$path (
		dirname
		, entname
		, "0"b				/* (use next bit). */
		||"1"b				/* Query caller if file protected . */
		||"0"b				/* Deletion of directory not allowed. */
		||"1"b				/* Delete segment or msf. */
		||"0"b				/* (examine next switch). */
		||"1"b				/* Chase link and delete entry linked to. */
		, "gtss"				/* Identifies who is questioning. */
		, code
		);

	     if db_mcfc then
		call com_err_ (code, "mcfc/del", """^a>^a""", dirname, entname);

	     if code ^= 0 then do;
		if code = error_table_$noentry then
		     fms_status.bit12 = "4005"b3;	/* NON-EXISTENT. */
		else
		fms_status.bit12 = gtss_filact_error_status_ (code); /* Unknown error. */
		if db_mcfc then
		     call com_err_ (
		     code
		     , ENTRY
		     , "Can not delete ""^a>^a""."
		     , dirname
		     , entname
		     );
	     end;
	     return;
	end					/* delete_file */;

obtain_entry: proc (h, u);

/* Obtain a file_entry from the "closest"
   chain of available entries to entry h.
   Set u to the index of the obtained entry.
*/
dcl  h                        fixed bin(24) parm;
dcl  u                        fixed bin(24) parm;
	     do i = h to hbound (mcfc.start_list, 1),
		     lbound (mcfc.start_list, 1) to (h-1);
		if ^can_not_lock ("avail", i, mcfc.start_list (i).avail.lock) then do;
		     if mcfc.start_list (i).avail.first = 0 then do;
			call unlock_entry ("avail", i, mcfc.start_list (i).avail.lock);
			goto cont;
		     end;
		     u = mcfc.start_list (i).avail.first;
		     mcfc.start_list (i).avail.first = file_entry (u).link;
		     call unlock_entry ("avail", i, mcfc.start_list (i).avail.lock);
		     return;
		end;

cont:		;
	     end;

/* Could not find ANY available entries. */
	     call com_err_ (
		0
		, ENTRY
		, "NO AVAILABLE CHAIN TO OBTAIN FROM (from ^i for ^i)"
		, h
		, u
		);
	     signal cond (gtss_fail);
	     return;
dcl  i                        fixed bin(24);
	end					/* obtain_entry */;

return_entry: proc (h, u);

/* Return file entry u to an available list. */
dcl  h                        fixed bin(24) parm;
dcl  u                        fixed bin(24) parm;
	     do i = h to hbound (mcfc.start_list, 1),
		     lbound (mcfc.start_list, 1) to (h-1);
		if ^can_not_lock ("avail", i, mcfc.start_list (i).avail.lock) then do;
		     if mcfc.start_list (i).avail.first = 0 then do;
			call unlock_entry ("avail", i, mcfc.start_list (i).avail.lock);
			goto cont;
		     end;
		     unspec (file_entry (u)) = "0"b;
		     file_entry (u).link = mcfc.start_list (i).avail.first;
		     mcfc.start_list (i).avail.first = u;
		     call unlock_entry ("avail", i, mcfc.start_list (i).avail.lock);
		     return;
		end;

cont:		;
	     end;

/* Could not find ANY available entries. */
	     call com_err_ (
		0
		, ENTRY
		, "NO AVAILABLE CHAIN TO RETURN TO (from ^i for ^i)"
		, h
		, u
		);
	     signal cond (gtss_fail);
	     return;
dcl  i                        fixed bin(24);
	end					/* return_entry */;

get_uid:	proc (fuid) returns (bit (1));

/* Obtain the unique id of the file to be accessed.
   Return "1"b if the unique id can NOT be obtained.
*/
dcl  fuid                     fixed bin(35)parm;

	     call hcs_$status_long (			/* Obtain uniqued file id. */
		dirname
		, entname
		, 1				/* Chase links. */
		, addr (br)
		, null ()				/* Return no name information. */
		, code
		);

	     if code ^= 0 then do;			/* Can not access the file. */
		if code = error_table_$noentry then
		     fms_status.bit12 = "4005"b3;	/* NON-EXISTENT. */
		else
		fms_status.bit12 = "4100"b3;
		return ("1"b);
	     end;

	     unspec (fuid) = br.uid;
	     return ("0"b);
	end					/* get_uid */;

remove_caller: proc (
		f				/* Index to file_entry to file accessed by caller. */
		, i				/* Name of caller (multics lock id). */
		, si				/* Index to start list for file chain. */
		, li				/* <0 => abs(li)=si. >0 => index of file
						   entry linked to this file entry. */
		, code				/* Return code. */
		);

/* Remove i as a caller for file.
   If last caller remove the file.
*/
dcl  f                        fixed bin(24)parm;
dcl  i                        bit(36)aligned parm;
dcl  si                       fixed bin(24) parm;
dcl  li                       fixed bin(24) parm;
dcl  code                     fixed bin(35)parm;
	     call get_caller_index (f, caller_ptr, k);

/* Search files caller list for "this" caller
   (i.e., the one with same multics lock id).
*/
	     n = file_entry (f).number_callers;
	     do j = 1 to n;
		if caller (k).lock_id (j) = i then do;	/* Caller located. */
		     n = n-1;			/* Reduce number of callers for file by one. */
		     file_entry (f).number_callers = n; /* Record reduced number. */
		     if j< (n+1) then do;		/* Compact the list of callers. */
			caller (k).lock_id (j) = caller (k).lock_id (n+1);
			caller (k).gcos_access (j) = caller (k).gcos_access (n+1);
		     end;
		     if n<1 then do;

/* There are no more callers accessing this file,
   remove the file entry.
*/

			if file_entry (f).delete then call delete_file;

			if can_not_lock ("name", f, mcfc_names.names_lock) then do;
			     call unlock_entry ("file", f, file_entry (f).file_lock);
			     goto busy;
			end;
			free ptr (file_entry (f).nameo, names) -> ns;
			call unlock_entry ("name", f, mcfc_names.names_lock);

			if can_not_lock ("chain", si, mcfc.start_list (si).files.lock) then do;
			     if db_mcfc then
				call com_err_ (
				0
				, ENTRY
				, """^a>^a"" can not be opened by ^w at this time."
				, dirname
				, entname
				, mlid
				);
/**CHANGE**/
			     signal cond (gtss_fail);
			end;
			call unlock_entry ("file", f, file_entry (f).file_lock);

			if (li>0) | (file_entry (f).link>0) then do;

/* There are more files on this chain,
   just remove this (f) file entry.
*/
			     if li<1 then		/* Entry f is 1st in chain. */
				mcfc.start_list (si).files.first = file_entry (f).link;
			     else			/* Entry f not 1st, link around f. */
			     file_entry (li).link = file_entry (f).link;
			end;
			else			/* No more files in chain. */
			mcfc.start_list (si).files.first = 0;

			call return_entry (si, f);
			call unlock_entry ("chain", si, mcfc.start_list (si).files.lock);
		     end;
		     else
		     call unlock_entry ("file", f, file_entry (f).file_lock);
		     code = 0;
		     return;
		end;
	     end;

/* Caller not in list of callers for file f? */
	     code = 1;				/* file name not in mcfc data base. */
	     fms_status.bit12 = "4100"b3;		/* ?? */
	     if db_mcfc then
		call com_err_ (
		0
		, ENTRY
		, "Attempting to close (^i ^w) ""^a>^a"" but not open by ^w."
		, f
		, file_entry (f).unique_id
		, dirname
		, entname
		, i
		);
	     call unlock_entry ("file", f, file_entry (f).file_lock);
	     return;
dcl  n                        fixed bin(24);
dcl  k                        fixed bin(24);
dcl  j                        fixed bin(24);
	end					/* remove_caller */;

defer_delete: proc (
		f				/* Index to file_entry to file accessed by caller. */
		, i				/* Name of caller (multics lock id). */
		, code				/* Return code. */
		);

/* Mark mcfc data base for deferred deletion.
*/
dcl  f                        fixed bin(24)parm;
dcl  i                        bit(36)aligned parm;
dcl  code                     fixed bin(35)parm;

	     code = 0;
	     call get_caller_index (f, caller_ptr, k);

/* Examine if deleter is a caller.
*/
	     n = file_entry (f).number_callers;
	     do j = 1 to n;
	     end;

/* Deleter is NOT a caller,
   i.e., not using the file.
*/
	     file_entry (f).delete = "1"b;

/* Rename the file to allow the deleter to
   reuse the file name, but preserving the
   file for other (concurrent) users.
*/
	     gtss_file_values.version = 1;
	     gtss_file_values.dname = dirname;
	     gtss_file_values.ename = entname;
	     gtss_file_values.new_ename = unique_chars_ (unique_bits_ ());
	     gtss_file_values.change_name = "1"b;
	     unspec (gtss_file_values.set_switch) = "0"b;
	     call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
dcl  gtss_attributes_mgr_$set entry(ptr,fixed bin(35));
	     if code = 0 then
		if diskx>0 then			/* Rename entry in gtss_disk data base. */
		     gtss_disk (diskx).entry_name = gtss_file_values.new_ename;

	     call unlock_entry ("file", f, file_entry (f).file_lock);
	     return;
dcl  j                        fixed bin(24);
dcl  n                        fixed bin(24);
dcl  k                        fixed bin(24);
	end					/* defer_delete */;

cant_use:	proc (f, i, a)returns (bit (1));

/* return "1"b if caller (multics lock id i) can NOT
   use file (file_entry index f) with gcos access a.
*/
dcl  f                        fixed bin(24) parm;
dcl  i                        bit(36)aligned parm;
dcl  a                        bit(6)parm;
	     call get_caller_index (f, caller_ptr, c);
retry:	     ;
	     do k = 1 to file_entry (f).number_callers;
		if i ^= caller (c).lock_id (k) then
						/* always allow caller to access his own files */
		     if compare_access (a, (caller (c).gcos_access (k))) then do;
			if nonexistent_process (caller (c).lock_id (k)) then do;
			     call restore_file (f);
			     goto retry;
			end;
			fms_status.bit12 = "4003"b3;	/* Permissions denied. */
			return ("1"b);
		     end;

	     end;
	     return ("0"b);
dcl  c                        fixed bin(24);
dcl  k                        fixed bin(24);
	end					/* cant_use */;

nonexistent_process: proc (id)returns (bit (1));

/* Return "1"b if lock id (id) does belong to
   a process that no longer exists.
*/
dcl  id                       bit(36)aligned parm;
	     lid = id;				/* Move to local variable, assures input not altered. */
	     call set_lock_$lock (
		lid
		, 0				/* Wait 0 seconds to attempt lock. */
		, c
		);
	     if (c = 0) | (c = error_table_$invalid_lock_reset) then return ("1"b);
	     return ("0"b);
dcl  c                        fixed bin(35);
dcl  lid                      bit(36)aligned;
	end					/* nonexistent_process */;

compare_access: proc (ca, ea)returns (bit (1));

dcl  ca                       bit(6)parm;
dcl  ea                       bit(6)parm ;
	     if calla.changing then return ("0"b);	/* Caller access allowing file to change. */
	     if exista.write then return ("1"b);	/* Already a writer. (fail). */
	     return ("0"b);

dcl 1 calla defined(ca),
      2 (
      read
,     write
,     append
,     execute
,     test
,     changing
        ) bit(1)unal;

dcl 1 exista defined(ea),
      2 (
      read
,     write
,     append
,     execute
,     test
,     changing
        ) bit(1)unal;
	end					/* comapre_access */;

record_caller: proc (f, i, a);

/* Record gcos caller (multics lock id i) as a caller
   accessing file (index f into file_entry) with gcos
   access a.
*/
dcl  f                        fixed bin(24) parm;
dcl  i                        bit(36)aligned parm;
dcl  a                        bit(6)parm;

	     call get_caller_index (f, caller_ptr, k);
	     j = file_entry (f).number_callers+1;
	     if j>hbound (caller.lock_id, 2) then do;
		if db_mcfc then
		     call com_err_ (
		     0
		     , ENTRY
		     , "Over ^i callers for file ^i"
		     , hbound (caller.lock_id, 2)
		     , f
		     );
		file_entry (f).number_who_could_not_call = file_entry (f).number_who_could_not_call+1;
		call unlock_entry ("file", f, file_entry (f).file_lock);
		goto busy;
	     end;
	     file_entry (f).number_callers = j;
	     caller (k).lock_id (j) = i;
	     caller (k).gcos_access (j) = a;

	     return;

dcl  u                        fixed bin (24);
dcl  k                        fixed bin (24);
dcl  j                        fixed bin (24);
	end					/* record_caller */;

%include gtss_mcfc_gci;

restore_file: proc (f);

/* Remove all callers for file f whose
   process no longer exist.
*/
dcl  f                        fixed bin(24) parm;
	     sp = caller_ptr;
	     call get_caller_index (f, caller_ptr, k);
	     n = file_entry (f).number_callers;
	     j = 1;
	     do while (j <= n);
		call set_lock_$lock (
		     caller (k).lock_id (j)
		     , 0				/* Wait 0 seconds to attempt lock. */
		     , c
		     );
		if (c = 0) | (c = error_table_$invalid_lock_reset) then do;

/* Remove this caller, his lock id was able to
   be reset => his process is defunct.
*/
		     if j<n then do;		/* Replace j-th caller with n-th. */
			caller (k).lock_id (j) = caller (k).lock_id (n);
			caller (k).gcos_access (j) = caller (k).gcos_access (n);
		     end;
		     n = n-1;
		end;
		else
		if c = error_table_$lock_wait_time_exceeded then

/* This caller has lock id for current
   process so retain the caller.
*/
		     j = j+1;
		else do;

/* Unexpected error attempting to test lock id.
*/
		     call com_err_ (
			c
			, ENTRY
			, "Attempting to restore file ^i caller ^i"
			, f
			, j
			);
		     signal cond (gtss_fail);
		end;
	     end;

/* Reset number of callers. */
	     file_entry (f).number_callers = n;

/* Reset save pointer value. */
	     caller_ptr = sp;
	     return;

dcl  sp                       ptr;
dcl  k                        fixed bin(24);
dcl  j                        fixed bin(24);
dcl  n                        fixed bin(24);
dcl  c                        fixed bin(35);
	end					/* restore_file */;

can_not_lock: proc (en, e, lw)returns (bit (1));

/* Lock word lw, for list named en at entry e.
   Return "1"b if can NOT lock, else return "0"b.
*/
dcl  en                       char(*)parm;
dcl  e                        fixed bin(24) parm;
dcl  lw                       bit(36)aligned;
	     if db_mcfc then
		call com_err_ (
		0
		, ENTRY
		, "^/  LOCK ^5a ^4i ^p ^a>^a"
		, en
		, e
		, addr (lw)
		, dirname
		, entname
		);
	     call set_lock_$lock (
		lw
		, gtss_ext_$mcfc.wait_time
		, c
		);
	     if c = 0 then return ("0"b);

	     if c = error_table_$invalid_lock_reset then do;
		if en = "file" then call restore_file (e);
		return ("0"b);
	     end;

/* Could not lock. */
	     if c = error_table_$lock_wait_time_exceeded then do;
		if db_mcfc then
		     call com_err_ (c, ENTRY, "(^a ^i)", en, e);
		return ("1"b);
	     end;
	     if c = error_table_$locked_by_this_process then do;
		call com_err_ (c, ENTRY,
		     "BUG? Will not proceed (^a ^i).", en, e);
		signal cond (gtss_fail);
		return ("1"b);
	     end;
	     call com_err_ (c, ENTRY,
		"UNEXPECTED LOCK ERROR? (^1 ^i)", en, e);
	     signal cond (gtss_fail);
	     return ("1"b);
dcl  c                        fixed bin(35);
	end					/* can_not_lock */;

unlock_entry: proc (en, e, lw);

/* Unlock word lw. In en named chain, entry e.
*/
dcl  en                       char(*)parm;
dcl  e                        fixed bin(24)parm;
dcl  lw                       bit(36)aligned parm;
	     if db_mcfc then
		call com_err_ (
		0
		, ENTRY
		, "^/UNLOCK ^5a ^4i ^p ^a>^a"
		, en
		, e
		, addr (lw)
		, dirname
		, entname
		);
	     call set_lock_$unlock (
		lw
		, c
		);
	     if c = 0 then return;

/* Could not unlock. */
	     if (c = error_table_$lock_not_locked) |
	     (c = error_table_$locked_by_other_process) then
		call com_err_ (c, ENTRY,
		"BUG? Will not proceed (^a ^i).", en, e);
	     else
	     call com_err_ (c, ENTRY,
		"UNEXPECTED LOCK ERROR? (^a ^i)", en, e);
	     signal cond (gtss_fail);
dcl  c                        fixed bin(35);
	end					/* unlock_entry */;

/* Variables for gtss_mcfc_
   IDENTIFIER		ATTRIBUTES */
dcl  addr                     builtin;
dcl  control_seg_ename char(32);
dcl  delete_$path             entry(char(*),char(*),bit(6),char(*),fixed bin(35));
dcl  divide                   builtin;
dcl  empty                    builtin;
dcl  ENTRY                    char(17);
dcl  error_table_$invalid_lock_reset fixed bin(35)ext;
dcl  error_table_$locked_by_other_process fixed bin(35)ext;
dcl  error_table_$locked_by_this_process fixed bin(35)ext;
dcl  error_table_$lock_not_locked fixed bin(35)ext;
dcl  error_table_$lock_wait_time_exceeded fixed bin(35)ext;
dcl  error_table_$noentry     fixed bin(35)ext;
dcl  fn                       char(168)var;
dcl  fni                      char(file_entry(i).namel) unal based(pointer(file_entry(i).nameo,names));
dcl  fuid                     fixed bin(35);
dcl  gtss_fail                condition ext;
dcl  h                        fixed bin(24);
dcl  hbound                   builtin;
dcl  hcs_$status_long         entry(char(*),char(*),fixed bin(1),ptr,ptr,fixed bin(35));
dcl  i                        fixed bin(24);
dcl  lbound                   builtin;
dcl  length                   builtin;
dcl  li                       fixed bin(24);
dcl  mod                      builtin;
dcl  n                        fixed bin(24);
dcl  ns                       char(length(fn))based;
dcl  nsp                      ptr;
dcl  null                     builtin;
dcl  offset                   builtin;
dcl  pointer                  builtin;
dcl  ptr                      builtin;
dcl  rtrim                     builtin;
dcl  set_lock_$lock           entry(bit(36)aligned,fixed bin,fixed bin(35));
dcl  set_lock_$unlock         entry(bit(36)aligned,fixed bin(35));
dcl  u                        fixed bin(24);
dcl  unique_bits_             entry returns(bit(70));
dcl  unique_chars_            entry(bit(*)) returns(char(15));
dcl  unspec                   builtin;
	

dcl 1 fms_status aligned based(statp)
,     2 bit12 bit(12)unal
,     2 bit60 bit(60)unal
;

%include gtss_mcfc;

%include gtss_ext_;

%include gtss_db_names;

dcl 1 br aligned like branch;
%include status_info;

%include gtss_file_values;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;
     end						/* gtss_mcfc_ */;
   



		    gtss_mcfc_defunct.pl1           12/11/84  1354.3rew 12/10/84  1044.3       46215


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

gtss_mcfc_defunct: proc;

/* Examine the gtss mcfc data base and
   display callers whose process no longer
   exist.

   Author:  Dave Ward	11/09/79
*/
	call gtss_mcfc_init_ (rs);
	if rs = "false" then return;
dcl  rs                       char(5)var;
	do i = lbound (mcfc.start_list, 1) to hbound (mcfc.start_list, 1);
	     if files (i).first ^= 0 then do;		/* Next chain of files. */
		if lock_chain (i, c) then do;		/* Chain locked during examination. */
		     call examine_chain (files (i).first);
		     call unlock_chain (i);
		end;
		else				/* Could not lock the chain. */
		call com_err_ (
		     c
		     , "gtss_mcfc_defunct"
		     , "Chain ^i."
		     , i
		     );
	     end;
	end;
dcl  c                        fixed bin(35);
	return;

lock_chain: proc (i, c)returns (bit (1));

/* Lock start_list file entry i.
   Return code c (0=>OK | ^0=>failure).
*/
dcl  i                        fixed bin(24) parm;
dcl  c                        fixed bin(35)parm;
	     call set_lock_$lock (
		start_list (i).files.lock
		, 60				/* Wait up to 60 (realtime) seconds. */
		, c
		);
	     if c = 0 then return ("1"b);		/* Successful. */
	     if c = error_table_$invalid_lock_reset then return ("1"b);
	     return ("0"b);				/* Failure. */
	end					/* lock_chain. */;

unlock_chain: proc (i);

/* Unlock start_list file entry i.
*/
dcl  i                        fixed bin(24) parm;
	     call set_lock_$unlock (
		start_list (i).files.lock
		, c
		);
	     if c = 0 then return;
	     call com_err_ (
		c
		, "gtss_mcfc_defunct"
		, "Could not unlock start list (^i) files lock."
		, i
		);
	     return;

dcl  c                        fixed bin(35);
	end					/* unlock_chain. */;

examine_chain: proc (i);

/* Examine each file on the start list
   chain i, for callers that have defunct
   processes.
*/
dcl  i                        fixed bin(24) parm;
	     n = i;
	     do while (n>0);
		call examine_file (n);
		n = file_entry (n).link;
	     end;
	     return;

dcl  n                        fixed bin(24);
	end					/* examine_chain. */;

examine_file: proc (f);

/* Display callers of file f that have
   defunct processes.
*/
dcl  f                        fixed bin(24) parm;
	     c = 0;				/* Count of defunct processes for f. */
	     call get_caller_index (f, caller_ptr, k);
	     do i = 1 to number_callers (f);
		if defunct_process (f, caller (k).lock_id (i)) then c = c+1;
	     end;

	     if c = 0 then return;
	     if c<number_callers (f) then
		call com_err_ (
		0
		, "gtss_mcfc_defunct"
		, "^i of ^i callers defunct for ^a"
		, c
		, number_callers (f)
		, file_name (f)
		);
	     else
	     call com_err_ (
		0
		, "gtss_mcfc_defunct"
		, "All ^i callers defunct for ^a"
		, c
		, file_name (f)
		);
	     return;

dcl  c                        fixed bin(24);
dcl  i                        fixed bin(24);
dcl  k                        fixed bin(24);
	end					/* examine_file */;

defunct_process: proc (f, lw)returns (bit (1));

/* Return "1"b if lock word (lw) belongs to
   a defunct process, otherwise return "0"b.
*/
dcl  f                        fixed bin(24) parm;
dcl  lw                       bit(36)aligned parm;
	     slw = lw;				/* Save input lock word value. */
	     call set_lock_$lock (
		lw
		, 0				/* Wait no time. */
		, c
		);
dcl  c                        fixed bin(35);
	     if c = error_table_$locked_by_other_process then

/* Locked by caller with an existent process (OK). */
		return ("0"b);
/**MORE**/
	     lw = slw;
	     return ("1"b);

dcl  slw                      bit(36);
	end					/* defunct */;

file_name: proc (f)returns (char (*));

/* Produce the "name" of file f.
*/
dcl  f                        fixed bin(24) parm;
dcl  ns                       char(namel(f))unal based(pointer(nameo(f),names));
	     return (ns);				/* AUGMENT. */
	end					/* file_name */;

/* Variables for gtss_mcfc_defunct:
   IDENTIFIER		ATTRIBUTES	*/
dcl  com_err_                 entry options(variable);
dcl  error_table_$invalid_lock_reset fixed bin(35)ext;
dcl  error_table_$locked_by_other_process fixed bin(35)ext;
dcl  error_table_$locked_by_this_process fixed bin(35)ext;
dcl  error_table_$lock_not_locked fixed bin(35)ext;
dcl  error_table_$lock_wait_time_exceeded fixed bin(35)ext;
dcl  get_lock_id_             entry(bit(36)aligned);
dcl  gtss_mcfc_init_          entry(char(*)var);
dcl  i                        fixed bin(24);
dcl  null                     builtin;
dcl  set_lock_$lock           entry(bit(36)aligned,fixed bin,fixed bin(35));
dcl  set_lock_$unlock         entry(bit(36)aligned,fixed bin(35));

%include gtss_mcfc_gci;

%include gtss_mcfc;

%include gtss_ext_;
     end						/* gtss_mcfc_defunct */;
 



		    gtss_mcfc_delete.pl1            12/11/84  1354.3rew 12/10/84  1044.3       96102


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

gtss_mcfc_delete: mcfcdl: proc;

/* Delete whole mcfc file chain,
   or one file on a chain,
   or one caller of file.

   Input arguments are one or more values of forms:
   chain or chain-file or chain-file-caller.
   The values "chain", "file" and "caller" are
   unsigned positive integers reflecting
   values output from gtss_mcfc_dump designating the
   corresponding entries.
   The caller will be queried for a "yes" or "no" BEFORE
   each entry is actually deleted.

   Author:	Dave Ward 08/08/79
*/
	sub_entry = "0"b;
	goto cont;

arg_ptr:	entry (pap);

/* Subroutine entry given pointer to arguments.
*/
dcl  pap                      ptr parm;
	sub_entry = "1"b;

cont:	;

	call gtss_mcfc_init_ (r);
	if r = "false" then
fail:	     return;

	do argn = 1 by 1;
	     if sub_entry then
		call cu_$arg_ptr_rel (argn, ap, al, code, pap);
	     else
	     call cu_$arg_ptr (argn, ap, al, code);
	     if code ^= 0 then do;			/* Concludion of input arguments. */
		if argn<2 then
		     call com_err_ (
		     code
		     , "gtss_mcfc_delete"
		     , "One or more: c[-f[-u]]. c, f, u are integers for chain, file and caller from gtss_mcfc_dump."
		     );
		return;
	     end;
	     call del (arg);
next_arg:	     ;
	end;

del:	proc (cfc);

/* Delete entry named by cfc parameter. */
dcl  cfc                      char(*)parm;

/* Obtain 3 integers for chain, file and caller.
*/
	     chain, file, caller = -1;
	     call get_int (1, cfc, chain);

/* Isolate and lock chain. */
	     if (chain<lbound (mcfc.start_list, 1)) | (chain>hbound (mcfc.start_list, 1)) then do;
		call com_err_ (
		     0
		     , "gtss_mcfc_delete"
		     , "Arg ^i (^a), chain ^i out of range ^i...^i. Skipped."
		     , argn
		     , arg
		     , chain
		     , lbound (mcfc.start_list, 1)
		     , hbound (mcfc.start_list, 1)
		     );
		goto next_arg;
	     end;

/* Lock chain. */
	     call set_lock_$lock (
		mcfc.start_list (chain).files.lock
		, 60				/* Wait up to 60 seconds. */
		, code
		);
	     if code = 0 then do;
cont_del:		;
		call del_file (chain, file, caller);

/* Unlock chain. */
		call set_lock_$unlock (
		     mcfc.start_list (chain).files.lock
		     , code
		     );
		if code ^= 0 then do;
		     call com_err_ (
			code
			, "gtss_mcfc_delete"
			, "Unlocking chain ^i (Arg ^i ""^a""). Quitting."
			, chain
			, argn
			, arg
			);
		     goto fail;
		end;
		return;
	     end;
	     if code = error_table_$invalid_lock_reset then do;
		call com_err_ (
		     code
		     , "gtss_mcfc_delete"
		     , "For chain ^i (Arg ^i ""^a"")."
		     , chain
		     , argn
		     , arg
		     );
		goto cont_del;
	     end;

/* Could not lock. */
	     if code = error_table_$lock_wait_time_exceeded then do;
		call com_err_ (
		     code
		     , "gtss_mcfc_delete"
		     , "Could not wait to lock chain ^i (Arg ^i ""^a""). Skipped."
		     , chain
		     , argn
		     , arg
		     );
		return;
	     end;
	     call com_err_ (
		code
		, "gtss_mcfc_delete"
		, "ENEXPECTED ERROR processing chain ^i (Arg ^i ""^a""). Quitting."
		, chain
		, argn
		, arg
		);
	     goto fail;


get_int:	     proc (i, s, v);

/* Obtain 3 integer values. */
dcl  i                        fixed bin(24) parm;
dcl  s                        char(*)parm;
dcl  v                        fixed bin(24) parm;
		if i>3 then return;
		k = search (s, "-");
		if k = 0 then do;			/* Contains no (more) minus signs. */
		     if verify (s, "0123456789")>0 then do;
bad_arg:			;
			call com_err_ (
			     0
			     , "gtss_mcfc_delete"
			     , "Argument ^i, ""^a"", not integer-integer-integer, skipped."
			     , argn
			     , arg
			     );
			goto next_arg;
		     end;
		     v = fixed (s, 24);
		     return;
		end;
		if verify (substr (s, 1, k-1), "0123456789")>0 then goto bad_arg;
		v = fixed (substr (s, 1, k-1), 24);
		if i = 1 then
		     call get_int (i+1, substr (s, k+1), file);
		else
		call get_int (i+1, substr (s, k+1), caller);
		return;
dcl  k                        fixed bin(24);
	     end					/* get_int */;
dcl  chain                    fixed bin(24);
dcl  file                     fixed bin(24);
dcl  caller                   fixed bin(24);
	end					/* del */;

del_file:	proc (c, f, u);

/* Delete caller u of file f on chain c.
*/
dcl  c                        fixed bin(24)parm;
dcl  f                        fixed bin(24)parm;
dcl  u                        fixed bin(24)parm;
	     if (f ^= -1)| (u ^= -1) then do;
		call com_err_ (
		     0
		     , "gtss_mcfc_delete"
		     , "Only delete chain implemented, arg ^i ""^a"""
		     , argn
		     , arg
		     );
		return;
	     end;
	     ln = -c;
	     n = mcfc.start_list (c).files.first;

	     if f = -1 then do;			/* => delete chain. */
		query_info.yes_or_no_sw = "1"b;	/* Demand yes or no. */
		query_info.suppress_name_sw = "0"b;	/* Display caller name. */
		query_info.status_code,
		     query_info.query_code = 0;
		call command_query_ (
		     addr (query_info)
		     , ans
		     , "gtss_mcfc_delete"
		     , "Can ALL chain ^i be deleted?"
		     , c
		     );
dcl  command_query_           entry options(variable);
		if ans = "no" then return;
dcl  ans                      char(3)var;
		mcfc.start_list (c).files.first = 0;	/* Make chain c available. */
	     end;

	     do while (n>0);
		fn = n;				/* File index. */
dcl  fn                       fixed bin(24);

/* Link to next file in chain. */
		ln = n;
		n = file_entry (n).link;
		if f = -1 then do;

/* Delete any file on chain c. */
		     call return_entry (c, fn);
		end;
		else do;
		     if n = f then do;		/* File entry found. */
			if u = -1 then do;		/* Delete all callers for file. */
/**MORE**/
			end;

/* Delete only caller u. */
/**MORE**/
			return;
		     end;
		end;
	     end;

/* File f not found. */
/**MORE**/
	     return;

dcl  n                        fixed bin(24);
dcl  ln                       fixed bin(24);
	end					/* del_file */;

return_entry: proc (h, u);

/* Return file entry u to an available list. */
dcl  h                        fixed bin(24) parm;
dcl  u                        fixed bin(24) parm;
	     do i = h to hbound (mcfc.start_list, 1),
		     lbound (mcfc.start_list, 1) to (h-1);
		if ^can_not_lock ("avail", i, mcfc.start_list (i).avail.lock) then do;
		     if mcfc.start_list (i).avail.first = 0 then do;
			call can_not_unlock ("avail", i, mcfc.start_list (i).avail.lock);
			goto cont;
		     end;
		     unspec (file_entry (u)) = "0"b;
		     file_entry (u).link = mcfc.start_list (i).avail.first;
		     mcfc.start_list (i).avail.first = u;
		     call can_not_unlock ("avail", i, mcfc.start_list (i).avail.lock);
		     return;
		end;

cont:		;
	     end;

/* Could not find ANY available entries. */
	     call com_err_ (
		0
		, "gtss_mcfc_"
		, "NO AVAILABLE CHAIN TO RETURN TO (from ^i for ^i)"
		, h
		, u
		);
	     goto fail;
dcl  i                        fixed bin(24);
	end					/* return_entry */;

can_not_lock: proc (en, e, lw)returns (bit (1));

/* Lock word lw, for list named en at entry e.
   Return "1"b if can NOT lock, else return "0"b.
*/
dcl  en                       char(*)parm;
dcl  e                        fixed bin(24) parm;
dcl  lw                       bit(36)aligned;
	     call set_lock_$lock (
		lw
		, gtss_ext_$mcfc.wait_time
		, c
		);
	     if c = 0 then return ("0"b);

	     if c = error_table_$invalid_lock_reset then do;
		return ("0"b);
	     end;

/* Could not lock. */
	     if c = error_table_$lock_wait_time_exceeded then do;
		call com_err_ (
		     c
		     , "gtss_mcfc_delete"
		     , "(^a ^i)"
		     , en
		     , e
		     );
		return ("1"b);
	     end;
	     if c = error_table_$locked_by_this_process then do;
		call com_err_ (
		     c
		     , "gtss_mcfc_delete"
		     , "BUG? Will not proceed (^a ^i)."
		     , en
		     , e
		     );
		goto fail;
	     end;
	     call com_err_ (
		c
		, "gtss_mcfc_delete"
		, "UNEXPECTED LOCK ERROR? (^1 ^i)"
		, en
		, e
		);
	     goto fail;
dcl  c                        fixed bin(35);
	end					/* can_not_lock */;

can_not_unlock: proc (en, e, lw);

/* Unlock word lw. In en named chain, entry e.
*/
dcl  en                       char(*)parm;
dcl  e                        fixed bin(24)parm;
dcl  lw                       bit(36)aligned parm;
	     call set_lock_$unlock (
		lw
		, c
		);
	     if c = 0 then return;

/* Could not unlock. */
	     if (c = error_table_$lock_not_locked) |
	     (c = error_table_$locked_by_other_process) then
		call com_err_ (
		c
		, "gtss_mcfc_delete"
		, "BUG? Will not proceed (^a ^i)."
		, en
		, e
		);
	     else
	     call com_err_ (
		c
		, "gtss_mcfc_delete"
		, "UNEXPECTED LOCK ERROR? (^a ^i)"
		, en
		, e
		);
	     goto fail;
dcl  c                        fixed bin(35);
	end					/* can_not_unlock */;

/* Variables for gtss_mcfc_delete:
   IDENTIFIER		ATTRIBUTES	*/
dcl  al                       fixed bin(24);
dcl  ap                       ptr;
dcl  arg                      char(al)unal based(ap);
dcl  argn                     fixed bin(24);
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  cu_$arg_ptr              entry(fixed bin(24),ptr,fixed bin(24),fixed bin(35));
dcl  cu_$arg_ptr_rel          entry(fixed bin(24),ptr,fixed bin(24),fixed bin(35),ptr);
dcl  empty                    builtin;
dcl  error_table_$invalid_lock_reset fixed bin(35)ext;
dcl  error_table_$locked_by_other_process fixed bin(35)ext;
dcl  error_table_$locked_by_this_process fixed bin(35)ext;
dcl  error_table_$lock_not_locked fixed bin(35)ext;
dcl  error_table_$lock_wait_time_exceeded fixed bin(35)ext;
dcl  get_lock_id_             entry(bit(36)aligned);
dcl  gtss_mcfc_init_          entry(char(*)var);
dcl  i                        fixed bin(24);
dcl  lid                      bit(36)aligned;
dcl  n                        fixed bin;
dcl  null                     builtin;
dcl  r                        char(5)var;
dcl  set_lock_$lock           entry(bit(36)aligned,fixed bin,fixed bin(35));
dcl  set_lock_$unlock         entry(bit(36)aligned,fixed bin(35));
dcl  sll                      fixed bin;
dcl  sub_entry                bit(1);

%include gtss_mcfc;

%include gtss_ext_;

%include query_info;
     end						/* gtss_mcfc_delete */;
  



		    gtss_mcfc_dump.pl1              12/11/84  1354.3rew 12/10/84  1044.3       46692


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

gtss_mcfc_dump: mcfcd: proc;

/* Dump the GCOS mcfc data base.

   Author: Dave Ward	08/08/79
*/
	nhe = "0"b;				/* => Do print header info. */

	call cu_$arg_ptr (1, ap, al, c);
	if c = 0 then do;
	     if arg = "-nhe" | arg = "-no_header" then nhe = "1"b;
	     else do;
		call com_err_ (
		     c
		     , "gtss_mcfc_dump"
		     , "Only -nhe (-no_header) allowed ""^a"""
		     , arg
		     );
		return;
	     end;
	end;

	call gtss_mcfc_init_ (rs);
	if rs = "false" then return;

	if ^nhe then do;
	     call ioa_ ("DUMP OF MULTIPLE CALLER'S FILE CONTROL (wait ^i, lock_id ^w):"
		, gtss_ext_$mcfc.wait_time
		, gtss_ext_$mcfc.multics_lock_id
		);

/* Print pathnames of mcfc segments. */
	     do i = 1 to hbound (mo, 1);
		call hcs_$fs_get_path_name (
		     mo (i)
		     , dn
		     , dnl
		     , en
		     , c
		     );
		if c ^= 0 then do;
		     call com_err_ (
			c
			, "gtss_mcfc_dump"
			, "Pointer ^i (^p)"
			, i
			, mo (i)
			);
		     return;
		end;
		call ioa_ ("^a>^a", substr (dn, 1, dnl), en);
	     end;
	end;


/* Measure available chains. */
	cul, cl, count = 0;
	do i = lbound (mcfc.start_list, 1) to hbound (mcfc.start_list, 1);
	     if mcfc.start_list (i).files.first ^= 0 then nfiu = "0"b; /* Atleast 1 chain. */
	     if mcfc.start_list (i).avail.lock = "0"b then do;
		cul = cul+1;
		l = trace (mcfc.start_list (i).avail.first);
		count (l) = count (l)+1;
	     end;
	     else
	     cl = cl+1;
	end;

/* Print available statistics. */
	call ioa_ ("Available: locked ^i unlocked ^i length distribution"
	     , cl
	     , cul
	     );
	do i = lbound (count, 1) to hbound (count, 1);
	     if count (i) ^= 0 then
		call ioa_$nnl (" ^i-^i", i, count (i));
	end;
	if nfiu then call ioa_$nnl (" NO FILES IN USE.");
	call ioa_$nnl ("^/");

/* Print file chains. */
	do i = lbound (mcfc.start_list, 1) to hbound (mcfc.start_list, 1);
	     if mcfc.start_list (i).files.first>0 then do;
		call ioa_$nnl ("^/[Chain ^4i]", i);
		if mcfc.start_list (i).files.lock = "0"b then call ioa_$nnl ("     locked");
		else call ioa_$nnl (" not locked");
		n = mcfc.start_list (i).files.first;
		mn = 0;
		do while ((n ^= 0)& (mn <= 100));
		     call ioa_$nnl (" uid ^w lock ^w del ^1b ^i>100^/(^4i) ""^a""^/"
			, file_entry (n).unique_id
			, file_entry (n).file_lock
			, file_entry (n).delete
			, file_entry (n).number_who_could_not_call
			, n
			, fnn
			);

/* Print list of callers. */
		     call get_caller_index (n, caller_ptr, e);
		     do k = 1 to file_entry (n).number_callers;
			call ioa_$nnl (" (^i ^w ^2o)"
			     , k
			     , caller (e).lock_id (k)
			     , caller (e).gcos_access (k)
			     );
		     end;
		     call ioa_$nnl ("^/");

		     mn = mn+1;
		     n = file_entry (n).link;
		end;
	     end;
	end;
	return;

trace:	proc (i)returns (fixed bin);

/* Trace length of chain starting at i. */
dcl  i                        fixed bin(24) parm;
	     n = i;
	     k = 0;
	     do while ((n ^= 0)& (k<hbound (count, 1)));
		k = k+1;
		n = file_entry (n).link;
	     end;
	     return (k);
dcl  n                        fixed bin(24);
dcl  k                        fixed bin(24);
	end					/* trace */;

%include gtss_mcfc_gci;

/* Variables for gtss_mcfc_dump:
   IDENTIFIER		ATTRIBUTES	*/
dcl  al                       fixed bin(24);
dcl  ap                       ptr;
dcl  arg                      char(al)unal based(ap);
dcl  c                        fixed bin(35);
dcl  cl                       fixed bin(24);
dcl  com_err_                 entry options(variable);
dcl  count                    (0:8000)fixed bin(24);
dcl  cul                      fixed bin(24);
dcl  cu_$arg_ptr              entry(fixed bin(24),ptr,fixed bin(24),fixed bin(35));
dcl  dn                       char(168);
dcl  dnl                      fixed bin;
dcl  e                        fixed bin(24);
dcl  en                       char(32);
dcl  fnn                      char(namel(n))unal based(pointer(nameo(n),names));
dcl  gtss_mcfc_init_          entry(char(*)var);
dcl  hcs_$fs_get_path_name    entry(ptr,char(*),fixed bin,char(*),fixed bin(35));
dcl  i                        fixed bin(24);
dcl  ioa_                     entry options(variable);
dcl  ioa_$nnl                 entry options(variable);
dcl  j                        fixed bin(24);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  mn                       fixed bin(24);
dcl  mo                       (6)ptr based(addr(gtss_ext_$mcfc.files_ptr));
dcl  n                        fixed bin(24);
dcl  nfiu                     bit(1)init("1"b);
dcl  nhe                      bit(1);
dcl  rs                       char(5)var;

%include gtss_mcfc;

%include gtss_ext_;
     end						/* gtss_mcfc_dump */;



		    gtss_mcfc_empty.pl1             12/11/84  1354.3rew 12/10/84  1044.3       17082


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

gtss_mcfc_empty: proc (rs);

/* Command to set the GCOS simulator's multiple
   caller file control data base "empty".

   Author: Dave Ward	08/08/79
*/
dcl  rs                       char(*)var parm;

	call gtss_mcfc_init_ (r);
	if r = "false" then do;
	     rs = r;
	     return;
	end;

/* Obtain caller's lock id. */
	call get_lock_id_ (lid);

	unspec (mcfc), unspec (names) = "0"b;

/* Pseudo lock all the start list. */
	mcfc.start_list.files.lock, mcfc.start_list.avail.lock = lid;

	names = empty ();

/* Set availibility chains. */
	n = lbound (mcfc.start_list, 1);
	sll = hbound (mcfc.start_list, 1)-lbound (mcfc.start_list, 1)+1;
	do i = lbound (file_entry, 1) to hbound (file_entry, 1);
	     file_entry (i).link = mcfc.start_list (n).avail.first;
	     mcfc.start_list (n).avail.first = i;
	     n = mod (n+1, sll);
	end;

/* Unlock all the start list. */
	mcfc.start_list.files.lock, mcfc.start_list.avail.lock = "0"b;

	rs = "true";
	return;

/* Variables for gtss_mcfc_empty:
   IDENTIFIER		ATTRIBUTES	*/
dcl  empty                    builtin;
dcl  get_lock_id_             entry(bit(36)aligned);
dcl  gtss_mcfc_init_          entry(char(*)var);
dcl  i                        fixed bin;
dcl  lid                      bit(36)aligned;
dcl  n                        fixed bin;
dcl  r                        char(5)var;
dcl  sll                      fixed bin;

%include gtss_mcfc;

%include gtss_ext_;
     end						/* gtss_mcfc_empty */;
  



		    gtss_mcfc_init_.pl1             12/11/84  1354.3rew 12/10/84  1044.3       28035


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

gtss_mcfc_init_: proc (rs);

/* Set gtss_ext_$mcfc (data base values for
   multiple caller file control). Required
   before any calls made to gtss_mcfc_.
   Record callers lock id.
   Set default mcfc wait time (30 seconds).
   Return rs "true" if successful, else "false"
   (i.e. => can be called as active function.

   Author: Dave Ward	08/08/79
   Change: Dave Ward	11/28/79 Use object referencing directory.
   Change:  Ron Barstad  02/07/83  Remove false reference to >exl... for mcfc files
*/
dcl  rs                       char(*)var parm;
label_to_locate_this_object:
	call hcs_$fs_get_path_name (
	     codeptr (label_to_locate_this_object)
	     , dir_for_this_object
	     , 0
	     , ""
	     , c
	     );
	if c ^= 0 then do;
	     call com_err_ (
		c
		, "gtss_mcfc_init_"
		, "Could not obtain directory of mcfc data base."
		);
	     rs = "false";
	     return;
	end;

	do i = 1 to hbound (mcfc_ptr, 1);
/* Set pointers to multiple caller file control
   (mcfc) data structures.
*/
	     call hcs_$initiate (
		dir_for_this_object
		, "GTSS.MCFC."||mcfc_name (i)
		, ""				/* Null reference name. */
		, 0				/* Segment no. not reserved. */
		, 1				/* Not a copy. */
		, mcfc_ptr (i)
		, c
		);
	     if c ^= 0 then
		if c ^= error_table_$segknown then do;
		     call com_err_ (
			c
			, "gtss_mcfc_init_"
			, "Could not obtain GTSS.MCFC.(FILES NAMES CALLERS_(1 2 3 4))."
			);
		     rs = "false";
		     return;
		end;
	end;

/* Obtain caller's (unique)
   lock identifier.
*/
	call get_lock_id_ (gtss_ext_$mcfc.multics_lock_id);

/* Set default wait time for mcfc callers.
   The number of real-time seconds a process
   is put to sleep awaiting use of mcfc.
*/
	gtss_ext_$mcfc.wait_time = 30;

	rs = "true";
	return;

/* Variables for gtss_mcfc_init_:
   IDENTIFIER		ATTRIBUTES */
dcl  c                        fixed bin(35);
dcl  codeptr                  builtin;
dcl  com_err_                 entry options(variable);
dcl  dir_for_this_object      char(168);
dcl  error_table_$segknown    fixed bin (35)ext;
dcl  get_lock_id_             entry(bit(36)aligned);
dcl  hcs_$fs_get_path_name    entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$initiate            entry(char(*),char(*),char(*),fixed bin(1),fixed bin(2),ptr,fixed bin(35));
dcl  i                        fixed bin;
dcl  mcfc_ptr                 (6)ptr aligned based(addr(gtss_ext_$mcfc.files_ptr));

dcl  mcfc_name                (6)char(9)var static int options(constant) init(
/* 1 */ "FILES"
,/* 2 */ "NAMES"
,/* 3 */ "CALLERS_1"
,/* 4 */ "CALLERS_2"
,/* 5 */ "CALLERS_3"
,/* 6 */ "CALLERS_4"
);

%include gtss_ext_;
     end						/* gtss_mcfc_init_ */;
 



		    gtss_multics_Hstar_.pl1         12/11/84  1354.3rew 12/10/84  1044.4      122463


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_multics_Hstar_: proc (subsystem_name, subsystem_origin, transfer_addr, total_pgm, high_address, error);

/**	gtss save and restore batch gcos simulator H*

	[Derived from gcos_mme_call_.pl1]

	Author:	Bob Grimes		04/15/78
	Changed:	Dave Ward			07/09/78
   Changed:         R. Barstad                    06/04/82
                     to change size of dcl me from 16 to 20 
	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
 **/
dcl  subsystem_name           char (6) parm;
dcl  subsystem_origin         bit (18) parm;
dcl  transfer_addr            fixed bin parm;
dcl  total_pgm                fixed bin(18) parm;
dcl  high_address             fixed bin(18) parm;
dcl  error                    bit (1) parm;

/** REMOVE  fibptr = addr (gtss_ext_$fib);*/						/* the first fib is the pointer to the tss library */
/** REMOVE lib_ptr = fib (1).pointer;*/	lib_ptr = null ();

/*  Read catalog record and search for program to be loaded   */
/* **************N   O   T   E*********************************************************
   *
   *	The catalog for the simulator library, tss_system_software_, is not
   *	the same as the catalog for a random system loadable file produced by
   *	SYSEDIT, and commonly used as a dynamic library (** file).
   *	This routine presently handles both types.  Note that it would be
   *	inefficient for the simulator to utilize a sector oriented catalog
   *	for its primary software library.  In fact, after GCOS is booted, it
   *	does not use the catalogs contained in its primary software libraries.
   *	It uses one linear directory that it has built from the disjoint disk
   *	catalogs of its primary libraries.  The catalog formats of the GCOS
   *	and the GCOS simulator primary libraries should be of no concern
   *	to users of either system.
   *
   *	See the GCOS PLM (AN77) for a detailed description of the differences
   *	in format between a random system loadable file (a dynamic library), the
   *	simulator library, and a tape system loadable file (from which the
   *	simulator library is produced).
   *
   **************N   O   T   E******************************************************* */


/*   the catalog block is at the beginning of the segment  */

	cat_ptr = lib_ptr;

	bcd_subsystem_name = "��";			/* initialize subsystem name to all bcd blanks */
	call gtss_ascii_bcd_ (addr (subsystem_name), 6, addr (bcd_subsystem_name));

	if gcatblk.avail_ptr ^= 1 then go to sim_cat;	/* determine catalog type */
	gcatsw = "1"b;				/* GCOS standard catalog type */


sim_cat:	gcatsw = "0"b;

	do i = 1 to catblk.no_ent;			/* loop for no. of entries in cat */
	     if catblk.element (i) = bcd_subsystem_name then do; /* hit ? */
		prefp = addrel (cat_ptr, catblk.address (i));
		go to readp;
	     end;
	end;


not_found:

	message = "";
	longerror = "call name missing";
	goto any_abort;
						/*  Come here when entry found. Seek to and read preface record   */


readp:

/*  compute no of dcws in preface     */


	do ndcw = 1 to 58 while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b);
	end;


	reloc_len = fixed (preface.reloc_words);	/* save no. of relocation words */
	load_origin = fixed (preface.origin);		/* save origin */
	pgm_length = fixed (preface.data_words);	/* save pgm length */

	if gcatsw then do;
	     reloc_len = reloc_len*64;		/* for a GCOS catalog, convert blocks to words */
	     pgm_length = pgm_length*64;
	     seek_save = seek_save + 64;		/* and program starts in next block */
	end;
	else data_ptr = addrel (prefp, 6+ndcw);		/* for simulator catalog , program immediately follows */

	transfer_addr = fixed (preface.entry);		/* save entry point */
	load_increment = 0;				/* init load increment */

	if subsystem_origin ^= (18)"0"b then do;	/* did slave specify an origin ? */
	     if load_origin > 131072 then		/* relocatable overlay ? */
		load_increment = fixed (subsystem_origin);
	     else load_increment = fixed (subsystem_origin)-load_origin; /* set up new load increment */
	     load_origin = fixed (subsystem_origin);	/* use user specified origin */
	     transfer_addr = transfer_addr+load_increment; /* new transfer address */
	end;


l2:
	high_address = load_origin+pgm_length;
	total_pgm = (divide (load_origin+pgm_length-1, 1024, 18)+1)*1024;
	if total_pgm >= 131072 then do;	/* will pgm fit ? */
	     message = "";
	     longerror = "subsystem size > limits";
	     goto any_abort;
	end;

	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

	if gseg = null then do;
	     message = "";
	     longerror = "slave area segments not created";
	     goto any_abort;
	end;
	call hcs_$truncate_seg (gseg, total_pgm, code);	/* truncate */

/* Set the actual max length limit on the segment */
	call hcs_$set_max_length_seg (gseg, total_pgm, code);
	if code ^= 0 then
	     do;
	     message = "";
	     longerror = "setting max length on slave segment";
	     goto any_abort;
	end;


	dcwp = addr (preface.dcws (1));
	first_loc = fixed (dcw_model.data_addr, 18, 0)-1024+load_increment;


/*  Loop to read data records into tss segment    */


	xfer_total = 0;				/* clear xfer total */
	do i = 1 to ndcw;				/* loop to process dcws */

	     dcwp = addr (preface.dcws (i));		/* get pointer to a dcw */
	     j = fixed (dcw_model.count);		/* grab xfer count */
	     if j = 0 then j = 4096;			/* count of 0 = 4096 */
	     xfer_total = xfer_total + j;		/* total up words to xfer */

	end;

/* copy program into segment */
	prog_ptr = addrel (gseg, first_loc);

	program_seg = data_blocks;

l3:
	preface.data_check = 0;
						/*  Calculate checksum and compare with that in preface block */


	if preface.data_check ^= 0 then do;		/* don't do if checksum = 0 */

	     ptr = addrel (gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_), first_loc); /* get ptr to first loc loaded */
	     accum = 0;				/* clear accumulator */
	     do i = 1 to xfer_total;
		accum = accum + fixed (checker (i));	/* add a word */
		if accum > 68719476735 then do;	/* carry into second word ? */
		     accum = accum - 68719476736 + 1;	/* add carry to low end of no. */
		end;
	     end;

	     if substr (unspec (accum), 37, 36) ^= unspec (preface.data_check) then do; /* error */
		message = "";
		longerror = "checksum error during load";
		goto any_abort;

	     end;

	end;
/*  If this is an absolute program, go turn control back to the user */


	if reloc_len = 0 then go to exit_gecall;

	if load_increment = 0 then go to exit_gecall;	/* no relocation to do */
/*  Come here when relocation finished    */


start_pgm:					/* return load origin and pgm length in A */


	error = "0"b;

io_abort:
any_abort:
	error = "1"b;
	return;
exit_gecall:

	error = "0"b;
	return;					/* go start program */

/**  Variables for gtss_multics_Hstar_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  null                     builtin;
dcl  hcs_$truncate_seg        ext entry (ptr, fixed bin(18), fixed bin (35));
dcl  gseg                     ptr	/* temp ptr to tss seg */;
dcl  abrt                     char (2);
dcl  accum                    fixed bin (71)	/* checksum accumulator */;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  ascii_gecall_name        char (6)	/* for printing in trace or error messages */;
dcl  bit                      builtin;
dcl  buffer                   bit (36000)	/* preface and relocation blk buffer */;
dcl  callp                    ptr init(null());
dcl  check_fs_errcode_        ext entry (fixed bin, char (8), char (100));
dcl  checker                  (pgm_length) bit (36) aligned based (ptr)	/* overlay for computing chksum */;
dcl  dcwp                     ptr init(null());
dcl  dylibsw                  bit (1) aligned init ("0"b)	/* on if searching dynamic library (**) */;
dcl  fb18                     fixed bin (18)	/* need full 18 bits for address arithmetic */;
dcl  fc                       char (6);
dcl  first_lib                bit (1) aligned init ("1"b)	/* on until initialzation done */;
dcl  first_loc                fixed bin	/* used by checksum rtn */;
dcl  fixed                    builtin;
dcl  gcatsw                   bit (1)	/*  0=simulator catalog, 1=tss format catalog */;
dcl  i                        fixed bin;
dcl  increment                fixed bin	/* number of parameter words to skip */;
dcl  ioa_                     ext entry options (variable);
dcl  ios_$read                ext entry (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  ios_$seek                ext entry (char (*) aligned, char (*), char (*), fixed bin, bit (72) aligned);
dcl  j                        fixed bin;
dcl  k                        fixed bin;
dcl  load_at                  char (8) aligned	/* holds attach name of file to load from */;
dcl  load_increment           fixed bin;
dcl  load_origin              fixed bin;
dcl  longerror                char (100);
dcl  message                  char (60);
dcl  min                      builtin;
dcl  ndcw                     fixed bin;
dcl  pgm_length               fixed bin;
dcl  sub                      char (4) aligned;
dcl  me char (20) init ("gtss_multics_Hstar_");
dcl  prefp                    ptr init(null());
dcl  ptr                      ptr init(null());
dcl  reloc_bits               (1) unaligned bit (1) based (prefp)	/* overlay for relocation record */;
dcl  reloc_len                fixed bin;
dcl  seclibsw                 bit (1) aligned init ("0"b)	/* on if searching secondary library */;
dcl  seek_save                fixed bin	/* holds seek offset */;
dcl  size                     fixed bin	/* size of pgm overlay arrays */;
dcl  st                       bit (72) aligned 	/* ios status */;
dcl  state                    char (4);
dcl  statp                    ptr init(null());
dcl  substr                   builtin;
dcl  unspec                   builtin;
dcl  word_no                  fixed bin;
dcl  xfer_total               fixed bin	/* used to hold total no. words to xfer */;
dcl  get_group_id$tag_star    ext entry returns (char (32));
dcl  cu_$level_get            ext entry (fixed binary);
dcl  hcs_$set_max_length_seg  ext entry (ptr,fixed bin (18), fixed bin (35));
dcl  bcd_subsystem_name       char (4) aligned;
dcl  string                   builtin;
dcl  code                     fixed binary (35);
dcl  get_group_id_$tag_star   ext entry returns (char (32));
						/*  work variables  */

dcl  lib_ptr                  ptr init(null());
dcl  data_ptr                 ptr init(null());
dcl  cat_ptr                  ptr init(null());
dcl  data_blocks              (xfer_total) based (data_ptr);
dcl  prog_ptr                 ptr init(null());

dcl  program_seg              (xfer_total) based (prog_ptr);
dcl 1 acla,					/* acl model for file system */
    2 userid char (32),
    2 pack,
      3 mode bit (5),				/* access  */
      3 reterr bit (13),
      3 (rb1, rb2, rb3) bit (6);

dcl 1 status aligned based (statp),			/* overlay for ios_ status */
    2 code fixed bin,				/* standard error code */
    2 fill bit (9) unaligned,
    2 eof bit (1) unaligned;						/* eof bit */


dcl 1 preface aligned based (prefp),			/* model of preface record - 64 words max */
    2 data_check fixed bin,				/* checksum of following data words */
    2 rel_check fixed bin,				/* checksum of following reloc. words */
    2 rel_abs fixed bin,				/* 0=absolute|^0=relocatable */
    2 name bit (36) unaligned,			/* name of pgm */
    2 entry bit (18) unaligned,			/* entry address */
    2 origin bit (18) unaligned,			/* origin */
    2 reloc_words bit (18) unaligned,			/* no. of relocation words */
    2 data_words bit (18) unaligned,			/* no. of data words */
    2 dcws (ndcw) bit (36) unaligned;						/* dcw(s) - max of 58 - to load following data records */


dcl 1 dcw_model aligned based (dcwp),			/* model of dcw */
    2 data_addr bit (18) unaligned,
    2 zero bit (3) unaligned,
    2 action bit (3) unaligned,
    2 count bit (12) unaligned;						/* number of words to xfer */


dcl 1 tss_reloc aligned based (ptr),			/* overlay for each half word  */
    2 half_wd (131072) bit (18) unaligned;						/* of the loaded program */


dcl 1 catblk aligned based (cat_ptr),			/* catalog image */
    2 nxt fixed bin,				/* pointer to next cat blk */
    2 no_ent fixed bin,				/* no. of entries in this cat blk */
    2 elblock (499),				/* room for 499 entries */
      3 element char (4) unaligned,			/* prog name */
      3 address fixed bin;						/* offset in file of preface rcrd */


dcl 1 gcatblk aligned based (cat_ptr),			/* catalog image for tss format catalog */
    2 avail_ptr fixed bin unaligned,
    2 next_cat fixed bin unaligned,
    2 pad bit (36),
    2 elblock (15),
      3 element char (4),
      3 length fixed bin unaligned,
      3 address fixed bin unaligned,
      3 pad bit (72);

%include gtss_ext_;


%include gtss_entry_dcls;
     end gtss_multics_Hstar_;
 



		    gtss_prgdes_ext_.alm            12/11/84  1354.3rew 12/10/84  1044.4       10314


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

"	Source for gtss program descriptors data base
"
"	Created by: Dave Ward		06/08/78
"
"	Include macros generated by execution of
"	on entries:
"	ted$com >udd>Gcos>gtss>tools>gtss
"  |translate_prgdes       (ANK) Produce gtss_prgdes from TSSA source.
"  |get_gtss_names         (ANK) Extract list of GECALL names form gtss_prgdes
"  |add_prgdes_info        (ANK) Add SS info (length, entry point, location) to program descriptors.
"
"	Changed by:	Dave Ward		06/08/78
"			ust portion removed (gtss_ext_data_.incl.alm)
"
	name	gtss_prgdes_ext_
	include	gtss_prgdes_macros_
	include	gtss_prgdes_alm_
"
"
"	Mark end of program descriptors.
	segdef	ENDprgds
ENDprgds:	aci	|ENDprgds|
"

	join	/static/loc1
	end
  



		    gtss_read_starCFP_.pl1          12/11/84  1354.3rew 12/10/84  1044.5       42993


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_read_starCFP_: proc (up, bp, ml, rl, ec);

/**       Author:   Dave Ward 02/23/79
          Change:   Al Dupuis 12/04/79 Rewritten to make use of cout term codes

          This entry is provided to read the next input sector from *CFP.
          The entry last_os is provided to read the last sector written
          to the *CFP file.
**/

	call read_next_sector;
	return;

last_os:	entry (up, bp, ml, rl, ec);

	n = gtss_ust.lcfio.sect_out - 1;
	call read_any_sector;
	return;


read_next_sector: proc;

	     ec = 0;
	     n = gtss_ust.lcfio.sect_in;
	     if n = gtss_ust.lcfst.initial_sect_out - 1
	     then cout_called = "1"b;
	     if n ^< gtss_ust.lcfst.initial_sect_out
	     then do;
		err_mess = "COMMAND FILE INPUT EXHAUSTED";
		gtss_ust.lcfst.start_term = 12;
		call common_error;
		return;
	     end;
	     gtss_starCF_$FILE.Seek_Address = n;
	     gtss_ust.lcfio.sect_in = n + 1;
	     gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	     fn = gtss_starCF_$FILE.cf.aft_indx;
	     call gtss_ios_io_ (
		fn,
		addr (select_sequence),
		addr (select_sequence),
		fixed (rel (addr (gtss_starCF_$FILE.cf))),
		status,
		code);
	     if status ^= 0
	     then do;
		err_mess = "COMMAND FILE I/O ERROR";
		gtss_ust.lcfst.start_term = 2;
		call common_error;
		return;
	     end;
		 /** Check for too many characters **/
	     if no_characters > ml
	     then do;
		err_mess = "INPUT LINE LENGTH TOO LONG";
		gtss_ust.lcfst.start_term = 11;
		call common_error;
		return;
	     end;
	     l, rl = no_characters;
	     if substr (chars, l, 1) = CR
	     then substr (chars, l, 1) = NL;
	     bp -> MC = gtss_starCF_$FILE.RECORD.chars;
	     ec = 0;
	     return;
	end;


read_any_sector: proc;


	     ec = 0;
	     gtss_starCF_$FILE.Seek_Address = n;
	     gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	     fn = gtss_starCF_$FILE.cf.aft_indx;
	     call gtss_ios_io_ (
		fn,
		addr (select_sequence),
		addr (select_sequence),
		fixed (rel (addr (gtss_starCF_$FILE.cf))),
		status,
		code);
	     if status ^= 0
	     then do;
		err_mess = "COMMAND FILE I/O ERROR";
		gtss_ust.lcfst.start_term = 2;
		call common_error;
		return;
	     end;
	     l, rl = no_characters;
	     if substr (chars, l, 1) = CR
	     then substr (chars, l, 1) = NL;
	     bp -> MC = gtss_starCF_$FILE.RECORD.chars;
	     ec = 0;
	     return;
	end;


common_error: proc;


	     ec = 1;
	     mc_ptr = gtss_find_cond_frame_ ("derail");
	     if mc_ptr = null ()     /** no gmap program to abort **/
	     then call gtss_CFP_abort_;
	     else do;
		if err_mess ^= ""
		then call gtss_abort_subsystem_ (
		     mc_ptr,
		     "gtss_read_starCFP_",
		     0,
		     err_mess);
		else call gtss_abort_subsystem_ (
		     mc_ptr,
		     "gtss_read_starCFP_",
		     0);
		return;
	     end;
	end;


/**  Variables for gtss_read_starCFP_
**/
dcl  bp                       ptr parm;  /** (input) callers buffer **/
dcl  code                     fixed bin (35);
dcl  cr                       bit (9) static int options (constant) init ("015"b3);
dcl  ec                       fixed bin (35) parm;  /** (output) Multics error code **/
dcl  err_mess                 char (250) init ("");
dcl  fn                       fixed bin (24);
dcl  l                        fixed bin (24);
dcl  mc_ptr                   ptr init (null ());
dcl  ml                       fixed bin (21) parm; /** (input) buffer length **/
dcl  n                        fixed bin (18) unsigned unal;
dcl  nl                       bit (9) static int options (constant) init ("012"b3);
dcl  rl                       fixed bin (21) parm; /** (input) no of chars **/
dcl  rl_chars		char (rl) unal based;
dcl  status                   fixed bin(24);
dcl  CR                       char (1) based (addr (cr));
dcl  MC			char (l) based;
dcl  NL                       char (1) based (addr (nl));
dcl  up                       ptr parm;  /** (input) not used **/
%include gtss_starCF_;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_db_names;

%include gtss_device_cmds;
     end;
   



		    gtss_run_subsystem_.pl1         08/04/87  1723.9r   08/04/87  1541.5      123732


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

/**************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   **************************************************************/

gtss_run_subsystem_: rs_: proc (prgdes_index);

/**	Load and set into execution the object from the
   fast library specified by program descriptor
   information (indexed by parmaeter "prgdex_index").

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Change:  Dave Ward	05/29/79 gdb H* modules.
   Change:  Scott C. Akers    08/17/81 Reset tty_modes on quit
   **/
dcl  prgdes_index             fixed bin (24)parm;
dcl  arg_list_ptrp            ptr parm;

	pdx = prgdes_index;				/* Local value. */
	arg_list_ptr = null ();			/* arg_list1 should not be in use. */
	restore = "0"b;				/* Did not enter at restore. */
	restor_continue (gtss_ext_$stack_level_) = right_here;
	restor_continue2 (gtss_ext_$stack_level_) = right_here2;
	goto continue;

restor:	entry (prgdes_index, arg_list_ptrp);

/**	Entry provided for drl_restor of a subsystem	**/

/**	Set two static internal variables used to
   access information needed for derail restor
   functionality provided in gtss_run_subsystem_.
   **/
	pdx = prgdes_index;				/* Index to program descriptor. */
	arg_list_ptr = arg_list_ptrp;			/* DRL RESTOR arguments (arg_list1). */

/**	Now return to the invocation of gtss_run_subsystem_
   that instituted the execution of the subsystem for which this overlay
   is a part (i.e., the overlay being brought in by the
   DRL RESTOR).
   **/
	goto restor_continue (gtss_ext_$stack_level_);
right_here: ;

/**	We are now here in gtss_run_subsystem_ (obviously) BUT
   back in the invocation indicated above (i.e., back
   "some" Multics stack frames. This process is carried out
   to simulate GCOS TSS functioning when a DRL RESTOR is
   processed.
   **/
	restore = "1"b;
	tral = fixed (arg_list1.tra);			/* Record transfer address. */
	go to continue;

restor_perm: entry (dummy, arg_list_ptrp, entry_pt);
dcl  dummy                    fixed bin (24) parm;
dcl  entry_pt                 fixed bin (18) parm;

/* 	Entry for provided for DRL RESTOR of a permfile. */

/* 	Save needed arguments in static variables. */
	entry_point = entry_pt;

/* 	Now return to the appropriate invocation of gtss_run_subsystem_ */
	goto restor_continue2 (gtss_ext_$stack_level_);
right_here2: ;
	ep = entry_point;

	if db_run_subsystem then
	     call ioa_ (
	     "gtss_run_subsystem_(^i,^b) ss_name=""^a"" gdb_name=""^a"""
	     , pdx
	     , restore
	     , gtss_prgdes_ext_$prgdes.ss_name (pdx)
	     , gtss_ext_$gdb_name
	     );
	go to ready_to_transfer;

continue:	;

	gseg, op = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	c = gtss_prgdes_ext_$prgdes.component (pdx);
	ip = gtss_ext_$fast_lib.comp_ptr (c);
	il = gtss_ext_$fast_lib.comp_wds (c);

	so = fixed (gtss_prgdes_ext_$prgdes.seek_address (pdx));
	ps = gtss_prgdes_ext_$prgdes.program_size (pdx);

/* Tempory fix for fortran memory limit problem ************************************************** */
	if ^restore then if current_ps ^= -1 then ps = current_ps;
	ls = gtss_prgdes_ext_$prgdes.load_size (pdx);
	ep = gtss_prgdes_ext_$prgdes.entry_point (pdx);
	la = gtss_prgdes_ext_$prgdes.initial_load_address (pdx);
	if restore then				/* Reset length of area preceeding code. */
	     if loc_use then la = fixed (loc);		/* Caller designating code location. */
	     else la = fixed (loc)+la;		/* Displace whole load unit. */
	call gtss_bcd_ascii_ (
	     addr (gtss_prgdes_ext_$prgdes.bci_catalog_name (pdx)), 6, addr (ln));

	if db_run_subsystem then do;
	     call ioa_ (
		"gtss_run_subsystem_(^i,^b) ss_name=""^a""^-ln=""^a"""
		, pdx
		, restore
		, gtss_prgdes_ext_$prgdes.ss_name (pdx)
		, ln
		);
	     call ioa_ (
		"op=^p^-ip=^p^-il=^i^-so=^i", op, ip, il, so);
	     call ioa_ (
		"la=^i^-ls=^i^-ps=^i^-ep=^i", la, ls, ps, ep);
	end;
	if gse_ext_$modes.ss then do;
	     on quit call gtss_fix_tty_modes_ ();
	     call ioa_ ("Subsystem ^a", gtss_prgdes_ext_$prgdes.ss_name (pdx));
	     revert quit;
	end;


	if ^restore then do;			/* Overlay load does not reset available memory length. */
						/**	Adjust length of segment to load length.	**/
	     call hcs_$set_max_length_seg (op, sys_info$max_seg_size, code); /* Reset to largest seg size. */
	     if code = 0 then
		call hcs_$truncate_seg (op, (ps), code);
	     if code = 0 then
		call hcs_$set_bc_seg (op, fixed (ps*36, 24, 0), code);
	     ll = (divide (ps-1, 1024, 24, 0)+1)*1024;	/* modulo 1024 word (See seg_max_length). */

/**	hcs_$set_max_length_seg duplication of using
   BAR mode to detect out of bounds on user's memory segment.
   if code = 0 then
   call hcs_$set_max_length_seg (op, (ll), code);
   **/
	     if code ^= 0 then do;
		call com_err_ (code, "gtss_run_subsystem_",
		     "Could not set length of object segment.");
		signal cond (gtss_fail);
	     end;
	end;

	fp = ip;					/* Pointer to object in library. */
	tp = op;					/* Pointer to segment to load object into. */
	if ^restore then do;			/* Overlay load does not zero this memory area. */
	     l = la;				/* Space required before the object. */
	     tp -> MA = "0"b;			/* Zero this space. */
	end;

	tp = addrel (tp, la);			/* Position after the space. */
	fp = addrel (fp, so);			/* Position to object in library. */
	l1 = il - so;				/* No. words remaining in this library component segment. */
	l2 = ls;					/* No. words in object to be moved. */
	do while (ls>0);
	     l = min (l1, l2);			/* No. words for this move. */
	     if l<1 then do;
		call com_err_ (0, "gtss_run_subsystem_",
		     "Bug: zero words moved from library.");
		signal cond (gtss_fail);
	     end;
	     tp -> MA = fp -> MA;			/* Move piece of object. */
	     ls = ls-l;
	     if ls>0 then do;			/* Object continues on next component. */
		c = c+1;				/* Index of next component. */
		if c>gtss_ext_$fast_lib.fast_lib_ncp then do;
		     call com_err_ (0, "gtss_run_subsystem_",
			"Bug: exceeded library components.");
		     signal cond (gtss_fail);
		end;
		fp = gtss_ext_$fast_lib.comp_ptr (c);
		il = gtss_ext_$fast_lib.comp_wds (c);
		so = 0;
		ls = ls - l;
		tp = addrel (tp, l);
	     end;
	end;

	if ^restore then do;

/**	Set UST.	**/
	     gtss_ust.lswap.size,
		gtss_ust.lsize.limit = ll_b18;	/* set up the ust value */
	     gtss_ust.lsize.bar = divide (ll+511, 512, 17, 0); /* BAR limit in 512 word blocks. */

/**
   initialize the slave prefix
   lhole.high is set to the exact program size specified by the subsystem
   being initially loaded.
   lhole.total is set to the highest addressable location after the program size
   has been rounded up mod 1024.
   **/
	     gtss_spa.lhole.high = ps;
	     gtss_spa.lhole.total = ll-1;
	     gtss_spa.lwrap.b23 = "0"b;		/* Clear T.ERR flag. */

/**	Set a timer manager to limit the subsystem to run
   no more than gtss_inst  seconds (parm 2
   "11"b => relative seconds). If the time runs out
   call gtss_fault_processor_$timer_runout.
   **/


/**
   Set up label variable in external static so that when the GCOS
   program terminates, the handler can return to this procedure
   and revert the stack properly.
   **/
	     gtss_ext_$drl_rtrn (gtss_ext_$stack_level_) = end_activity;
	end;

	gtss_spa.lnam = gtss_prgdes_ext_$prgdes.bci_catalog_name (pdx);

/**
   Ready to transfer to tss segment. Call a program to set BAR and do
   a TSS to enter BAR mode. Pass as args the limit part of the BAR
   (number of 512 word blocks), and a pointer to the entry in the tss segment
   which is the location of the entry GECALL to get the subsytem going.
						   **/

	if restore then
	     if tral ^= 0 then ep = tral;

ready_to_transfer: ;


	if gse_ext_$modes.gdb then
	     call gcos_debug_$loadtime (
	     "-gtss"				/* memory segment name */
	     , (gtss_prgdes_ext_$prgdes.ss_name (pdx))
	     , ""
	     , la
	     );
	gtss_ext_$flags.drl_in_progress = "0"b;
	gtss_ext_$flags.dispose_of_drl_on_pi = "0"b;
	gtss_ext_$flags.unfinished_drl = "0"b;
	gtss_ext_$flags.popup_from_pi = "0"b;
	call gtss_set_slave_ ((gtss_ust.lsize.bar), addrel (op, ep));

/* Control will return to the top of the next page, via a nonlocal goto,
   when the subsystem gives up control, which it will do for any of the following reasons:

   1) DRL RETURN from the subsystem,
   2) DRL ABORT from the subsystem,
   3) fault in subsystem, of a type which causes an abort,
   4) error in one of the drl simulators, of a type which causes an abort.
   */
	call com_err_ (0, "gtss_run_subsystem_", "RETURNED FROM gtss_set_slave_ (BUG)");
	signal cond (gtss_fail);


/* Control comes here via a nonlocal goto, when the activity terminates */
finish:	entry;					/* Called by gtss_interp_prim_ */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

end_activity: ;
	call conclude_subsystem;
	return;

conclude_subsystem: proc;

/**	Perform functions at conclusion of execution fo
   current subsystem.
   **/


/**	Catch miss-setting of label variable. **/
	     gtss_ext_$drl_rtrn (gtss_ext_$stack_level_) = gtss_ext_$bad_drl_rtrn;
	     gtss_ust.lswth.b13 = gtss_spa.lwrap.b23;
	     return;
	end					/* conclude_subsystem */;

mem_size:	entry;

/* Reset current_ps, i.e., memory size. */
	call cu_$arg_ptr (1, ap, al, code);
	if code ^= 0 then do;
bad_mem_size:  ;
	     call com_err_ (code,
		"gtss_run_subsystem_$mem_size",
		"Argument is memory size (decimal integer optionally followed by k), or ""?"", or ""default"".");
	     return;
	end;
	if arg = "default" then current_ps = -1;	/* Use library value. */
	else
	if arg ^= "?" then do;			/* Obtain caller's value. */
	     if (al>1) & ((argk.K = "K") | (argk.K = "k")) then do; /* Memory size in K (1024). */
		if verify (Ksize, "0123456789")>0 then goto bad_mem_size;
		current_ps = fixed (Ksize)*1024;
	     end;
	     else do;				/* Memory size in decimal. */
		if verify (arg, "0123456789")>0 then goto bad_mem_size;
		current_ps = fixed (arg);
	     end;
	end;
	if current_ps = -1 then
	     call com_err_ (0, "gtss_run_subsystem_$mem_size",
	     "Current memory size is from library.");
	else
	call com_err_ (0, "gtss_run_subsystem_$mem_size",
	     "Current memory size is ^12o (^i.) ^12oK (^i.K)"
	     , current_ps, current_ps
	     , divide (current_ps, 1024, 24), divide (current_ps, 1024, 24)
	     );
	return;

dcl  current_ps               fixed bin (35) static int init (65536);						/* 65536 => 64K */
dcl  cu_$arg_ptr              entry options (variable);
dcl  ap                       ptr init(null());
dcl  al                       fixed bin;
dcl  arg                      char (al)unal based (ap);
dcl 1 argk unal based (ap),
    2 Ksize char (al-1)unal,
    2 K char (1)unal;

/**	Variables for gtss_run_subsystem_
     IDENTIFIER		ATTRIBUTES	**/
dcl gtss_fix_tty_modes_ entry ext;
dcl  any_other                condition ext;
dcl  arg_list_ptr             ptr static int;
dcl  c                        fixed bin (24);
dcl  code                     fixed bin (35);
dcl  debug                    entry;
dcl  ep                       fixed bin (24);
dcl  entry_point              fixed bin (18) static;
dcl  fp                       ptr init(null());
dcl  gcos_debug_$loadtime     entry (char (*), char (*), char (*), fixed bin (24));
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition ext;
dcl  hcs_$set_bc_seg          entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$set_max_length_seg  entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$truncate_seg        entry (ptr, fixed bin (24), fixed bin (35));
dcl  il                       fixed bin (24);
dcl  ioa_                     entry options (variable);
dcl  ip                       ptr init(null());
dcl  l                        fixed bin (24);
dcl  l1                       fixed bin (24);
dcl  l2                       fixed bin (24);
dcl  la                       fixed bin (24);
dcl  ll                       fixed bin (24);
dcl  ln                       char (6);
dcl  ls                       fixed bin (24);
dcl  MA                       (l)bit (36)aligned based;
dcl  op                       ptr init(null());
dcl  pdx                      fixed bin (24)static int;
dcl  ps                       fixed bin (24);
dcl  quit                     condition;
dcl  restore                  bit (1)init ("0"b);
dcl  restor_continue          (4)label static int;
dcl  restor_continue2         (4)label static int;
dcl  so                       fixed bin (24);
dcl  sys_info$max_seg_size    fixed bin (24)ext;
dcl  timer_manager_$cpu_call  entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call entry (entry);
dcl  tp                       ptr init(null());
dcl  tral                     fixed bin (24);

dcl 1 ll_overlay aligned based (addr (ll)),
    2 ll_fb18 bit (18)unal,
    2 ll_b18 bit (18)unal;

%include gtss_restor_arg_list1;

%include gtss_prgdes_;

%include gtss_ext_;

%include gtss_install_values_;

%include static_handlers;

%include gtss_ust_ext_;

%include gtss_spa;

%include gtss_entry_dcls;

%include gse_ext_;

%include gtss_db_names;
     end						/* gtss_run_subsystem_. */;



		    gtss_save_restore_data_.cds     12/11/84  1354.3rew 12/10/84  1044.5       26487


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_save_restore_data_:proc;

/* Generate object for "gtss_save_restore_data_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_save_restore_data_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_save_restore_data_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_save_restore_data_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_save_restore_data_";

	cds_args_ptr -> cds_args.seg_name = "gtss_save_restore_data_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_save_restore_data_");
	   else 
	      call com_err_( 0,"gtss_save_restore_data_","Object for gtss_save_restore_data_ created [^i words].",size(gtss_save_restore_data_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_save_restore_data_.incl.pl1 **/

dcl 1 gtss_save_restore_data_ aligned,
      2 IO like gtss_save_restore_data_$IO;

%include gtss_save_restore_data_;
%page;
%include cds_args;
end;
 



		    gtss_set_db_.pl1                12/11/84  1354.3rew 12/10/84  1044.5       34047


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

gtss_set_db_: proc;

/** Regulate and display debugging switches.

    Author: Dave Ward	08/15/79
    Change: Dave Ward	12/04/80 added switch for kin.
*/

	sub_entry = "0"b;
dcl  sub_entry                bit(1);
	goto cont;
arg_ptr:	entry (db, pa);

/* Subroutine entry. */
dcl  db                       (72)bit(1)parm;
dcl  pa                       ptr parm;
	sub_entry = "1"b;

cont:	;

	do i = 1 by 1;
	     if sub_entry then
		call cu_$arg_ptr_rel (i, ap, al, code, pa);
	     else
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then do;			/* Arguments concluded. */
		if i = 1 then
		     call com_err_ (code, "gtss",
		     "^/<arg> ... Where <arg> is -print | name | ^name");
		string (gtss_ext_$db) = string (db_bits);
		if sub_entry then string (db) = string (db_bits);
		return;
	     end;

	     if cmd_arg = "-print" then do;		/* Display settings. */
		do j = 1 to hbound (name, 1);
		     call ioa_ (
			"^3i. ^3a gtss_^a_"
			, j
			, off_on (fixed (db_bits (value (j)), 17))
			, name (j)
			);
		end;
	     end;
	     else do;				/* Switch to set. */
		if substr (cmd_arg, 1, 1) = "^" then do; /* OFF. */
		     dbs = "0"b;
		     fc = 2;
		end;
		else do;				/* ON. */
		     dbs = "1"b;
		     fc = 1;
		end;

		call set_db (dbs, substr (cmd_arg, fc));
	     end;
	end;

set_db:	proc (b, n);

/* Set db bit named by (n) to value (b). */
dcl  b                        bit(1)parm;
dcl  n                        char(*)parm;
	     l = length (n);
	     if substr (n, l, 1) = "_" then l = l-1;	/* Remove right underline. */
	     f = 1;
	     if l>length ("gtss_") then
		if substr (n, 1, length ("gtss_")) = "gtss_" then
		     f = length ("gtss_")+1;
	     fst = 1;
	     lst = hbound (name, 1);
	     do while (fst <= lst);
		mid = divide (fst+lst, 2, 17);
		if substr (n, f, l-f+1) = name (mid) then do; /* Found. */
		     db_bits (value (mid)) = b;
		     return;
		end;
		if substr (n, f, l-f+1)<name (mid) then lst = mid-1;
		else fst = mid+1;
	     end;

	     call com_err_ (0, "gtss",
		"""^a"" unknown debug switch name (-print provides names).",
		n);
	     return;

dcl  f                        fixed bin;
dcl  fst                      fixed bin;
dcl  l                        fixed bin;
dcl  lst                      fixed bin;
dcl  mid                      fixed bin;
	end					/* set_db */;

/* Variables for gtss_set_db_:
   IDENTIFIER		ATTRIBUTES	*/
dcl  al                       fixed bin (24);
dcl  ap                       ptr;
dcl  cmd_arg                  char (al)based (ap)unal;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  cu_$arg_ptr              entry (fixed bin (24), ptr, fixed bin (24), fixed bin (35));
dcl  cu_$arg_ptr_rel          entry (fixed bin (24), ptr, fixed bin (24), fixed bin (35),ptr);
dcl  dbs                      bit (1);
dcl  db_bits                  (72)bit (1)static int init ((72) (1)"0"b);
dcl  fc                       fixed bin (24);
dcl  hbound                   builtin;
dcl  i                        fixed bin(24);
dcl  ioa_                     entry options(variable);
dcl  j                        fixed bin(24);
dcl  off_on                   (0:1)char (3)static int options (constant) init ("off", "on");

%include gtss_ext_;

%include gtss_db_names;
     end						/* gtss_set_db_ */;
 



		    gtss_set_slave_.alm             11/05/86  1604.5r w 11/04/86  1038.9       23958


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

	name	gtss_set_slave_
	entry	gtss_set_slave_
	entry	load_bar
"
"	gtss routine to provide for setting  the BAR
"	and transferring to GCOS code in a simulated
"	memory segment.
"
"	dcl gtss_set_slave_ entry(fixed bin aligned,ptr,bit(1)aligned);
"	Arg 1	base address register value.
"	Arg 2	pointer to code to transfer to.
"
"	The base address register is loaded with the value passed in arg 1
"	and a TSS instruction is executed to cause control to go to the
"	tss slave program in BAR mode.
"
"	There is an additional entry to this program called load_bar. This
"	entry is called to load the bar and then return.
"
"
"	(gcos_set_slave contributors:)
"	WRITTEN BY DICK SNYDER, JANUARY 31, 1973 for the 6180
"	MODIFIED BY T. CASEY, MAY 1974  TO ADD no_bar ENTRY
"	MODIFIED BY D. KAYDEN DECEMBER 1974, JUNE 1975
"	Modified by M. R. Jordan, August 1977
"
"	(gtss contributors:)
"	Modified by D. B. Wardd, June 23, 1978
"	Modified by A. Kepner, August 29, 1978
"
	temp	temp
"
	include	stack_header
"
	include	stack_frame
"
gtss_set_slave_:
	push
	sprisp	sb|stack_header.bar_mode_sp save sp so signaller can reset
"				 it in case tss uses adr6
	lda	ap|2,*		get the BAR setting
	als	18		position it
	sta	temp
	lbar	temp		set the BAR
	eppbp	ap|4,*		get the ptr
	eppbp	bp|0,*		..

	stz	sp|stack_frame.entry_ptr  make stack traces look nice
	stz	sp|stack_frame.entry_ptr+1
"	In order to cause machine registers
"	to be loaded from the safe-store
"	region in the user's slave prefix
"	the following code wequence will
"	be set up and executed starting
"	at location 26 (decimal) in the
"	user's slave prefix.
"26	lreg	32	load index regs, a, q, etc.
"27	lareg	40	load addres registers
"28	tra	(to first executable instruction)
	epbpbb	bp|0	bb points to beginning of slave prefix
	ldaq	lreg	move lreg and lareg inst. to slave prefix
	staq	bb|26
	epaq	bp|0	isolate transfer address in q upper
	anq	-1,du
	orq	tra	build transfer instruction
	stq	bb|28	and move to prefix
	tss	bb|26	set BAR mode and start slave execution with
"			the 3 instructions provided.


load_bar:
	push
	lda	ap|2,*		get the BAR setting
	als	18		position it
	sta	temp
	lbar	temp		set the BAR
	return		that's it

	eight
lreg:	lreg	32
	lareg	40
tra:	tra	0
	end
  



		    gtss_starCF_.cds                12/11/84  1354.3rew 12/10/84  1044.6       25038


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_starCF_:proc;

/* Generate object for "gtss_starCF_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_starCF_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_starCF_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_starCF_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_starCF_";

	cds_args_ptr -> cds_args.seg_name = "gtss_starCF_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_starCF_");
	   else 
	      call com_err_( 0,"gtss_starCF_","Object for gtss_starCF_ created [^i words].",size(gtss_starCF_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_starCF_.incl.pl1 **/

dcl 1 gtss_starCF_ aligned,
      2 FILE like gtss_starCF_$FILE;

%include gtss_starCF_;
%page;
%include cds_args;
end;
  



		    gtss_tapstar_.cds               12/11/84  1354.3rew 12/10/84  1044.6       25164


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_tapstar_:proc;

/* Generate object for "gtss_tapstar_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_tapstar_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_tapstar_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_tapstar_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_tapstar_";

	cds_args_ptr -> cds_args.seg_name = "gtss_tapstar_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_tapstar_");
	   else 
	      call com_err_( 0,"gtss_tapstar_","Object for gtss_tapstar_ created [^i words].",size(gtss_tapstar_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_tapstar_.incl.pl1 **/

dcl 1 gtss_tapstar_ aligned,
     2 FILE like gtss_tapstar_$FILE;

%include gtss_tapstar_;
%page;
%include cds_args;
end;



		    gtss_tfa_ext_.cds               12/11/84  1354.3rew 12/10/84  1044.6       25371


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_tfa_ext_:proc;

/* Generate object for "gtss_tfa_ext_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_tfa_ext_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_tfa_ext_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_tfa_ext_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_tfa_ext_";

	cds_args_ptr -> cds_args.seg_name = "gtss_tfa_ext_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_tfa_ext_");
	   else 
	      call com_err_( 0,"gtss_tfa_ext_","Object for gtss_tfa_ext_ created [^i words].",size(gtss_tfa_ext_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_tfa_ext_.incl.pl1 **/

dcl 1 gtss_tfa_ext_ aligned,
      2 file_attributes like gtss_tfa_ext_$file_attributes;

%include gtss_tfa_ext_;
%page;
%include cds_args;
end;
 



		    gtss_update_safe_store_.alm     12/11/84  1354.3rew 12/10/84  1044.7       13878


"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

          name      gtss_update_safe_store_
          entry     gtss_update_safe_store_

gtss_update_safe_store_:
          eppbp     ap|2,*              " bp -> machine conditions
          eppbp     bp|0,*

          lda       gtss_ext_$stack_level_        " bb -> current "core" image
          als       1
          eppbb     gtss_ext_$gtss_slave_area_seg
          eppbb     bb|-2,al*

          mlr       (pr),(pr)           " move x0:7, a, q, e, t
          desc9a    bp|mc.regs,8*4
          desc9a    bb|lostr,8*4

          set       x,0                 " init offset for register conversion
          dup       8                   " for all 8 pointers in mc
          epp0      bp|mc.prs+x+x,*     " get pointer value
          sar0      bb|leisa+x          " save it in ar form
          set       x,x+1               " bump offset for next pointer
          dupend

          short_return

          equ       lostr,32            " subsystem offset of register storage
          equ       leisa,40            " subsystem offset of eis reg. storage

          include   mc
          end
  



		    gtss_ust_ext_.cds               12/11/84  1354.3rew 12/10/84  1044.7       25155


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
gtss_ust_ext_:proc;

/* Generate object for "gtss_ust_ext_" data.

   Author:    Dave Ward 1981
   Modified:  Ron Barstad  83-07-21  Remove dependency on ted_com, add include file
 */
/** Initialize cds_args **/

	cds_args_ptr=addr(space_for_cds_args);
	unspec(space_for_cds_args)="0"b;

/** Reference structure input to cds to assure it is in runtime table. **/

	if addr(gtss_ust_ext_)=null() then ;

/** No text section **/
	cds_args_ptr -> cds_args.sections (1).p = null ();
	cds_args_ptr -> cds_args.sections (1).len = 0;
	cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT";

/** Static section **/
	cds_args_ptr -> cds_args.sections (2).p = addr (gtss_ust_ext_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_ust_ext_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_ust_ext_";

	cds_args_ptr -> cds_args.seg_name = "gtss_ust_ext_";	/* Entryname of object segment. */
	cds_args_ptr -> cds_args.num_exclude_names = 0;		/* All level 2 names are entry points. */
	cds_args_ptr -> cds_args.exclude_array_ptr = null ();
	cds_args_ptr -> cds_args.switches.defs_in_link = "0"b;	/* Definitions contiguous to text section. */
	cds_args_ptr -> cds_args.switches.separate_static = "0"b;	/* Static in linkage section (to bind). */
	cds_args_ptr -> cds_args.switches.have_text = "0"b;	/* No text section. */
	cds_args_ptr -> cds_args.switches.have_static = "1"b;	/* There is a static section. */
	cds_args_ptr -> cds_args.switches.pad = "0"b;		/* Must be zeroes (see create_data_segment_). */

	call create_data_segment_ (cds_args_ptr, code);
	if code ^= 0 
	   then 
	      call com_err_ (code, "cds_gtss_ust_ext_");
	   else 
	      call com_err_( 0,"gtss_ust_ext_","Object for gtss_ust_ext_ created [^i words].",size(gtss_ust_ext_));

	return;
%page;
/** Data for cds **/
dcl  addr                     builtin;
dcl  cds_args_ptr             ptr init(null());
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  create_data_segment_     entry(ptr,fixed bin(35));
dcl  null                     builtin;
dcl  size                     builtin;
dcl  unspec                   builtin;
dcl  1 space_for_cds_args     aligned like cds_args;
%page;
/** This data structure must exactly match that of gtss_ust_ext_.incl.pl1 **/

dcl 1 gtss_ust_ext_ aligned,
      2 ust like gtss_ust_ext_$ust;

%include gtss_ust_ext_;
%page;
%include cds_args;
end;
 



		    gtss_write_starCFP_.pl1         12/11/84  1354.3rew 12/10/84  1044.8       60786


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */

gtss_write_starCFP_: proc (up, bp, rl, ec);

/**       Author:   Dave Ward 03/20/79
          Change:   Al Dupuis 12/04/79 Rewritten to make use of cout term codes
	Change:   Al Dupuis 12/14/79 Added write_deferred subroutine.
**/

	call gtss_aft_$find ("*CFP", fn, code);
	if code = 0 & normal_output
	then do;
	     call write_now;
	     return;
	end;
	call write_deferred;
	if normal_output
	then do;
		/** write logon banner first **/
	     bp = l_info.l_ptr (l_info.no_lines);
	     rl = l_info.l_len (l_info.no_lines);
	     call write_now;
	     do loop_cntr = 1 to l_info.no_lines - 1;
		bp = l_info.l_ptr (loop_cntr);
		rl = l_info.l_len (loop_cntr);
		call write_now;
		if ec ^= 0
		then do;
		     call end_def_write;
		     return;
		end;
	     end;
	     call end_def_write;
	end;
	return;

write_now: proc;


	     ec = 0;
	     if rl = 0 then return;
	     n = gtss_ust.lcfio.sect_out;
	     if n < gtss_ust.lcfst.initial_sect_out
	     then do;
		err_mess = "Output sector no not > last input sector";
		gtss_ust.lcfst.start_term = 3;
		call common_error;
		return;
	     end;
	     gtss_starCF_$FILE.Seek_Address = n;
	     gtss_ust.lcfio.sect_out = n + 1;
	     if rl > length (RECORD.chars)
	     then do;
		err_mess = "Output line length too long.";
		gtss_ust.lcfst.start_term = 11;
		call common_error;
		return;
	     end;
	     RECORD.no_characters = rl;
	     substr (RECORD.chars, 1, rl) = bp -> rl_chars;
		 /** If first char is pad, make it CR so output won't be indented **/
	     if substr (RECORD.chars, 1, 1) = rubout_char
	     then substr (RECORD.chars, 1, 1) = CR;
write_loop:    ;
	     gtss_starCF_$FILE.OP2.Device_Command = write_cmd;
	     fn = gtss_starCF_$FILE.cf.aft_indx;
	     call gtss_ios_io_ (
		fn,
		addr (select_sequence),
		addr (select_sequence),
		fixed (rel (addr (gtss_starCF_$FILE.cf))),
		status,
		code);
	     if status = 1     /** EOF encountered **/
	     then do;
		call gtss_ios_change_size_ (fn, 5, "0"b, st2, code);
		if st2 = 0 | st2 = 2   /** 0=OK, 2=hit max size **/
		then do;
		     gtss_starCF_$FILE.Seek_Address = n;
		     goto write_loop;
		end;
		if code = error_table_$rqover
		then err_mess = "EXCEEDED AVAILABLE LLINKS ATTEMPTING TO GROW *CFP";
		gtss_ust.lcfst.start_term = 4;
		call common_error;
		return;
	     end;
	     if status ^= 0
	     then do;
		err_mess = "COMMAND FILE I/O ERROR";
		gtss_ust.lcfst.start_term = 2;
		call common_error;
		return;
	     end;
	     return;
	end;

write_deferred: proc;

	     ec = 0;
	     saved_code = code;
	     if normal_output
	     then do;
		call hcs_$make_seg ("", "", "", 10, l_info_ptr, code);
		if code = 0
		then call hcs_$make_seg ("", "", "", 10, l_ptr, code);
		if code ^= 0
		then do;
		     err_mess = "Couldn't do i/o for ..init";
		     call common_error;
		     call end_def_write;
		     return;
		end;
		normal_output = "0"b;
		l_info.no_chars = 1;
		l_info.no_lines = 0;
	     end;
	     l_info.no_lines = l_info.no_lines + 1;
	     l_info.l_ptr (l_info.no_lines) =
		addr (char_string (l_info.no_chars));
	     l_info.l_len (l_info.no_lines) = rl;
	     l_info.no_chars = l_info.no_chars + rl;
	     l_info.l_ptr (l_info.no_lines) -> line = bp -> line;
	     if saved_code = 0
	     then normal_output = "1"b;
	     return;
	end;

end_def_write: proc;


	     call delete_$ptr (l_info_ptr, "100100"b,
		"gtss_write_starCFP_", code);
	     l_info_ptr = null ();
	     call delete_$ptr (l_ptr, "100100"b,
		"gtss_write_starCFP_", code);
	     l_ptr = null ();
	     normal_output = "1"b;

	end;

common_error: proc;

	     ec = 1;
	     mc_ptr = gtss_find_cond_frame_ ("derail");
		 if mc_ptr = null ()     /** no gmap program to abort **/
	     then call gtss_CFP_abort_;
	     else do;
		if err_mess ^= ""
		then call gtss_abort_subsystem_ (
		     mc_ptr,
		     "gtss_write_starCFP_",
		     0,
		     err_mess);
		else call gtss_abort_subsystem_ (
		     mc_ptr,
		     "gtss_write_starCFP_", 0);
		return;
	     end;
	end;


/**  Variables for gtss_write_starCFP_
**/
dcl  bp                       ptr parm;  /** (input) callers buffer **/
dcl  char_string (l_info.no_chars) char (1) based (l_ptr);
dcl  code                     fixed bin (35);
dcl  cr                       bit (9) static int options (constant) init ("015"b3);
dcl  delete_$ptr              entry (pointer, bit (6), char (*), fixed bin (35));
dcl  ec                       fixed bin (35) parm;  /** (output) Multics error code **/
dcl  err_mess                 char (250) init ("");
dcl  error_table_$rqover	fixed bin (35) ext;
dcl  fn                       fixed bin (24);
dcl  hcs_$make_seg	          entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  line                     char (rl) based;
dcl  loop_cntr	          fixed bin (24);
dcl  l_info_ptr               ptr static internal init (null());
dcl  l_ptr                    ptr static internal init (null());
dcl  mc_ptr                   ptr init (null ());
dcl  n                        fixed bin (18) unsigned unal;
dcl  nl                       bit (9) static int options (constant) init ("012"b3);
dcl  normal_output            bit (1) static internal init ("1"b);
dcl  pad_char		bit (9) static int options (constant) init ("177"b3);
dcl  rl                       fixed bin (21) parm; /** (input) no of chars **/
dcl  rl_chars		char (rl) unal based;
dcl  rubout_char		char (1) based (addr (pad_char));
dcl  saved_code	          fixed bin (35);
dcl  status                   fixed bin(24);
dcl  st2			fixed bin (24);
dcl  CR                       char (1) based (addr (cr));
dcl  NL                       char (1) based (addr (nl));
dcl  up                       ptr parm;  /** (input) not used **/

dcl 1 l_info based (l_info_ptr),
      2 no_lines fixed bin (24),
      2 no_chars fixed bin (24),
      2 filler (l_info.no_lines),
        3 l_ptr ptr,
        3 l_len fixed bin (21);

%include gtss_starCF_;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_db_names;

%include gtss_device_cmds;
     end;

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