


		    PNOTICE_tss.alm                 12/11/84  1401.5r w 12/11/84  1401.5        2853


	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1GTEM0B0000"
	aci	"C2GTEM0B0000"
	aci	"C3GTEM0B0000"
	end
   



		    gcos_set_environment.pl1        12/11/84  1349.3rew 12/10/84  1042.4      204048


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

gcos_set_environment: gse: proc;

/* *	Set process environment for GCOS TIME-SHARING on Multics

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

	if gse_already_called then do;
	     call com_err_ (
		0
		, "gcos_set_environment"
		, "gse can not be recursively called.^/release or new_proc if not already in gse."
		);
	     return;
	end;
	on cleanup gse_already_called = "0"b;
	gse_already_called = "1"b;

/* First-time-only initialization. */

	if ^gse_initialized then do;
	     gse_ext_$drm_rule = 0;
	     addr (gse_ext_$modes) -> mode_overlay = default_modes;
	     gse_ext_$umc_name = "";
	     gse_ext_$smc_pathname = "";
	     gse_ext_$gcos_debug_pathname = "";
	     gse_initialized = "1"b;
	end;

/* *	Obtain list of arguments pointers and lengths. * */
	call cu_$arg_count (nargs);
	if nargs>hbound (arg_p, 1) then do;
	     call com_err_ (
		0
		, "gcos_set_environment"
		, "Only ^i arguments allowed. Quitting."
		, hbound (args
		, 1)
		);
	     gse_already_called = "0"b;
	     return;
	end;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, arg_p (i), arg_l (i), code);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gcos_set_environment"
		     , "Argument ^i. Quitting."
		     , i
		     );
		gse_already_called = "0"b;
		return;
	     end;
	end;
	call arguments;
	if ^argument_error then do;
	     on cleanup call record_static_changes;
	     call record_static_changes;
	end;
	if print then call print_environment_values;
	gse_already_called = "0"b;
	return;

dbpn:	entry (dpn);

/* Return pathname of debug file. */
dcl  dpn                      char(168)var parm;
	dpn = rtrim (gse_ext_$gcos_debug_pathname);
	return;

set_dbpn:	entry (new_dpn);

/* Reset pathname of debug file. */
dcl  new_dpn                  char(168)parm;
	gse_ext_$gcos_debug_pathname = new_dpn;
	return;

arguments: proc;

/* Initialization for processing arguments */
	     usage_flag, argument_error = "0"b;
	     drm_rule = 0;
	     gcos_debug_pathname = "";
	     expanded_table_name = "";
	     string (modes_given) = "0"b;
	     print = "0"b;
	     reset = "0"b;
	     smc_pathname = "";
	     umc_name = "";
	     internal_modes = mode_array;

	     if nargs <= 0 then do;
		usage_flag, argument_error = "1"b;
		call com_err_ (
		     error_table_$noarg
		     , "gcos_set_environment"
		     );
	     end;

	     do i = 1 to nargs;
		pp = arg_p (i);
		lp = arg_l (i);

/* Make sure we have a control argument. */
		if lp <= 0 then go to end_arg_case;
		if substr (option_arg, 1, 1) ^= "-" then do;
unrecognized_arg:	     ;
		     usage_flag, argument_error = "1"b;
		     call com_err_ (
			error_table_$bad_arg
			, "gcos_set_environment"
			, """^a"""
			, option_arg
			);
		     go to end_arg_case;
		end;
		j = min (length (arg), lp-1);
		arg = substr (option_arg, 2, j);

/* Perform a binary search for this control argument over the table T */
		f = 1;
		l = hbound (T, 1);
		do while (f <= l);
		     m = divide (f+l, 2, 24, 0);
		     if arg = T (m) then do;
			j = Transfer (m);
			go to arg_case (j);
		     end;
		     if arg < T (m) then l = m-1;
		     else f = m + 1;
		end;
		go to unrecognized_arg;

arg_case (1):	;				/* -directory_mapping */

		if drm_rule ^= 0 then do;
		     argument_error = "1"b;
		     call com_err_ (
			error_table_$inconsistent
			, "gcos_set_environment"
			, "^/The -directory_mapping control argument may not"
			||"^/occur more than once in the argument list."
			);
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;

		if i < nargs then do;
		     pp2 = arg_p (i+1);
		     lp2 = arg_l (i+1);
		     if lp2 <= 0 then go to missing_drm;
		     if substr (next_arg, 1, 1) = "-"
		     then go to missing_drm;
		     do j = 1 to hbound (drm_args, 1);
			if drm_args (j) = next_arg then do;
			     drm_rule = j;
			     i = i + 1;		/* move on to next argument */
			     go to end_arg_case;
			end;
		     end;
		     usage_flag, argument_error = "1"b;
		     call com_err_ (
			error_table_$bad_arg
			, "gcos_set_environment"
			, "^/The -directory_mapping control argument must be"
			||"^/followed by ""umc"", ""smc"", or ""wd""--not ""^a""."
			, next_arg
			);
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;
missing_drm:	;
		usage_flag, argument_error = "1"b;
		call com_err_ (
		     error_table_$noarg
		     , "gcos_set_environment"
		     , "^/The -directory_mapping control argument must be"
		     ||"^/followed by ""umc"",""smc"", or ""wd""."
		     );
		go to end_arg_case;

arg_case (2):	;				/* -gcos_debug_pathname */

		if gcos_debug_pathname ^= "" then do;
		     argument_error = "1"b;
		     call com_err_ (
			error_table_$inconsistent
			, "gcos_set_environment"
			, "The -gcos_debug_pathname control argument may not"
			||"^/occur more than once in the argument list."
			);
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;

		if i < nargs then do;
		     pp2 = arg_p (i+1);
		     lp2 = arg_l (i+1);
		     if lp2 <= 0 then go to default_gdbpn;
		     if substr (next_arg, 1, 1) = "-"
		     then go to default_gdbpn;
		     gcos_debug_pathname = next_arg;
		     if lp2 > 168 then do;
			argument_error = "1"b;
			call com_err_ (
			     error_table_$pathlong
			     , "gcos_set_environment"
			     , """^a"""
			     , next_arg
			     );
		     end;
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;

default_gdbpn:	;

/* Default gcos_debug control file is Person_id.gdb in user's home directory. */
		call default_debug_pathname;
		go to end_arg_case;

arg_case (3):	;				/* -modes */

		if i < nargs then do;
		     pp2 = arg_p (i+1);
		     lp2 = arg_l (i+1);
		     if lp2 <= 0 then go to modes_missing;
		     if substr (next_arg, 1, 1) = "-" then goto modes_missing;
		     j = 1;
		     remaining_modes = next_arg;
		     do while (j > 0);
			j = index (remaining_modes, ",");
			if j = 0 then this_mode = remaining_modes;
			else do;
			     this_mode = substr (remaining_modes, 1, j-1);
			     remaining_modes = substr (remaining_modes, j+1);
			end;
			if this_mode = ""
			then mode_name = "";
			else do;
			     mode_switch = (substr (this_mode, 1, 1) ^= "^");
			     if mode_switch
			     then mode_name = this_mode;
			     else mode_name = substr (this_mode, 2);
			end;
			do k = 1 to hbound (modes, 1);
			     if mode_name = modes (k) then do;
				if modes_given (k) then do;
				     argument_error = "1"b;
				     call com_err_ (
					error_table_$inconsistent
					, "gcos_set_environment"
					, "^/Mode ""^a"" is repeated in modes_string."
					, mode_name
					);
				end;
				else modes_given (k) = "1"b;
				internal_modes (k) = mode_switch;
				go to next_mode;
			     end;
			end;
			argument_error = "1"b;
			call com_err_ (
			     error_table_$bad_arg
			     , "gcos_set_environment"
			     , "^/Mode ""^a"" not recognized."
			     ||"^/Valid modes are: ast,drl,gdb,mcmd,mquit,ss."
			     , this_mode
			     );
next_mode:		;
		     end;
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;
modes_missing:	;
		usage_flag, argument_error = "1"b;
		call com_err_ (
		     error_table_$noarg
		     , "gcos_set_environment"
		     , "^/The -modes control argument must be followed by a modes_string."
		     ||"^/Valid modes are: ast,drl,gdb,mcmd,mquit,ss."
		     );
		go to end_arg_case;

arg_case (4):	;				/* -print */
		print = "1"b;
		go to end_arg_case;

arg_case (5):	;				/* -reset */
		reset = "1"b;
		go to end_arg_case;

arg_case (6):	;				/* -smc_pathname */

		if smc_pathname ^= "" then do;
		     argument_error = "1"b;
		     call com_err_ (
			error_table_$inconsistent
			, "gcos_set_environment"
			, "^/The -smc_pathname control argument may not occur"
			||"^/more than once in the argument list."
			);
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;
		if i < nargs then do;
		     pp2 = arg_p (i + 1);
		     lp2 = arg_l (i + 1);
		     if lp2 <= 0 then go to missing_spn;
		     if substr (next_arg, 1, 1) = "-"
		     then go to missing_spn;
		     smc_pathname = next_arg;
		     if lp2 > 168 then do;
			argument_error = "1"b;
			call com_err_ (
			     error_table_$pathlong
			     , "gcos_set_environment"
			     , """^a"""
			     , next_arg
			     );
		     end;
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;

missing_spn:	;
		usage_flag, argument_error = "1"b;
		call com_err_ (
		     error_table_$noarg
		     , "gcos_set_environment"
		     , "^/The -smc_pathname control argument must be"
		     ||"^/followed by the SMC directory name."
		     );
		go to end_arg_case;

arg_case (7):	;				/* -umc_name */

		if umc_name ^= "" then do;
		     argument_error = "1"b;
		     call com_err_ (
			error_table_$inconsistent
			, "gcos_set_environment"
			, "^/The -umc_name control argument may not"
			||"^/occur more than once in the argument list."
			);
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;
		if i < nargs then do;
		     pp2 = arg_p (i + 1);
		     lp2 = arg_l (i + 1);
		     if lp2 <= 0 then go to missing_unm;
		     if substr (next_arg, 1, 1) = "-"
		     then go to missing_unm;
		     umc_name = translate (next_arg,
			"abcdefghijklmnopqrstuvwxyz",
			"ABCDEFGHIJKLMNOPQRSTUVWXYZ");
		     if lp2 > 12 then do;
			argument_error = "1"b;
			call com_err_ (
			     error_table_$bigarg
			     , "gcos_set_environment"
			     , "^/The umc_name argument may not exceed 12 characters."
			     );
		     end;
		     i = i + 1;			/* move on to next argument */
		     go to end_arg_case;
		end;

missing_unm:	;
		usage_flag, argument_error = "1"b;
		call com_err_ (
		     error_table_$noarg
		     , "gcos_set_environment"
		     , "^/The -umc_name control argument must"
		     ||"^/be followed by the UMC name."
		     );
end_arg_case:	;
	     end;


/* Make sure all necessary control arguments have been given for the
   directory mapping_rule specified (if any).  Also check the user's access to the
   root directory implied by the mapping_rule. */
	     if argument_error then go to end_drm_case;
	     go to drm_case (drm_rule);

drm_case (0):  ;					/* no mapping rule */
	     go to end_drm_case;

drm_case (1):  ;					/* umc_dir_mode */
	     dir_name = ">udd>"||umc_name;
	     root_dir = ">udd>"||rtrim (umc_name)||">"||rtrim (umc_name);
	     if umc_name = "" then do;
		argument_error = "1"b;
		call com_err_ (
		     error_table_$inconsistent
		     , "gcos_set_environment"
		     , "^/When -directory_mapping umc is specified the"
		     ||"^/-umc_name control argument must also be given."
		     );
		go to end_drm_case;
	     end;

check_root:    ;

/* Validate the existence of and user's access to the root directory for
   umc_dir_mode or smc_dir_mode. */
	     entryname = umc_name;
	     call hcs_$get_user_effmode (dir_name, entryname, "", (get_ring_ ()), access_mode, code);

/* Make sure user has at least status access to root directory. */
	     if code = 0 & access_mode < 8
	     then code = error_table_$moderr;
	     if code ^= 0 then do;
		argument_error = "1"b;
		call com_err_ (
		     code
		     , "gcos_set_environment"
		     , "^/^a"
		     , root_dir
		     );
	     end;

	     go to end_drm_case;

drm_case (2):  ;					/* working_dir_mode */
	     go to end_drm_case;

drm_case (3):  ;					/* smc_dir_mode */
	     root_dir = rtrim (smc_pathname)||">"||rtrim (umc_name);
	     call absolute_pathname_ (smc_pathname, dir_name, code);
	     if code ^= 0 then do;
		argument_error = "1"b;
		call com_err_ (
		     code
		     , "gcos_set_environment"
		     , "^/^a"
		     , rtrim (smc_pathname)
		     );
		go to end_drm_case;
	     end;
	     if umc_name = "" | smc_pathname = "" then do;
		argument_error = "1"b;
		call com_err_ (
		     error_table_$inconsistent
		     , "gcos_set_environment"
		     , "^/When -directory_mapping smc is specified the"
		     ||"^/-smc_pathname and -umc_name control arguments"
		     ||"^/must be given."
		     );
		go to end_drm_case;
	     end;
	     go to check_root;
end_drm_case:  ;
	     if reset then do;
		if string (modes_given) then do;
		     argument_error = "1"b;
		     call com_err_ (
			error_table_$inconsistent
			, "gcos_set_environment"
			, "^/The -modes and -reset control arguments are mutually exclusive."
			);
		end;
		else string (internal_modes) = default_modes;
	     end;
	     if gcos_debug_pathname ^= "" |
	     (modes_given (3) & internal_modes (3))
	     then do;
		if gcos_debug_pathname = ""
		then if gse_ext_$gcos_debug_pathname = ""
		     then call default_debug_pathname;
		     else gcos_debug_pathname = gse_ext_$gcos_debug_pathname;
		call expand_pathname_$add_suffix (gcos_debug_pathname,
		     "gdb",
		     dir_name,
		     entryname,
		     code);
		if code ^= 0 then do;
		     argument_error = "1"b;
		     call com_err_ (
			code
			, "gcos_set_environment"
			, "^/^a"
			, rtrim (gcos_debug_pathname)
			);
		     go to end_debug_code;
		end;
		expanded_table_name = rtrim (dir_name)||">"||entryname;

/* Create the break table if it does not already exist. */
		call hcs_$make_seg (dir_name,
		     entryname,
		     "",
		     10,				/* rw access */
		     seg_ptr,
		     code);
		if code = 0
		then do;
		     call ioa_ ("gcos_set_environment:  Break table created.^/^a",
			rtrim (expanded_table_name));
		     call hcs_$truncate_seg (seg_ptr, 0, code);
		     if code ^= 0 then do;
			argument_error = "1"b;
			call com_err_ (
			     code
			     , "gcos_set_environment"
			     , "^/^a"
			     , rtrim (expanded_table_name)
			     );
			go to end_debug_code;
		     end;
		end;
		else if seg_ptr = null ()
		then do;
		     argument_error = "1"b;
		     call com_err_ (
			code
			, "gcos_set_environment"
			, "^/^a"
			, rtrim (expanded_table_name)
			);
		     go to end_debug_code;
		end;

/* Make sure user has read and write access to break table. */
		call hcs_$fs_get_mode (seg_ptr,
		     access_mode,
		     code);
		if code ^= 0 then do;
		     argument_error = "1"b;
		     call com_err_ (
			code
			, "gcos_set_environment"
			, "^/^a"
			, rtrim (expanded_table_name)
			);
		     go to end_debug_code;
		end;
		if ^ access_mode_overlay.read |
		^access_mode_overlay.write then do;
		     argument_error = "1"b;
		     call com_err_ (
			code
			, "gcos_set_environment"
			, "^/^a^/The user must have read and write access on the break table segment.",
			rtrim (expanded_table_name));
		end;
end_debug_code:	;
	     end;
	     if usage_flag then
		call ioa_$ioa_switch (
		iox_$error_output
		, "Usage: gcos_set_environment {-directory_mapping [umc|smc|wd]}"
		||"^/^5x{-gcos_debug_pathname path} {-modes modes_string} {-print} {-reset}"
		||"^/^5x{-smc_pathname path} {-umc_name name}"
		||"^2/At least 1 argument is required."
		);
	end					/* arguments */;

default_debug_pathname: proc;

/* Default gcos_debug control file is Person_id.gdb in user's home directory. */

dcl  p1                       char (22);
dcl  p2                       char (9);
	     call user_info_$whoami (p1, p2, "");
	     Person_id = rtrim (p1);
	     call user_info_$homedir (gcos_debug_pathname);
	     gcos_debug_pathname = rtrim (gcos_debug_pathname)||">"||Person_id||".gdb";
	end					/* default_debug_pathname */;

print_environment_values: proc;
	     do i = 1 to hbound (mode_array, 1);
		mode_name = modes (i);
		if mode_array (i)
		then this_mode = mode_name;
		else this_mode = "^"||mode_name;
		if i = 1 then remaining_modes = this_mode;
		else remaining_modes = remaining_modes||","||this_mode;
	     end;

	     call ioa_ (
		"^/Current GCOS environment values:"
		||"^/^5x-modes ^a"
		||"^/^5x-directory_mapping ^a"
		, remaining_modes
		, drm_args (gse_ext_$drm_rule)
		);
	     if gse_ext_$drm_rule = 3
	     then call ioa_ ("^5x-smc_pathname ^a", rtrim (gse_ext_$smc_pathname));
	     if gse_ext_$drm_rule = 1 | gse_ext_$drm_rule = 3
	     then call ioa_ ("^5x-umc_name ^a", rtrim (gse_ext_$umc_name));
	     if gse_ext_$gcos_debug_pathname ^= ""
	     then call ioa_ ("^5x-gcos_debug_pathname ^a", rtrim (gse_ext_$gcos_debug_pathname));
	end;					/* print_environment_values */

record_static_changes: proc;
	     if drm_rule ^= 0 then gse_ext_$drm_rule = drm_rule;
	     mode_array = internal_modes;
	     if umc_name ^= "" then gse_ext_$umc_name = umc_name;
	     else if umc_name = "" & drm_rule = 2 then gse_ext_$umc_name = "";
	     if smc_pathname ^= "" then gse_ext_$smc_pathname = smc_pathname;
	     if expanded_table_name ^= "" then gse_ext_$gcos_debug_pathname = expanded_table_name;
	     gse_already_called = "0"b;
	end;					/* record_static_changes */

/* *	Variables for gse: * */
dcl  absolute_pathname_       entry (char (*), char (*), fixed bin (35));
dcl  access_mode              fixed bin (5);
dcl  arg                      char (40);
dcl  argument_error           bit (1);
dcl  cleanup                  condition;
dcl  code                     fixed bin (35);
dcl  com_err_                 entry options (variable);
dcl  cu_$arg_count            ext entry (fixed bin (24));
dcl  cu_$arg_ptr              ext entry (fixed bin (24), pointer, fixed bin (24), fixed bin (35));
dcl  default_modes            bit (6) int static options (constant) init ("100000"b);						/* ast mode is on by default--others off */
dcl  dir_name                 char (168);
dcl  drm_args                 (0:3) char (7) int static options (constant) init ("not_set", "umc", "wd", "smc");
dcl  drm_rule                 fixed bin (24);
dcl  entryname                char (32);
dcl  error_table_$bad_arg     fixed bin (35) ext;
dcl  error_table_$bigarg      fixed bin (35) ext;
dcl  error_table_$inconsistent fixed bin (35) ext;
dcl  error_table_$mdc_no_access fixed bin (35) ext;
dcl  error_table_$moderr      fixed bin (35) ext;
dcl  error_table_$noarg       fixed bin (35) ext;
dcl  error_table_$pathlong    fixed bin (35) ext;
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  expanded_table_name      char (168);
dcl  f                        fixed bin (24);
dcl  gcos_debug_pathname      char (168);
dcl  get_ring_                entry returns (fixed bin (3));
dcl  gse_already_called       bit (1) static int init ("0"b);
dcl  gse_initialized          bit (1) static int init ("0"b);
dcl  hcs_$fs_get_mode         entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$get_user_effmode    entry (char (*), char (*), char (*), fixed bin,
     fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg            entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$truncate_seg        entry (ptr, fixed bin (18), fixed bin (35));
dcl  i                        fixed bin (24);
dcl  internal_modes           (6) bit (1) int unal automatic;
dcl  ioa_                     entry options (variable);
dcl  ioa_$ioa_switch          entry options (variable);
dcl  iox_$error_output        ext ptr;
dcl  j                        fixed bin (24);
dcl  k                        fixed bin (24);
dcl  l                        fixed bin (24);
dcl  lp                       fixed bin (24);
dcl  lp2                      fixed bin (24);
dcl  m                        fixed bin (24);
dcl  mode_array               (6) bit (1) unal based (addr (gse_ext_$modes));
dcl  mode_name                char (10) varying;
dcl  mode_overlay             bit (6) unal based (addr (gse_ext_$modes));
dcl  mode_switch              bit (1);
dcl  modes_given              (6) bit (1) unal;
dcl  nargs                    fixed bin (24);
dcl  next_arg                 char (lp2) based (pp2);
dcl  option_arg               char (lp) based (pp);
dcl  pp                       ptr;
dcl  pp2                      ptr;
dcl  print                    bit (1);
dcl  Person_id                char (22) varying;
dcl  remaining_modes          char (60) varying;
dcl  reset                    bit (1);
dcl  root_dir                 char (168) varying;
dcl  seg_ptr                  ptr;
dcl  smc_pathname             char (168);
dcl  this_mode                char (11) varying;
dcl  umc_name                 char (12) int automatic;
dcl  usage_flag               bit (1);
dcl  user_info_$homedir       entry (char (*));
dcl  user_info_$whoami        entry (char (*), char (*), char (*));

dcl 1 access_mode_overlay aligned based (addr (access_mode)),
    2 fill bit (32) unal,
    2 read bit (1) unal,
    2 execute bit (1) unal,
    2 write bit (1) unal,
    2 fill2 bit (1) unal;

dcl  modes                    (6) char (10) varying int static options (constant)
     init ("ast", "drl", "gdb", "mcmd", "mquit", "ss");

dcl  T                        (13) char (20) int static options (constant) init (	/* This list must be ordered by the ascii collating seq. */
						/* The ordering is needed for binary search. */
     "directory_mapping",				/* arg_case 1 */
     "drm",					/* arg_case 1 */
     "gcos_debug_pathname",				/* arg_case 2 */
     "gdbpn",					/* arg_case 2 */
     "modes",					/* arg_case 3 */
     "pr",					/* arg_case 4 */
     "print",					/* arg_case 4 */
     "reset",					/* arg_case 5 */
     "rs",					/* arg_case 5 */
     "smc_pathname",				/* arg_case 6 */
     "spn",					/* arg_case 6 */
     "umc_name",					/* arg_case 7 */
     "unm")					/* arg_case 7 */
     ;

dcl  Transfer                 (13) fixed bin (24) int static options (constant) init (
     1,						/* -directory_mapping */
     1,						/* -drm */
     2,						/* -gcos_debug_pathname */
     2,						/* -gdbpn */
     3,						/* -modes */
     4,						/* -pr */
     4,						/* -print */
     5,						/* -reset */
     5,						/* -rs */
     6,						/* -smc_pathname */
     6,						/* -spn */
     7,						/* -umc_name */
     7)						/* -unm */
     ;

dcl 1 args (300),
    2 arg_p ptr,
    2 arg_l fixed bin (24);

%include gse_ext_;
     end						/* gse */;



		    gcos_tss.pl1                    08/04/87  1725.3r   08/04/87  1541.5      333954


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


gcos_tss: gtss: proc;

/**	GCOS TIME-SHARING on Multics

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 db entry.
   Change:  Dave Ward	03/20/79 get_line init.
   Change:  Mel Wilson	03/26/79 set ust CARD permission and urgency.
   Change:  Dave Ward	03/28/79 db switches by name.
   Change:  Al Kepner	03/30/79 to allow gtss to be called under file outpuut.
   Change:  Al Dupuis         06/01/79 to init bits used for command file processing.
   Change:  Dave Ward	06/28/79 Set gcos terminal type.
   Change:  Dave Ward	07/28/79 Set mcfc structure pointers.
   Change:  Bob Alvarado	08/01/79 added ll190 to output modes.
   Change:  Al Dupuis	08/02/79 added drun entry.
   Change:  Dave Ward	08/12/79 mcfc entry.
   Change:  Al Dupuis	08/20/79 added call to timer_manager and gtss_abs_$cpu_runout, so that
			         when gtss$drun is called, it sets an execution time limit.
   Change:  Paul Benjamin	09/21/79 removed setting gtss_ust.lflg2.b6 from initialize
   Change:  Al Dupuis	09/25/79 moved timer_manager_ stuff to gtss_drun_,
			         added call to gtss_drun_ from init
			         and term, and begin block for finish.
   Change:  Paul Benjamin     10/03/79 inhibit quits when logging out
   Change:  Dave Ward	11/06/79 cleanup freeing of work space repositioned.
   Change:  Al Dupuis	11/10/79 initialize gtss_ext_$drun_jid, set gtss_ext_$process_type.
   Change:  Dave Ward	12/18/79 prevent clean_up from getting in loop.
   Change:  Al Dupuis         01/15/80 site-settable drun_start_time.
   Change:  Scott C. Akers    08/14/81 Reset tty_modes on QUITs.
   Change:  Scott C. Akers	11/24/81 Prevent looping on uninitialiazed AFT.
   Change:  Scott C. Akers	01/05/82 Don't require GSE before GTSS. Use defaults instead.
   Change:  Ron Barstad  3.0  82-08-11 Change 4J to 4JS3
   Change:  Ron Barstad  3.1  83-02-22 Delete call to cu_$cp for GSE, defaults set in gse_ext_
   Change:  Ron Barstad  3.2  83-03-31 Added function code 8 to drl T.CFIO
   Change:  Ron Barstad  3.3  83-06-29 Brought drls PASUST and T.CMVO to 4js3
                                       Fix drm rule init to zero by gse
   **/

	if gtss_already_called then do;
	     call com_err_ (			/* gtss called recursively. */
		0
		, "gtss("||gtss_constants$version||")"
		, "gtss can not be recursively called.^/release or new_proc if not already in gtss.");
	     return;
	end;

/**       Set default directory mapping. **/
	if gse_ext_$drm_rule = 0 then gse_ext_$drm_rule = 2; /* make it wd */

/**	Obtain list of arguments pointers and lengths. **/
	call cu_$arg_count (nargs);
	if nargs > 0 then do;
	     call com_err_ (			/* gtss called with arguments, none allowed. */
		error_table_$arg_ignored
		, "gtss("||gtss_constants$version||")"
		, "^/Use gcos_set_environment command to set parameters for gtss.");
	     return;
	end;
start:	;
	unspec (gtss_ext_$flags) = "0"b;

	gtss_already_called = "1"b;

/**	Set on blocks (except any_other).		**/
	on cleanup call clean_up;
	on cond (gtss_fail) begin;
	     call com_err_ (
		0
		, "gtss("||gtss_constants$version||")"
		, "Cannot continue. Quitting."
		);
	     goto termination;
	end;
	on cond (command_error) begin;
	     if gtss_ext_$put_chars = gtss_CFP_output_
	     then call gtss_com_err_;
	end;
	on cond (finish) begin;
	     if execute_drun ^= 0 then do;
						/* Determine if drun termination was complete */
		call hcs_$initiate_count (gtss_ext_$homedir,
		     "drun_restart." || gtss_ext_$drun_jid, "",
		     bit_count, 1, gtss_ext_$restart_seg_ptr, code);
		if gtss_ext_$restart_seg_ptr ^= null () then do;
		     call delete_$ptr (gtss_ext_$restart_seg_ptr, code);
		     call com_err_ (
			0
			, "gtss$drun"
			, "When simulator termination took place the catalog entry was marked as still executing");
		end;
	     end;
	end;

	if initialize () then do;
	     AFT_INITIALIZED = "1"b;

	     if db_drl_kin then
		if gtss_dump_kin_$init () then goto abort;

	     if gse_ext_$modes.gdb then do;
		call gcos_debug_$initial (code);
		gse_ext_$modes.gdb = (code = 0);
	     end;
	     on any_other call gtss_fault_processor_;
	     call ioa_ ("GTSS 4JS3 (^a)", gtss_constants$version);

/**	Process GCOS TSS input		**/
	     call gtss_interp_prim_;
termination:   ;

	     if db_drl_kin then call gtss_dump_kin_$fin;
	end;
abort:	;
	on quit call gtss_fix_tty_modes_;		/* Don't let him screw anything up now.
						   Just fix the tty modes and keep going. */
	call clean_up;
	return;

unset_drl_rtrn: ;
	call com_err_ (
	     0
	     , "gtss("||gtss_constants$version||")"
	     , "goto gtss_ext_$drl_rtrn(^i) or gtss_ext_$restart_from_pi or gtss_ext_$popup_from_pi" ||
	     "^/or gtss_ext_$dispose_of_drl returned to gtss unset_drl_rtrn.",
	     gtss_ext_$stack_level_);
	signal cond (gtss_fail);
	return;
%page;
get_mem:	entry (sap, slp)returns (bit (1));

/**	Entry to provide pointers to slave area pointers and
   the stack level index (used by gcos_debug).
   **/
dcl  sap                      ptr parm;
dcl  slp                      ptr parm;
	sap = addr (gtss_ext_$gtss_slave_area_seg);
	slp = addr (gtss_ext_$stack_level_);
	return ("0"b);				/* Successful. */
%page;
db:	entry;

/**	Regulate and display debug switch bits. **/
dcl  args_ptr                 ptr;
dcl  cu_$arg_list_ptr         entry(ptr);
	call cu_$arg_list_ptr (args_ptr);
	call gtss_set_db_$arg_ptr (db_bits, args_ptr);
	return;
dcl  gtss_set_db_$arg_ptr     entry((72)bit(1),ptr);
%page;
init:	entry;
	if initialize () then ;
	return;
%page;
mcfc:	entry;

/* Perform various mcfc functions:
   -wait n	Set wait time to n seconds.
*/
	call cu_$arg_count (nargs);
	if (nargs<1)| (nargs>5) then do;
	     call com_err_ (0, "gtss$mcfc",
		"Allowable args: -wait n, -print.");
	     return;
	end;
dcl  need_n                   bit(1);
	need_n = "0"b;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gtss$mcfc", "Arg ^i.", i);
		return;
	     end;
	     if need_n then do;
		need_n = "0"b;
		if verify (cmd_arg, "0123456789")>0 then
		     call com_err_ (0, "gtss$mcfc",
		     "Arg ^i, ""^a"", not integer number of seconds.", i, cmd_arg);
		else
		gtss_ext_$mcfc.wait_time = fixed (cmd_arg, 24);
	     end;
	     else
	     if cmd_arg = "-wait" then need_n = "1"b;
	     else
	     if cmd_arg = "-print" then do;
		call com_err_ (0, "gtss$mcfc",
		     "mcfc wait seconds ^i", gtss_ext_$mcfc.wait_time);
	     end;
	     else
	     call com_err_ (0, "gtsmcfc",
		"Arg ^i, ""^a"", not from -wait n or -print.", i, cmd_arg);
	end;
	if need_n then
	     call com_err_ (0, "gtss$mcfc", "-wait not followed by n, number of seconds.");
	return;
%page;
drun:	entry;

/** Check for one valid DRUN ID (nnnnD) **/

	call cu_$arg_count (nargs);
	if nargs ^= 1 then do;
	     call com_err_ (0, "gtss$drun",
		"Correct usage is gtss$drun drun_job_id");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, argl, code);
	if code ^= 0 then do;
	     call com_err_ (code, "gtss$drun");
	     return;
	end;

	if (argl ^= 5)
	| ((d1 < "0") | (d1 > "9"))
	| ((d2 < "0") | (d2 > "9"))
	| ((d3 < "0") | (d3 > "9"))
	| ((d4 < "0") | (d4 > "9"))
	| ^((d5 = "d") | (d5 = "D"))
	then do;
	     call com_err_ (0, "gtss$drun",
		"^a is not a valid drun job id", argument);
	     return;
	end;

/** Tell DRUN it's time to execute **/
	djid = argument;
	call gtss_ascii_bcd_ (arg_ptr, 5, addr (drun_job_id));
	execute_drun = 17;

	goto start;

%page;
clean_up:	proc;
						/**	gtss cleanup condition procedure.	**/

	     on cleanup goto fin_cleanup;

	     if db_drl_kin then call gtss_dump_kin_$clean;
	     if AFT_INITIALIZED
	     then if ((gtss_ust.lcjid ^= "0"b) | (drun_term_req))
		then call gtss_drun_ (error);		/* DRUN termination */
	     do i = 1 to hbound (temp_segment_ptr, 1);
		if temp_segment_ptr (i) ^= null () then do; /* Maximize segment length. */
		     call hcs_$set_max_length_seg (
			temp_segment_ptr (i)
			, sys_info$max_seg_size
			, code);
		     if code ^= 0 then
			call com_err_ (code, "gtss$clean_up",
			"Could not maximize temp segment ^i (^p)",
			i, temp_segment_ptr (i));
		end;
	     end;


	     if gtss_ext_$sig_ptr ^= null () then do;	/* pointer was diddled */
		call sct_manager_$set (derail_sct_index, gtss_ext_$sig_ptr, code);
		if code ^= 0 then
		     call com_err_ (code, "gtss$clean_up", "Reseting static handler.");
		gtss_ext_$sig_ptr = null ();		/* reinitialize */
	     end;

/**	Close any files indicated open in AFT.	**/
	     on cleanup goto fin_close;
	     if AFT_INITIALIZED then
	     do i = 1 to hbound (aft_entry, 1);
		if aft_entry (i).used then do;
		     call gtss_ios_close_ (
			(i)
			, addr (fms_status)
			, code
			);
		     if fms_status.bit12 ^= "4000"b3 then
			call com_err_ (
			code
			, "gtss$clean_up"
			, "File (^i) ""^a"" won't close. Status=^w."
			, i
			, aft_entry (i).altname
			, fms_status
			);
		end;
fin_close:	;
	     end;
	     revert cleanup;

/**	Clear AFT table (of what can cause problems). **/
	     gtss_ext_$aft.start_list = 0;
	     gtss_ext_$aft.aft_entry.used = "0"b;
	     gtss_ext_$aft.free_space = 1;
	     gtss_ext_$aft.first_added, gtss_ext_$aft.last_added = 0;

	     if reattach then do;
		call iox_$modes (iox_$user_output, current_modes, old_modes, code);
		if code ^= 0 then
		     call com_err_ (code, "gtss$cleanup");
	     end;

	     call null_label (gtss_ext_$finished);
	     call null_label (gtss_ext_$bad_drl_rtrn);
	     do i = 1 to hbound (gtss_ext_$drl_rtrn, 1);
		call null_label (gtss_ext_$drl_rtrn (i));
	     end;

	     call release_temp_segments_ (
		"gtss("||gtss_constants$version||")"
		, temp_segment_ptr
		, code);
	     if code ^= 0 then call com_err_ (code, "gtss$clean_up", "Releasing temp segments.");
	     gtss_ext_$gtss_slave_area_seg = null ();
	     gtss_ext_$work_area_ptr = null ();

	     if gtss_ext_$fast_lib.fast_lib_fcb ^= null () then
		call msf_manager_$close (fast_lib_fcb); /* Free space allocated for msf control block. */
	     gtss_already_called = "0"b;

fin_cleanup:   ;
	     return;

dcl  code                     fixed bin (35)static int;
dcl  i                        fixed bin (24)static int;
dcl  status                   fixed bin (24)static int;
dcl 1 fms_status aligned,
      2 bit12 bit(12)unal,
      2 bit60 bit(60)unal;
	end clean_up ;
%page;
initialize: proc returns (bit (1));

/**	Return "1"b if successful, else "0"b.
   **/
	     call gtss_derail_processor_$set;

/**	Retain following assignments at top of
   initialization to assure clean_up handler
   can function.
   **/
	     gtss_ext_$gtss_slave_area_seg = null ();
	     gtss_ext_$work_area_ptr = null ();
	     temp_segment_ptr = null ();
	     gtss_ext_$fast_lib.fast_lib_fcb = null ();
	     gtss_ext_$sig_ptr = null ();
	     call gtss_ios_initialize_;
	     aft_entry.used = "0"b;
	     reattach = "1"b;

/**	End of sensitive assignments.	**/

/**	Set debugging switches OFF. */
	     string (gtss_ext_$db) = string (db_bits);

	     gtss_ext_$last_k_was_out = "0"b;		/* Last tty i/o not output. */
	     gtss_ext_$aem = 5;			/* Force additional error messages displayed. */

/**	Set label variables.	**/
	     gtss_ext_$finished = termination;
	     gtss_ext_$bad_drl_rtrn = unset_drl_rtrn;
	     gtss_ext_$drl_rtrn = unset_drl_rtrn;
	     gtss_ext_$popup_from_pi = unset_drl_rtrn;
	     gtss_ext_$restart_from_pi = unset_drl_rtrn;
	     gtss_ext_$dispose_of_drl = unset_drl_rtrn;

/* Initialize mcfc data base. */
	     call gtss_mcfc_init_ (rs);
dcl  rs                       char(5)var;
	     if rs = "false" then return ("0"b);

/**	Initialize statistics data.		**/
	     gtss_ext_$statistics.total_time = 0;
	     gtss_ext_$statistics.count = 0;
	     gtss_ext_$gdb_name = " ";
	     gtss_ext_$stack_level_ = 1;

/**	Establish library of objects
   for installed subsystems.
   **/
	     gtss_ext_$fast_lib.fast_lib_fcb = null ();
	     gtss_ext_$fast_lib.fast_lib_ncp = 0;	/* Number of components. */
	     gtss_ext_$fast_lib.comp_ptr = null ();
	     gtss_ext_$fast_lib.comp_wds = 0;
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$initialize",
		     "Can not obtain directory containing installed subsystem library.");
		return ("0"b);
	     end;
	     call msf_manager_$open (
		(installation_directory)
		, (gtss_install_values_$fast_msf)
		, gtss_ext_$fast_lib.fast_lib_fcb
		, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gtss$initialize",
		     "Can not obtain installed subsystem library ^a>^a.",
		     installation_directory, gtss_install_values_$fast_msf);
		return ("0"b);
	     end;

/**	Obtain component pointers. **/
	     do i = 0 by 1 while (code = 0);
		call msf_manager_$get_ptr (
		     gtss_ext_$fast_lib.fast_lib_fcb
		     , i
		     , use_existing_components
		     , gtss_ext_$fast_lib.comp_ptr (i)
		     , l
		     , code);
		if code = 0 then			/* Set component length. */
		     gtss_ext_$fast_lib.comp_wds (i) = divide (l, 36, 24, 0);
		else
		if code ^= error_table_$noentry then do;
		     call com_err_ (code, "gtss$initialize",
			"Failed attempting to get component ^i of library ^a>^a.",
			i, installation_directory, gtss_install_values_$fast_msf);
		     return ("0"b);
		end;
	     end;
	     if i<1 then do;
		call com_err_ (0, "gtss$initialize",
		     "No components for library ^a>^a.",
		     installation_directory, gtss_install_values_$fast_msf);
		return ("0"b);
	     end;
	     gtss_ext_$fast_lib.fast_lib_ncp = i-1;

/**	Initialize bits used in command file processing */
	     unspec (gtss_ext_$CFP_bits) = "0"b;
	     unspec (gtss_ext_$com_reg) = "0"b;		/* init communication region */
	          /** Set drun cpu limit and preferred start time in 64ths of milsec **/
	     gtss_ext_$com_reg.tsdpt = drun_cpu_limit;
	     gtss_ext_$com_reg.tsddt = drun_start_time;

/**	Initialize user status table.		**/
	     unspec (gtss_ust_ext_$ust) = "0"b;
	     call decode_clock_value_ (clock (), m, d, y, time, w, z);
	     time = divide (time, 1000, 71, 0) * 64;
	     gtss_ust.ltalc.tod = time53;		/* => time / 2**18. */
	     gtss_ust.lrtll.char_length = 81;
	     gtss_ust.lrtll.word_length = 21;
	     gtss_ust.lflg2.b24 = "0"b;		/* Auto blank indicator off. */
	     gtss_ust.lflg2.b25 = "0"b;		/* Auto mode off. */
	     gtss_ust.linno = 10;			/* Default auto[x] initial line number. */
	     gtss_ust.lincr = 10;			/* Default auto[x] line number increment. */
	     gtss_ust.lacpt.cardin,			/* Permission to use CARDIN, BPRINT, BPUNCH */
		gtss_ust.lacpt.lods,		/* Permission to use LODS */
		gtss_ust.lacpt.lodx = "1"b;		/* Permission to use LODX */
	     gtss_ust.lacpt.cardin_urgency = "00000000000101"b; /* default cardin urgency of 05 */

/* Initialize remote i/o buffer. */
	     gtss_ust.current_line_pointer = bit (fixed (fixed (rel (addr (gtss_ust.count_of_characters_transmitted)))
		- fixed (rel (addr (gtss_ust))), 18), 18);
	     gtss_ust.buffer_threshold_address = bit (fixed (
		fixed (rel (addr (gtss_ust.word_after_ust)))-
		fixed (rel (addr (gtss_ust))), 18), 18);
	     gtss_ust.number_words_transmitted, count_of_characters_transmitted = 1;
	     string (gtss_ust.characters_transmitted) = " ";
	     gtss_ust.characters_transmitted (1),
		gtss_ust.characters_transmitted (2),
		gtss_ust.characters_transmitted (3),
		gtss_ust.characters_transmitted (4) = CR; call gtss_ascii_bcd_ (addr (ascii_channel_id), 2, addr (gtss_ust.lbuf.station_id));
	     gtss_ust.lbuf.address = bit (fixed (fixed (rel (addr (gtss_ust.remote_io_buffer)))-
		fixed (rel (addr (gtss_ust))), 18), 18);
	     gtss_ust.lbuf.tally = "1"b;
	     gtss_ust.lcals.b18_35 = bit (fixed (
		fixed (rel (addr (gtss_ust.lcals)))-fixed (rel (addr (gtss_ust)))
		+2*hbound (gtss_ust.subsystems, 1), 18), 18);
	     gtss_ust.lcals.b0_17 = fixed (rel (addr (gtss_ust.lcals))) -
		fixed (rel (addr (gtss_ust)));
	     gtss_ust.lfile.program_stack, gtss_ust.lxxx.b0_17 =
		fixed (rel (addr (gtss_ust.lxxx)))- fixed (rel (addr (gtss_ust)));

	     call set_terminal_type (
		gtss_ust.lbuf.terminal_type
		, gtss_ust.lbuf.station_id
		);

	     call user_info_ (person_id, proj, acct);
	     gtss_ext_$user_id = rtrim (proj);
	     call user_info_$homedir (gtss_ext_$homedir);
	     call user_info_$process_type (gtss_ext_$process_type);

/* No longer used by mcfc.
   dcl user_info_$process_type entry(fixed bin);
   dcl pt fixed bin;
   call user_info_$process_type (pt);
   dcl amz (3)char(1)static int options(constant)init("a","m","z");
   gtss_ext_$multics_access_id = rtrim (person_id)||"."
   ||rtrim (proj)||"."
   ||amz (pt);
*/

	     if gse_ext_$drm_rule = 2 then do;		/* wd mapping rule */
						/* .LID in the UST will be set to the first
						   12 characters of the working_dir name. */
		call expand_pathname_ (get_wdir_ (), "", wd_name, code);
		if code ^= 0 then do;
		     call com_err_ (code, "gtss$initialize",
			"Failed attempting to get entry name portion of working_dir");
		     return ("0"b);
		end;
		call gtss_ascii_bcd_ (addr (wd_name), 12, addr (gtss_ust.lid));
	     end;
	     else do;				/* umc or smc mapping rule */
		call gtss_ascii_bcd_ (addr (gse_ext_$umc_name), 12, addr (gtss_ust.lid));
	     end;
/* Put local values in UST (set if gtss$drun called) */
	     if drun_job_id ^= "0"b then do;
		gtss_ust.lcjid = drun_job_id;
		call gtss_bcd_ascii_ (addr (drun_job_id), 5, addr (gtss_ext_$drun_jid));
	     end;
	     else gtss_ext_$drun_jid = " ";
	     gtss_ust.lcfst.start_term = execute_drun;
	     ascii_channel_id = substr (unique_chars_ ("0"b), 13, 2); /* get a substr(unique_chars_("0"b) set */


/**	Provide process directory work segments.	**/
	     call get_temp_segments_ (
		"gtss("||gtss_constants$version||")"
		, temp_segment_ptr
		, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gtss$initialize", "Could not obtain slave area segs. Quitting.");
		return ("0"b);
	     end;

/**	Assign to external variables. **/
	     gtss_ext_$gtss_slave_area_seg (1) = temp_segment_ptr (1);
	     gtss_ext_$gtss_slave_area_seg (2) = temp_segment_ptr (2);
	     gtss_ext_$gtss_slave_area_seg (3) = temp_segment_ptr (3);
	     gtss_ext_$gtss_slave_area_seg (4) = temp_segment_ptr (4);

/**	Provide empty based area for allocation.	**/
	     gtss_ext_$work_area_ptr = temp_segment_ptr (5);
	     work_area = empty ();

/**	Provide temp segment for deferred (FMS) catalog records.	**/
	     gtss_ext_$deferred_catalogs_ptr = temp_segment_ptr (6);

/**	Provide segment for multics acl area (hcs_).	**/
	     gtss_ext_$hcs_work_area_ptr = temp_segment_ptr (7);

/**	Obtain of caller's process directory.	**/
	     pd = get_pdir_ ();
	     gtss_ext_$pdir = rtrim (pd);

	     call gtss_aft_$initialize (code);
	     if code ^= 0 then do;
		call com_err_ (0, "gtss$initialize",
		     "Could not initialize aft.");
		return ("0"b);
	     end;

/* Set iox_$get_line as initial build mode input routine. */
	     gtss_ext_$get_line = iox_$get_line;

/* Set iox_$put_chars as initial terminal output routine. */
	     gtss_ext_$put_chars = iox_$put_chars;

/**	Open SY** file.	**/
dcl  arg_space                (size (arg))bit (36)aligned;
dcl  mc_space                 (size (mc))bit (36)aligned;

	     arg_ptr = addr (arg_space);
	     arg.ascii_file_name = "sy**";
	     arg.arg2.a = "64"b3;			/* MSU0400 (disk)?  */
	     arg.arg2.b = "0"b;			/* Use standare TSS temp file device. */
	     arg.arg2.c = "1"b;			/* Random. */
	     arg.arg2.d = "0001"b3;			/* 1 link. */

	     call gtss_drl_defil_$subr (
		arg_ptr
		, addr (dfsw)
		, addr (mc_space)
		);

dcl 1 dfsw aligned,
    2 sw1 fixed bin (24),
    2 sw2 fixed bin (24);

	     if dfsw.sw1 ^= 0 then do;
		call com_err_ (0, "gtss$initialize",
		     "Can not open SY**. DRL DEFIL status ^i.", sw1);
		return ("0"b);
	     end;
	     gtss_ext_$SYstarstar_file_no = arg_ptr -> fixed_bin24; /* Record AFT entry for SY** (it doesn't move). */

/**	Initialize SY** accumulator data base
   (used by gtss_build_).
   **/
	     unspec (gtss_SYstarstar_$FILE) = "0"b;
	     gtss_SYstarstar_$FILE.OP1.Device_Command = seek_cmd;
	     gtss_SYstarstar_$FILE.OP1.Count = "02"b3;	/* 2 => two operations, seek and write. */
	     gtss_SYstarstar_$FILE.OP2.Device_Command = write_cmd;
						/* Word offset to gtss_SYstarstar_$FILE.Seek_Word. */
	     gtss_SYstarstar_$FILE.ID1.DCW_list_loc = rel (addr (gtss_SYstarstar_$FILE.Seek_Word));
	     gtss_SYstarstar_$FILE.ID2.DCW_list_loc = rel (addr (gtss_SYstarstar_$FILE.DCW));
						/* Word offset to Seek_Address. */
	     gtss_SYstarstar_$FILE.Seek_loc = rel (addr (gtss_SYstarstar_$FILE.Seek_Address));
	     gtss_SYstarstar_$FILE.Status_loc = rel (addr (gtss_SYstarstar_$FILE.STATUS));
	     gtss_SYstarstar_$FILE.Seek_count = 1;	/* => 1 word of Seek_Address. */
	     gtss_SYstarstar_$FILE.DCW.word_count = "1200"b3; /* 1200 octal = 640 decimal (words). */
						/* Word offset to gtss_SYstarstar_$FILE.RECORD. */
	     gtss_SYstarstar_$FILE.DCW.memory_loc = rel (addr (gtss_SYstarstar_$FILE.RECORD));
	     gtss_SYstarstar_$FILE.SYss = "sy**";
	     gtss_SYstarstar_$FILE.ID1.fcb_loc
		, gtss_SYstarstar_$FILE.ID2.fcb_loc
		= rel (addr (gtss_SYstarstar_$FILE.SYss));

/** Initialize ios select sequence to provide
   for reading the command processing file.
   **/
	     unspec (gtss_starCF_$FILE) = "0"b;
						/* "0"b => cf stack is empty. */
	     gtss_starCF_$FILE.OP1.Device_Command = seek_cmd;
	     gtss_starCF_$FILE.OP1.Count = 2;		/* 2 => two operations (seek read) */
						/* Word offset to gtss_starCF_$FILE.Seek_Word. */
	     gtss_starCF_$FILE.ID1.DCW_list_loc = rel (addr (gtss_starCF_$FILE.Seek_Word));
	     gtss_starCF_$FILE.ID2.DCW_list_loc = rel (addr (gtss_starCF_$FILE.DCW));
						/* Word offset to Seek_Address. */
	     gtss_starCF_$FILE.Seek_loc = rel (addr (gtss_starCF_$FILE.Seek_Address));
	     gtss_starCF_$FILE.Status_loc = rel (addr (gtss_starCF_$FILE.STATUS));
	     gtss_starCF_$FILE.Seek_count = 1;		/* => 1 word of Seek_Address. */
	     gtss_starCF_$FILE.DCW.word_count = 64;
						/* Word offset to gtss_starCF_$FILE.RECORD. */
	     gtss_starCF_$FILE.DCW.memory_loc = rel (addr (gtss_starCF_$FILE.RECORD));
/** Initialize ios select sequence for reading #D **/
	     unspec (gtss_def_q_$FILE) = "0"b;
	     gtss_def_q_$FILE.OP1.Device_Command = seek_cmd;
	     gtss_def_q_$FILE.OP1.Count = 2;		/* 2 => two operations (seek read) */
						/* Word offset to gtss_def_q_$FILE.Seek_Word. */
	     gtss_def_q_$FILE.ID1.DCW_list_loc = rel (addr (gtss_def_q_$FILE.Seek_Word));
	     gtss_def_q_$FILE.ID2.DCW_list_loc = rel (addr (gtss_def_q_$FILE.DCW));
						/* Word offset to Seek_Address. */
	     gtss_def_q_$FILE.Seek_loc = rel (addr (gtss_def_q_$FILE.Seek_Address));
	     gtss_def_q_$FILE.Status_loc = rel (addr (gtss_def_q_$FILE.STATUS));
	     gtss_def_q_$FILE.Seek_count = 1;		/* => 1 word of Seek_Address. */
	     gtss_def_q_$FILE.DCW.word_count = 64;
						/* Word offset to gtss_def_q_$FILE.RECORD. */
	     gtss_def_q_$FILE.DCW.memory_loc = rel (addr (gtss_def_q_$FILE.RECORD));
	     gtss_def_q_$FILE.ID1.fcb_loc,
		gtss_def_q_$FILE.ID2.fcb_loc
		= rel (addr (gtss_def_q_$FILE.DQ));


/**	Initialize data base used for file IO by
   gtss_drl_drlsav_ and gtss_drl_restor_. **/

	     unspec (gtss_save_restore_data_$IO) = "0"b;
	     gtss_save_restore_data_$IO.OP1.Device_Command = seek_cmd;
	     gtss_save_restore_data_$IO.OP1.Count = "02"b3; /* 2 => two operations. */
	     gtss_save_restore_data_$IO.OP2.Device_Command = write_cmd;
						/* Word offset to gtss_save_restore_data_$IO.Seek_Word. */
	     gtss_save_restore_data_$IO.ID1.DCW_list_loc = rel (addr (gtss_save_restore_data_$IO.Seek_Word));
	     gtss_save_restore_data_$IO.ID2.DCW_list_loc = rel (addr (gtss_save_restore_data_$IO.DCW));
						/* Word offset to Seek_Address. */
	     gtss_save_restore_data_$IO.Seek_loc = rel (addr (gtss_save_restore_data_$IO.Seek_Address));
	     gtss_save_restore_data_$IO.Status_loc = rel (addr (gtss_save_restore_data_$IO.STATUS));
	     gtss_save_restore_data_$IO.Seek_count = 1;	/* => 1 word of Seek_Address. */

/**	Record current static handler for derails (reset at conclusion of gtss).	**/
	     call sct_manager_$get (derail_sct_index, gtss_ext_$sig_ptr, code);
	     if code ^= 0 then do;
sct_fail:		;
		call com_err_ (code, "gtss$initialize", "Can't set static handler for derails");
		return ("0"b);
	     end;

/**	Reset static handler for derails to gtss's handler.	**/

	     call sct_manager_$set (derail_sct_index, addr (gtss_derail_processor_), code);
	     if code ^= 0 then goto sct_fail;

	     call iox_$modes (iox_$user_output, "edited,^can,ll190", current_modes, code);
	     if code ^= 0 then do;
		reattach = "0"b;
		if code = error_table_$no_operation
		then current_modes = "";
		else if code ^= error_table_$not_attached then do;
		     call com_err_ (code, "gtss$initialize",
			"Could not obtain terminal modes");
		     return ("0"b);
		end;
	     end;

/* If gtss$drun has been called, or a DRUN has been done before (the
   deferred queue file ([hd]>drun_#d_q) exists, do DRUN initialization */
	     if gtss_ust.lcjid ^= "0"b then
		call gtss_drun_ (error);
	     else do;
		call hcs_$status_minf (gtss_ext_$homedir, "drun_#d_q",
		     1, type, bit_count, code);
		if code ^= error_table_$noentry then do;
		     call gtss_drun_ (error);
		     drun_term_req = "1"b;
		end;
	     end;
	     if error then do;
		call com_err_ (0, "gtss$initialize",
		     "Couldn't do DRUN initialization");
		return ("0"b);
	     end;


	     return ("1"b);
	end initialize ;
%page;
null_label: proc (l);

/**	Set label variable unusable.	**/
dcl  l                        label parm;
	     l = null_null;
	     return;

dcl  null_null                label based (addr (two_nulls));
dcl  two_nulls                (2)ptr static int init ((2)null ());
	end null_label ;
%page;
set_terminal_type: proc (tt, sid);

/* Map Multics caller's terminal type and channel
   to GCOS terminal type and station id.
*/
dcl  sid                      bit(12)unal parm;
dcl  tt                       bit(5)unal parm;
	     call user_info_$terminal_data (
		term_id_code
		, term_type
		, term_channel
		, term_line_type
		, term_charge_type
		);

/* Translate Multics terminal types
   to gcos types.

   Note: multics_type type table not in use
   (see below).
*/
	     if substr (term_type, 1, 1) = "V" then do;	/* => CRT (see multics type table). */
		tt = "01101"b;			/* 15octal => CRT. */
		gtss_ust.lflg2.b20 = "1"b;		/* => VIP. */
	     end;
	     else tt = "00100"b;			/* 4octal => teleprinter | command file. */

/* Interpret Multics channel value
   as 12bits (2 bcd chars) gcos value.
*/
	     sid =
		bit (fixed (search ("abcdefghijklmnopqrstuvwxyz", substr (term_channel, 1, 1)), 6))
		||
		bit (fixed (search ("0123456789", substr (term_channel, 6, 1)), 6));
	     return;

dcl  i                        fixed bin;
dcl  term_channel             char(8);
dcl  term_charge_type         char(8);
dcl  term_id_code             char(4);
dcl  term_line_type           fixed bin;
dcl  term_type                char(12);
dcl  user_info_$terminal_data entry(char(*),char(*),char(*),fixed bin,char(*));

dcl 1 multics_term (79)static int options(constant)
,     2 type char(18) init(
  /* 01 */	"1050"
, /* 02 */	"2741"
, /* 03 */	"AJ630"
, /* 04 */	"ARDS"
, /* 05 */	"ASCII"
, /* 06 */	"ASCII_CAPS"
, /* 07 */	"ASCII_CRT"
, /* 08 */	"ASCII_CRT_CAPS"
, /* 09 */	"BMARK"
, /* 10 */	"CDC713"
, /* 11 */	"CORR2741"
, /* 12 */	"DELTA4000"
, /* 13 */	"DIABLO1620"
, /* 14 */	"DTC300S"
, /* 15 */	"DTC300SE"
, /* 16 */	"DTC302"
, /* 17 */	"DTC302E"
, /* 18 */	"DTC302_12"
, /* 19 */	"DTC302_12E"
, /* 20 */	"EX300"
, /* 21 */	"FOX1100"
, /* 22 */	"G115"
, /* 23 */	"G115_UPPER"
, /* 24 */	"GENCOM"
, /* 25 */	"HCCT102"
, /* 26 */	"HC_SPOOL"
, /* 27 */	"IBM2780"
, /* 28 */	"IBM2780_FULL"
, /* 29 */	"IBM3780"
, /* 30 */	"IBM3780_FULL"
, /* 31 */	"L6TCF"
, /* 32 */	"LA120"
, /* 33 */	"LA120_10C6L_14X11"
, /* 34 */	"LA120_16C6L_8X11"
, /* 35 */	"LA36"
, /* 36 */	"LA36E"
, /* 37 */	"LA36_TABS"
, /* 38 */	"LED120"
, /* 39 */	"LED120E"
, /* 40 */	"PHXTST"
, /* 41 */	"ROSY"
, /* 42 */	"ROSYE"
, /* 43 */	"ROSYI"
, /* 44 */	"ROSY_TABS"
, /* 45 */	"SARA"
, /* 46 */	"SYSTEM75"
, /* 47 */	"TEK4013"
, /* 48 */	"TEK4015"
, /* 49 */	"TEK4015E"
, /* 50 */	"TEK4023"
, /* 51 */	"TELERAY1061"
, /* 52 */	"TELERAY1061E"
, /* 53 */	"TELERAY1061_ECHO"
, /* 54 */	"TELERAY3700"
, /* 55 */	"TI725"
, /* 56 */	"TI735"
, /* 57 */	"TI745"
, /* 58 */	"TN300"
, /* 59 */	"TN300I"
, /* 60 */	"TTY33"
, /* 61 */	"TTY37"
, /* 62 */	"TTY38"
, /* 63 */	"TTY43"
, /* 64 */	"VIP7200"
, /* 65 */	"VIP7200E"
, /* 66 */	"VIP7700R"
, /* 67 */	"VIP7700_CLUSTER"
, /* 68 */	"VIP7705"
, /* 69 */	"VIP7714"
, /* 70 */	"VIP7760"
, /* 71 */	"VIP7760_CONTROLLER"
, /* 72 */	"VIP7801"
, /* 73 */	"VIP7801E"
, /* 74 */	"VIP7804"
, /* 75 */	"VIP7804_CLUSTER"
, /* 76 */	"VT100"
, /* 77 */	"VT100W"
, /* 78 */	"VT100WS"
, /* 79 */	"VT52"
			)
,     2 gcos_type bit(5)
;
	end set_terminal_type ;
%page;
/*   Variables for gcos_tss:			 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  acct                     char (32);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  AFT_INITIALIZED	bit (1) init ("0"b);
dcl  al                       fixed bin(24);
dcl  any_other                condition ext;
dcl  ap                       ptr;
dcl  argl                     fixed bin (24);
dcl  argument                 char (argl) based (arg_ptr);
dcl  arg_ptr                  ptr init (null ());
dcl  ascii_channel_id         char (2);
dcl  bit_count                fixed bin (24);
dcl  cat_entry                fixed bin (18) unsigned;
dcl  cleanup                  condition ext;
dcl  clock                    builtin;
dcl  cmd_arg                  char(al)unal based(ap);
dcl  cmd_line		char (132);
dcl  code                     fixed bin (35);
dcl  command_error            condition;
dcl  copy                     builtin;
dcl  current_modes            char (400)static int init (" ");
dcl  cu_$arg_count            ext entry (fixed bin (24));
dcl  cu_$arg_ptr              entry(fixed bin(24),ptr,fixed bin(24),fixed bin(35));
dcl  cu_$cp		entry (ptr, fixed bin(21), fixed bin(35));
dcl  d                        fixed bin (24);
dcl  db_bits                  (72)bit (1)static int init ((72) (1)"0"b);
dcl  dc_ptr                   ptr init (null());
dcl  decode_clock_value_      ext entry (fixed bin (71), fixed bin (24), fixed bin (24), fixed bin (24), fixed bin (71), fixed bin (24), char (3) aligned);
dcl  delete_$ptr              entry (ptr, fixed bin (35));
dcl  djid                     char (5);
dcl  drun_cpu_limit           fixed bin (36) unsigned init (34000 * 64 * 1000);
dcl  drun_job_id              bit (36) init ("0"b);
dcl  empty                    builtin;
dcl  error                    bit (1) init ("0"b);
dcl  error_table_$arg_ignored fixed bin (35) ext;
dcl  error_table_$noentry     fixed bin (35)ext;
dcl  error_table_$not_attached fixed bin (35)ext;
dcl  error_table_$no_operation fixed bin (35)ext;
dcl  error_table_$out_of_sequence fixed bin (35) ext;
dcl  expand_pathname_         entry (char (*), char (*), char (*), fixed bin (35));
dcl  finish                   condition ext;
dcl  fixed_bin24              fixed bin (24) based;
dcl  fn                       fixed bin (24);
dcl  gcos_debug_$initial      entry (fixed bin (35));
dcl  get_pdir_                ext entry returns (char (168)aligned);
dcl  get_temp_segments_       entry (char (*), (*)ptr, fixed bin (35));
dcl  get_wdir_                ext entry returns (char (168));
dcl  gtss_already_called      bit (1)static int init ("0"b);
dcl  gtss_dump_kin_$clean     entry options(variable);
dcl  gtss_dump_kin_$fin       entry options(variable);
dcl  gtss_dump_kin_$init      entry() returns(bit(1));
dcl  gtss_fail                condition ext;
dcl  gtss_fix_tty_modes_	ext entry;
dcl  hbound                   builtin;
dcl  hcs_$fs_get_path_name    entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$initiate_count      entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$set_max_length_seg  entry (ptr, fixed bin (35), fixed bin (35));
dcl  hcs_$status_minf         entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  i                        fixed bin (24);
dcl  installation_directory   char (168);
dcl  ioa_                     ext entry options (variable);
dcl  iox_$get_line            entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35))ext;
dcl  iox_$modes               entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$put_chars           entry (ptr, ptr, fixed bin (24), fixed bin (35)) ext;
dcl  iox_$user_output         ptr ext;
dcl  k                        fixed bin (71);
dcl  l                        fixed bin (24);
/** To have druns run at 5:00PM when the user does not specify a start time,
simply change the commented out portion of the next dcl. Change 17 to
?? (hour number) if you want some other time. **/
dcl  drun_start_time          fixed bin (36) unsigned init (0); /**  init (17*60*60*64*1000) **/
dcl  drun_term_req            bit (1) auto init ("0"b);
dcl  execute_drun             fixed bin (18) unsigned init (0);
dcl  length                   builtin;
dcl  m                        fixed bin (24);
dcl  me_ptr                   ptr init (null ());
dcl  msf_manager_$adjust      entry (ptr, fixed bin (24), fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close       entry (ptr);
dcl  msf_manager_$get_ptr     entry (ptr, fixed bin (24), bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open        entry (char (*), char (*), ptr, fixed bin (35));
dcl  nargs                    fixed bin (24);
dcl  null                     builtin;
dcl  old_modes                char (400);
dcl  one_word                 bit (36) based;
dcl  pd                       char (168);
dcl  person_id                char (22);
dcl  proj                     char (9);
dcl  quit                     condition;
dcl  reattach                 bit (1);
dcl  rel                      builtin;
dcl  release_temp_segments_   entry (char (*), (*)ptr, fixed bin (35));
dcl  rtrim                    builtin;
dcl  sct_manager_$get         entry (fixed bin, ptr, fixed bin (35));
dcl  sct_manager_$set         entry (fixed bin, ptr, fixed bin (35));
dcl  search                   builtin;
dcl  size                     builtin;
dcl  status                   fixed bin (24)init (0);
dcl  substr                   builtin;
dcl  subsystem_name           char (4);
dcl  sys_info$max_seg_size    fixed bin (35)ext;
dcl  temp_segment_ptr         (7)ptr static int;
dcl  time                     fixed bin (71);
dcl  type                     fixed bin (2);
dcl  unique_chars_            entry (bit (*))returns (char (15));
dcl  unspec                   builtin;
dcl  user_info_               ext entry (char (*), char (*), char (*));
dcl  user_info_$homedir       entry (char (*));
dcl  user_info_$process_type  entry (fixed bin (17));
dcl  use_existing_components  bit (1)static int options (constant)init ("0"b);
dcl  w                        fixed bin (24);
dcl  wd_name                  char (32);
dcl  work_area                area (sys_info$max_seg_size)aligned based (gtss_ext_$work_area_ptr);
dcl  y                        fixed bin (24);
dcl  z                        char (3) aligned;

dcl 1 time2	aligned based(addr(time))
,     2 time53	fixed bin(53)unal
,     2 fill	bit(18)unal
;

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

dcl 1 args (100),
    2 arg_p ptr,
    2 arg_l fixed bin (24);

dcl 1 drun_jid defined argument,
      2 d1 char (1),
      2 d2 char (1),
      2 d3 char (1),
      2 d4 char (1),
      2 d5 char (1);
%page;
%include gtss_ext_;
%page;
%include gtss_install_values_;
%page;
%include static_handlers;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_SYstarstar_;
%page;
%include gtss_save_restore_data_;
%page;
%include gtss_dfd_ext_;
%page;
%include gtss_entry_dcls;
%page;
%include gtss_device_cmds;
%page;
%include gtss_defil_arg;
%page;
%include mc;
%page;
%include gse_ext_;
%page;
%include gtss_starCF_;
%page;
%include gtss_def_q_;
%page;
%include gtss_deferred_queue;
%page;
%include gtss_constants;
%page;
%include gtss_db_names;
     end gtss ;
  



		    gse_ext_.cds                    12/11/84  1349.3rew 12/10/84  1042.4       28809


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

/* Generate object for "gse_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(gse_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 (gse_ext_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gse_ext_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gse_ext_";

	cds_args_ptr -> cds_args.seg_name = "gse_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_gse_ext_");
	   else 
	      call com_err_( 0,"gse_ext_","Object for gse_ext_ created [^i words].",size(gse_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 gse_ext_.incl.pl1 **/

dcl 1 gse_ext_ aligned,
      2 drm_rule		    fixed bin(24) init(2),
      2 gcos_debug_pathname       char(168) init(""),
      2 smc_pathname              char(168) init(""),
      2 umc_name                  char(12) init(""),
      2 modes	aligned,
        3 ast		bit(01) unal init("1"b),
        3 drl		bit(01) unal init("0"b),
        3 gdb		bit(01) unal init("0"b),
        3 mcmd		bit(01) unal init("0"b),
        3 mquit		bit(01) unal init("0"b),
        3 ss		bit(01) unal init("0"b),
        3 fill		bit(30) unal init("0"b);

%include gse_ext_;
%page;
%include cds_args;
end;
   



		    gtss_CFP_abort_.pl1             12/11/84  1349.3rew 12/10/84  1042.4       44019


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

gtss_CFP_abort_: proc;


/**
	Author: Al Dupuis 06/21/79

	This procedure is called by gtss_abort_subsystem_ when an error
	has occured which will terminate command file processing (CFP).
	A given *CF file (of which there may be *CFP *CFQ *CFR *CFS and *CFT)
	will contain it's own bcd label table, and the information to
	restore the previous (more inner) file. This procedure sets
	the restore information to the ..abort label sector number,
	if it is present, if not, it sets it to the COUT sector so that
	the file will terminate.
**/


/* read the current *CF file's COUT sector */
	gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	file_number = gtss_starCF_$FILE.cf.aft_indx;
	gtss_starCF_$FILE.Seek_Address = gtss_ust.lcfst.initial_sect_out - 1;
	call read_cout;
	if status ^= 0 then return;
	cout_ptr = addr (no_characters);
	scp = addr (save_cout);

/* set the next input sector to be the $*$lbl ..abort sector if present,
   if not set it to the COUT sector so this *CF file will terminate */
	if label_present ()
	then gtss_ust.lcfio.sect_in = new_sect_in;
	else gtss_ust.lcfio.sect_in = gtss_ust.lcfst.initial_sect_out - 1;

	i = 1;
	highest_level = 0;

/* if we're not in nested CFP then we're done */
	do a = "Q", "R", "S", "T";
	     call gtss_aft_$find ("*CF" || a, fn, code);
	     if code = 0 then do;
		file_no (i) = fn;
		highest_level = highest_level + 1;
	     end;
	     i = i + 1;
	end;

	if highest_level = 0 then return;

	highest_level = highest_level + 1;
	file_no (highest_level) = gtss_starCF_$FILE.cf.aft_indx;

/* save the current COUT sector */
	save_cout = cout_ptr -> cout;
	old_seek_no = gtss_ust.lcfst.initial_sect_out - 1;

	do i = highest_level to 2 by -1;

/* read the previous (more inner) COUT sector */
	     file_number = file_no (i - 1);
	     new_seek_no = scp -> c_lcfst.init_sect_out - 1;
	     gtss_starCF_$FILE.Seek_Address = scp -> c_lcfst.init_sect_out - 1;
	     gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	     call read_cout;
	     if status ^= 0 then return;

/* if it has a ..abort label, set the saved COUT restore information
   to reflect it, else set the restore info to it's COUT sector */
	     if label_present ()
	     then scp -> c_lcfio.sector_in = new_sect_in;
	     else scp -> c_lcfio.sector_in = scp -> c_lcfst.init_sect_out - 1;
	     temp_buffer = cout_ptr -> cout;
	     cout_ptr -> cout = save_cout;

/* and write the COUT sector with restore information */
	     gtss_starCF_$FILE.OP2.Device_Command = write_cmd;
	     file_number = file_no (i);
	     gtss_starCF_$FILE.Seek_Address = old_seek_no;
	     call write_cout;
	     if status ^= 0 then return;
	     old_seek_no = new_seek_no;
	     save_cout = temp_buffer;
	end;

label_present: proc returns (bit (1));

	     do idx = 1 to hbound (cout_ptr -> label_table, 1);
		if abort_label = cout_ptr -> label_name (idx) then do;
		     new_sect_in = cout_ptr -> label_pos (idx);
		     cout_ptr -> label_name (idx) = "0"b;
		     cout_ptr -> label_pos (idx) = 0;
		     return ("1"b);
		end;
	     end;
	     return ("0"b);

dcl idx fixed bin (24);
	end;					/* label_present */

read_cout: write_cout: proc;

	     status = 0;
	     call gtss_ios_io_ (			/* read/write the cout sector from *CFP */
		file_number,
		addr (select_sequence),
		addr (select_sequence),
		fixed (rel (addr (gtss_starCF_$FILE.cf))),
		status,
		code);
	     if status ^= 0
	     then call ioa_ ("gtss_CFP_abort_:" ||
		"Unable to read/write cout sector (status ^i)",
		status);

	end;					/* read_write_cout */

dcl  a char (1);
dcl  abort_label bit (54) static int options (constant) init ("333321224651632020"b3);						/* bcd ..ABORT */
dcl  code fixed bin (35);
dcl  cout char (253) based;
dcl  cout_ptr ptr init (null());
dcl  file_name (5) char (4) init ("*CFP", "*CFQ", "*CFR", "*CFS", "*CFT");
dcl  file_no (5) fixed bin (24);
dcl  file_number fixed bin (24);
dcl  fn fixed bin (24);
dcl  gtss_fail condition ext;
dcl  highest_level fixed bin (24);
dcl  i fixed bin (24);
dcl  ioa_ entry options (variable);
dcl  new_sect_in fixed bin (18) unsigned;
dcl  new_seek_no fixed bin (18) unsigned;
dcl  old_seek_no fixed bin (18) unsigned;
dcl  save_cout char (253);
dcl  scp ptr init (null());
dcl  status fixed bin (24);
dcl  temp_buffer char (253);

%include gtss_deferred_queue;

%include gtss_starCF_;

%include gtss_entry_dcls;

%include gtss_ust_ext_;

%include gtss_device_cmds;
     end;						/* gtss_CFP_abort_ */
 



		    gtss_CFP_break_.pl1             12/11/84  1349.3rew 12/10/84  1042.5       20196


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

gtss_CFP_break_: proc;

/**	Author: Al Dupuis  06/23/79.
	Changed: Al Dupuis	11/10/79 Set break termination code.

   	This module is called to determine if the user has defined
	the special label $*$lbl ..break in his/her *CFP file
	when in command file processing. If the label was defined,
	the next sector to read (gtss_ust.lcfio.sect_in) is set
	to the sector number associated with this label. Otherwise,
	it is set to the cout sector.

**/


	gtss_ust.lcfst.start_term = 8;
	call com_err_$suppress_name (0, "gtss_CFP_break_",
	     "BREAK RECEIVED");
	gtss_starCF_$FILE.Seek_Address,
	     gtss_ust.lcfio.sect_in = gtss_ust.lcfst.initial_sect_out - 1;
	gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	call gtss_ios_io_ (				/* read the cout sector from *CFP */
	     gtss_starCF_$FILE.cf.aft_indx,
	     addr (select_sequence),
	     addr (select_sequence),
	     fixed (rel (addr (gtss_starCF_$FILE.cf))),
	     status,
	     error_code);
	if status ^= 0
	then do;
	     call ioa_ ("gtss_CFP_break_:"
		|| "Unable to read cout sector status (^i)", status);
	     return;
	end;
	cout_ptr = addr (no_characters);

	do i = 1 to hbound (cout_ptr -> label_table, 1);
	     if break_label = cout_ptr -> label_name (i) then do;
		gtss_ust.lcfio.sect_in = cout_ptr -> label_pos (i);
		return;
	     end;
	end;


dcl break_label bit (54) static int options (constant) init ("333322512521422020"b3);						/* "..BREAK" */
dcl com_err_$suppress_name entry options (variable);
dcl cout_ptr ptr init (null());
dcl error_code fixed bin (35);
dcl i fixed bin (24);
dcl ioa_ entry options (variable);
dcl status fixed bin (24);

%include gtss_deferred_queue;

%include gtss_starCF_;

%include gtss_device_cmds;

%include gtss_ust_ext_;

%include gtss_entry_dcls;
     end;						/* gtss_CFP_break_ */



		    gtss_CFP_input_.pl1             12/11/84  1349.3rew 12/10/84  1042.5       85869


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

gtss_CFP_input_: proc (up, bp, ml, rl, ec);

/**      This program is called to do all input when doing
         CRUN/DRUN processing. Depending on the modes in
         effect as a result of processing $*$ requests, the
         appropriate input/output actions are performed.

         Author: Al Dupuis 05/05/79.
  Changed: Ron Barstad 83-03-31  fixed length of output substr in debug to rl, was rl-1
**/

dcl  up ptr parm;		/** (input) iocb ptr **/
dcl  bp ptr parm;		/** (input) points to callers buffer **/
dcl  ml fixed bin (21) parm;	/** (input) buffer length **/
dcl  rl fixed bin (21) parm;	/** (output) number of characters returned **/
dcl  ec fixed bin (35) parm;	/** (output) Multics error code **/

/**
	ACTION		MEANING

	action-1		terminal read
	action_2		terminal read, terminal write
	action_3		terminal read, *CFP write
	action_4		terminal read, terminal write, *CFP write

	action_5		*CFP read
	action_6		*CFP read, terminal write
	action_7		*CFP read, *CFP write
	action_8		*CFP read, terminal write, *CFP write


      EXCLUDE   DELE_ON   COPY_ON   TALK_ON                 ACTION

	0	0	0	0		action_7
	0	0	0	1		action_3
	0	0	1	0		action_8
	0	0	1	1		action_3
	0	1	0	0		action_5
	0	1	0	1		action_1
	0	1	1	0		action_6
	0	1	1	1		action_2
	1	0	0	0		action_5
	1	0	0	1		action_1
	1	0	1	0		action_6
	1	0	1	1		action_1
	1	1	0	0		action_5
	1	1	0	1		action_1
	1	1	1	0		action_6
	1	1	1	1		action_2

**/

	no_input_yet = "1"b;

/**       Obtain the input line from terminal or current *CFP file,
          and do any special processing requested by $*$ cards
**/


	do while (no_input_yet);


	     if gtss_starCF_$FILE.cf.first_time = "1"b
	     then call set_exclude;			/* done once for each new *CFP file */
	     else;
	     rtn_bits = gtss_starCF_$FILE.cf.exclude_on || dele_on || copy_on || talk_on;
	     proper_rtn = rtn_table (fixed (rtn_bits, 4));
	     call proper_rtn;
	     if db_CFP_input then call ioa_ (
		"input sector no was (^d)"
		|| "    no of chars read was (^d)"
		|| "^/chars read were (^a)",
		gtss_ust.lcfio.sect_in - 1,
		rl,
		substr (RECORD.chars, 1, rl));

	     if rl >= 4 then
		if ((substr (bp -> string, 1, 4) = "cpos") | /* have to set this bit so that */
		(substr (bp -> string, 1, 4) = "CPOS")) then /* drl_t_cfio_ won't start a new *CFP file */
		     cpos_called = "1"b;

	     if rl >= 3 then			/* if drun execution in progress, check for last cmnd */
		if gtss_ust.lcjid ^= "0"b then
		     if ((substr (bp -> string, 1, 3) = "bye")
		     | (substr (bp -> string, 1, 3) = "BYE"))
		     | (gtss_ust.lcfio.sect_in ^< gtss_ust.lcfst.initial_sect_out)
		     then call end_of_drun;

	     if CFP_in_progress then			/* gtss_read_starCFP_ may have exhausted input */
		if rl > 3 then
		     if (index (bp -> string, "$*$") ^= 0) then do;
			if substr (bp -> string, rl, 1) = CR then substr (bp -> string, rl, 1) = NL;
			call gtss_dsd_process_ (up, bp, ml, rl, ec); /* special processing of line */
		     end;
		     else no_input_yet = "0"b;	/* does not contain $*$ */
		else no_input_yet = "0"b;		/* not long enough for $*$ line */
	     else no_input_yet = "0"b;		/* all *CFP input exhausted */

	end;


action_1:	proc;

	     call iox_$get_line (iox_$user_input, bp, ml, rl, ec);
	     if ec = error_table_$long_record
	     then call long_line;

	end					/* action_1 */;


action_2:	proc;

	     call iox_$get_line (iox_$user_input, bp, ml, rl, ec);
	     if ec = error_table_$long_record
	     then call long_line;
	     if ec = 0 then call iox_$put_chars (iox_$user_output, bp, rl, code);
	     if code ^= 0 then call bug_complaint;

	end					/* action_2 */;


action_3:	proc;

	     call iox_$get_line (iox_$user_input, bp, ml, rl, ec);
	     if ec = error_table_$long_record
	     then call long_line;
	     if ec = 0 then do;
		i = gtss_edit_dsd_ (bp, rl);		/* does line go to *CFP */
		if i = 0 then call gtss_write_starCFP_ (up, bp, rl, code); /* yes */
	     end;
	     if code ^= 0 then call bug_complaint;

	end					/* action_3 */;


/**	NOT USED AT THIS TIME
action_4:	proc;

	     call iox_$get_line (iox_$user_input, bp, ml, rl, ec);
               if ec = error_table_$long_record
               then call long_line;
	     if ec = 0 then call iox_$put_chars (iox_$user_output, bp, rl, code);
	     if code = 0 then do;
		i = gtss_edit_dsd_ (bp, rl);		
		if i = 0 then call gtss_write_starCFP_ (up, bp, rl, code); 
	     end;
	     if code ^= 0 then call bug_complaint;

          end;
*/


action_5:	proc;

	     call gtss_read_starCFP_ (up, bp, ml, rl, ec);

	end					/* action_5 */;


action_6:	proc;

	     call gtss_read_starCFP_ (up, bp, ml, rl, ec);
	     if ec = 0 then call iox_$put_chars (iox_$user_output, bp, rl, code);
	     if code ^= 0 then call bug_complaint;

	end					/* action_6 */;


action_7:	proc;

	     call gtss_read_starCFP_ (up, bp, ml, rl, ec);
	     if ec = 0 then do;
		i = gtss_edit_dsd_ (bp, rl);		/* does line go to *CFP */
		if i = 0 then call gtss_write_starCFP_ (up, bp, rl, code); /* yes */
	     end;
	     if code ^= 0 then call bug_complaint;

	end					/* action_7 */;


action_8:	proc;

	     call gtss_read_starCFP_ (up, bp, ml, rl, ec);
	     if ec = 0 then call iox_$put_chars (iox_$user_output, bp, rl, code);
	     if code = 0 then do;
		i = gtss_edit_dsd_ (bp, rl);		/* does line go to *CFP */
		if i = 0 then call gtss_write_starCFP_ (up, bp, rl, code); /* yes */
	     end;
	     if code ^= 0 then call bug_complaint;

	end					/* action_8 */;


bug_complaint: proc;

	     gtss_ust.lcfst.start_term = 2;
	     call gtss_abort_subsystem_ (
		gtss_find_cond_frame_ ("derail"),
		"gtss_CFP_input",
		0,
		"Encountered a bad i/o to terminal or *CFP."
		);
	     return;
	end					/* bug_complaint */;


set_exclude: proc;

	     gtss_starCF_$FILE.cf.first_time = "0"b;
	     gtss_starCF_$FILE.Seek_Address = gtss_ust.lcfst.initial_sect_out - 1;
	     gtss_starCF_$FILE.OP2.Device_Command = read_cmd;
	     fn = gtss_starCF_$FILE.cf.aft_indx;
	     call gtss_ios_io_ (			/* read the cout sector from *CFP */
		fn,
		addr (select_sequence),
		addr (select_sequence),
		fixed (rel (addr (gtss_starCF_$FILE.cf))),
		status,
		code);
	     if status ^= 0 then do;
		call com_err_ (code, "gtss_CFP_input_$set_exclude",
		     "Unable to read cout sector (status ^i)", status);
		call bug_complaint;
		return;
	     end;

	     dib_ptr = addr (no_characters);		/* DIB description--DB84 page 16-22 */
	     if dib_ptr -> dq_dib.dbflg.f_exc = "1"b then
		gtss_starCF_$FILE.cf.exclude_on = "1"b;
	     else gtss_starCF_$FILE.cf.exclude_on = "0"b;

	end;					/* set_exclude */


long_line: proc;

	     attempts = 1;
	     do while (attempts < 6);
		if ec = error_table_$long_record then do;
		     call com_err_ (0, "", "RETRANSMIT LAST LINE");
		     call iox_$control (up, "resetread", null (), ec);
		     call iox_$get_line (iox_$user_input, bp, ml, rl, ec);
		     attempts = attempts + 1;
		end;
		else return;
	     end;

	     rl = 0;

	end;					/* long_line */

end_of_drun: proc;


	     buffer = gtss_abs_logout_banner_ ();	/* banner is 2 lines */
	     nl_indx = index (buffer, NL);
	     rl = (nl_indx - 1) + 4;
	     bp -> string =
		CR || NL || substr (buffer, 1, nl_indx - 1) || CR || NL;
	     call gtss_write_starCFP_ (up, bp, rl, code);
	     if code = 0 then do;
		rl = length (buffer) - nl_indx + 2;
		bp -> string = substr (buffer, nl_indx + 1) || CR || NL;
		call gtss_write_starCFP_ (up, bp, rl, code);
		if code = 0 then do;		/* read the cout sector */
		     gtss_ust.lcfio.sect_in = gtss_ust.lcfst.initial_sect_out - 1;
		     call gtss_read_starCFP_ (up, bp, ml, rl, ec);
		end;
	     end;

	     if code ^= 0 then call bug_complaint;

dcl buffer char (300) varying;
dcl nl_indx fixed bin (24);

	end;					/* end_of_drun */

/**
Variables for gtss_CFP_input_
**/


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

dcl  CR                       char(1)static int options(constant) init("");
dcl (i, l, fn, status, attempts, l_idx) fixed bin (24);
dcl code fixed bin (35) init (0);
dcl string char (rl) based (bp);
dcl (fixed, null, substr) builtin;
dcl ioa_ entry options (variable);
dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl iox_$user_input ptr ext;
dcl iox_$user_output ptr ext;
dcl gtss_fail condition ext;
dcl error_table_$long_record fixed bin (35) external;

dcl proper_rtn entry int variable;
dcl rtn_table (0:15) entry init (
    action_7,
    action_3,
    action_8,
    action_3,
    action_5,
    action_1,
    action_6,
    action_2,
    action_5,
    action_1,
    action_6,
    action_1,
    action_5,
    action_1,
    action_6,
    action_2);

dcl dib_ptr ptr init (null());

%include gtss_CFP_bits;

%include gtss_device_cmds;

%include gtss_starCF_;

%include gtss_ust_ext_;

%include gtss_ext_;

%include gtss_entry_dcls;

%include gtss_deferred_queue;

%include gtss_db_names;
     end						/* gtss_CFP_input_ */;
   



		    gtss_CFP_output_.pl1            12/11/84  1349.3rew 12/10/84  1028.6       35208


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

gtss_CFP_output_: proc (up, bp, rl, ec);

/**      This program is called to do all output when doing
         CRUN/DRUN processing. Depending on the modes in
         effect as a result of processing $*$ requests, the
         appropriate output actions are performed.

         Author: Al Dupuis 05/05/79.
  Changed:  Ron Barstad  83-03-31  Fixed size of substr on debub output to rl, was rl-1
  Changed:  Ron Barstad  84-11-29  Start off by setting error code to zero.

	ACTION		MEANING

	action_1		terminal write
	action_2		*CFP write
	action_3		terminal write, *CFP write
	action_4		no write
	action_5		terminal write, terminal write


	DELE_ON	COPY_ON	TALK_ON		ACTION

	   0	   0	   0		action_2
	   0	   0	   1		action_3
	   0	   1	   0		action_3
	   0	   1	   1		action_3
	   1	   0	   0		action_4
	   1	   0	   1		action_1
	   1	   1	   0		action_1
	   1	   1	   1		action_5


**/
/**  **/

	ec = 0;
	rtn_bits = "0"b || dele_on || copy_on || talk_on;
	proper_rtn = rtn_table (fixed (rtn_bits, 4));
	call proper_rtn;
	if db_CFP_input then call ioa_ (
	     "output sector no was (^d)"
	     || "    no of chars written was (^d)"
	     || "^/chars written were (^a)",
	     gtss_ust.lcfio.sect_out - 1,
	     rl,
	     substr (RECORD.chars, 1, rl));


/** 
**/
action_1:	proc;

	     call iox_$put_chars (iox_$user_output, bp, rl, ec);
	     if ec ^= 0 then call bug_complaint;
	end					/* action_1 */;
/** 
**/
action_2:	proc;

	     call gtss_write_starCFP_ (up, bp, rl, ec);
	     if ec ^= 0 then call bug_complaint;
	end					/* action_2 */;
/** 
**/
action_3:	proc;

	     call iox_$put_chars (iox_$user_output, bp, rl, ec);
	     if ec = 0 then
		call gtss_write_starCFP_ (up, bp, rl, code);
	     if code ^= 0 | ec ^= 0 then call bug_complaint;

	end					/* action_3 */;
/**  **/

action_4:	proc;

	end					/* action_4 (very quick proc) */;
/**  **/
action_5:	proc;

	     call iox_$put_chars (iox_$user_output, bp, rl, ec);
	     if ec = 0 then
		call iox_$put_chars (iox_$user_output, bp, rl, code);
	     if code ^= 0 | ec ^= 0 then call bug_complaint;

	end					/* action_5 */;
/**  **/

bug_complaint: proc;


	     gtss_ust.lcfst.start_term = 2;
	     call gtss_abort_subsystem_ (
		gtss_find_cond_frame_ ("derail"),
		"gtss_CFP_output_",
		0,
		"Encountered a bad i/o to terminal or *CFP");
	     return;
	end					/* bug_complaint */;
/**  **/


/*	Variables for gtss_CFP_output_
*/

dcl ioa_ entry options (variable);
dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl iox_$user_input ptr ext;
dcl iox_$user_output ptr ext;
dcl  up                       ptr parm /* (NOT USED. Needed for iox_ compatibility). */;
dcl  bp                       ptr parm /* (input) Callers buffer. */;
dcl  rl                       fixed bin(21)parm /* (output) Number characters returned. */;
dcl  ec                       fixed bin(35)parm /* (output) Multics error code. */;
dcl code fixed bin (35) init (0);
dcl (null, fixed) builtin;
dcl proper_rtn entry int variable;
dcl rtn_table (0:7) entry init (
    action_2,
    action_3,
    action_3,
    action_3,
    action_4,
    action_1,
    action_1,
    action_5);
/**  */

%include gtss_entry_dcls;
/**  **/
%include gtss_CFP_bits;
/**  **/
%include gtss_starCF_;
/**  **/
%include gtss_ext_;
/**  **/
%include gtss_ust_ext_;

%include gtss_db_names;
     end						/* gtss_CFP_output_ */;



		    gtss_SYstarstar_.cds            12/11/84  1349.3rew 12/10/84  1042.5       25650


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

/* Generate object for "gtss_SYstarstar_" 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_SYstarstar_)=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_SYstarstar_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_SYstarstar_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_SYstarstar_";

	cds_args_ptr -> cds_args.seg_name = "gtss_SYstarstar_";	/* 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_SYstarstar_");
	   else 
	      call com_err_( 0,"gtss_SYstarstar_","Object for gtss_SYstarstar_ created [^i words].",size(gtss_SYstarstar_));

	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_SYstarstar_.incl.pl1 **/

dcl 1 gtss_SYstarstar_ aligned,
      2 FILE aligned like gtss_SYstarstar_$FILE;

%include gtss_SYstarstar_;
%page;
%include cds_args;
end;
  



		    gtss_abandon_CFP_.pl1           12/11/84  1349.3rew 12/10/84  1042.6       23481


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

gtss_abandon_CFP_: proc;

/* Reset to non-command file processing.

   Author: Dave Ward 03/27/79

   Changed: Al Dupuis 05/22/79 To turn off copy_on, etc...bits.
   Changed: Al Dupuis 10/01/79 Added call to timer_manager_.
   Changed: Al Dupuis 10/01/79 To zero out any termination code in start_term.
   Changed: Al Dupuis 11/10/79 End of ..init processing.
*/
	call timer_manager_$reset_cpu_call (gtss_fault_processor_$timer_runout);
	call timer_manager_$reset_cpu_call (gtss_abs_$cpu_runout);
	gtss_ext_$flags.ss_time_limit_set = "0"b;
	gtss_ext_$flags.timer_ranout = "0"b;
	gtss_ust_ext_$ust.gtss_ust.limit = 0;
	gtss_ext_$get_line = iox_$get_line;
	gtss_ext_$put_chars = iox_$put_chars;
	cpos_called = "0"b;
	CFP_in_progress = "0"b;
	dele_on = "0"b;
	copy_on = "0"b;
	talk_on = "0"b;
	trap_off = "0"b;
	lswt2.b6 = "0"b;
	gtss_ust.lcfst.start_term = 0;		/* reset any abort term code */

/* If we are just finishing processing a ..init file thru CRUN, but still
   have to execute DRUN (we are under absentee) prepare things	*/
	if gtss_ext_$process_type = 2
	then do;
	     if ((gtss_ust.lcjid = "0"b)
	     & (gtss_ext_$drun_jid ^= " "))
	     then do;
		gtss_ust.lcfst.start_term = 17;
		call gtss_ascii_bcd_ (addr (gtss_ext_$drun_jid), 5, addr (gtss_ust.lcjid));
		call gtss_aft_$find ("*CFP", fn, code);
		if code ^= 0
		then return;
		call gtss_ios_close_ (fn,
		     addr (fms_status),
		     code);
		if fms_status.bit12 ^= "4000"b3
		then do;
		     call ioa_ ("gtss_abandon_CFP_: "
			|| "*CFP won't close. Status (^w).",
			fms_status);
		     return;
		end;
		call gtss_aft_$delete ("*CFP", fn, code);
	     end;
	end;
	return;

dcl  code				fixed bin (35);
dcl  fn				fixed bin (24);
dcl  ioa_                               entry options (variable);
dcl  iox_$get_line            	entry ext;
dcl  iox_$put_chars           	entry ext;
dcl  timer_manager_$reset_cpu_call	entry (entry);
dcl  1 fms_status aligned,
       2 bit12 bit (12) unaligned,
       2 bit60 bit (60) unaligned;

%include gtss_ext_;

%include gtss_starCF_;

%include gtss_CFP_bits;

%include gtss_ust_ext_;

%include gtss_entry_dcls;
     end						/* gtss_abandon_CFP_ */;
   



		    gtss_abort_dump_.pl1            12/11/84  1349.3rew 12/10/84  1042.6       54621


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

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

/* This gcos error message will
   be printed out on return,
   but only if abort is due to DRL ABORT. */

/**	gtss abort dump

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	08/03/79 Revised open call.
   Change:  Dave Ward	10/31/79 Exit for record quota overflow.
   **/
dcl  drl_abort_code           fixed bin (18) parm;
dcl  size_change              fixed bin (24);
	drl_abort_code = 35;			/* DRL ABORT -- ABORT FILE WRITTEN */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	call hcs_$status_mins (gseg, 01b, bc, code);	/* Obtain bit count (bc) of segment to dump. */
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gtss_abort_dump_"
		, "COULD NOT OBTAIN BIT COUNT (^p)."
		, gseg
		);
	     return;
	end;
	l = divide (bc, 36, 24, 0);			/* Number of words to dump. */

/**	Obtain output file.	**/
	call gtss_aft_$add ("ABRT", fn, code);
	if code = 2 then do;
	     call com_err_ (
		0
		, "gtss_abort_dump_"
		, "NO ROOM IN AFT FOR ABRT FILE."
		);
	     return;
	end;
	if code = 0 then do;			/* New file (ABRT). */
	     abrt_attributes_block.fill = "0"b;
	     link_size = divide (l+3839, 3840, 24, 0);	/* enough full links for dump */
	     abrt_attributes_block.current_size = 12 * link_size; /* size in llinks */
	     abrt_attributes_block.device_type = "64"b3;	/* => disk. */
	     abrt_attributes_block.llink_flag = "0"b;	/* links (=>12*320=3840 words). */
	     abrt_attributes_block.max_size = divide (sys_info$max_seg_size+319, 320, 24, 0); /* maximum number of llinks
						   in a multics segment */
	     abrt_attributes_block.mode = "0"b;		/* Sequential. */
	     abrt_attributes_block.non_null = "1"b;
	     abrt_attributes_block.perm = "0"b;		/* Temporatry file. */
	     if link_size <= 16383			/* 2**14-1 */
	     then abrt_attributes_block.size = substr (bit (link_size, 24), 11, 14);
	     else abrt_attributes_block.size = "0"b;
	     abrt_attributes_block.user_attr = "0"b;
	     addr (abrt_attributes_block.words_block) -> fixed_bin11 = 64;
	     fnp = fn;				/* Convert fn to numeric string (fnps/fnp). */

	     call gtss_ios_open_ (
		/* 1 */ fn			/* AFT index. */
		, /* 2 */ (gtss_ext_$pdir)		/* ABRT directory. */
		, /* 3 */ unique_chars_ ("0"b)||".abrt."||fnps /* Multics segment name. */
		, /* 4 */ "110000"b			/* bit=1 => read, bit2=1 => write. */
		, /* 5 */ "0"b			/* => sequential. */
		, /* 6 */ addr (abrt_attributes_block)
		, /* 7 */ addr (gcos_status)		/* gtss_ios_ result code. */
		, /* 8 */ code			/* Multics error code. */
		);
dcl 1 gcos_status aligned,
      2 bit12 bit(12)unal,
      2 bit60 bit(60)unal;
	     if gcos_status.bit12 ^= "4000"b3 then do;
		call com_err_ (
		     code
		     , "gtss_abort_dump_"
		     , "GTSS_IOS_$OPEN GCOS_STATUS=^w. CAN'T OPEN ABRT"
		     , gcos_status
		     );
		aft_entry (fn).used = "0"b;		/* => Don't close, forget aft entry. */
		return;
	     end;
	end;

	else do;					/* File already in AFT. */

/* See if we have write access */
	     if permissions (fn).write then do;

/* Try to grow ABRT file if too small */
		if file_size (fn) < l then do;

/* Figure out how many links are required. */
		     link_size = divide (l + 3839, 3840, 24, 0);
		     size_change = link_size * 12 - divide (file_size (fn), 320, 24, 0);
		     call gtss_ios_change_size_ (fn, size_change, "0"b, status, code);
		     if status ^= 0 then do;
			if code = error_table_$rqover then do;
			     call com_err_ (
				code
				, "gtss_abort_dump_"
				, "EXCEEDED LLINKS AVAILABLE"
				);
			     drl_abort_code = 34;
			     return;
			end;
			drl_abort_code = 40;	/* DRL ABORT - ABORT FILE TOO SMALL */
			l = file_size (fn);
		     end;
		end;
	     end;
	     else do;				/* No write permission */
		drl_abort_code = 34;		/* DRL ABORT -- CANNOT WRITE ABRT FILE */
		return;
	     end;
	end;

/* get pointer to target file */
	if msf (fn)
	then abrt_ptr = msf_array_ptr (fn) -> msf_components (1);
	else abrt_ptr = single_segment_ptr (fn);

/* Move memory image into abort file */
	abrt_ptr -> m = gseg -> m;
	return;

/**  Variables for gtss_abort_dump_
   IDENTIFIER		ATTRIBUTES	**/
dcl  abrt_ptr                 ptr init(null());
dcl  bc                       fixed bin (24);
dcl  code                     fixed bin (35);
dcl  divide                   builtin;
dcl  error_table_$rqover      fixed bin(35)ext;
dcl  fixed_bin11              fixed bin (11)unal based;
dcl  fn                       fixed bin (24);
dcl  fnp                      pic "99";
dcl  fnps                     char (2)based (addr (fnp));
dcl  gseg                     ptr init(null());
dcl  hcs_$status_mins         entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  l                        fixed bin (24);
dcl  link_size                fixed bin (24);
dcl  m                        char (4*l) based;
dcl  msf_components           (0:499) ptr based;
dcl  null                     builtin;
dcl  status                   fixed bin (24);
dcl  sys_info$max_seg_size    fixed bin (35) ext;
dcl  unique_chars_            entry (bit (*))returns (char (15));

dcl 1 abrt_attributes_block aligned like gtss_file_attributes static int;

%include gtss_file_attributes;

%include gtss_ext_;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;
     end						/* gtss_abort_dump_ */;
   



		    gtss_abort_subsystem_.pl1       12/11/84  1349.3rew 12/10/84  1028.8       72036


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

/** ************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_abort_subsystem_: proc (mcpp, caller_name, gcos_error_code);

/** Abort call to subsystem and not-implemented.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward	03/27/79 null mcp, abandon.
   Changed: Al Dupuis	06/12/79 to allow for transferring to special
			$*$lbl ..abort when doing command file processing.
   Changed: Al Dupuis         12/01/79 changed ios_ calls to com_err_, set error
                              code (lcfst.start_term) for cout subsystem.
   Changed: Ron Barstad       84-02-28  Changed size of error_structure to reflect gtss_pnterr
   ** /

/*


   This routine is called by derail routines  which  detect  errors.
   Under  control  of user accessible bits in spa.lwrap it prints an
   error message and/or prepares for execution of the user's  wrapup
   code.    If   the   wrapup   code   is   not   to   be  executed,
   gtss_abort_subsystem_ does a nonlocal goto to  gtss_ext_$drl_rtrn
   (gtss_ext_$stack_level_)  thus  aborting  the  subsystem.  If the
   wrapup code is to  be  executed,  gtss_abort_subsystem_  modifies
   scu.ilc  in  the  saved machine conditions to point to the wrapup
   code and then returns.  When gtss_abort_subsystem_  returns,  its
   caller  should  also  return  so  that  the  wrapup  code  can be
   executed.


   Usage:
   dcl gtss_abort_subsystem_ entry options (variable);
   call                                        gtss_abort_subsystem_
   (mcp,caller_name,gcos_error_code,ioa_control_string,arg1,...argn);
   Where:
   1. mcp    (input)             (ptr)
   is  a  pointer  to  the  machine conditions saved when the derail
   fault occurred.
   2. caller_name (input)        (char(*))
   is  the   name   of   the   DRL   routine   which    is   calling
   gtss_abort_subsystem_.
   3. gcos_error_code (input)    (fixed bin(18))
   is  a  gcos  timesharing  error  code as docutented for .LABRT in
   DD17C Rev 0 pp.3-3.1,3.2.
   (4. ioa_control_string         (input)
   is an optional control string for an error message.  If no  error
   message is desired only 3 parameters should be passed.
   5. argi   (input)
   optional arguments for use with the ioa_ control string.
*/
dcl  addr                     builtin;
dcl  arg_count                fixed bin  /* total number of args passed. */;
dcl  arg_list_ptr             ptr init(null());
dcl  caller_name              char (*) parm;
dcl  com_err_$suppress_name   entry options (variable);
dcl  cu_$arg_count            entry (fixed bin);
dcl  cu_$arg_list_ptr         entry (ptr);
dcl  drl_abort_code           fixed bin (18);
dcl  error_structure          (69) char (50) based (addr (gtss_pnterr));
dcl  gcos_error_code          fixed bin (18) parm;
dcl  gseg                     ptr init(null());
dcl  gtss_fail                condition;
dcl  i                        fixed bin (24);
dcl  instruction_counter      bit (18)  /* transfer address for user's wrapup routine */;
dcl  ioa_                     ext entry options (variable);
dcl  ioa_$general_rs          entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  lower_limit              bit (18);
dcl  mcpp                     ptr parm;
dcl  null                     builtin;
dcl  rtn_string               char (256);
dcl  rtn_string_len           fixed bin;
dcl  upper_limit              bit (18);
dcl  current_level		fixed bin (24);

/* Make sure we have required arguments */
	call cu_$arg_count (arg_count);
	if arg_count < 3 then do;
	     call com_err_ (0, "gtss_abort_subsystem_",
		"Only ^i aruments supplied; Minimum 3 required", arg_count);
	     signal condition (gtss_fail);
	end;

	if gtss_ust.lflg2.b8 then call gtss_CFP_abort_;
	
/* Get machine condition pointer */
	mcp = mcpp;
	if mcp = null () then do;
	     call com_err_$suppress_name (0, "gtss_abort_subsystem_", "Machine conditions not available.");
	     call pr_msg;
	     call gtss_drl_sysret_ (null (), 0);
	     signal cond (gtss_fail);
	end;
	scup = addr (mc.scu);

/* Get pointer to user's segment */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

/* If in CFP and user error, set cout termination code */
	if ((gtss_ust.lflg2.b8) & (gcos_error_code ^= 0))
	then do;
	     gtss_ust.lcfst.start_term = 6;
	     gtss_ust.lerrm = bit (fixed (gcos_error_code, 36), 36);
	end;

/* Write abort file only if bit 19 of .LWRAP is off */
	drl_abort_code = 0;
	if ^gtss_spa.lwrap.b19 then do;
	     gtss_spa.lwrap.b19 = "1"b;
	     call gtss_abort_dump_ (drl_abort_code);
	end;

/* Print error message if WRAPUP is already in progress or
   bit 20 of .LWRAP is off. */
	if gtss_spa.lwrap.b18 | ^gtss_spa.lwrap.b20
	then do;
	     if gcos_error_code = 35			/* we were called by gtss_drl_abort_ */
	     & drl_abort_code ^= 0			/* gtss_abort_dump_ has been called */
	     then call com_err_$suppress_name (0, "gtss_abort_subsystem_", "^/"||
		error_structure (drl_abort_code), fixed (scu.ilc, 18));
	     else call pr_msg;
	end;

/* Save instruction counter and error code in .LABRT in slave prefix */
	gtss_spa.labrt.b0_17 = bit (fixed (fixed (scu.ilc, 18)+1, 18), 18);
	if gcos_error_code = 35			/* we were called by gtss_drl_abort_ */
	& drl_abort_code ^= 0			/* gtss_abort_dump_ has been called */
	then gtss_spa.labrt.b18_35 = drl_abort_code;
	else gtss_spa.labrt.b18_35 = gcos_error_code;
	gtss_ust.licec = gtss_spa.labrt;

/* If wrapup is already in progress it will not be paid again */
	if gtss_spa.lwrap.b18 then go to
	     gtss_ext_$drl_rtrn (gtss_ext_$stack_level_);

/* Mark wrapup in progress */
	gtss_spa.lwrap.b18 = "1"b;

/* See if the user provided a valid wrapup address. */
	lower_limit = bit (binary (100, 18), 18);
	upper_limit = gtss_ust.lsize.limit;
	instruction_counter = gtss_spa.lwrap.b0_17;

/* If not, ignore wrapup request. */
	if instruction_counter < lower_limit | instruction_counter >= upper_limit then
	     go to gtss_ext_$drl_rtrn (gtss_ext_$stack_level_);

/* Prepate to execute user's wrapup routine */
	scu.ilc = instruction_counter;
	return;

not_imp:	entry (mcpp, drl_type);
dcl  drl_type                 fixed bin parm;
dcl  fixed                    builtin;
	mcp = mcpp;
	scup = addr (mc.scu);
	i = gtss_ust.lxxx.b0_17 - fixed (rel (addr (gtss_ust.lxxx)))
	     +fixed (rel (addr (gtss_ust)));
	call com_err_$suppress_name (0, "gtss_abort_subsystem_",
	"^/Unimplemented drl ^a at ^o from subsystem ""^a""^/"
	     , DRL_NAME (drl_type)
	     , fixed (scu.ilc)
	     , ss_name (gtss_ust.lprgs (i).b0_17)
	     );
	goto gtss_ext_$drl_rtrn (gtss_ext_$stack_level_);

pr_msg:	proc;

/* Print callers message. */
	     if arg_count > 3 then do;
		call cu_$arg_list_ptr (arg_list_ptr);
		call ioa_$general_rs (arg_list_ptr, 4, 5, rtn_string, rtn_string_len, "0"b, "0"b);
		if rtn_string_len > 0 then
		     if substr (rtn_string, 1, rtn_string_len) ^= "" then
		     call com_err_$suppress_name (0, "gtss_abort_subsystem_", "^/^a", substr (rtn_string, 1, rtn_string_len));
	     end;
	     return;
	end					/* pr_msg */;

%include gtss_spa;

%include gtss_ext_;

%include mc;

%include gtss_prgdes_;

%include gtss_ust_ext_;

%include gtss_drl_names;

%include gtss_pnterr;

%include gtss_entry_dcls;

%include gtss_starCF_;
     end						/* gtss_abort_subsystem_ */;



		    gtss_abs_.pl1                   12/11/84  1349.3rew 12/10/84  1042.7      175662


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

gtss_abs_: proc;

/**
	ENTRY		FUNCTION

	get_id		Returns the unique Multics absentee request
			id, for the given DRUN job id.

	get_drm		Returns the generated gcos_set_environment
			command, with the directory mapping rules
			currently in effect.

	create_absin	Returns an absin file.

	abs_equiv		Performs the equivalent Multics absentee
			function that the DRUN subsystem has just
			performed. Examples: enter_abs_request ...etc.

	cpu_runout	This entry is called when the execution time limit
			has been exceeded. Puts the appropriate error code
			in the UST, aborts the current subsystem, and lets
			the DRUN subsystem produce the output file.

	dabt_check	This entry is called every 30 cpu seconds (set
			in gtss_drun_) when a DRUN is executing under
			absentee. It checks to see if the DABT request
			has been given from an interactive process to
			cancel this run.

   Author:  Al Dupuis	08, 1979.
   Change:  Dave Ward	08/19/79 Provide cwd to dir drun done from.
			         Eliminated cl, made same as cmd_line.
   Change:  Al Dupuis	08/20/79 Added cpu_runout entry.
   Change:  Al Dupuis	09/16/79 Added dabt_check entry.
**/


	call com_err_ (0, "gtss_abs_",
	     "See documentation for meaningful entries.");
	return;


get_id:	entry (drun_job_id) returns (char (19));

/**
	This entry returns the unique Multics absentee
	request id associated with the DRUN job id given.
**/


	caller = "gtss_abs_$get_id";
	error = "0"b;
	djid = drun_job_id;
	if ^valid_id ()
	then return (" ");
	call get_abs_id;
	return (absentee_id);


get_drm:	entry returns (char (*));

/**

	This entry returns a generated gcos_set_environment
	command, with the drm rules currently in effect.
**/

	caller = "gtss_abs_$get_drm";
	dir_map_rule = gse_ext_$drm_rule;
	if dir_map_rule = 0 then do;
	     call com_err_ (0, caller,
		"Bug, gse_ext_$drm_rule was not set.");
	     return (" ");
	end;

	if dir_map_rule = 1 then
	     return ("gse -drm umc -umc_name " || rtrim (gse_ext_$umc_name));

	else if dir_map_rule = 2 then
	     return ("gse -drm wd");

	else if dir_map_rule = 3 then
	     return ("gse -drm smc -smc_pathname "
	     || rtrim (gse_ext_$smc_pathname)
	     || " -umc_name " || rtrim (gse_ext_$umc_name));

	else call com_err_ (0, caller,
	     "gse_ext_$drm_rule invalid, value = ^a",
	     gse_ext_$drm_rule);
	return (" ");

dcl  dir_map_rule             fixed bin (24);


create_absin: entry returns (char (*));

/**	This entry generates the absin file	**/


	return ("&1" || CR
	     || "gtss$drun &2" || CR
	     || "drun" || CR
	     || "bye" || CR
	     || "logout" || CR);

abs_equiv: entry;

/**
	This entry performs the equivalent action,
	in Multics terms, that the DRUN subsystem has
	just performed. It is called from
	gtss_drl_t_cfio_ function (6), after the DRUN
	subsystem has modified the #D queue file, to
	reflect an action it has just performed.
	In the following chart, the value of action
	is the value of the status of the catalog
	entry as described in DB84, page 16-20.

	ACTION		MODULE		Multics EQUIVALENT

	  1		enter_abs_req	enters a Multics absentee request
	  4		cancel_abs_req	cancels the Multics absentee request

**/


/** Obtain pointer to #D header **/
	call gtss_dq_$hdrp (dqh_ptr);
	if dqh_ptr = null () then call gtss_abort_subsystem_ (
	     gtss_find_cond_frame_ ("derail"),
	     caller,
	     0,
	     "Could not get pointer to #D header");
	no_of_entries = dqh_ptr -> dq_header.dhbsn.no_of_cea;
	call gtss_dq_$entries_info (addr (entries_info), no_of_entries, no_of_entries_found);
	if no_of_entries_found = 0 then return;

/** Perform the equivalent absentee function **/
	do eii = 1 to no_of_entries_found;
	     call job_action (entries_info.job_stat (eii));
	end;


	return;

cpu_runout: entry (mc_ptr, name);


/* If subsystem timer running kill it	*/
	if gtss_ext_$flags.ss_time_limit_set then do;
	     call timer_manager_$reset_cpu_call (gtss_fault_processor_$timer_runout);
	     gtss_ext_$flags.ss_time_limit_set = "0"b;
	end;

/* Send error message to *CFP */
	gtss_ext_$flags.gtss_com_err_sw = "1"b;
	call com_err_$suppress_name (0, "gtss_abs_",
	     "<67> PROCESSOR TIME LIMIT EXCEEDED");

/* And pass the fault over to be processed	*/
	call gtss_fault_processor_$timer_runout (mc_ptr, name);
	return;

dabt_check: entry (mc_ptr, name);


	call ipc_$read_ev_chn (gtss_ext_$event_channel, ev_occured,
	     gtss_ext_$restart_seg_ptr, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, caller,
		"Couldn't check to see if event occured.");
	     signal condition (gtss_fail);
	end;
	if ev_occured = 0 then do;
	     call timer_manager_$cpu_call (30, "11"b, gtss_abs_$dabt_check);
	     return;
	end;

/* A DABT request has been sent by an interactive process */
	call timer_manager_$reset_cpu_call (gtss_abs_$cpu_runout);
	call timer_manager_$reset_cpu_call (gtss_fault_processor_$timer_runout);
	gtss_ext_$flags.ss_time_limit_set = "0"b;
	gtss_ext_$flags.timer_ranout = "0"b;

/* Send error message to *CFP */
	gtss_ext_$flags.gtss_com_err_sw = "1"b;
	call com_err_$suppress_name (0, "gtss_abs_",
	     "<67> TERMINATED BY DABT WHILE EXECUTING");
	
/* Put a decimal 13 in start_term so DRUN subsystem knows DABT request has
   been given. Set the next input sector to be the COUT sector. Unwind
   the primitive interpretor to it's first invokation.	*/
	gtss_ust.lcfst.start_term = 13;
	gtss_ust.lcfio.sect_in = gtss_ust.lcfst.initial_sect_out - 1;
	call gtss_interp_prim_$sysret ();		/* doesn't return */
	return;					/* just in case */

get_abs_id: proc;

/** Get the output from list_absentee_request (lar) **/
	     proc_dir = get_pdir_ ();
	     path = "ao_" || unique_chars_ ("0"b);
	     cmd_line = "fo [pd]>" || path;
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);
	     cmd_line = "lar -long";
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);
	     cmd_line = "ro";
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);

/** Overlay lar output **/
	     call hcs_$initiate_count (proc_dir, path, "", bit_count,
		1, seg_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Couldn't initiate ^a in ^a",
		     path, proc_dir);
		error = "1"b;
	     end;

/** Get the Multics absentee request id **/
	     call find_id;
	     if error then absentee_id = " ";
	     else absentee_id = abs_id;

/** Finished with lar output **/
	     call delete_$ptr (seg_ptr, "100100"b, "gtss_abs_", code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Couldn't delete ^a in ^a",
		     path, proc_dir);
	     end;


find_id:	     proc;

		did_pos = index (cs, djid);
		if did_pos = 0 then do;
		     error = "1"b;
		     return;
		end;

		table_length = did_pos - 1;
		do backup_indx = table_length to 11 by -1;
		     rid_ptr = addr (table (backup_indx - 11));
		     if rid = "Request ID:" then do;
			aid_ptr = addr (table (backup_indx + 1));
			return;
		     end;
		end;

		call com_err_ (0, caller,
		     "Bug, could not get absentee request id");
		error = "1"b;
	     end;					/* find_id */
	end;					/* get_abs_id_ */

valid_id:	proc returns (bit (1));

	     if ((d1 < "0") | (d1 > "9"))
	     | ((d2 < "0") | (d2 > "9"))
	     | ((d3 < "0") | (d3 > "9"))
	     | ((d4 < "0") | (d4 > "9"))
	     | ^((d5 = "d") | (d5 = "D"))
	     then do;
		call com_err_ (0, caller,
		     "^a is not a valid drun job id", djid);
		return ("0"b);
	     end;

	     if d5 = "d" then d5 = "D";
	     return ("1"b);

	end;					/* valid_id */


no_action: proc;

	     return;

	end;					/* no_action */

enter_abs_req: proc;


/** Check to see if request has been entered before **/
	     if entries_info.aid (eii) ^= " " then do;
		call check_date_time;
		if ^reschedule then return;
	     end;
	     caller = "gtss_abs_$enter_abs_req";


/** Generate the following command
ear [hd]>drun_control -of drun_control.nnnnD -bf {-li n -tm "DT" -rt} -ag "gse_command" nnnnD
**/

/** enter_abs_request [hd]>drun_control -of [hd]>drun_control.nnnnD -brief **/
	     call user_info_$homedir (home_dir);
	     cmd_line = "enter_abs_request " || rtrim (home_dir) || ">" || absin_file_name;
	     cmd_line = cmd_line || " -of " || rtrim (home_dir) || ">" || absin_file_name || "." || entries_info.did (eii);
	     cmd_line = cmd_line || " -brief";

	     call gtss_dq_$catp (entries_info.did (eii), dc_ptr, cat_entry);
	     if dc_ptr = null () then call gtss_abort_subsystem_ (
		null (),
		caller,
		0,
		"Couldn't get pointer to catalog entry for ^a",
		entries_info.did (eii));

/** -limit nnnnn	**/
	     if dc_ptr -> dq_catalog.dcelp ^= 0 then do;
		milsec = dc_ptr -> dq_catalog.dcelp / 64;
		sec = (milsec / 1000) + 50;		/* if gtss$drun hasn't aborted job 50 seconds
						   after time limit exceeded, let absentee do it */
		seconds = sec;
		cmd_line = cmd_line || " -limit " || seconds;
	     end;

/** {-time "mm/dd/yy {hhmm}"}	**/
	     sec = 0;
	     call gtss_bcd_ascii_ (addr (dc_ptr -> dq_catalog.dcdsd), 6, addr (requested_date));
	     requested_date = substr (requested_date, 3, 2) || "/" || substr (requested_date, 5, 2) || "/" || substr (requested_date, 1, 2);
	     cmd_line = cmd_line || " -time """ || requested_date;

	          /** Use specified time or site preferred time or now **/
	     if dc_ptr -> dq_catalog.dcdst ^= -1
	     then sec = divide (divide (dc_ptr -> dq_catalog.dcdst, 64, 36), 1000, 36);
	     else if gtss_ext_$com_reg.tsddt ^= 0
	     then sec = divide (divide (gtss_ext_$com_reg.tsddt, 64, 36), 1000, 36);
	     if sec ^= 0
	     then do;
		hrs = divide (sec, 3600, 2);
		mins = divide ((sec - (hrs * 3600)), 60, 2);
		hours = hrs;
		minutes = mins;
		requested_time = hours || minutes || ".0";
		cmd_line = cmd_line || " " || requested_time || """";
	     end;
	     else cmd_line = cmd_line || """";

/** {-restart}		**/
	     call gtss_dq_$dibp (entries_info.did (eii), dib_ptr);
	     if dib_ptr = null () then do;
		call com_err_ (0, caller,
		     "Could not get pointer to DIB for ^a", entries_info.did (eii));
		return;
	     end;
	     if dib_ptr -> dq_dib.dbflg.f_res then
		cmd_line = cmd_line || " -restart";

/** -ag "gse -drm umc|smc|wd {-smc_pathname path} {-umc_name name}" nnnnD **/
	     cmd_line = cmd_line || " -ag ""cwd ";
	     cmd_line = cmd_line||rtrim (get_wdir_ ());
	     cmd_line = cmd_line||";";
dcl get_wdir_ entry returns(char(168)aligned);
	     cmd_line = cmd_line||gtss_abs_$get_drm ();
	     cmd_line = cmd_line||"""";
	     cmd_line = cmd_line || " ";
	     cmd_line = cmd_line||entries_info.did (eii);
	     if db_abs then call ioa_ ("^a", cmd_line);
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);


	end;					/* enter_abs_request */

cancel_abs_req: proc;

/* If there is no Multics absentee id, the request has already been cancelled.
   If there is an id, and the restart segment exists, the DRUN is executing
   and was cancelled via an ipc_ signal by gtss_drl_t_cfio_ function 7.
   If it hasn't started to execute yet, it will be cancelled here via a
   cancel_abs_request.				*/


	     if entries_info.aid (eii) = " " then return;
	     call hcs_$initiate_count (gtss_ext_$homedir,
		"drun_restart." || entries_info.did (eii), "",
		bit_count, 1, gtss_ext_$restart_seg_ptr, code);
	     if gtss_ext_$restart_seg_ptr ^= null () then do;
		call hcs_$terminate_noname (gtss_ext_$restart_seg_ptr, code);
		return;
	     end;

	     cmd_line = "cancel_abs_request -id " || entries_info.aid (eii) || " -brief -all";

	     if db_abs then call ioa_ ("^a", rtrim (cmd_line));
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);

	end;					/* cancel_abs_request */

check_date_time: proc;

	     reschedule = "0"b;
	     if gtss_ust.lcjid ^= "0"b then return;	/* forget trying to reschedule if running under absentee */
	     caller = "check_date_time";
	     call gtss_dq_$catp (entries_info.did (eii), dc_ptr, cat_entry);
	     if dc_ptr = null () then call gtss_abort_subsystem_ (
		null (),
		caller,
		0,
		"Could not get pointer to ^a's catalog entry",
		entries_info.did (eii));

	     call gtss_bcd_ascii_ (addr (dc_ptr -> dq_catalog.dcdsd), 6, addr (requested_date));
	     requested_date = substr (requested_date, 3, 2) || "/" || substr (requested_date, 5, 2) || "/" || substr (requested_date, 1, 2);


/** Get the output from list_absentee_request (lar) **/
	     proc_dir = get_pdir_ ();
	     path = "ao_" || unique_chars_ ("0"b);
	     cmd_line = "fo [pd]>" || path;
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);
	     cmd_line = "lar -long" || " -id " || entries_info.aid (eii);
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);
	     cmd_line = "ro";
	     call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);

/** Overlay lar output **/
	     call hcs_$initiate_count (proc_dir, path, "", bit_count,
		1, seg_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Couldn't initiate ^a in ^a",
		     path, proc_dir);
		error = "1"b;
	     end;

/** Determine if this has been rescheduled to an earlier date/time **/
	     if index (cs, "Deferred time:") = 0 then do;
		call com_err_ (0, caller,
		     "Couldn't find the deferred time for ^a", entries_info.did (eii));
		return;
	     end;

/* Get the deferred time line			*/
	     chars = substr (cs, index (cs, "Deferred time:"));
	     chars = before (chars, CR);
	     if index (chars, "Deferred time:	" || requested_date) = 0 /* white space is tab char */
	     then reschedule = "1"b;
	     else do;				/* same date, now check the time */
		if dc_ptr -> dq_catalog.dcdst ^= -1 then do; /* if no time specified it can't be rescheduled */
		     chars = substr (chars, length ("Deferred time:	" || requested_date) + 1);
		     chars = ltrim (chars);
		     btp = addrel (addr (chars), 1);
		     if valid (based_time) then do;
			hrs = convert (hrs, substr (chars, 1, 2));
			mins = convert (mins, substr (chars, 3, 2));
			time = (hrs * 60 * 60) + (mins * 60);
			gcos_time = dc_ptr -> dq_catalog.dcdst / 1000 / 64;
			if ((gcos_time < time - 300)
			| (gcos_time > time + 300))
			then reschedule = "1"b;
			else;
		     end;
		     else do;
			call com_err_ (0, caller,
			     "Couldn't get the requested time from absentee (^a)", chars);
			return;
		     end;
		end;
		else reschedule = "0"b;
	     end;

	     if reschedule then do;
		cmd_line = "cancel_abs_request -id " || entries_info.aid (eii) || " -brief -all";
		if db_abs then call ioa_ ("^a", cmd_line);
		call cu_$cp (addrel (addr (cmd_line), 1), length (cmd_line), code);
	     end;

/** Finished with lar output **/
	     call delete_$ptr (seg_ptr, "100100"b, "gtss_abs_", code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Couldn't delete ^a in ^a",
		     path, proc_dir);
	     end;
	end;					/* check_date_time */

/*	gtss_get_abs_id_ local declares */

dcl  absentee_id              char (19);
dcl  absin_file_name          char (12) init ("drun_control");
dcl  abs_id                   char (19) based (aid_ptr);
dcl  aid                      char (19);
dcl  aid_ptr                  ptr init (null());
dcl  backup_indx              fixed bin (24);
dcl  based_time		pic "9999v.9" based (btp);
dcl  btp			ptr;
dcl  bit_count                fixed bin (24);
dcl  caller                   char (32) varying;
dcl  cat_entry                fixed bin (18) unsigned;
dcl  chars		char (256) varying;
dcl  cmd_line                 char (350) varying;
dcl  code                     fixed bin (35);
dcl  com_err_$suppress_name   entry options (variable);
dcl  convert_ipc_code_	entry (fixed bin (35));
dcl  cs                       char (bit_count / 9) based (seg_ptr);
dcl  cu_$cp                   entry (ptr, fixed bin, fixed bin (35));
dcl  dc_ptr                   ptr init (null());
dcl  delete_$ptr              entry (pointer, bit (6), char (*), fixed bin (35));
dcl  dib_ptr                  ptr init (null ());
dcl  did_pos                  fixed bin (24);
dcl  djid                     char (5);
dcl  dqh_ptr                  ptr init (null());
dcl  drun_job_id              char (5) parm;
dcl  eii                      fixed bin (18) unsigned;
dcl  error                    bit (1) init ("0"b);
dcl  ev_occured		fixed bin;
dcl  get_pdir_                entry returns (char (168));
dcl  gcos_time		fixed bin (36) unsigned;
dcl  gtss_fail		condition ext;
dcl  hcs_$initiate_count      entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname    entry (ptr, fixed bin (35));
dcl  home_dir                 char (64);
dcl  hours                    char (2);
dcl  hrs                      pic "99";
dcl  i                        fixed bin (18) unsigned;
dcl  ioa_                     entry options (variable);
dcl  ipc_$read_ev_chn	entry (fixed bin (71), fixed bin, ptr, fixed bin (35));
dcl  mc_ptr		ptr parm;
dcl  milsec                   fixed bin (35);
dcl  mins                     pic "99";
dcl  minutes                  char (2);
dcl  name			char (4) parm;
dcl  no_of_entries            fixed bin (18) unsigned;
dcl  no_of_entries_found      fixed bin (18) unsigned;
dcl  old_min                  pic "s99";
dcl  path                     char (18);
dcl  proc_dir                 char (168);
dcl  requested_date           char (8);
dcl  requested_time           char (6);
dcl  reschedule               bit (1);
dcl  rid                      char (11) based (rid_ptr);
dcl  rid_ptr                  ptr init (null());
dcl  sec                      fixed bin (35) init (0);
dcl  seconds                  pic "99999";
dcl  seg_ptr                  ptr init (null());
dcl  spare_indx               fixed bin (24);
dcl  table                    (table_length) char (1) based (seg_ptr);
dcl  table_length             fixed bin (24);
dcl  time 		fixed bin (36) unsigned;
dcl  timer_manager_$cpu_call	entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call	entry (entry);
dcl  unique_chars_            entry (bit (*)) returns (char (15));
dcl  user_info_$homedir       entry (char (*));

dcl  CR                       char (1) init ("
");

dcl 1 d defined djid,
      2 d1 char (1),
      2 d2 char (1),
      2 d3 char (1),
      2 d4 char (1),
      2 d5 char (1);

dcl  job_action               (0:7) entry init (
	no_action,
	enter_abs_req,
	no_action,
	no_action,
	cancel_abs_req,
	no_action,
	no_action,
	no_action);

dcl 1 entries_info (315),
      2 did char (5),
      2 aid char (19),
      2 job_stat fixed bin (6) unsigned;
dcl 1 event_info based (gtss_ext_$restart_seg_ptr),
      2 channel_id fixed bin (71),
      2 message fixed bin (71),
      2 sender bit (36),
      2 origin,
        3 dev_signal bit (18) unal,
        3 ring bit (18) unal,
      2 channel_index fixed bin;

%include gtss_deferred_queue;

%include gtss_ext_;

%include gtss_entry_dcls;

%include gse_ext_;

%include gtss_db_names;

%include gtss_ust_ext_;
     end;						/* gtss_abs_ */
  



		    gtss_abs_login_banner_.pl1      12/11/84  1349.3rew 12/10/84  1042.7       17478


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

gtss_abs_login_banner_: proc returns (char (*));

	call user_info_$login_data (pid, pjid, acct, anon, stby, wt, time_login, lw);
	call decode_clock_value_$date_time (time_login, month, dom, year, hour, minute, second, microsecond, dow, "", code);
	call gtss_bcd_ascii_ (addr (gtss_ust.lcjid), 5, addr (ascii_lcjid));
	call ioa_$rs ("HIS SERIES 6000 ON ^d/^d/^d AT ^d.^d  DEFERRED # ^a",
		    ret_string, ret_len,
		    month, dom, year - 1900,
		    hour, minute * 1000 / 60, ascii_lcjid);
	return (substr (ret_string, 1, ret_len));

/* gtss_abs_login_banner_ local declares */
dcl acct char (32);
dcl anon fixed bin;
dcl ascii_lcjid char (5);
dcl clock_ entry returns (fixed bin (71));
dcl code fixed bin (35);
dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin,
		fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35));
dcl dom fixed bin;
dcl dow fixed bin;
dcl hour fixed bin;
dcl ioa_$rs entry options (variable);
dcl lw char (5);
dcl minute fixed bin;
dcl microsecond fixed bin (71);
dcl month fixed bin;
dcl pid char (22);
dcl pjid char (9);
dcl ret_len fixed bin (21);
dcl ret_string char (256);
dcl second fixed bin;
dcl stby fixed bin;
dcl time_login fixed bin (71);
dcl wt fixed bin;
dcl user_info_$login_data entry (char (*), char (*), char (*), fixed bin, fixed bin, fixed bin, fixed bin (71), char (*));
dcl year fixed bin;


%include gtss_ust_ext_;

%include gtss_entry_dcls;
end; /* gtss_abs_login_banner_ */
  



		    gtss_abs_logout_banner_.pl1     12/11/84  1349.3rew 12/10/84  1042.7       21906


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

gtss_abs_logout_banner_: proc returns (char (*));

	call user_info_$limits (mlim, clim, cdate, crf, shlim, msp, csp, shsp);
	call user_info_$login_data (pid, pjid, acct, anon, stby, wt, time_login, lw);
	call decode_clock_value_$date_time (time_login, month, dom, year, hour, minute, second, microsecond, dow, "", code);
	hr = hour;
	min = minute;
	call decode_clock_value_$date_time (clock_ (), month, dom, year, hour, minute, second, microsecond, dow, "", code);
	call ioa_$rs ("**COST:  $ ^d.00 TO DATE:  $ ^d.00"
	     || "^/**ON AT ^d.^d - OFF AT ^d.^d ON ^d/^d/^d",
	     ret_string, ret_len,
	     session_cost, msp,
	     hr, min * 1000 / 60, hour, (minute * 1000 / 60) + 11, month, dom, year - 1900);
	return (substr (ret_string, 1, ret_len));

dcl acct char (32);
dcl anon fixed bin;
dcl cdate fixed bin (71);
dcl clim float bin;
dcl clock_ entry returns (fixed bin (71));
dcl code fixed bin (35);
dcl crf fixed bin;
dcl csp float bin;
dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin,
		fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35));
dcl dom fixed bin;
dcl dow fixed bin;
dcl hour fixed bin;
dcl hr fixed bin;
dcl ioa_$rs entry options (variable);
dcl lw char (5);
dcl microsecond fixed bin (71);
dcl min fixed bin;
dcl minute fixed bin;
dcl mlim float bin;
dcl month fixed bin;
dcl msp float bin;
dcl pid char (22);
dcl pjid char (9);
dcl ret_len fixed bin (21);
dcl ret_string char (300);
dcl second fixed bin;
dcl session_cost fixed bin init (0);
dcl shlim (0:7) float bin;
dcl shsp (0:7) float bin;
dcl stby fixed bin;
dcl time_login fixed bin (71);
dcl wt fixed bin;
dcl user_info_$limits entry (float bin, float bin, fixed bin (71), fixed bin, (0:7) float bin,
		float bin, float bin, (0:7) float bin);
dcl user_info_$login_data entry (char (*), char (*), char (*), fixed bin, fixed bin, fixed bin, fixed bin (71), char (*));
dcl year fixed bin;
     end;						/* gtss_abs_logout_banner_ */
  



		    gtss_adjust_size_.pl1           12/11/84  1349.3rew 12/10/84  1042.7       11457


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_adjust_size_: proc (gfap);
dcl  gfap ptr parm;

/* Adjust size of user file.

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

/* Adjust the size field in the descriptor of the attributes structure. */

	gtss_file_attributes_ptr = gfap;
	s = current_size;
	if ^llink_flag then
	     s = divide (s, 12, 24, 0);
	if s_overflow then s_size = "0"b;
	size = s_size;

dcl  s fixed bin (24);
dcl 1 s_overlay aligned based (addr (s)),
    2 s_overflow bit (22) unal,
    2 s_size bit (14) unal;

%include gtss_file_attributes;
     end gtss_adjust_size_;
   



		    gtss_aft_.pl1                   12/11/84  1349.3rew 12/10/84  1042.8       47727


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

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

/**	Provide gtss AFT (Available File Table) functions.

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

/**	Declaration of parameters for all
	entry points.
 **/
dcl	status		fixed bin(24)parm;
dcl	name		char(8)parm;
dcl	file_no		fixed bin(24)parm;
	call com_err_ (0, "gtss_aft_",
	     "See gtss_aft_ documentation for meaningful entries.");
	return;

initialize: entry (status);
/**	Initialize gtss_ext_$aft structure (external)
	to make all entries available.
 **/
	status = 0;				/* => successful. */
	start_list = 0;				/* => start list empty. */
	used = "0"b;				/* => AFT empty. */
	altname = " ";
	previous_add = 0;
	next_add = 0;
	do i = 2 to hbound (aft_entry, 1);		/* Link all entries available. */
	     next_entry (i-1) = i;
	end;
	next_entry (hbound (aft_entry, 1)) = 0;		/* End of available chain. */
	free_space = 1;				/* 1st aft_entry available. */
	first_added, last_added = 0;			/* No entries yet. */
	return;

add:	entry (name, file_no, status);
	n = translate (name, lower, upper);
	i = mod (n_fb72, hbound (start_list, 1)+1);
	k = start_list (i);
	do while (k>0);				/* Examine for name in aft table. */
	     if n = altname (k) then do;		/* Already in table. */
		file_no = k;
		status = 1;
		return;
	     end;
	     k = next_entry (k);			/* Link to next entry. */
	end;
/* (good) name not in table. */
	k = free_space;
	if k = 0 then do;				/* No entries available. */
	     file_no = 0;
	     status = 2;
	     return;
	end;

	free_space = next_entry (k);			/* Set free_space to next available. */
	altname (k) = n;				/* Place new name in aft. */
	next_entry (k) = start_list (i);		/* Link name into hash chain. */
	used (k) = "1"b;				/* => in use. */
	start_list (i) = k;				/* Reset start of hash chain. */

/**	Update order added chain.	**/
	if last_added = 0 then do;			/* First aft entry. */
	     first_added, last_added = k;
	     previous_add (k), next_add (k) = 0;
	end;
	else do;					/* Not the first entry. */
	     previous_add (k) = last_added;		/* The current last is before me. */
	     next_add (last_added) = k;		/* Place me at end of order added chain. */
	     next_add (k) = 0;			/* I am the last. */
	     last_added = k;			/* Now I'm the last. */
	end;

	file_no = k;
	status = 0;				/* New name successfully added. */
	return;

find:	entry (name, file_no, status);
	n = translate (name, lower, upper);
	k = start_list (mod (n_fb72, hbound (start_list, 1)+1));
	do while (k>0);
	     if n = altname (k) then do;		/* Found. */
		file_no = k;
		status = 0;
		return;
	     end;
	     k = next_entry (k);			/* Link to next entry in hash chain. */
	end;
/* Not found. */
	file_no = 0;
	status = 1;
	return;

delete:	entry (name, file_no, status);
	n = translate (name, lower, upper);
	i = mod (n_fb72, hbound (start_list, 1)+1);
	k = start_list (i);
	p = addr (start_list (i));			/* To be reset. */
	do while (k>0);
	     if n = altname (k) then do;		/* Found. */
		p -> fb = next_entry (k);		/* Link around k-th entry. */
		next_entry (k) = free_space;		/* Make k-th entry available. */
		used (k) = "0"b;			/* => not in use. */
		free_space = k;			/* Reset start of free entry chain. */

/**	Adjust add order chain.		**/
		goto FL (fixed ((first_added = k)|| (last_added = k)));

FL(0):;	/** Neither first nor last. **/
		previous_add (next_add (k)) = previous_add (k);
		next_add (previous_add (k)) = next_add (k);
		goto fin_FL;

FL(1):;	/** Not the first but is the last. **/
		i = previous_add (k);
		last_added = i;
		next_add (i) = 0;
		goto fin_FL;

FL(2):;	/** First but not last. **/
		i = next_add (k);
		first_added = i;
		previous_add (i) = 0;
		goto fin_FL;

FL(3):;	/** First and last. **/
		first_added, last_added = 0;		/* Final name deleted. */

fin_FL:		;

		file_no = k;
		status = 0;
		return;
	     end;
	     p = addr (next_entry (k));		/* To be reset. */
	     k = next_entry (k);			/* Link to next entry in hash chain. */
	end;
/* Not found. */
	file_no = 0;
	status = 1;
	return;

/**	Variables for gtss_aft_:
	IDENTIFIER	ATTRIBUTES	**/
dcl	com_err_		entry options(variable);
dcl	fb		fixed bin(24)based;
dcl	hbound		builtin;
dcl	i		fixed bin(24);
dcl	k		fixed bin(24);
dcl	lower		char(26)aligned static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl	mod		builtin;
dcl	n		char(8)aligned	/* Local name value. */;
dcl	n_fb72		fixed bin(71)aligned based(addr(n))	/* Name as numeric value. */;
dcl	p		ptr;
dcl	translate		builtin;
dcl	upper		char(26)aligned static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

%include	gtss_ext_;
     end						/* gtss_aft_ */;
 



		    gtss_ascii_bcd_.alm             12/11/84  1349.3rew 12/10/84  1042.8       27675


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

"	ASCII to BCD conversion routine.
"
"	dcl	gtss_ascii_bcd_ entry(ptr,FB,ptr);
"	Parm 1:	Pointer to (input) ascii string.
"	Parm 2:	Length of (input) string.
"	Parm 3:	Pointer to (output) bcd string.
"		(caller must assure output string long enough).
"
"	dcl	gtss_print_line_bcd_ entry(ptr,FB,ptr,FB);
"	MORE
"
"	dcl	gtss_ascii_bcd_check_ entry(ptr,FB,ptr,FB);
"	MORE
"
"
"	Author:	Dave Ward		05/22/78
"			(from gcos_cv_ascii_gebcd_)
"
	name	gtss_ascii_bcd_
	entry	gtss_ascii_bcd_
	entry	gtss_ascii_bcd_check_
	entry	gtss_printline_bcd_

gtss_ascii_bcd_:
	eppbp	ap|2,*		bp -> input data
	eppbp	bp|0,*
	lda	ap|4,*		a = length
	eppbb	ap|6,*		bb -> output buffer
	eppbb	bb|0,*

join:	mvt	(pr,rl),(pr,rl)
	desc9a	bp|0,al
	desc6a	bb|0,al
	arg	table

	short_return


gtss_ascii_bcd_check_:
	eppbp	ap|2,*
	eppbp	bp|0,*		bp -> input data
	lda	ap|4,*		a = length
	eppbb	ap|6,*		bb -> output buffer
	eppbb	bb|0,*

	tct	(pr,rl)
	desc9a	bp|0,al
	arg	tctable
	arg	bb|0

	stz	ap|8,*
	ttn	join		no illegal chars found
	lda	bb|0
	ana	-1,dl
	ada	1,dl		move count from last good to first bad char
	sta	ap|8,*		store error code
	short_return

gtss_printline_bcd_:
	save
	eppbp	ap|2,*		bp -> input data
	eppbp	bp|0,*
	lxl7	ap|4,*
	eppbb	ap|6,*		bb -> output buffer
	eppbb	bb|0,*
	stz	tally		zero output character count

	scm	(pr,rl),(du),mask(016)
	desc9a	bp|0,x7
	arg	0
	arg	tally

	ldq	tally
	tze	ttf
	mvt	(pr,rl),(pr,rl)
	desc9a	bp|0,ql
	desc6a	bb|0,ql
	arg	table
	ttn	ret

ttf:	stz	count

pull:	mlr	(pr,ql),(pr),fill(0)
	desc9a	bp|0,1
	desc9a	temp,4

	lda	temp
	cmpa	=o012000,du
	tnz	not_nl
	aos	count
	adq	1,dl
	cmpq	ap|4,*
	tmi	pull
put_nl:	lda	count
	als	24
	ana	=o007700,du
	ora	=o770000,du
	sta	NL
	eppbp	NL
	tra	put_cc

not_nl:	szn	count
	tnz	put_nl
	cmpa	=o014000,du
	tnz	ret
	eppbp	NP
put_cc:	ldq	tally
	mlr	(pr),(pr,ql)
	desc6a	bp|0,2
	desc6a	bb|0,2
	adq	2,dl

ret:	stq	ap|8,*
	return

table:	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020020020020
	oct	020077076013
	oct	053074032057
	oct	035055054060
	oct	073052033061
	oct	000001002003
	oct	004005006007
	oct	010011015056
	oct	036075016017
	oct	014021022023
	oct	024025026027
	oct	030031041042
	oct	043044045046
	oct	047050051062
	oct	063064065066
	oct	067070071012
	oct	037034040072
	oct	057021022023
	oct	024025026027
	oct	030031041042
	oct	043044045046
	oct	047050051062
	oct	063064065066
	oct	067070071012
	oct	040034020020

tctable:	dec	-1,-1,-1,-1,-1,-1,-1,-1
	dec	0,0,0,0,0,0,0,0
	dec	0,0,0,0,0,0,0,0
	dec	0,0,0,0,0,0,0
	vfd	9/0,9/0,9/1,9/1

NP:	oct	772000000000
	temp	NL,temp,tally,count
	end
 



		    gtss_attributes_mgr_.pl1        12/11/84  1349.3rew 12/10/84  1042.8      170604


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

gtss_attributes_mgr_: proc;

/**	Procedure to obtain and set the attribute values on
	a (Multics) GCOS file.

	The values are stored in names added to the file name.

	Given a Multics GCOS file with added names of the form:
		E.N.V

	where:	E => single element entry name on the file.
		N => attribute name (4 character, see attr_name array).
		V => current value of that attribute.

	Values are provided by the caller in the structure
	gtss_file_values (See gtss_file_values.incl.pl1).

	The 4 variables: version, dname, ename and new_ename
	(in the gtss_file_values) are filled in by the caller
	and the get entry called to obtain the current
	attributes for the designated file (returned
	in the gtss_file_values structure. set_switch
	values are not returned).

	The set entry requires the same 4 variables as for
	get. In addition bits are set "1"b in set_switch
	variables to indicate an attribute to set and the
	corresponding (non set_switch) variable set to the
	new value desired. Note the use of ename and
	new_ename combinations to provide for setting
	initial attributes and renaming as well as
	resetting values.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	08/14/79 db_attributes_mgr installation.
   Change:  Dave Ward	08/25/79 Revised noal setting.
   Change:  Ron Barstad	83-08-17 replaced hcs_$(initiate chname_seg) with chname_file
**/

	call com_err_ (0, "gtss_attributes_mgr_", "Entries are $get and $set.");
	return;
%page;
get:	entry (vp, rc);

/**	Obtain file attribute values.
**/
dcl  rc                       fixed bin(35)parm;
dcl  set_entry                bit(1);
dcl  vp                       ptr parm;

	fvp = vp;					/* Obtain values in caller's structure. */
	set_entry = "0"b;
	goto continue;


set:	entry (vp, rc);

/**	Set file attribute values.	**/

	fvp = addr (gtss_file_values);		/* Obtain values for set. */
	set_entry = "1"b;

continue:	;
						/* Verify caller's vp usable. */
	if (vp = null ()) |
	((addr (vp) -> bit72&get_ptr_bits) ^= ptr_constant) then do;
	     rc = error_table_$bad_ptr;
	     goto exit;
	end;


	if set_entry then do;			/* Obtain version and file name. */
	     gtss_file_values.version = vp -> fv.version;
	     gtss_file_values.dname = vp -> fv.dname;
	     gtss_file_values.ename = vp -> fv.ename;
	     gtss_file_values.new_ename = vp -> fv.new_ename;
	end;

	fv.info_ptr = null ();

	if fv.version ^= 1 then do;			/* Current version must be 1. */
	     rc = error_table_$unimplemented_version;
	     goto exit;
	end;

	en = fv.ename;

	c = fixed ((fv.ename ^= " ") || (fv.new_ename ^= " "), 2);
	goto name_case (c);

name_case(0):; /** Neither old nor new name given. */
	rc = error_table_$badpath;
	goto exit;

name_case(1):; /** New name only. **/
	if set_entry then goto do_set;
	rc = error_table_$bad_entry_point_name;
	goto exit;

name_case(2):; /** Old name only. **/
name_case(3):; /** Both old and new names. **/

	call hcs_$status_long (
	     fv.dname
	     , fv.ename
	     , 1b					/* Chase link. */
	     , addr (si)
	     , addr (names_area)
	     , code
	     );
	if code ^= 0 then do;
	     rc = code;
	     goto exit;
	end;

	fv.info_ptr = addr (si);

	if (si.type = "10"b) & (si.bit_count = "0"b) then do; /* Multics directory. */
	     fv.catalog = "1"b;			/* File is a catalog. */
	     fv.data_flags.mode_random = "1"b;
	     fv.data_flags.busy
		, fv.data_flags.null_file
		, fv.attributes.attr
		= "0"b;
	     fv.data_fields.maxll
		, fv.data_fields.curll = divide (fixed (si.records_used, 24)*1024, 320, 24);
	     fv.data_fields.number_allocations = 1;
	     fv.creation_date = dt (si.dtbm);

	     if set_entry then
		rc = error_table_$not_seg_type;
	     else
	     rc = 0;
	     goto exit;
	end;

	fv.catalog = "0"b;				/* File is not a catalog. */

	nn = fixed (si.nnames, 17);			/* Number of names on the file. */
	anp = pointer (addr (names_area), si.names_relp);
	string (have_attr) = "0"b;
	do i = 1 to nn;

/* Partition the i-th name into E, N, V fields. */
	     namei = file_name (i);
	     k = search (reverse (namei), ".");
	     if k = 0 then goto next;			/* No periods in i-th name. */

/* Set initial lengths of name fields. */
	     Nl = length (namei)-k;
	     Vl = k-1;

/* Set final lengths of name fields. */
	     k = search (reverse (name2.EN), ".");
	     if k = 0 then goto next;			/* Not 2 periods in name. */
	     El = Nl-k;
	     Nl = k-1;

/* Adjust value length to exclude
   trailing spaces. */
	     Vl = length (rtrim (name.V));

/* Prefix before attribute name must
   be the same as the file entry name.
*/
	     if fv.ename ^= name.E then goto next;

/* Establish which attribute this name specifies. */
	     k = index (string (attr_name), name.N);
	     if k = 0 then goto next;			/* Not one of attribute names. */
	     if mod (k-1, length (attr_name (0)))>0 then goto next; /* Not an attribute. */
	     k = divide (k-1, length (attr_name (0)), 17); /* k => which attribute. */
	     if set_entry then name_index (k) = i;	/* Record that i-th name is to be
						   used to replace the k-th attribute. */
	     goto set_mode (k);

set_mode(0):;	/** (mode) Random or sequential. **/
	     if name.V = "r" then do;
		fv.data_flags.mode_random = "1"b;
		have_attr (k) = "1"b;		/* Mark mode random. */
	     end;
	     else
	     if name.V = "s" then do;
		fv.data_flags.mode_random = "0"b;
		have_attr (k) = "1"b;		/* Mark mode sequential. */
	     end;
	     goto next;

set_mode(1):;	/** (maxl) Maximum length of file. **/
	     fv.data_fields.maxll = get_dec_value (k);
	     goto next;

set_mode(2):;	/** (curl) Current length of file. **/
	     fv.data_fields.curll = get_dec_value (k);
	     goto next;

set_mode(3):;	/** (busy) File in use. */
	     fv.data_flags.busy = yes_or_no (k);
	     goto next;

set_mode(4):;	/** (attr) User specified file attributes. **/
	     fv.attributes.attr = get_oct_value (k);
	     goto next;

set_mode(5):;	/** (null) File has never been written to. **/
	     fv.data_flags.null_file = yes_or_no (k);
	     goto next;

set_mode(6):;	/** (noal) Number of allocations, i.e., simulator accesses. **/
	     if set_entry then do;
		if vp -> fv.set_switch.number_allocations then do; /* Obtain for increment. */
		     if vp -> fv.data_fields.number_allocations>0 then /* But only if not initial value. */
			current_number_allocations = get_dec_value (k);
		end;
		else
		fv.data_fields.number_allocations = get_dec_value (k);
		have_attr (k) = "1"b;
	     end;
	     else					/* Obtain for caller. */
	     fv.data_fields.number_allocations = get_dec_value (k);
	     goto next;

set_mode(7):;	/** (crdt) File creation date. **/
	     fv.creation_date = name.V;
	     have_attr (k) = "1"b;
	     goto next;

next:	     ;

	end;

	if (^string (have_attr) ^= "0"b) then do;	/* Not all values obtained. */
	     rc = error_table_$action_not_performed;
	     goto exit;
	end;

	if ^set_entry then do;			/* Conclude return. */
	     rc = 0;
	     goto exit;
	end;
%page;
/* Reset added names => set entry called. */
do_set:	;
	lvp = vp;					/* Local vp. */
	if c = 2 then				/* New name same as ename. */
	     new = rtrim (fv.ename);
	else do;					/* Use new ename. */
	     new = rtrim (fv.new_ename);
	     if c = 1 then				/* Only new name specified. */
		en = new;
	     else					/* ename and new_ename specified. */
	     if string (set_sw) = "0"b then do;
						/* Nothing to set => just remaning old values. */
		set_sw = "1"b;			/* Reset all values. */
		lvp -> fv.data_flags = fv.data_flags;
		lvp -> fv.data_fields = fv.data_fields;
		lvp -> fv.attributes.attr = fv.attributes.attr;
		lvp -> fv.data_fields.number_allocations = fv.data_fields.number_allocations;
		lvp -> fv.creation_date = fv.creation_date;
	     end;
	end;

	if lvp -> fv.change_name then do;		/* Rename the entry. */
	     call hcs_$chname_file (
		(gtss_file_values.dname)
		, en
		, en				/* Old name. */
		, (lvp -> fv.new_ename)		/* New name. */
		, code
		);
	     if code ^= 0 then do;
		rc = code;
		goto exit;
	     end;

/* File entry is now the new name. */
	     en = lvp -> fv.new_ename;

/* Assure all values provided. */
	     if ^lvp -> fv.set_switch.mode_random then
		lvp -> fv.data_flags.mode_random = fv.data_flags.mode_random;
	     if ^lvp -> fv.set_switch.maxll then
		lvp -> fv.data_fields.maxll = fv.data_fields.maxll;
	     if ^lvp -> fv.set_switch.curll then
		lvp -> fv.data_fields.curll = fv.data_fields.curll;
	     if ^lvp -> fv.set_switch.busy then
		lvp -> fv.data_flags.busy = fv.data_flags.busy;
	     if ^lvp -> fv.set_switch.attr then
		lvp -> fv.attributes.attr = fv.attributes.attr;
	     if ^lvp -> fv.set_switch.null_file then
		lvp -> fv.data_flags.null_file = fv.data_flags.null_file;
	     if ^lvp -> fv.set_switch.number_allocations then
		lvp -> fv.data_fields.number_allocations = fv.data_fields.number_allocations;
	     if ^lvp -> fv.set_switch.creation_date then
		lvp -> fv.creation_date = fv.creation_date;
	     set_sw = "1"b;
	end;

	new = new||".";
	n = " ";

	do i = lbound (name_index, 1) to hbound (name_index, 1);
	     if ^set_sw (i) then goto next_change;
	     if c>1 then
		n = file_name (name_index (i));	/* The name to change. */
						/* Form change name up to suffix. */
	     cn = new;
	     cn = cn||attr_name (i);
	     cn = cn||".";
	     goto set_change (i);

set_change(0):;	/** (mode) Random or sequential. **/
	     if lvp -> fv.data_flags.mode_random then cn = cn||"r";
	     else cn = cn||"s";
	     goto make_change;

set_change(1):;	/** (maxl) Maximum length of file. **/
	     pic12 = lvp -> fv.data_fields.maxll;
	     cn = cn||tlz (pic12c);
	     goto make_change;

set_change(2):;	/** (curl) Current length of file. **/
	     pic12 = lvp -> fv.data_fields.curll;
	     cn = cn||tlz (pic12c);
	     goto make_change;

set_change(3):;	/** (busy) File in use. */
	     if lvp -> fv.data_flags.busy then cn = cn||"yes";
	     else cn = cn||"no";
	     goto make_change;

set_change(4):;	/** (attr) User specified file attributes. **/
	     v.r = lvp -> fv.attributes.attr;
	     v.f = "0"b;
	     do k = 1 to 12;
		cn = cn||substr ("01234567", fixed (va (k), 17)+1, 1);
	     end;
	     goto make_change;

set_change(5):;	/** (null) File has never been written to. **/
	     if lvp -> fv.data_flags.null_file then cn = cn||"yes";
	     else cn = cn||"no";
	     goto make_change;

set_change(6):;	/** (noal) Number of allocations by GCOS simulator. */
	     pic12 = mod (current_number_allocations+lvp -> fv.data_fields.number_allocations, 262144);
	     cn = cn||tlz (pic12c);
	     goto make_change;

set_change(7):;	/** (crdt) Creation date MMDDYY **/
	     cn = cn||lvp -> fv.creation_date;
	     goto make_change;


make_change:   ;

	     call hcs_$chname_file (
		(gtss_file_values.dname)
		, en
		, rtrim (n)			/* Old name. */
		, (cn)				/* New name. */
		, code
		);
	     if code ^= 0 then
		if code ^= error_table_$segnamedup then do;
		     if db_attributes_mgr then
			call com_err_ (
			code
			, "gtss_attributes_mgr_"
			, "File attribute, added name, ""^a"" already exists."
			, cn
			);
		     rc = code;
		     goto exit;
		end;

next_change:   ;

	end;

	rc = 0;					/* All values have be obtained and reset. */

exit:	;
	if db_attributes_mgr then call pr_vals (vp);
	return;
%page;
dt:	proc (d)returns (char (6));

/* Map Multics (36 bit) date d to gcos MMDDYY. */
dcl  d                        bit(36)parm;
	     call date_time_$fstime (d, r);
	     return (mm||dd||yy);

dcl  date_time_$fstime        entry(bit(36),char(*));
dcl  r                        char(24);
dcl 1 r1 aligned based(addr(r))
,     2 mm char(2)unal
,     2 s1 char(1)unal
,     2 dd char(2)unal
,     2 s2 char(1)unal
,     2 yy char(2)unal
;
	end dt ;
%page;
get_dec_value: proc (k)returns (fixed bin);

/**	Return the numeric string that is the suffix on the
	entry name (n) converted to binary and set k-th
	attribute processed.
**/
dcl  k                        fixed bin parm;
	     if verify (name.V, "0123456789")>0 then return (0); /* Not all numeric (fail). */
	     have_attr (k) = "1"b;
	     return (fixed (name.V, 17));

	end get_dec_value ;
%page;
get_oct_value: proc (k)returns (bit (35));

/**	Return the suffix of the entry name (n) treated as
	a 12 digit octal value (the left 35 bits).
	Mark k-th attribute processed.
**/
dcl  k                        fixed bin parm;

	     v.r = "0"b;
	     do j = 1 to length (name.V);
		i = search ("01234567", substr (name.V, j, 1))-1;
		if i = -1 then return ((35)"0"b);
		va (j) = i3;
	     end;
	     have_attr (k) = "1"b;
	     return (v.r);

dcl  i                        fixed bin(35);
dcl  j                        fixed bin;

dcl 1 i_ovl aligned based(addr(i)),
    2 left33 bit(33)unal,
    2 i3     bit( 3)unal;
	end get_oct_value ;
%page;
pr_vals:	proc (p);

/* Print a gtss_file_values. */
dcl  p                        ptr parm;
	     if set_entry then do;
		ssp = addr (p -> fv.set_switch);
		call com_err_ (rc, "gtss_attributes_mgr_$set");
	     end;
	     else do;
		ssp = addr (ones);
		call com_err_ (rc, "gtss_attributes_mgr_$get");
	     end;
	     call ioa_ ("version^-^i", p -> fv.version);
	     call ioa_ ("dname^-""^a""", p -> fv.dname);
	     call ioa_ ("ename^-""^a""", p -> fv.ename);
	     call ioa_ ("new_ename^-""^a""", p -> fv.new_ename);
	     call ioa_ ("change_name^-^a", no_yes (fixed (p -> fv.change_name, 1)));
	     call ioa_ ("catalog^-^a", no_yes (fixed (p -> fv.catalog, 1)));
	     call ioa_ ("info_ptr^-^p", p);
	     a = 0;
	     a35 = p -> fv.attributes.attr;
	     if ss (0) then call ioa_ ("0. ^a mode_random^-""^1b""b", attr_name (0), p -> fv.data_flags.mode_random);
	     if ss (1) then call ioa_ ("1. ^a maxll^-^i", attr_name (1), p -> fv.data_fields.maxll);
	     if ss (2) then call ioa_ ("2. ^a curll^-^i", attr_name (2), p -> fv.data_fields.curll);
	     if ss (3) then call ioa_ ("3. ^a busy^-""^1b""b", attr_name (3), p -> fv.data_flags.busy);
	     if ss (4) then call ioa_ ("4. ^a attr^-^w", attr_name (4), a);
	     if ss (5) then call ioa_ ("5. ^a null_file^-""^1b""b", attr_name (5), p -> fv.data_flags.null_file);
	     if ss (6) then call ioa_ ("6. ^a number_allocations^-^i", attr_name (6), p -> fv.data_fields.number_allocations);
	     if ss (7) then call ioa_ ("7. ^a creation_date^-^a", attr_name (7), p -> fv.creation_date);
	     return;

dcl  a                        fixed bin(35);
dcl 1 ao aligned based(addr(a)),
    2 a35 bit(35)unal,
    2 a01 bit(01)unal;
dcl  ioa_                     entry options(variable);
dcl  no_yes                   (0:1)char(3)static int options(constant)init("no","yes");
dcl  ones                     bit(36)init((36)"1"b);
dcl  ss                       (0:36)bit(1)unal based(ssp);
dcl  ssp                      ptr;
	end pr_vals ;
%page;
tlz:	proc (c12)returns (char (12)var);

/* Trim left zeroes from c12, but retain
   one zero if all zeroes.
*/
dcl  c12                      char(12)parm;
	     r = ltrim (c12, "0");
	     if r = "" then return ("0");
	     return (r);

dcl  r                        char(12)var;
	end tlz ;
%page;
yes_or_no: proc (k)returns (bit (1));

/**	Return "1"b if suffix is "yes" and "0"b if it is "no".
	Set attribute processed.
**/
dcl  k                        fixed bin parm;
	     if name.V = "yes" then do;
		have_attr (k) = "1"b;
		return ("1"b);
	     end;
	     if name.V = "no" then
		have_attr (k) = "1"b;
	     return ("0"b);
	end yes_or_no ;
%page;
/*   Variables for gtss_attributes_mgr_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  anp                      ptr init(null());
dcl  c                        fixed bin(2);
dcl  cn                       char(32)var;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry options(variable);
dcl  current_number_allocations fixed bin(35)init(0);
dcl  El                       fixed bin(24);
dcl  empty                    builtin;
dcl  en                       char(32);
dcl  error_table_$action_not_performed fixed bin(35)ext;
dcl  error_table_$badpath     fixed bin(35)ext;
dcl  error_table_$bad_entry_point_name fixed bin(35)ext;
dcl  error_table_$bad_ptr     fixed bin(35)ext;
dcl  error_table_$duplicate_file_id fixed bin(35)ext;
dcl  error_table_$not_seg_type fixed bin(35)ext;
dcl  error_table_$segnamedup  fixed bin(35)ext;
dcl  error_table_$unimplemented_version fixed bin(35)ext;
dcl  file_name                (nn)char(32)aligned based(anp);
dcl  file_ptr                 ptr;
dcl  fvp                      ptr init(null());
dcl  have_attr                (0:7)bit(1);
dcl  hcs_$chname_file         entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$initiate            entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$status_long         entry(char(*),char(*),fixed bin(1),ptr,ptr,fixed bin(35));
dcl  i                        fixed bin;
dcl  index                    builtin;
dcl  k                        fixed bin;
dcl  length                   builtin;
dcl  lvp                      ptr init(null());
dcl  n                        char(32)aligned;
dcl  namei                    char(32)aligned;
dcl  names_area               area(1000)init(empty());
dcl  name_index               (0:7)fixed bin;
dcl  new                      char(32)var;
dcl  Nl                       fixed bin(24);
dcl  nn                       fixed bin;
dcl  pic12                    pic "(12)9";
dcl  pic12c                   char(12)based(addr(pic12));
dcl  reverse                  builtin;
dcl  rtrim                    builtin;
dcl  search                   builtin;
dcl  set_sw                   (0:7)bit(1)based(addr(lvp->fv.set_switch));
dcl  substr                   builtin;
dcl  va                       (12)bit(3)based(addr(v));
dcl  verify                   builtin;
dcl  Vl                       fixed bin(24);

dcl 1 name aligned based(addr(namei))
,     2 E  char(El)unal
,     2 p1 char( 1)unal
,     2 N  char(Nl)unal
,     2 p2 char( 1)unal
,     2 V  char(Vl)unal
;

dcl 1 name2 aligned based(addr(namei))
,     2 EN char(Nl)unal
,     2 p2 char( 1)unal
,     2 V  char(Vl)unal
;

dcl 1 fv aligned based(fvp) like gtss_file_values;

dcl 1 v,
    2 r bit(35),
    2 f bit( 1);


dcl 1 si aligned static int like branch	/* (Must be static, caller gets info_ptr to it). */;
%page;
%include gtss_ptr_check;
%page;
%include gtss_file_values;
%page;
%include status_info;
%page;
%include gtss_db_names;
%page;
%include gtss_ext_;
     end gtss_attributes_mgr_ ;



		    gtss_bcd_ascii_.alm             12/11/84  1349.3rew 12/10/84  1042.8       12663


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

"	bcd to ascii (upper case)
"
"	dcl gtss_bcd_ascii_ entry(ptr,fixed bin(24),ptr);
"	Arguments:
"		1. Pointer to input bcd characters (6 bit).
"		2. Number of characters.
"		3. Pointer to ascii output string.
"
"	Author:	Dave Ward		05/05/78
"		From Mike Jordan's gdb_bcd_ascii_.alm
"
	name	gtss_bcd_ascii_
	entry	gtss_bcd_ascii_
gtss_bcd_ascii_:
	eppbp	ap|2,*		bp->input data
	eppbp	bp|0,*
	lda	ap|4,*		get char count
	eppap	ap|6,*		ap->output buffer
	eppap	ap|0,*
	mvt	(pr,rl),(pr,rl)
	desc6a	bp|0,al
	desc9a	ap|0,al
	arg	upper
	short_return

	entry	lc
lc:
	eppbp	ap|2,*		bp->input data
	eppbp	bp|0,*
	lda	ap|4,*		get char count
	eppap	ap|6,*		ap->output buffer
	eppap	ap|0,*
	mvt	(pr,rl),(pr,rl)
	desc6a	bp|0,al
	desc9a	ap|0,al
	arg	lower
	short_return

upper:	aci	|0123456789[#@:>?|
	aci	| ABCDEFGHI&.](<\|
	aci	|^JKLMNOPQR-$*);'|
	aci	|+/STUVWXYZ_,%="!|

lower:	aci	|0123456789[#@:>?|
	aci	| abcdefghi&.](<\|
	aci	|^jklmnopqr-$*);'|
	aci	|+/stuvwxyz_,%="!|
	end
 



		    gtss_break_vector_.pl1          12/11/84  1349.3rew 12/10/84  1028.8       33525


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

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

/* The subsystem has specified a transfer vector for line break
   (mulitcs quit).  We must locate the appropriate machine
   conditions and alter the instruction counter.

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

/* We will search the stack backwards from the current
   stack frame checking each quit and derail fault
   to see if it occurred in the current slave segment. If no
   such fault is found then the  subsystem must have returned before
   quit was signalled so no machine conditions will be altered. */

	sp = find_condition_frame_ (null ());
	do while (sp ^= null ());
	     call find_condition_info_ (sp, addr (cond_info), code);
	     if condition_name = "quit" | condition_name = "derail"
	     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 do; /* have found fault in slave segment */
		     mcp = cond_info.mcptr;
		     gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
		     lbrk.ic = scu.ilc;
		     lbrk.ir = string (scu.ir);
		     scu.ilc = lbrk.tra_addr;
		end;
	     end;
	     sp = find_condition_frame_ (sp);
	end;
	return;					/* end of main entry */


drl_in_progress: entry () returns (bit (1));

/* This entry searches the stack backwards from the current stack
   frame to determine if the slave program was interrupted by a derail
   fault. If so, it returns "1"b */

	sp = find_condition_frame_ (null ());
	do while (sp ^= null ());
	     call find_condition_info_ (sp, addr (cond_info), code);
	     if condition_name = "derail"
	     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 do; /* have found fault in slave segment */
		     return ("1"b);
		end;
	     end;
	     sp = find_condition_frame_ (sp);
	end;
	return ("0"b);				/* end of drl_in_progress entry */


status:	entry () returns (bit (1)unal);

/* The entry gtss_break_vector_$status indicated is the subsystem
   wants to handle its own line breaks ((.LBRK+1) in nonzero).
   Usage:
   dcl gtss_break_vector_$status entry() returns (bit(1)unal);
   flag = gtss_break_vector_$status();
   where flag is "1"b iff (.LBRK+1) is nonzero. */

	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	lower_limit = bit (binary (100, 18), 18);
	upper_limit = gtss_ust.lsize.limit;
	return (lbrk.tra_addr >= lower_limit & lbrk.tra_addr < upper_limit); /* end of status entry */


dcl  code fixed bin(35);
dcl  gseg ptr ;
dcl  lower_limit bit(18);
dcl  mcpp ptr parm;
dcl  sp ptr;						/* ptr to current stack frame being searched */
dcl  upper_limit bit(18);
dcl 1 cond_info aligned,
%include cond_info;
dcl find_condition_frame_ entry(ptr) returns(ptr);
dcl find_condition_info_ entry(ptr,ptr,fixed bin(35));

%include gtss_ext_;

%include gtss_spa;

%include mc;

%include gtss_ust_ext_;
     end gtss_break_vector_;
   



		    gtss_build_.pl1                 12/11/84  1349.3rew 12/10/84  1042.9      151029


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

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

gtss_build_: proc;

/**	gtss "build" mode.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward		02/21/79 New get_line.
   Changed: Dave Ward		03/27/79 Convert put_chars.
   Changed: Al Kepner		03/30/79 fix problem with
   				an cc driving gtss which exits with &quit.
   Changed: Bob Alvarado		05/15/79 added return back to primitive
   				interp. for processing of #(commands).
   Changed: Al Dupuis		06/21/79 add call to gtss_CFP_break_
   Changed: Al Dupuis		06/14/79 to set external indicator to
   			          show if in build mode.
   Changed: Dave Ward		06/27/79 Corrected quit handling.
   Changed: Dave Ward		06/30/79 Retransmit message.
   Changed: Bob Alvarado		08/23/79 commented out ref to lswth.b10.
				08/31/79 added #auto and #autox code.
				09/04/79 reworked #auto code to accept
				line count and line incr.
   Changed: Bob Alvarado		11/26/79 removed all code simulating
				#auto and added a call to drl_callss.
				The auto subsystem is now processing 
				#auto.
   Changed: Scott C. Akers		08/17/81 Reset tty_modes on QUIT.
 **/

/**	gtss_build_ accumulates all input terminal line
   (up to the capacity of the SY** accumulator structure)
   and only writes the data to the SY** under two
   circumstances:

   1. Returning to the primitive interpreter
   (i.e., a non-line number input).

   2. SY** accumulator full (2 llinks, i.e., 640 words).
   **/
	in_pound_sign_build = "0"b;
	i = gtss_ust.lxxx.b0_17 - fixed (rel (addr (gtss_ust.lxxx)))+ fixed (rel (addr (gtss_ust)));
	if gtss_ust.lprgs (i).b0_17 = gtss_prgdes_ext_$edbn then do;

	/**	Build is being called by the editor. **/
	     in_edit = "1"b;
	end;
	else in_edit = "0"b;
	build_mode = "1"b;
	first8 = " ";

/**	Initialize gtss_SYstarstar.	**/
	unspec (gtss_SYstarstar_$FILE.RECORD) = "0"b;	/* Clear all SY** records. */
	call init_RECORD (1);
	rx = 1;					/* Current RECORD. */
	line_numb_len = 0;				/* => Auto[x] mode not on yet. */
	star_count = 0;				/* No begin of line star output yet. */
/* b10 will not be set by build  */
	/*	gtss_ust.lswth.b10, */ gtss_ust.lswth.b17 = "0"b; /* No data on SY** */

	on quit begin;
	     on quit call gtss_fix_tty_modes_;
	     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;
/* 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 go to next_asterisk;

next_line: ;

/**	Examine if SY** "full".	**/
	if rx >= hbound (gtss_SYstarstar_$FILE.RECORD, 1) then /* In final SY** record. */
	     if ((hbound (tty_data, 2)-tdw)*4) < gtss_ust.lrtll.char_length then do;
/* Not enough room in SY** for a maximum length record. */
		call write_SYstarstar;		/* Move tty lines to SY** file. */

/**	Place the SY** full "command" in UST remove i/o buffer. **/
		count_of_characters_transmitted = divide (length (SYstarstar_full)+8, 9, 17, 0);
		number_words_transmitted = divide (length (SYstarstar_full)+35, 17, 0);
		addr (characters_transmitted (1)) -> full_bits = SYstarstar_full;
		build_mode = "0"b;
		return;
	     end;

	if star_count = 0 then
	     if gtss_ext_$last_k_was_out then
		call gtss_ext_$put_chars (		/* Extra LF needed. */
		iox_$user_output
		, addr (LF)
		, 1
		, code);

next_asterisk: ;
	if gse_ext_$modes.ast then do;
	     call gtss_ext_$put_chars (		/* Output "*" on caller's terminal at the beginning of a line. */
		iox_$user_output
		, addr (CR_ASTERISK)
		, 2
		, code);
	     star_count = star_count+1;
	end;

after_asterisk: ;

	if gtss_ust.lflg2.b25 then do;		/* => AUTO[X] mode => provide line number. */
	     l = gtss_ust.linno;
	     if gtss_ust.lflg2.b24 then do;		/* No space => autox. */
		if l>99999999 then do;
		     call com_err_ (0, "gtss_build_", "mode terminated. line number too long.");
		     gtss_ust.lflg2.b25 = "0"b;
		     line_numb_len = 0;
		     goto next_line;
		end;
		if l>9999 then do;
		     p8 = l;
		     line_numb_ptr = addr (p8);
		     line_numb_len = 8;
		end;
		else do;
		     p4 = l;
		     line_numb_ptr = addr (p4);
		     line_numb_len = 4;
		end;
	     end;
	     else do;				/* Space => auto. */
		if l>9999999 then do;
		     call com_err_ (0, "gtss_build_", "mode terminated. line number too long.");
		     gtss_ust.lflg2.b25 = "0"b;
		     line_numb_len = 0;
		     goto next_line;
		end;
		if l>999 then do;
		     p7 = l;
		     line_numb_ptr = addr (p7space);
		     p7space.space = " ";
		     line_numb_len = 8;
		end;
		else do;
		     p3 = l;
		     line_numb_ptr = addr (p3space);
		     p3space.space = " ";
		     line_numb_len = 4;
		end;
	     end;
	     gtss_ust.linno = l + gtss_ust.lincr;	/* Increment the line number. */

	     call gtss_ext_$put_chars (		/* Print the line number on the caller's terminal. */
		iox_$user_output
		, line_numb_ptr
		, (line_numb_len)
		, code);

	     addr (characters_transmitted) -> MLN = line_numb_ptr -> MLN; /* Move line number to remote buffer. */
	end;

	gtss_ext_$last_k_was_out = "0"b;
	gtss_ust.lbuf.tally = "0"b;

reinput:	;
	call gtss_ext_$get_line (			/* Obtain next input line. */
	     iox_$user_input
	     , addr (characters_transmitted (line_numb_len+1))
	     , min (gtss_ust.lrtll.char_length, hbound (characters_transmitted, 1))-line_numb_len
	     , bytes_input
	     , code);
	if code ^= 0 then do;
	     if code = error_table_$end_of_info then go to after_asterisk;
	     if code = error_table_$long_record then do;
		call iox_$control (
		     iox_$user_input
		     , "resetread"
		     , null ()
		     , code
		     );
dcl  iox_$control             entry (ptr, char (*), ptr, fixed bin (35));
		call gtss_ext_$put_chars (		/* Print retry message. */
		     iox_$user_output
		     , addr (retry_message)
		     , length (retry_message)
		     , code);
		goto reinput;
	     end;
	     call com_err_ (code, "gtss_build_", "Terminal failure.");
	     signal cond (gtss_fail);
	end;

	if bytes_input = 0 then go to after_asterisk;

	if bytes_input = 1 then do;			/* No characters input (just a newline). */
	     if gtss_ust.lflg2.b25 then do;		/* Turn auto[x] mode off. */
		gtss_ust.linno = gtss_ust.linno-gtss_ust.lincr; /* Use current linno as next. */
		gtss_ust.lflg2.b25 = "0"b;
		line_numb_len = 0;
	     end;
	     count_of_characters_transmitted = length (CR4);
	     number_words_transmitted = divide (length (CR4)+3, 4, 17, 0);
	     addr (characters_transmitted (1)) -> CR4chars = CR4;
	     goto fin;
	end;

	if in_edit then do;
	     if bytes_input>1 then
		if characters_transmitted (1) = "#" then /* Special processing. */
		     if bytes_input>2 then
			if characters_transmitted (2) ^= "#" then do; /* Examine for command. */
check_for_command:		     ;
			     build_mode = "0"b;
			     pound_sign_cmd = substr (string (characters_transmitted), 2, 4);
			     if pound_sign_cmd ^= "auto" then do;
				call write_SYstarstar;
				return;
			     end;
			     count_of_characters_transmitted = bytes_input;
			     gtss_ext_$stack_level_ = gtss_ext_$stack_level_ - 1;
			     characters_transmitted (bytes_input) = CR;
			     call gtss_drl_callss_$callss_pound_sign_comd (addr (pound_sign_cmd), 1);
			     gtss_ext_$stack_level_ = gtss_ext_$stack_level_ + 1;
			     in_pound_sign_build = "1"b;
			     goto next_line;

/*
   if gtss_interp_prim_$is_command(substr(string(characters_transmitted),1,4)) then goto fin;
*/
			end;
			else			/* 2nd character is a "#". */
/**  ??
if terminal type = VIP
     &
   in CF mode then goto check_for_command;
*/			;
	end;
	else					/* => Not in editor. */
	if gse_ext_$modes.mcmd then
	     if bytes_input>2 then			/* Examine for escape to multics line. */
		if characters_transmitted (line_numb_len+1) = "e" then
		     if search (SP_TAB, characters_transmitted (line_numb_len+2))>0 then begin;
			call cu_$cp (addr (characters_transmitted (line_numb_len+3)), bytes_input-2, code);
			if gtss_ust.lflg2.b25 then
			     gtss_ust.linno = gtss_ust.linno-gtss_ust.lincr; /* Use current linno as next. */

/* Update gtss_ust.lid in case user has changed working_directory or
   used the gcos_set_environment command. */
			if gse_ext_$drm_rule = 2 then do; /* wd mapping rule */
						/* .LID in the UST will be set to the first
						   12 characters of the working_dir name. */
			     call expand_pathname_ (get_wdir_ (), "", wd_name, code);
			     if code ^= 0 then do;
				call com_err_ (code, "gtss_build_",
				     "Failed attempting to get entry name portion of working_dir");
				signal cond (gtss_fail);
			     end;
			     call gtss_ascii_bcd_ (addr (wd_name), 12, addr (gtss_ust.lid));
			end;
			else do;			/* umc or smc mapping rule */
			     call gtss_ascii_bcd_ (addr (gse_ext_$umc_name), 12, addr (gtss_ust.lid));
			end;
			goto next_line;
		     end;

	count_of_characters_transmitted,
	     bytes_read = line_numb_len + bytes_input;
	number_words_transmitted =
	     divide ((bytes_read+3), 4, 17, 0);
	characters_transmitted (bytes_read) = CR;

	if ^in_edit then
	     if line_numb_len = 0 then do;		/* Check if caller typed line number. */
		i = verify (first8, " ");
		if i <= 0 then do;			/* First 8 character of terminal line blank. */
fin:		     ;
		     if in_pound_sign_build then do;
			in_pound_sign_build = "0"b;
			goto next_line;
		     end;
		     call write_SYstarstar;
		     build_mode = "0"b;
		     return;
		end;
		if (search (characters_transmitted (i), "0123456789") = 0) then goto fin; /* Terminal line not numbered. */
	     end;

/**	Move terminal line into SY** accumulator.	**/

/**	Indicate SY** contains data.	**/
	bytes_read = bytes_read-1;			/* Exclude CR from SY** record. */
	tw =					/* Total words to SY** record. */
	     divide ((bytes_read+3), 4, 24, 0);
	if (tw+2)> (hbound (tty_data, 2)-tdw) then do;	/* Proceed to next SY**. */
	     RECORD (rx).number_words = tdw;		/* Record number of words in record. */
	     rx = rx+1;
	     call init_RECORD (rx);
	end;
	p = addr (RECORD (rx).tty_data (tdw));		/*  => start where file mark was. */
	p -> number_record_words = tw;
	j = mod (bytes_read, 4);
	p -> next_available_char_in_last_word = j2;	/* j2 => j. */
	p -> file_mark = "0"b;
	p -> zeroes = "0"b;
	p -> media_code = "0110"b;			/* => 6 => ASCII. */
	p -> report_code = "0"b;
	addrel (p, tw) -> b36 = (4)"177"b3;		/* First fill last data word with octal 177's. */
	addrel (p, 1) -> MS = addr (characters_transmitted) -> MS; /* Move data characters to remote buffer. */
	tdw = tdw+tw+1;				/* Data words + 1 RCW. */

	goto next_line;

init_RECORD: proc (r);

/**	Initialize RECORD( r )	**/
dcl  r                        fixed bin (24)parm;
	     tdw = 1;				/* Current tty_data word. */
	     RECORD (r).relative_block_count = r-1;
	     return;
	end					/* init_RECORD */;

write_SYstarstar: proc;

/**	Write the SY** accumulator out to the SY** file.	**/
	     if (rx = 1) & (tdw = 1) then return;	/* Still no data on SY**. */
/* b10 will not be set by build */
	     /* gtss_ust.lswth.b10, */ gtss_ust.lswth.b17 = "1"b; /* Data to merge in SY**. */
	     gtss_SYstarstar_$FILE.Seek_Address = 0;
	     RECORD (rx).number_words = tdw;		/* Record number words for final record. */
	     tty_data (rx, tdw) = "0"b;
	     addr (tty_data (rx, tdw)) -> file_mark = "1111"b; /* Provide file mark in final word. */
	     call gtss_ios_io_ (
		gtss_ext_$SYstarstar_file_no
		, addr (gtss_SYstarstar_$FILE.select_sequence)
		, addr (gtss_SYstarstar_$FILE.select_sequence)
		, fixed (rel (addr (tty_data (hbound (tty_data, 1), hbound (tty_data, 2))))) /* Last word of accumulator (offset) available. */
		, status
		, code);
	     if status ^= 0 then do;
		call com_err_ (code, "gtss_build_",
		     "Unable to write SY**, gtss_ios_ status=^i", status);
		signal cond (gtss_fail);
	     end;

/**	Initialize gtss_SYstarstar.	**/
	     call init_RECORD (1);
	     rx = 1;				/* Current RECORD. */
	     return;
	end					/* write_SYstarstar */;

/**	Variables for gtss_build_
   IDENTIFIER	ATTRIBUTES	**/
dcl  addr                     builtin;
dcl  pound_sign_cmd		char(4);
dcl  b36                      bit (36)aligned based;
dcl  bytes_input              fixed bin (21);
dcl  bytes_read               fixed bin (21);
dcl  code                     fixed bin (35);
dcl  CR4chars                 char(length(CR4))based;
dcl  cu_$cl                   ext entry ();
dcl  cu_$cp                   ext entry (ptr, fixed bin, fixed bin (35));
dcl  divide                   builtin;
dcl  error_table_$end_of_info fixed bin (35) ext;
dcl  error_table_$long_record fixed bin (35) ext;
dcl  expand_pathname_         entry (char(*), char(*), char(*), fixed bin(35));
dcl  first3                   pic"(3)9" based (addr (characters_transmitted));
dcl  first7                   pic"(7)9" based (addr (characters_transmitted));
dcl  first8                   char (8)aligned based (addr (characters_transmitted));
dcl  full_bits                bit(length(SYstarstar_full))based;
dcl  get_wdir_                entry returns(char(168));
dcl  gtss_fail                condition ext;
dcl  gtss_fix_tty_modes_	ext entry;
dcl  gtss_interp_prim_$re_enter_prim entry;
dcl  gtss_prgdes_ext_$edbn    fixed bin (24)ext;
dcl  i                        fixed bin;
dcl  in_pound_sign_build		bit(1);
dcl  in_edit                  bit(1);
dcl  ioa_                     ext entry options (variable);
dcl  ioa_$nnl                 ext entry options (variable);
dcl  iox_$get_line            entry (ptr, ptr,fixed bin(21),fixed bin(21),fixed bin(35));
dcl  iox_$user_input          ext ptr;
dcl  iox_$user_output         ext ptr;
dcl  j                        fixed bin (35);
dcl  l                        fixed bin (24);
dcl  line_numb_len            fixed bin (24);
dcl  line_numb_ptr            ptr init(null());
dcl  min                      builtin;
dcl  MLN                      char (line_numb_len)aligned based;
dcl  MS                       char (bytes_read)aligned based;
dcl  p                        ptr init(null());
dcl  p4                       pic"(4)9";
dcl  p8                       pic"(8)9";
dcl  program_interrupt        cond ext;
dcl  gtss_drl_callss_$callss_pound_sign_comd	entry(ptr,fixed bin);
dcl  quit                     condition ext;
dcl  rel                      builtin;
dcl  rtrim		builtin;
dcl  rx                       fixed bin (24);
dcl  search                   builtin;
dcl  SP                       char (1)static int options (constant)init (" ");
dcl  SP_TAB                   char (2)static int options (constant)init (" 	");
dcl  star_count               fixed bin (24);
dcl  status                   fixed bin (24);
dcl  substr                   builtin;
dcl  SYstarstar_full          bit(72)static int options(constant)init("004004004001015015015015"b3);
dcl  tdw                      fixed bin (24);
dcl  tw                       fixed bin (24);
dcl  wd_name                  char (32);

dcl  retry_message            char(21)static int options(constant)init("RETRANSMIT LAST LINE
");

dcl 1 p3space aligned
     , 3 p3 pic"(3)9" unal
     , 3 space char (1)unal
     ;

dcl 1 p7space aligned
     , 3 p7 pic"(7)9" unal
     , 3 space char (1)unal
     ;

dcl 1 j_overlay aligned based (addr (j)),
    2 l_34 bit (34)unal,
    2 j2 bit (2)unal;

dcl  HTAB			char(1)static int options(constant)init("	");
dcl
	CR4 char(4)static int options(constant)init((4)"");

dcl
     CR_ASTERISK char (2) static int options (constant) init ("*");
dcl
     CR char (1) static int options (constant) init ("");
dcl  LF                       char (1)static int options (constant)init ("
");

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;

%include gtss_SYstarstar_;

%include gtss_rec_control_word;

%include gtss_entry_dcls;

%include gse_ext_;
/**  **/
%include gtss_starCF_;
     end						/* gtss_build_ */;
   



		    gtss_com_err_.pl1               12/11/84  1349.3rew 12/10/84  1042.9       30834


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

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

gtss_com_err_: proc;

/**       This procedure is called from gtss after the condition
	command_error has been signalled by com_err_. It takes
	the com_err_ string and sends it to *CFP. com_err_ is
	then requested not to print it if gtss_ext_$flags.gtss_com_err_sw
	is true. If the call was a result of problems with the
	*CFP file the write to it is not attempted.

	Author: Al Dupuis      11/02/79.                         **/

	/** Check for *CFP problems **/
	if gtss_ust.lcfst.start_term > 0
	& gtss_ust.lcfst.start_term < 5
	then return;
	
          /** Locate the error condition information **/
	if find_frame ("command_error") = null ()
	then do;
	     call ioa_ ("Couldn't get frame for command_error.");
	     return;
	end;

	/** And write error message to *CFP after preceding it with cr lf **/
	if errmess_lth > gtss_max_lth - 2
	then errmess_lth = gtss_max_lth - 2;
	error_message = cr_lf || error_message;
	errmess_lth = errmess_lth + 2;
	call gtss_write_starCFP_ (null (), errmess_ptr, fixed (errmess_lth, 21), code);
	if gtss_ext_$flags.gtss_com_err_sw
	then gtss_ext_$flags.gtss_com_err_sw,
	     print_sw = "0"b;
	

find_frame: proc (condition_parm) returns (ptr);

	     sp = find_condition_frame_ (null ());
	     do while (sp ^= null ());
		call find_condition_info_ (sp, addr (cond_info), code);
		if cond_info.condition_name = condition_parm then
		     return (cond_info.infoptr);
		sp = find_condition_frame_ (sp);
	     end;
	     return (null ());

dcl condition_parm char (32) varying parm;
	end;					/* find_frame */

dcl code fixed bin (35);
dcl command_error cond ext;
dcl cr_lf char (2) based (addr (crlf));
dcl crlf bit (18) static int options (constant) init ("015012"b3);	
dcl err_mess char (errmess_lth) based (errmess_ptr);
dcl error_message char (max_errmess_lth) based (errmess_ptr);
dcl find_condition_frame_ entry (ptr) returns (ptr);
dcl find_condition_info_ entry (ptr, ptr, fixed bin(35));
dcl gtss_max_lth fixed bin static int options (constant) init (252);
dcl ioa_ entry options (variable);
dcl sp ptr init (null ());
dcl 1 command_error_info aligned based (cond_info.infoptr),
      2 length fixed bin,
      2 version fixed bin,
      2 action_flags aligned,
        3 cant_restart bit (1) unaligned,
        3 default_restart bit (1) unaligned,
        3 reserved bit (34) unaligned,
      2 info_string char (256) varying,
      2 status_code fixed bin (35),
      2 name_ptr ptr,
      2 name_lth fixed bin,
      2 errmess_ptr ptr,
      2 errmess_lth fixed bin,
      2 max_errmess_lth fixed bin,
      2 print_sw bit (1);
dcl 1 cond_info aligned,
%include cond_info;

%include mc;

%include gtss_entry_dcls;

%include gtss_ext_;

%include gtss_ust_ext_;
     end;						/* gtss_com_err_ */

  



		    gtss_constants.cds              12/11/84  1349.3rew 12/10/84  1028.8       25335


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

/* Generate object for "gtss_constants" 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_constants)=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_constants);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_constants);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_constants";

	cds_args_ptr -> cds_args.seg_name = "gtss_constants";	/* 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_constants");
	   else 
	      call com_err_( 0,"gtss_constants","Object for gtss_constants created [^i words].",size(gtss_constants));

	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_constants.incl.pl1 **/

dcl 1 gtss_constants aligned,
     2 version char (4) var init ("4.0");

%include gtss_constants;
%page;
%include cds_args;
end;
 



		    gtss_def_q_.cds                 12/11/84  1349.3rew 12/10/84  1042.9       24903


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

/* Generate object for "gtss_def_q_" 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_def_q_)=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_def_q_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_def_q_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_def_q_";

	cds_args_ptr -> cds_args.seg_name = "gtss_def_q_";	/* 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_def_q_");
	   else 
	      call com_err_( 0,"gtss_def_q_","Object for gtss_def_q_ created [^i words].",size(gtss_def_q_));

	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_def_q_.incl.pl1 **/

dcl 1 gtss_def_q_ aligned,
      2 FILE like gtss_def_q_$FILE;

%include gtss_def_q_;
%page;
%include cds_args;
end;
 



		    gtss_derail_processor_.pl1      12/11/84  1349.3rew 12/10/84  1042.9      111447


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

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

gtss_derail_processor_: proc (mcpp, fault_name, dummy1, dummy2, continue);
dcl  mcpp ptr parm;
dcl  fault_name char (*)parm;
dcl  dummy1 ptr parm;
dcl  dummy2 ptr parm;
dcl  continue bit (1)aligned parm;
	mcp = mcpp;

/*
   This procedure is called by sct_manager_ when a DRL condition is
   raised  in  the  current ring. This procedure will make sure the
   DRL is in the GCOS slave segment and then process it.

   The  faulting  instruction  (DRL)  is  located  in  the  machine
   conditions,  and  is  examined for request type (as given in the
   computed address.) The
   appropriate drl handler is called with a
   ptr to the machine conditions. When  the  drl  handler  returns,
   this  procedure  will  modify  the machine conditions to force a
   transfer to the proper location,  skipping  over  any  parameter
   words  that  followed  the drl, and then it will return, causing
   the modified machine conditions to be restored and the execution
   of the slave program to be resumed.


   Author:	Robert J. Grimes	Created
   Albert N. Kepner	  1978
   Robert M. May
   David B. Ward
   Changed:	Dave Ward		02/23/79 t.cfio
   Changed:         Mel Wilson          March/79 drl jsts, snumb, spawn
   Changed:	Al Dupuis		June/79 drl pdio.
   Changed:	Ron Barstad	83-07-25  To 4JS3 with DRLs to  71
   * */
%page;
/*
   This procedure is called as a static handler for the condition DRL in the current ring.
   After making sure the DRL is in the GCOS segment and initializing some data
   items we process the DRL.
*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

	if fixed (baseno (gseg), 18, 0) ^= fixed (scu.ppr.psr, 15, 0) then do;
	     if gtss_ext_$sig_ptr ^= null () then
		call cu_$ptr_call (gtss_ext_$sig_ptr, mcp, fault_name, dummy1, dummy2, continue);
	     return;
	end;
	continue = "0"b;

	derail_ptr = addrel (gseg, scu.ilc);
	drl_number = drl_numb;			/* Local value. Note derails are signed integers. */

/*
   Check to see if the DRL number is in the ball park.  If not abort the user.
*/
	if drl_number < lbound (drl_handler, 1) | drl_number > hbound (drl_handler, 1) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_derail_processor_",
		5,
		gtss_pnterr.err5,
		fixed (scu.ilc, 18));
	     scu.rfi = "1"b;
	     scu.if = "1"b;
	     return;
	end;

/* Print name and location of derail if appropriate */
	if gse_ext_$modes.drl then do;
	     on quit;
	     call ioa_ ("Derail ^7a at ^6o", DRL_NAME (drl_number), fixed (scu.ilc, 18));
	     revert quit;
	end;

/* save registers */
	gtss_spa.lostr.regs = mc.regs;
						/* save eis registers */
	gtss_spa.leisa = mc.eis_info;
						/* save drl type and location */
	gtss_ust.ldrl.code = drl_number;
	gtss_ust.ldrl.ilc = scu.ilc;
	gtss_spa.losti.ilc = scu.ilc;
						/* save indicator registers */
	gtss_spa.losti.ir = scu.ir;
						/* do some accounting for the guy -- to be done */
	increment = 0;
	gtss_ext_$statistics.count (drl_number) = gtss_ext_$statistics.count (drl_number) + 1; /* bump usage count */
	initial_cpu_time = virtual_cpu_time_ ();

/* Save instruction counter value. On return if it has been changed
   it indicates a user's wrapup routine is to be called. */
	saved_ilc = scu.ilc;

	gtss_ext_$dispose_of_drl = dispose_of_derail;
	gtss_ext_$flags.drl_in_progress = "1"b;
	gtss_ext_$flags.dispose_of_drl_on_pi = disposable_derail (drl_number);

/*
   Call the appropriate DRL processor .
*/
	if drl_handler (drl_number) = gtss_abort_subsystem_$not_imp
	then increment = drl_number;
	call drl_handler (drl_number) (mcp, increment);

/* put code in here to measure drl activity */
	gtss_ext_$statistics.total_time (drl_number) = gtss_ext_$statistics.total_time (drl_number) +
	     virtual_cpu_time_ ()- initial_cpu_time;	/* count total time used by a drl */

/*
   Modify the machine conditions to skip the DRL and any arguments
   to it.  This is accomplished by modifying the IC (scu.ilc) and forcing
   the processor to refetch the instruction pair.
*/
/* However, if scu.ilc has already been changed, it will be left alone,
   since this means user's wrapup code is about to be executed. */
	if saved_ilc = scu.ilc then do;
	     increment = increment + 1 + fixed (scu.ilc, 18);
	     scu.ilc = substr (unspec (increment), 19, 18);
	end;

/* Update saved machine registers in user's slave prefix. */
	call gtss_update_safe_store_ (mcp);
dispose_of_derail: ;
	scu.rfi = "1"b;
	scu.if = "1"b;
	gtss_ext_$dispose_of_drl = gtss_ext_$bad_drl_rtrn;
	gtss_ext_$restart_from_pi = gtss_ext_$bad_drl_rtrn;
	gtss_ext_$flags.dispose_of_drl_on_pi = "0"b;
	gtss_ext_$flags.drl_in_progress = "0"b;
	if gtss_ext_$flags.popup_from_pi then do;
	     gtss_ext_$flags.popup_from_pi = "0"b;
	     gtss_ext_$flags.unfinished_drl = "0"b;
	     go to gtss_ext_$popup_from_pi;
	end;
	if gtss_ext_$flags.unfinished_drl then do;
	     gtss_ext_$flags.unfinished_drl = "0"b;
	     call gtss_break_vector_ ();
	end;
	return;
%page;
set: entry;

/* *	Entry to set drl_handler entry variable.	* */

/*    octal name
   ===== ==== */
	drl_handler (-10) = gtss_drl_msub_;		/* DRL -012 Call Multics sub. */
	drl_handler (-09) = gtss_abort_subsystem_$not_imp; /* DRL -011 */
	drl_handler (-08) = gtss_abort_subsystem_$not_imp; /* DRL -010 */
	drl_handler (-07) = gtss_abort_subsystem_$not_imp; /* DRL -007 */
	drl_handler (-06) = gtss_abort_subsystem_$not_imp; /* DRL -006 */
	drl_handler (-05) = gtss_abort_subsystem_$not_imp; /* DRL -005 */
	drl_handler (-04) = gtss_abort_subsystem_$not_imp; /* DRL -004 */
	drl_handler (-03) = gtss_abort_subsystem_$not_imp; /* DRL -003 */
	drl_handler (-02) = gtss_abort_subsystem_$not_imp; /* DRL -002 */
	drl_handler (-01) = gtss_abort_subsystem_$not_imp; /* DRL -001 */
	drl_handler (000) = gtss_abort_subsystem_$not_imp; /* DRL 0000 -not available- */
	drl_handler (001) = gtss_drl_dio_;		/* DRL 0001 dio */
	drl_handler (002) = gtss_drl_kotnow_$gtss_drl_kout_; /* DRL 0002 kout */
	drl_handler (003) = gtss_drl_koutn_;		/* DRL 0003 koutn */
	drl_handler (004) = gtss_drl_kin_;		/* DRL 0004 kin */
	drl_handler (005) = gtss_drl_return_;		/* DRL 0005 return */
	drl_handler (006) = gtss_drl_defil_;		/* DRL 0006 defil */
	drl_handler (007) = gtss_drl_abort_;		/* DRL 0007 abort */
	drl_handler (008) = gtss_drl_setswh_;		/* DRL 0010 setswh */
	drl_handler (009) = gtss_drl_rstswh_;		/* DRL 0011 rstswh */
	drl_handler (010) = gtss_drl_rew_;		/* DRL 0012 rew */
	drl_handler (011) = gtss_drl_filsp_;		/* DRL 0013 filsp */
	drl_handler (012) = gtss_drl_retfil_;		/* DRL 0014 retfil */
	drl_handler (013) = gtss_drl_relmem_;		/* DRL 0015 relmem */
	drl_handler (014) = gtss_drl_addmem_;		/* DRL 0016 addmem */
	drl_handler (015) = gtss_drl_corfil_;		/* DRL 0017 corfil */
	drl_handler (016) = gtss_drl_snumb_;		/* DRL 0020 snumb */
	drl_handler (017) = gtss_drl_time_;		/* DRL 0021 time */
	drl_handler (018) = gtss_drl_pasaft_;		/* DRL 0022 pasaft */
	drl_handler (019) = gtss_drl_termtp_;		/* DRL 0023 termtp */
	drl_handler (020) = gtss_drl_pdio_;		/* DRL 0024  */
	drl_handler (021) = gtss_drl_restor_;		/* DRL 0025 restor */
	drl_handler (022) = gtss_drl_spawn_;		/* DRL 0026 spawn */
	drl_handler (023) = gtss_drl_tapein_;		/* DRL 0027 */
	drl_handler (024) = gtss_drl_callss_;		/* DRL 0030 callss */
	drl_handler (025) = gtss_abort_subsystem_$not_imp; /* DRL 0031 */
	drl_handler (026) = gtss_abort_subsystem_$not_imp; /* DRL 0032 */
	drl_handler (027) = gtss_drl_pasust_;		/* DRL 0033  pasust */
	drl_handler (028) = gtss_drl_morlnk_;		/* DRL 0034 morlnk */
	drl_handler (029) = gtss_abort_subsystem_$not_imp; /* DRL 0035 */
	drl_handler (030) = gtss_drl_filact_;		/* DRL 0036 filact */
	drl_handler (031) = gtss_drl_setlno_;		/* DRL 0037 setlno */
	drl_handler (032) = gtss_drl_sysret_;		/* DRL 0040 sysret */
	drl_handler (033) = gtss_abort_subsystem_$not_imp; /* DRL 0041 */
	drl_handler (034) = gtss_abort_subsystem_$not_imp; /* DRL 0042 */
	drl_handler (035) = gtss_abort_subsystem_$not_imp; /* DRL 0043 */
	drl_handler (036) = gtss_drl_pasdes_;		/* DRL 0044 pasdes */
	drl_handler (037) = gtss_drl_jsts_;		/* DRL 0045 jsts */
	drl_handler (038) = gtss_abort_subsystem_$not_imp; /* DRL 0046 */
	drl_handler (039) = gtss_drl_part_;		/* DRL 0047 part */
	drl_handler (040) = gtss_drl_grow_;		/* DRL 0050 grow */
	drl_handler (041) = gtss_abort_subsystem_$not_imp; /* DRL 0051 */
	drl_handler (042) = gtss_abort_subsystem_$not_imp; /* DRL 0052 */
	drl_handler (043) = gtss_drl_switch_;		/* DRL 0053 */
	drl_handler (044) = gtss_drl_drlimt_;		/* DRL 0054 drlimt */
	drl_handler (045) = gtss_abort_subsystem_$not_imp; /* DRL 0055 */
	drl_handler (046) = gtss_drl_kotnow_;		/* DRL 0056 kotnow */
	drl_handler (047) = gtss_drl_objtim_;		/* DRL 0057 objtim */
	drl_handler (048) = gtss_drl_spawn_$gtss_drl_pasflr_; /* DRL 0060 pasflr */
	drl_handler (049) = gtss_drl_stoppt_;		/* DRL 0061 */
	drl_handler (050) = gtss_drl_drlsav_;		/* DRL 0062 drlsav */
	drl_handler (051) = gtss_drl_task_;		/* DRL 0063 task */
	drl_handler (052) = gtss_drl_pseudo_;		/* DRL 0064 pseudo */
	drl_handler (053) = gtss_drl_prgdes_;		/* DRL 0065 prgdes */
	drl_handler (054) = gtss_drl_gwake_;		/* DRL 0066 gwake */
	drl_handler (055) = gtss_abort_subsystem_$not_imp; /* DRL 0067 */
	drl_handler (056) = gtss_abort_subsystem_$not_imp; /* DRL 0070 */
	drl_handler (057) = gtss_abort_subsystem_$not_imp; /* DRL 0071 */
	drl_handler (058) = gtss_drl_t_goto_;		/* DRL 0072 t.goto */
	drl_handler (059) = gtss_drl_t_cmov_;		/* DRL 0073 t.cmov */
	drl_handler (060) = gtss_drl_t_linl_;		/* DRL 0074 t.linl */
	drl_handler (061) = gtss_abort_subsystem_$not_imp; /* DRL 0075 */
	drl_handler (062) = gtss_abort_subsystem_$not_imp; /* DRL 0076 */
	drl_handler (063) = gtss_drl_t_cfio_;		/* DRL 0077 t.cfio */
	drl_handler (064) = gtss_abort_subsystem_$not_imp; /* DRL 0100 */
	drl_handler (065) = gtss_drl_t_rscc_;		/* DRL 0101 t.rscc */
	drl_handler (066) = gtss_abort_subsystem_$not_imp; /* DRL 0102 */
	drl_handler (067) = gtss_drl_t_err_;		/* DRL 0103 t.err */
	drl_handler (068) = gtss_abort_subsystem_$not_imp; /* DRL 0104 */
	drl_handler (069) = gtss_abort_subsystem_$not_imp; /* DRL 0105 */
	drl_handler (070) = gtss_abort_subsystem_$not_imp; /* DRL 0106 */
	drl_handler (071) = gtss_abort_subsystem_$not_imp; /* DRL 0107 */
	return;
%page;
/* *  Declarations for gtss_derail_processor_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  addr builtin;
dcl  baseno builtin;
dcl  cu_$ptr_call entry options (variable);
dcl 1 derail aligned based (derail_ptr),
    2 drl_numb fixed bin (17) unal,			/* drl_numb is fixed bin(17) to allow for negative derails */
    2 drl_op bit (18) unal;
dcl  derail_ptr ptr init (null ());
dcl  drl_number fixed bin (17);
dcl  drl_handler (-10:71)entry (ptr, fixed bin (24))static;
dcl  fixed builtin;
dcl  gseg ptr init (null ());
dcl  hbound builtin;
dcl  increment fixed bin (24);
dcl  initial_cpu_time fixed bin (71);
dcl  ioa_ entry options (variable);
dcl  lbound builtin;
dcl  quit_flag bit (1);
dcl  quit condition;
dcl  saved_ilc bit (18);
dcl  substr builtin;
dcl  unspec builtin;
dcl  virtual_cpu_time_ entry returns (fixed bin (71));

dcl  disposable_derail (-10:71)
     bit (1) unal static int options (constant) init (
    (12) (1)"0"b,					/* -12 to +01 (octal) */
     "1"b,					/* DRL KOUT (02 octal) */
     "1"b,					/* DRL KOUTN (03 octal) */
    (42) (1)"0"b,					/* 04 to 55 (octal) */
     "1"b,					/* DRL KOTNOW (56 octal) */
    (25) (1)"0"b);						/* 57 to 107 (octal) */
%page;
%include gtss_spa;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_drl_names;
%page;
%include gtss_pnterr;
%page;
%include gtss_ext_;
%page;
%include mc;
%page;
%include gtss_entry_dcls;
%page;
%include gse_ext_;

end gtss_derail_processor_;
 



		    gtss_dfd_ext_.cds               12/11/84  1349.3rew 12/10/84  1042.9       25398


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

/* Generate object for "gtss_dfd_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_dfd_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_dfd_ext_);	/* Caller's data. */
	cds_args_ptr -> cds_args.sections (2).len = size (gtss_dfd_ext_);	/* No. words in data structure. */
	cds_args_ptr -> cds_args.sections (2).struct_name = "gtss_dfd_ext_";

	cds_args_ptr -> cds_args.seg_name = "gtss_dfd_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_dfd_ext_");
	   else 
	      call com_err_( 0,"gtss_dfd_ext_","Object for gtss_dfd_ext_ created [^i words].",size(gtss_dfd_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_dfd_ext_.incl.pl1 **/

dcl 1 gtss_dfd_ext_ aligned,
      2 disk_file_data (41) like gtss_dfd_ext_$disk_file_data;

%include gtss_dfd_ext_;
%page;
%include cds_args;
end;
  



		    gtss_dq_.pl1                    12/11/84  1349.3rew 12/10/84  1028.9      214137


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

gtss_dq_: proc;

/**	Author: Al Dupuis 08/79
	Change: Dave Ward 08/79/03 Revised call to ios open.
	Change: Al Dupuis 11/10/79 Reworked open_exc code.
          Change: Ron Barstad  84-11-21  Always open drun_d_q if accessed.

	This module performs the following operations:

	ENTRY		OPERATION

	gtss_dq_$create	Creates the GCOS #D file in the users home
			directory. ([hd]>drun_#d_q) Creates the absin
			segment in the home directory. ([hd]>drun_control)

	gtss_dq_$open_exc	Opens the deferred queue for exclusive read and write

	gtss_dq_$open_gen	Opens the deferred queue for read while writers.

	gtss_dq_$hdrp	Returns a pointer to the #D header, given the DRUN job id.

	gtss_dq_$catp	Returns a pointer to the #D catalog entry, and the relative
			position of the entry in the queue, given the DRUN job id.

	gtss_dq_$dibp	Returns a pointer to the #D DIB, given the DRUN job id.

	gtss_dq_$entries_info Fills in the following structure.
			  1 entries_info (no_of_cat_entries)
			    2 did char (5),			the drun job id
			    2 aid char (19),		the Multics absentee id
			    2 job_status fb (6) unsigned;	the job status from #D catalog
			  An entry in this structure is created for every
			  catalog entry in the #D queue that has been used.

	gtss_dq_$mod_js	Modifies a catalog entrie's job status.
**/

	call com_err_ (0, "gtss_dq_",
	     "See documentation for meaningful entries.");
	return;


create:	entry (error);

/**
	arg_1  (output) Set to 1 if the required operation could
		      not be performed.

	This entry creates the DRUN deferred file (#D) in the
	user's home directory. It then initializes the header and
	catalogue as described in DB84 Page 16-18.

**/

	caller = "gtss_dq_$create";
	error = "0"b;
	call create_file;
	if ^local_error then call set_attr;
	if ^local_error then call access_dq;
	if ^local_error then call init_head_cat;
	error = local_error;
	return;


open_exc:	entry (error);

	caller = "gtss_dq_$open_exc";
	error = "0"b;
	if file_opened then call close_file;
	if local_error then do;
	     error = local_error;
	     return;
	end;

	call access_dq;
	if local_error then do;
	     call com_err_ (0, caller,
		"Couldn't set runtime attributes on #D file.");
	     error = local_error;
	     return;
	end;
	call gtss_ios_open_ (
	     fn,
	     gtss_file_values.dname,
	     gtss_file_values.ename,
	     "110000"b,
	     "1"b,
	     gtss_file_attributes_ptr,
	     addr (gcos_status),
	     code);
	if db_dq then call com_err_ (0, caller,
	     "status for open (1st attempt) was (^w)",
	     gcos_status.bit12);
	if gcos_status.bit12 = "4000"b3
	then do;
	     file_opened = "1"b;
	     return;
	end;
	do i = 1 to max_attempts while (gcos_status.bit12 ^= "4000"b3);
	     if db_dq then call com_err_ (0, caller,
		"going to sleep for ^d seconds.",
		wait_time);
	     call timer_manager_$sleep (wait_time, "11"b);
	     call gtss_ios_open_ (
		fn,
		gtss_file_values.dname,
		gtss_file_values.ename,
		"110000"b,
		"1"b,
		gtss_file_attributes_ptr,
		addr (gcos_status),
		code);
	     if db_dq then call com_err_ (0, caller,
		"status for open (attempt no ^d) was (^w)",
		i, gcos_status.bit12);
	end;
	if gcos_status.bit12 = "4000"b3
	then do;
	     file_opened = "1"b;
	     return;
	end;
	error = "1"b;
	call ioa_ ("FILE #D BUSY: TRY AGAIN IN A MINUTE");
	return;

open_gen:	entry (error);

	caller = "gtss_dq_$open_gen";
	error = "0"b;

	if file_opened then call close_file;
	if local_error then do;
	     error = local_error;
	     return;
	end;

	call access_dq;
	if local_error then do;
	     call com_err_ (0, caller,
		"Couldn't set runtime attributes on #D file.");
	     error = local_error;
	     return;
	end;
	call gtss_ios_open_ (
	     fn,
	     gtss_file_values.dname,
	     gtss_file_values.ename,
	     "100001"b,
	     "1"b,
	     gtss_file_attributes_ptr,
	     addr (gcos_status),
	     code);
	if gcos_status.bit12 ^= "4000"b3 then do;
	     call com_err_ (0, caller,
		"Couldn't open #D file (status ^w)",
		gcos_status.bit12);
	     error = "1"b;
	     return;
	end;
	else file_opened = "1"b;

	return;


hdrp:	entry (dqhp);

/**	This entry is called to obtain a pointer to the
	DRUN #D file's header. The pointer is null if
	the operation could not be performed.
**/

	caller = "gtss_dq_$hdrp";
	call gtss_aft_$find ("#D", fn, code);
	if code ^= 0 then do;
	     call access_dq;
	     call open_gen (local_error);
	end;
	if ^local_error then do;
	     gtss_def_q_$FILE.Seek_Address = 0;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	end;
	if local_error then dqhp = null ();
	else dqhp = addr (gtss_def_q_$FILE.no_characters);
	return;


catp:	entry (drun_job_id, dcp, cat_e_parm);

/**
	arg_1 (input)	The DRUN job id.
	arg_2 (output)	A pointer to the catalog entry.
			Null if the entry could not be found.
	arg_3 (output)	The relative position of the catalog
			entry in the #D queue. Used to read
			the associated DIB.
**/

	caller = "gtss_dq_$catp";
	call gtss_ascii_bcd_ (addr (drun_job_id), 5, addr (bcd_jid));
	call gtss_aft_$find ("#D", fn, code);
	if code ^= 0 then call access_dq;
	if ^local_error then do;
	     gtss_def_q_$FILE.Seek_Address = 0;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	     if ^local_error then dqh_ptr = addr (gtss_def_q_$FILE.no_characters);
	end;
	if ^local_error then call get_cat_entry;
	if local_error then do;
	     cat_e_parm = 0;
	     dcp = null ();
	end;
	else do;
	     cat_e_parm = cat_entry;
	     dcp = dc_ptr;
	end;
	return;

dibp:	entry (drun_job_id, dibp);

/**
	arg_1 (input)	The DRUN job id.
	arg_2 (output)	A pointer to the DIB entry.
			Null if the entry could not be found.
**/

	caller = "gtss_dq_$dibp";
	call gtss_ascii_bcd_ (addr (drun_job_id), 5, addr (bcd_jid));
	call gtss_aft_$find ("#D", fn, code);
	if code ^= 0 then call access_dq;
	if ^local_error then do;
	     gtss_def_q_$FILE.Seek_Address = 0;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	     if ^local_error then do;
		dqh_ptr = addr (gtss_def_q_$FILE.no_characters);
		cat_entries_avail = dqh_ptr -> dq_header.dhbsn.no_of_cea;
	     end;
	end;
	if ^local_error then call get_cat_entry;
	if ^local_error then do;
	     gtss_def_q_$FILE.Seek_Address = (5 * drun_file_size) - cat_entries_avail + cat_entry - 1;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	end;
	if local_error then dibp = null ();
	else dibp = addr (gtss_def_q_$FILE.no_characters);
	return;

entries_info: entry (eip, no_of_e, no_of_entries_found);

/**
	arg_1 (input)	A pointer to the info structure.
	arg_2 (input)	The number of entries in the structure.
	arg_3 (output)	The number of entries found.

**/
	caller = "gtss_dq_$entries_info";
	if eip = null () then do;
	     call com_err_ (0, caller,
		"Invalid pointer to structure.");
	     no_of_entries_found = 0;
	     return;
	end;

	call gtss_dq_$hdrp (dqh_ptr);
	if dqh_ptr = null () then call gtss_abort_subsystem_ (
	     null (),
	     caller,
	     0,
	     "Could not get pointer to #D queue's header.");
	read_limit = dqh_ptr -> dq_header.dhbsn.no_of_cea / 8;
	wp = dqh_ptr;
	curr_entry = 1;

/** Examine the first seven entries contained in the header **/
	do i = 2 to 8;
	     dc_ptr = addr (words (i));
	     if dc_ptr -> dq_catalog.dcjid.job_status ^= 0 then do;
		entries_info.job_stat (curr_entry) =
		     dc_ptr -> dq_catalog.dcjid.job_status;
		call gtss_bcd_ascii_ (addr (dc_ptr -> dq_catalog.dcjid.bcd_job_id), 5, addr (entries_info.did (curr_entry)));
		entries_info.aid (curr_entry) = gtss_abs_$get_id (entries_info.did (curr_entry));
		curr_entry = curr_entry + 1;
	     end;
	end;

/** And examine the rest of the entries **/
	do sec_no = 1 to read_limit;
	     gtss_def_q_$FILE.Seek_Address = sec_no;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	     do i = 1 to 8;
		dc_ptr = addr (words (i));
		if dc_ptr -> dq_catalog.dcjid.job_status ^= 0 then do;
		     entries_info.job_stat (curr_entry) =
			dc_ptr -> dq_catalog.dcjid.job_status;
		     call gtss_bcd_ascii_ (addr (dc_ptr -> dq_catalog.dcjid.bcd_job_id), 5, addr (entries_info.did (curr_entry)));
		     entries_info.aid (curr_entry) = gtss_abs_$get_id (entries_info.did (curr_entry));
		     curr_entry = curr_entry + 1;
		end;
	     end;
	end;

	no_of_entries_found = curr_entry - 1;
	if db_dq then
	     if curr_entry - 1 > 0 then
		do i = 1 to curr_entry - 1;
		call ioa_ ("^a   ^a   Job status = ^i",
		     entries_info.did (i), entries_info.aid (i), entries_info.job_stat (i));
	     end;


	return;


mod_js:	entry (drun_job_id, job_stat, error);


/**
	arg_1 (input)	The DRUN job id.
	arg_2 (input)	The new value of job status. (See DB84 16-20 DCJID)
	arg_3 (output)	Set to 0 if operation successful.
**/


	caller = "gtss_dq_$mod_js";
	error = "0"b;
	if job_stat > 7 then do;
	     call com_err_ (0, caller,
		"^d is not a valid job status", job_stat);
	     error = "1"b;
	     return;
	end;
	call gtss_ascii_bcd_ (addr (drun_job_id), 5, addr (bcd_jid));

/* Read header, get sector with catalog entry, change job status, write back out */
	gtss_def_q_$FILE.Seek_Address = 0;
	gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	call read_sector;
	if local_error then do;
	     error = local_error;
	     return;
	end;
	dqh_ptr, dc_ptr = addr (gtss_def_q_$FILE.no_characters);
	call get_cat_entry;
	if local_error then do;
	     error = local_error;
	     return;
	end;
	dc_ptr -> dq_catalog.dcjid.job_status = job_stat;
	if i = 0 then gtss_def_q_$FILE.Seek_Address = i;
	else gtss_def_q_$FILE.Seek_Address = i - 1;
	gtss_def_q_$FILE.OP2.Device_Command = write_cmd;
	call write_sector;
	if local_error then do;
	     error = local_error;
	     return;
	end;

/* Read the file into the buffer		*/
	do i = 0 to hbound (d_buf, 1);
	     gtss_def_q_$FILE.Seek_Address = i;
	     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
	     call read_sector;
	     if local_error then do;
		error = local_error;
		return;
	     end;
	     d_buf (i) = dqh_ptr -> sector;
	end;

/* Calculate checksum on buffer, move header from buffer to output buffer,
   write header sector back to #D file				*/
	checksum_field = checksum (addrel (addr (d_buf (0)), 1),
	     ((hbound (d_buf, 1) + 1) * 64) - 1);

	dqh_ptr -> sector = addr (d_buf (0)) -> sector;
	gtss_def_q_$FILE.OP2.Device_Command = write_cmd;
	gtss_def_q_$FILE.Seek_Address = 0;
	call write_sector;
	if local_error then do;
	     error = local_error;
	     return;
	end;

	return;

create_file: proc;

	     call user_info_$homedir (gtss_file_values.dname);
	     gtss_file_values.new_ename = drun_file_name;

	     call hcs_$make_seg (gtss_file_values.dname, gtss_file_values.new_ename,
		"", 10, seg_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gtss_dq_create",
		     "Could not create drun_#d_q seg, quitting");
		local_error = "1"b;
		return;
	     end;

	     call hcs_$set_bc_seg (seg_ptr, drun_file_size*320*36, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Could not set bit count, quitting");
		local_error = "1"b;
		return;
	     end;

	     call hcs_$set_safety_sw (gtss_file_values.dname, gtss_file_values.new_ename,
		"1"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Cannot set safety switch, quitting");
		local_error = "1"b;
		return;
	     end;

	     call hcs_$make_seg (gtss_file_values.dname,
		absin_fn, "", 10, seg_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gtss_dq_create",
		     "Could not create absin seg, quitting");
		local_error = "1"b;
		return;
	     end;

	     char_string = gtss_abs_$create_absin ();
	     csl = length (char_string);
	     chars = char_string;
	     call hcs_$set_bc_seg (seg_ptr, csl * 9, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Could not set bit count, quitting");
		local_error = "1"b;
		return;
	     end;
	     call hcs_$set_safety_sw (gtss_file_values.dname, absin_fn,
		"1"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Cannot set safety switch, quitting");
		local_error = "1"b;
		return;
	     end;

	end;					/* create_file */

set_attr:	proc;
	     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 = "1"b;
	     gtss_file_values.data_flags.busy = "0"b;
	     gtss_file_values.data_flags.null_file = "1"b;

	     gtss_file_values.data_fields.curll = drun_file_size;
	     gtss_file_values.data_fields.maxll = drun_file_size;
	     gtss_file_values.data_fields.number_allocations = 0;

	     gtss_file_values.attributes.attr = "0"b;
	     string (date_val) = date ();
	     gtss_file_values.creation_date = mm||dd||yy;

	     call gtss_attributes_mgr_$set (addr (gtss_file_values.version), code);
	     if code ^= 0 then do;
		call com_err_ (code, caller,
		     "Could not set attributes");
		local_error = "1"b;
		return;
	     end;

	end;					/* set_attr */

access_dq: proc;

	     call gtss_aft_$find ("#D", fn, code);
	     if code ^= 0 then do;
		call gtss_aft_$add ("#D", fn, code);
		if code = 1 then do;
		     call com_err_ (0, caller,
			"#D file already in aft");
		     local_error = "1"b;
		     return;
		end;
		else if code ^= 0 then do;
		     call com_err_ (0, caller,
			"Could not add #D file to aft (status ^i)", code);
		     local_error = "1"b;
		     return;
		end;
	     end;
	     gtss_file_values.version = 1;
	     gtss_file_values.change_name = "0"b;
	     gtss_file_values.new_ename = " ";
	     gtss_file_values.ename = drun_file_name;
	     call user_info_$homedir (gtss_file_values.dname);

	     call gtss_attributes_mgr_$get (addr (gtss_file_values), code);
	     if code ^= 0 then do;
		call com_err_ (0, caller,
		     "Couldn't get #D attributes (code ^i)", code);
		local_error = "1"b;
		return;
	     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 1. */
	     call gtss_attributes_mgr_$set (addr (gtss_file_values), code);
	     if code ^= 0 then do;
		call com_err_ (0, caller,
		     "Couldn't reset attributes (code ^i)", code);
		local_error = "1"b;
		return;
	     end;


/**	Set runtime attributes structure for ios. **/
	     gtss_file_attributes_ptr = addr (gtss_tfa_ext_$file_attributes.temp_file (fn));
	     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;
	     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;					/* access_dq */


init_head_cat: proc;


	     call gtss_aft_$find ("#D", fn, code);
	     if code ^= 0 then do;
		call com_err_ (0, caller,
		     "Couldn't find #D in aft");
		local_error = "1"b;
		return;
	     end;
	     call gtss_ios_open_ (
		fn,
		gtss_file_values.dname,
		gtss_file_values.ename,
		"110000"b,
		"1"b,
		gtss_file_attributes_ptr,
		addr (gcos_status),
		code);
	     if gcos_status.bit12 ^= "4000"b3 then do;
		call com_err_ (0, caller,
		     "Couldn't open #D file (status ^w)",
		     gcos_status.bit12);
		local_error = "1"b;
		return;
	     end;
	     else file_opened = "1"b;
	     dqh_ptr = addr (gtss_def_q_$FILE.RECORD.no_characters);
	     unspec (dqh_ptr -> dq_header) = "0"b;
	     dqh_ptr -> dhbsn.no_of_cea = (320 * drun_file_size - 8) / 72;
	     call decode_clock_value_ (
		clock_ ()
		, month
		, day_of_month
		, year
		, time_of_day
		, day_of_week
		, time_zone
		);

	     ascii_date.yr = mod (year, 100);
	     ascii_date.mo = month;
	     ascii_date.dy = day_of_month;
	     call gtss_ascii_bcd_ (addr (ascii_date), 6, addr (dqh_ptr -> dhdat));

	     milsec = divide (time_of_day, 1000, 71);
	     milsec64ths = milsec*64;
	     dqh_ptr -> dhtim = milsec64ths;
	     dqh_ptr -> dhrns = milsec64ths;
	     sp = dqh_ptr;
	     dc_ptr = addr (sp -> cs (33));
	     unspec (dc_ptr -> dq_catalog) = "0"b;
	     dc_ptr -> dcdsd = dqh_ptr -> dhdat;
	     dc_ptr -> dcdst = -1;

	     gtss_def_q_$FILE.OP2.Device_Command = write_cmd;
	     call gtss_ios_io_ (
		fn,
		addr (gtss_def_q_$FILE.select_sequence),
		addr (gtss_def_q_$FILE.select_sequence),
		fixed (rel (addr (gtss_def_q_$FILE.DQ))),
		status,
		code);
	     if status ^= 0 then do;
		call com_err_ (code, caller,
		     "Unable to write header. (status ^i)", status);
		local_error = "1"b;
		return;
	     end;

	     call close_file;

	end;					/* init_dq_head */

read_sector: write_sector: proc;

/** Read/write #D sector **/
	     call gtss_aft_$find ("#D", fn, code);
	     if code ^= 0 then do;
		call com_err_ (0, caller,
		     "Couldn't access the #D file.");
		local_error = "1"b;
		return;
	     end;
	     call gtss_ios_io_ (
		fn,
		addr (gtss_def_q_$FILE.select_sequence),
		addr (gtss_def_q_$FILE.select_sequence),
		fixed (rel (addr (gtss_def_q_$FILE.DQ))),
		status,
		code);
	     if status ^= 0 then do;
		call com_err_ (code, caller,
		     "Unable to read/write sector. (status ^i)", status);
		local_error = "1"b;
		return;
	     end;

	end;					/* read_sector */

get_cat_entry: proc;

	     cat_entries_avail = dqh_ptr -> dq_header.dhbsn.no_of_cea;
	     read_limit = dqh_ptr -> dq_header.dhbsn.no_of_cea / 8;

/** Find the catalog entry **/
	     i = 0;
	     if ^find_cat_entry () then do;
		not_found = "1"b;
		do i = 1 to read_limit while (not_found);
		     gtss_def_q_$FILE.OP2.Device_Command = read_cmd;
		     gtss_def_q_$FILE.Seek_Address = i;
		     call gtss_ios_io_ (
			fn,
			addr (gtss_def_q_$FILE.select_sequence),
			addr (gtss_def_q_$FILE.select_sequence),
			fixed (rel (addr (gtss_def_q_$FILE.DQ))),
			status,
			code);
		     if status ^= 0 then do;
			call com_err_ (code, caller,
			     "Unable to read catalog sector. (status ^i)", status);
			local_error = "1"b;
			return;
		     end;
		     if find_cat_entry () then not_found = "0"b;
		end;

		if i > read_limit then do;
		     local_error = "1"b;
		     cat_entry = 0;
		end;

	     end;

	     if i ^= 0 then
		cat_entry = 7 + ((i - 1) * 8) + cat_entry;
	     else cat_entry = cat_entry - 1;

find_cat_entry: proc returns (bit (1));

		wp = addr (gtss_def_q_$FILE.RECORD.no_characters);

		do cat_entry = 1 to 8;
		     dc_ptr = addr (words (cat_entry));
		     if dc_ptr -> dq_catalog.dcjid.bcd_job_id = bcd_jid
		     then return ("1"b);
		end;

		return ("0"b);

	     end;					/* find_cat_entry */

	end;					/* get_cat_entry */

close_file: proc;

	     call gtss_aft_$find ("#D", fn, code);
	     if code ^= 0 then do;
		file_opened = "0"b;
		return;
	     end;
	     call gtss_ios_close_ (fn, addr (gcos_status), code);
	     if gcos_status.bit12 ^= "4000"b3 then do;
		call com_err_ (0, caller,
		     "Couldn't close #D file (status ^w)",
		     gcos_status.bit12);
		local_error = "1"b;
		return;
	     end;
	     file_opened = "0"b;

	end;					/* close_file */


/*	gtss_dq_ local declares	*/

dcl CR char (1) init ("
");
dcl absin_fn char (32) init ("drun_control.absin");
dcl bcd_jid bit (30);
dcl caller char (32) varying;
dcl cat_entry fixed bin (18) unsigned;
dcl cat_e_parm fixed bin (18) unsigned parm;
dcl cat_entries_avail fixed bin (18) unsigned;
dcl char_string char (252) varying;
dcl checksum_field bit (36) based (addr (d_buf (0)));
dcl chars char (csl) based (seg_ptr);
dcl clock_ entry returns(fixed bin(71));
dcl code fixed bin (35);
dcl cs (253) char (1) based;
dcl csl fixed bin (24);
dcl curr_entry fixed bin (18) unsigned;
dcl day_of_month fixed bin;
dcl day_of_week fixed bin;
dcl date builtin;
dcl d_buf (0:((320*71-8)/72/8)-1) bit (36 * 64);
dcl dc_ptr ptr init (null());
dcl dcp ptr parm;
dcl decode_clock_value_ entry(fixed bin(71),fixed bin,fixed bin,fixed bin,fixed bin(71),fixed bin,char(3)aligned);
dcl dib_ptr ptr init (null());
dcl dibp ptr parm;
dcl dqh_ptr ptr init (null());
dcl dqhp ptr parm;
dcl drun_file_name char (32) init ("drun_#d_q");
dcl drun_file_size fixed bin (24) init (71);
dcl drun_job_id char (5) parm;
dcl djid char (5);
dcl eb bit (1);
dcl eip ptr parm;
dcl error bit (1) parameter;
dcl file_opened bit (1) static internal init ("0"b);
dcl fn fixed bin (24);
dcl gtss_fail condition external;
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 hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35));
dcl i fixed bin (18) unsigned;
dcl ioa_ entry options (variable);
dcl j fixed bin (18) unsigned;
dcl job_stat fixed bin (6) unsigned parm;
dcl local_error bit (1) automatic init ("0"b);
dcl max_attempts fixed bin init (50);
dcl milsec64ths fixed bin(35);
dcl milsec fixed bin(71);
dcl month fixed bin;
dcl no_of_e fixed bin (18) unsigned parm;
dcl no_of_entries_found fixed bin (18) unsigned parm;
dcl not_found bit (1);
dcl read_limit fixed bin (18) unsigned;
dcl sec_no fixed bin (18) unsigned;
dcl sector bit (36 * 64) based;
dcl seg_ptr ptr init (null());
dcl sp ptr init (null());
dcl status fixed bin (24);
dcl timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl time_of_day fixed bin(71);
dcl time_zone char(3)aligned;
dcl user_info_$homedir entry (char(*));
dcl wait_time fixed bin (71) init (1);
dcl words (8) bit (36 * 8) based (wp);
dcl wp ptr init (null());
dcl year fixed bin;
dcl 1 ascii_date aligned,
      2 yr pic "99" unal,
      2 mo pic "99" unal,
      2 dy pic "99" unal;
dcl 1 date_val,
      2 yy char(2)unal,
      2 mm char(2)unal,
      2 dd char(2)unal;

dcl 1 entries_info (no_of_e) based (eip),
      2 did char (5),
      2 aid char (19),
      2 job_stat fixed bin (6) unsigned;
dcl 1 gcos_status aligned,
     2 bit12 bit(12)unal,
     2 bit60 bit(60)unal;


%include gtss_file_values;

%include gtss_def_q_;

%include gtss_deferred_queue;

%include gtss_device_cmds;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;

%include gtss_tfa_ext_;

%include gtss_db_names;

%include gtss_ext_;

%include gtss_ust_ext_;

%include gtss_checksum;
     end;						/* gtss_dq */
   



		    gtss_drl_abort_.pl1             12/11/84  1349.3rew 12/10/84  1042.9       13824


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

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

/* *	gtss abort subsystem.

   Authors:	Robert J. Grimes	Created
   Albert N. Kepner	  1978
   Robert M. May
   David B. Ward
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;

/* *

   DRL ABORT, ABORT SUBSYSTEM (octal 07)


   8_________1_6_____________________

   DRL      ABORT

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-6)

*/

	mcp = mcpp;
	scup = addr (mc.scu);
	increment = 0 ;				/* Zero arguments */
	call gtss_abort_subsystem_ (mcp,
	     "gtss_drl_abort_",
	     35,
	     gtss_pnterr.err35,
	     fixed (scu.ilc, 18));
	return;

/* *	Variables for gtss_drl_abort_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  gtss_fail condition;

%include gtss_pnterr;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;
     end						/* gtss_drl_abort_ */;



		    gtss_drl_addmem_.pl1            12/11/84  1349.3rew 12/10/84  1043.0       39114


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

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

gtss_drl_addmem_: proc (mcpp, increment);

/**	gtss add memory.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db switch.
   Change:  Ron Barstad  02/07/83  Remove changing gtss_spa.lhole.total--the
                                   real drl does not do this. Will allow B
                                   program to run.
   **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL ADDMEM, ADD MEMORY (octal 16)


   8_________1_6_____________________

   DRL      ADDMEM
   C(A)     return location,0
   C(Q)     0,number words high

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-08)

*/

	increment = 0 ;				/* Zero arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

	if (AU > gtss_ust.lsize.limit) /* remove? | (fixed (AU, 18) < 100) | (AL ^= "0"b) */ then do;
	     if db_drl_addmem then
		call ioa_ (
		"gtss_drl_addmem_"
		, "Improper return address: AU=^6o AL=^6o lisize.limit=^6o"
		, AU
		, AL
		, gtss_ust.lsize.limit
		);

/* Improper return address. */
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_addmem_"
		, 4
		, gtss_pnterr.err4
		, fixed (scu.ilc, 18)
		);
	     return;
	end;

	nl = divide (fixed (QL, 18, 0), 1024, 24)*1024;	/* Number of additional memory words requested. */
	ZERO_l = nl*36;				/* Number of bits to zero. */
	ml = fixed (gtss_ust.lsize.limit, 18, 0) + nl;	/* set up the new limit */

	if ml > gtss_install_values_$memory_limit then do;

/* Exceeds installation limit. */
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_addmem_"
		, 0
		, gtss_pnterr.err100
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	addrel (gseg, gtss_ust.lsize.limit) -> ZERO = "0"b;
	gtss_ust.lswap.size, gtss_ust.lsize.limit = ml_r18; /* Save new limit in ust */
/*	gtss_spa.lhole.total = ml;	NO! */		/* Save new limit in slave prefix */

	gtss_ust.lsize.bar = divide (ml+511, 512, 17, 0);
	call gtss_set_slave_$load_bar (fixed (gtss_ust.lsize.bar, 18, 0)); /* Reset BAR register. */

	gtss_spa.losti.ilc = AU;			/* set up the return address in the slave area */
	gtss_spa.losti.ir = "0"b;			/* zero the indicators */

	increment = fixed (AU, 18, 0) - fixed (scu.ilc, 18, 0) -1; /* Restart execution of user's code at return location. */

	if db_drl_addmem then
	     call ioa_ (
	     "gtss_drl_addmem_:  words added ^i, limit ^i, A-reg ^w, Q-reg ^w."
	     , nl
	     , ml
	     , Afix
	     , Qfix);
	return;


/**  Variables for gtss_drl_addmem_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  Afix                     fixed bin (35)aligned based (addr (A_reg));
dcl  Qfix                     fixed bin (35)aligned based (addr (Q_reg));
dcl  ioa_                     entry options (variable);
dcl  ZERO                     bit (ZERO_l)based;
dcl  ZERO_l                   fixed bin (24);
dcl  nl                       fixed bin (35);
dcl  ml                       fixed bin (35);
dcl  gseg                     ptr init(null());
dcl  status                   fixed bin (35);

dcl 1 ml_overlay aligned based (addr (ml)),
    2 ml_l18 bit (18)unal,
    2 ml_r18 bit (18)unal;

dcl 1 Q_reg aligned based (addr (mc.regs.q)),
    2 QU bit (18)unal,
    2 QL bit (18)unal;

dcl 1 A_reg aligned based (addr (mc.regs.a)),
    2 AU bit (18)unal,
    2 AL bit (18)unal;

%include gtss_spa;

%include gtss_ust_ext_;

%include gtss_pnterr;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;

%include gtss_install_values_;

%include gtss_db_names;
     end						/* gtss_drl_addmem_ */;
  



		    gtss_drl_callss_.pl1            11/05/86  1603.9r w 11/04/86  1034.1       29376


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

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

/*	Internal call to another subsystem.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward	05/17/79 Debug display of ss name.
   Changed: Bob Alvarado	11/26/79 Added callss_pound_sign_comd entry.
   Changed: Dave Ward         1981     sorted dcl, added %page
*/
dcl  increment                fixed bin parm;
dcl  mcpp                     ptr parm;
	mcp = mcpp;

/*

   DRL CALLSS, INTERNAL CALL TO ANOTHER SUBSYSTEM (octal 30)


   8_________1_6_____________________

   DRL      CALLSS
   ASCII    1,name

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1977
   Page 3-9)

*/
%page;
	increment = 1 ;				/* One argument */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/* Check for DRL RETURN following the DRL CALLSS. If found,
   the combination is treated as a DRL T.GOTO */
	if next_instruction = "000005002000"b3 then do;	/* DRL RETURN */
	     if db_drl_callss then
		call ioa_ ("gtss_drl_callss_: DRL T.GOTO ""^a""", ss_name);
	     call gtss_interp_prim_$t_goto (ss_name);
	end;

/* The above call does not return. The t_goto entry point causes
   the process stack to be unwound to the previous invocation of
   the primitive interpreter. */
	goto cont;
%page;
callss_pound_sign_comd: entry (ap, increment);
dcl  ap                       ptr parm;
	mcp = null ();
	arg_list_ptr = ap;
cont:

/* Call a new subsystem */
/* But first save the bar mode stack pointer */

	sb = baseptr (baseno (addr (bar_mode_stack_ptr))); /* Get ptr to stack_4 */
	bar_mode_stack_ptr = stack_header.bar_mode_sp;

	if db_drl_callss then
	     call ioa_ ("gtss_drl_callss_: DRL CALLSS ""^a""", ss_name);
	call gtss_interp_prim_$callss (ss_name, mcp);

/* Restore bar mode stack pointer */
	stack_header.bar_mode_sp = bar_mode_stack_ptr;
	return;
%page;
/*   Variables for gtss_drl_callss_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  arg_list_ptr             ptr init(null());
dcl  bar_mode_stack_ptr       ptr auto	/* This variable must be automatic */;
dcl  gseg                     ptr init(null());
dcl  ioa_                     entry options(variable);

dcl 1 arg_list aligned based (arg_list_ptr),
    2 ss_name char (4) unal,
    2 next_instruction bit (36);
%page;
%include gtss_ext_;
%page;
%include mc;
%page;
%include gtss_entry_dcls;
%page;
%include stack_header;
%page;
%include gtss_db_names;
     end gtss_drl_callss_;



		    gtss_drl_corfil_.pl1            12/11/84  1349.3rew 12/10/84  1043.0       46548


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

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

/*

   DRL CORFIL, DATA FROM/TO CORE FILE (octal 17)


   8_________1_6______

   DRL      CORFIL


   C(A)     Data location             n

   C(Q)        i                      k

   A short block of memory, called the core file, is maintained
   for each user.  It allows one subsystem to pass data  to  another
   without accessing a mass storage device.  This block of memory is
   10  words  in  length  and  may be written or read by a subsystem
   using the CORFIL derail.


   The  left  half  of  A  contains  the  location  within  the
   subsystem  that the data is to be read into or written from.  The
   right  half  of  A  contains  the  number  of  words  (n)  to  be
   transmitted.   The  value  of n must be equal to or less than 10.
   The left half of Q contains the number of the memory cell (i)  at
   which  transmission is to begin.  The memory cells are numbered 1
   through 10.  The right half  of  Q  (k)  indicates  the  type  of
   operation desired:


   k = 0 - transfer data from subsystem to memory
   k = 1 - transfer data from memory to subsystem

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

*/
						/* 	External Entries						 */


/* 	Work Variables						 */

dcl  increment fixed bin;				/* no of param words to skip */
dcl 1 a aligned,
    2 address fixed bin (17) unaligned,
    2 number_words fixed bin (17) unaligned;

dcl 1 q aligned,
    2 start_word fixed bin (17) unaligned,
    2 r_w_indicator fixed bin (17) unaligned;

dcl  buffer_ptr ptr init(null());
dcl  buffer (0:9) bit (36) unaligned based (buffer_ptr);

dcl  number_words fixed bin;
dcl  i fixed bin;
dcl  j fixed bin;

dcl (addrel, fixed, unspec, addr, divide) builtin;

/* 	P     R     O     C     E     D     U     R     E		 */


	scup = addr (mc.scu);

	increment = 0;				/* no arguements */
	unspec (a) = unspec (mc.regs.a);		/* get copy of a register */
	unspec (q) = unspec (mc.regs.q);		/* and also the q register */

/* check for valid location for the place to stuff the stuff */
	if a.address > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_corfil_",
		11,
		gtss_pnterr.err11,
		fixed (scu.ilc, 18));
	     return;
	end;
						/* check for some words to move */
	if a.number_words > 0 then do;
						/* don't allow more than 10 words to be specified */
	     if a.number_words > 10 then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_corfil_",
		     11,
		     gtss_pnterr.err11,
		     fixed (scu.ilc, 18));
		return;
	     end;
						/* check for upper bound of the buffer to be filled */
	     if (a.address+a.number_words-1) > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_corfil_",
		     11,
		     gtss_pnterr.err11,
		     fixed (scu.ilc, 18));
		return;
	     end;
						/* don't allow a negative start */
	     if q.start_word < 0 then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_corfil_",
		     11,
		     gtss_pnterr.err11,
		     fixed (scu.ilc, 18));
		return;
	     end;
						/* or allow more than 10 words requested */
	     if q.start_word > 10 then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_corfil_",
		     11,
		     gtss_pnterr.err11,
		     fixed (scu.ilc, 18));
		return;
	     end;
						/* if offset is > 0 then reduce to a zero start location */
	     if q.start_word > 0 then q.start_word = q.start_word - 1;
						/* calculate end location */
	     number_words = a.number_words + q.start_word-1;
						/* check for validatity */
	     if number_words > 10 then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_corfil_",
		     11,
		     gtss_pnterr.err11,
		     fixed (scu.ilc, 18));
		return;
	     end;
						/* set up pointer around users buffer */
	     buffer_ptr = addrel (
		gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_)
		, a.address);
						/* set to always start at beginning of corefile */
	     j = 0;
						/* for subsystem to core file */
	     if q.r_w_indicator = 0 then
		do i = q.start_word to number_words;
		gtss_ust.lcfil (j) = buffer (i);
		j = j+1;
	     end;
	     else
						/* for core file to subsystem */
	     do i = q.start_word to number_words;
		buffer (i) = gtss_ust.lcfil (j);
		j = j+1;
	     end;
						/* all done */
	end;

%include gtss_ust_ext_;

%include gtss_pnterr;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;
     end gtss_drl_corfil_;



		    gtss_drl_defil_.pl1             12/11/84  1349.3rew 12/10/84  1043.0       70929


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

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

gtss_drl_defil_: proc (mcpp, increment);

/* *	gtss create a temporary file.

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

   Changed: Al Dupuis	10/18/79 To keep temp file size up to date.
   Changed: Dave Ward	02/06/80 corrected file size returned if in aft.
   Changed:  Ron Barstad  02/07/83  Fixed incorrectly formatted ioa control string in com_err call
   * */
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/* *

   DRL DEFIL,  DEFINE AND ACCESS A TEMPORARY FILE (octal 6)


   8_________1_6_____________________

   DRL      DEFIL
   ZERO     L(arg),L(stat)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-34,35)

*/

	increment = 1 ;				/* One arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/* *	Obtain name of file to rewind.	* */
	if (fixed (L_arg, 18)+2) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_defil_",
		4,
		"DEFIL: File name outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	arg_ptr = addrel (gseg, L_arg);

/* *	Obtain pointer to return status word.	* */
	if L_stat >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_defil_",
		4,
		"DEFIL: Status word outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	status_words_ptr = addrel (gseg, L_stat);

/* *	Obtain (fn) the AFT index to the file.	* */
create_temp: ;
	call gtss_aft_$add ((ascii_file_name), fn, code);
	if code = 1 then do;			/* Name already in AFT. */
	     status_word_1 = 5;			/* Duplicate file name (i.e., already in AFT. */
	     Device_type = temp_file (fn).device_type;
	     Words_per_physical_block = temp_file (fn).words_block;
	     Size_in_blocks_or_links = temp_file (fn).llink_flag; /* 0 => links, 1 => llinks (blocks). */
	     Linked_or_Random = temp_file (fn).mode;
	     Perm_or_Temp = temp_file (fn).perm;
	     File_size = temp_file (fn).size;

load_A_register: ;
	     mc.regs.a = A_reg_b36;
	     if db_drl_defil then
		call ioa_ (
		"gtss_drl_defil_: ""^a"" (aft ^i)"
		||"^/A-reg (dev=^2o wpb=^4o random=^1b perm=^1b size=^5o^[l^;^s^]links)"
		, ascii_file_name
		, fn
		, fixed (A_reg.Device_type, 24)
		, fixed (A_reg.Words_per_physical_block, 24)
		, A_reg.Linked_or_Random
		, A_reg.Perm_or_Temp
		, fixed (A_reg.File_size, 17)
		, A_reg.Size_in_blocks_or_links
		);
	     return;
	end;
	if code = 2 then do;			/* AFT full. */
no_temp_available: ;
	     status_word_1 = 3;			/* No room in AFT. */
	     return;
	end;
						/* => code =0 */

/* *	Prepare gtss_ios_ file attributes block
   for temp file.
   * */
	temp_file (fn).max_size = 0;			/* 0 => unlimited */
	temp_file (fn).current_size = fixed (arg2.d, 17)*12; /* d is in links, current_size in llinks.  */
	temp_file (fn).non_null = "0"b;		/* Has never been written to. */
	temp_file (fn).user_attr = "0"b;		/* (no used). */
	if arg2.b then
	     Device_type, temp_file (fn).device_type = arg2.a;
	else
	Device_type, temp_file (fn).device_type = "64"b3;
	Words_per_physical_block, temp_file (fn).words_block = "0100"b3; /* 100 oct = 64 dec words per block (ALWAYS). */
	Size_in_blocks_or_links, temp_file (fn).llink_flag = "0"b; /* 0 => links (12 llinks/blocks @). */
	Linked_or_Random, temp_file (fn).mode = arg2.c;	/* 0 (linked) | 1 (random). */
	Perm_or_Temp, temp_file (fn).perm = "0"b;	/* Temporary file. */
	temp_file (fn).fill = "0"b;
	File_size, temp_file (fn).size = "00"b||arg2.d;	/* size 14 bits, d 12 bits. */

	call gtss_ios_open_ (
	     /* 1 */ (fn)				/* AFT index. */
	     , /* 2 */ (gtss_ext_$pdir)		/* Temp file directory. */
	     , /* 3 */ file_name (fn)
	     , /* 4 */ "110000"b			/* bit=1 => read, bit2=1 => write. */
	     , /* 5 */ arg2.c			/* => linked or random. */
	     , /* 6 */ addr (temp_file (fn))
	     , /* 7 */ addr (fms_status)		/* gtss_ios_ status code. */
	     , /* 8 */ code				/* Multics error code. */
	     );
dcl 1 fms_status aligned,
      2 bit12 bit(12)unal,
      2 bit60 bit(60)unal;
	if fms_status.bit12 = "4000"b3 then do;
	     status_word_1 = 0;			/* Successful. */
	     goto load_A_register;
	end;
	call com_err_ (
	     code
	     , "gtss_drl_defil_"
	     , "gtss_ios_open_ status=^w. Can't open ""^a"""
	     , fms_status
	     , ascii_file_name
	     );
	aft_entry (fn).used = "0"b;			/* => Don't close, forget aft entry. */
	status_word_1 = 4;				/* Temporary file not available. */
	return;

subr:	entry (arg_ptr_p, status_words_ptr_p, mcp_p);

/* *	Subroutine entry to create a temp file.

   Caller must supply "arg" structure values and
   one word (based status_words_ptr_p).
   "mcp_p" should be set to space large enough so
   mc.regs.a variable can be used (see mc.incl.pl1).
   The 1st parameter (arg_ptr_p) points to the
   AFT file number variable (fixed bin) at return.
   * */
dcl  arg_ptr_p                ptr parm;
dcl  status_words_ptr_p       ptr parm;
dcl  mcp_p                    ptr parm;

	arg_ptr = arg_ptr_p;
	arg_ptr_p = addr (fn);			/* Point to AFT file number variable. */
	status_words_ptr = status_words_ptr_p;
	mcp = mcp_p;
	goto create_temp;

dcl  ioa_                     entry options(variable);

file_name: proc (f)returns (char (32)var);

/*	Provide Multics segment name for temp file.	* */
dcl  f                        fixed bin (24)parm;

	     p2 = f;				/* Convert AFT index to 2 numeric digits. */
	     r = unique_chars_ ("0"b);
	     r = r||".";
	     r = r||translate (aft_entry (f).altname, "+'_~????", "*. ;<>()");
	     r = r||".";
	     r = r||char (p2);
	     return (r);

dcl  r                        char (32)var;
dcl  p2                       pic"99";
	end					/* file_name */;

/* *	Variables for gtss_drl_defil_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  A_reg_b36                bit (36)aligned init ("0"b);
dcl  addrel                   builtin;
dcl  arg_list_ptr             ptr init(null());
dcl  arg_ptr                  ptr init(null());
dcl  code                     fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  index                    builtin;
dcl  status                   fixed bin (24);
dcl  status_word_1            fixed bin (24)aligned based (status_words_ptr);
dcl  unique_chars_            entry (bit (*))returns (char (15));

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_arg bit (18)unal
     , 2 L_stat bit (18)unal
     ;

dcl 1 A_reg aligned based (addr (A_reg_b36))
     , 3 Device_type bit (06)unal
     , 3 Words_per_physical_block bit (12)unal
     , 3 Size_in_blocks_or_links bit (01)unal
     , 3 Linked_or_Random bit (01)unal
     , 3 Perm_or_Temp bit (01)unal
     , 3 unused bit (01)unal
     , 3 File_size bit (14)unal
     ;

%include gtss_ext_;

%include mc;

%include gtss_io_status_words;

%include gtss_tfa_ext_;

%include gtss_dfd_ext_;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_defil_arg;

%include gtss_db_names;
     end						/* gtss_drl_defil_ */;
   



		    gtss_drl_dio_.pl1               12/11/84  1349.3rew 12/10/84  1043.0       51480


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

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

/**	gtss user's disk i/o.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	3/30/79 Debug display dio action.
   Change:  Bob Alvarado      08/22/79 added io  count to ust.
   Change:  Paul Benjamin	09/26/79 Error message for attempt to write to read-only file
   Change:  Dave Ward	10/30/79 Failure for quota overflow.
*/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL DIO, DO I/O ON USER'S FILE (octal 1)


   8_________1_6_____________________

   DRL      DIO
   Seek command
   ZERO     L(fileid),L(dcw1)
   Read/Write command
   ZERO     L(fileid),L(dcw2)
   ZERO     L(status),0

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-35)

*/

	increment = 5 ;				/* Five arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get address of arglist */

/**	Obtain name of file on which to do i/o.	**/
	if seek_locs.L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_dio_",
		4,
		"DIO: file name outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	afn_ptr = addrel (gseg, seek_locs.L_fileid);

/**	Obtain pointer to return status word.	**/
	if L_status >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_dio_",
		4,
		"DIO: Status word outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	status_words_ptr = addrel (gseg, L_status);
	unspec (status_words.WORD1) = "0"b;		/* => Major status = 0. */
	Termination_indicator = "1"b;

/**	Obtain (fn) the AFT index to the file.	**/
	call gtss_aft_$find (ascii_file_name, fn, code);

	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     Major_status = "0001"b;			/* Device busy. */
	     return;
	end;
	if db_drl_dio then
	     call com_err_ (
	     0
	     , "gtss_drl_dio_"
	     , "^a on file ""^a"" (aft ^i)"
	     , iocmd (read_write_cmd.device_command)
	     , translate (ascii_file_name, UPPER, lower)
	     , fn
	     );

	call gtss_ios_io_ (
	     fn
	     , arg_list_ptr
	     , arg_list_ptr
	     , fixed (gtss_ust.lsize.limit, 24)
	     , status
	     , code);
	if (status ^= 0) & (status ^= 1) then do;	/* Not success and not eof. */
	     if db_drl_dio then
		call com_err_ (
		code
		, "gtss_drl_dio_"
		, "File ""^a"" (aft ^i) gtss_ios_io_ status=^i"
		, translate (ascii_file_name, UPPER, lower)
		, fn
		, status
		);
	     if (status = 2) then
		call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_dio_"
		, 0
		, "DIO(^6o) WRITE ATTEMPTED ON READ-ONLY FILE - ^a"
		, fixed (scu.ilc, 18)
		, translate (ascii_file_name, UPPER, lower)
		);
	     else
	     if (status = 16) then
		call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_dio_"
		, 0
		, "DIO(^6o) ^a EXCEEDED LLINKS AVAILABLE - ^a"
		, fixed (scu.ilc, 18)
		, iocmd (read_write_cmd.device_command)
		, translate (ascii_file_name, UPPER, lower)
		);
	     else
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_dio_"
		, 0
		, "DIO (^6o) ^a FAILED FILE ""^a"" (AFT ^i)"
		, fixed (scu.ilc, 18)
		, iocmd (read_write_cmd.device_command)
		, translate (ascii_file_name, UPPER, lower)
		, fn
		);
	     return;
	end;
	no_of_disk_io = no_of_disk_io + 1;
	return;

/**	Variables for gtss_drl_dio_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char (8)based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  lower                    char(26)aligned static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  status                   fixed bin (24);
dcl  UPPER                    char(26)aligned static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

dcl 1 arg_list aligned based (arg_list_ptr)
     , 3 seek_cmd
     , 4 device_command bit (06)unal
     , 4 zeroes_1 bit (12)unal
     , 4 IOC_Command bit (05)unal
     , 4 zeroes_2 bit (01)unal
     , 4 control bit (06)unal
     , 4 count bit (06)unal

     , 3 seek_locs
     , 4 L_fileid bit (18)unal
     , 4 L_dcw1 bit (18)unal

     , 3 read_write_cmd
     , 4 device_command bit (06)unal
     , 4 zeroes_1 bit (12)unal
     , 4 IOC_Command bit (05)unal
     , 4 zeroes_2 bit (01)unal
     , 4 control bit (06)unal
     , 4 count bit (06)unal

     , 3 read_write_locs
     , 4 L_fileid bit (18)unal
     , 4 L_dcw2 bit (18)unal

     , 3 L_status bit (18)unal
     , 3 zeroes_3 bit (18)unal
     ;

%include gtss_ext_;

%include mc;


%include gtss_io_status_words;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_device_cmds;

%include gtss_db_names;

%include gtss_iocmd;
     end						/* gtss_drl_dio_ */;



		    gtss_drl_drlimt_.pl1            12/11/84  1349.3rew 12/10/84  1043.0       14868


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

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

/*	Store processor time limit 

   Authors:	Robert J. Grimes	Created
   Albert N. Kepner	  1978
   Robert M. May
   David B. Ward
   Changed:  Al Dupuis	09/26/79 It was a null implementation.
*/

dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

DRL DRLIMT, stores the processor time limit for the subsystem in the UST.


   8_________1_6_____________________

   DRL      DRLIMT
   Return

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-11)

*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	increment = 0;				/* Zero arguments */
	time = fixed (mc.regs.a, 36) * 64 * 1000;
	gtss_ust_ext_$ust.gtss_ust.limit = fixed (time, 36);

	return;

dcl gseg ptr init(null());
dcl time fixed bin (71);

%include mc;

%include gtss_ust_ext_;

%include gtss_ext_;
     end gtss_drl_drlimt_;



		    gtss_drl_drlsav_.pl1            12/11/84  1349.3rew 12/10/84  1043.1      107874


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

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

gtss_drl_drlsav_: proc (mcpp, increment);

/* *	gtss save a program on a permanemt file.

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

   Changed:  Ron Barstad    11/06/82  Remove stringsize condition from word_count assign 
*/
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/**

   DRL DRLSAV, SAVE PROGRAM ON PERMANEMT FILE (octal 62)


   8_________1_6_____________________

   DRL      DRLSAV
   ZERO	  nameloc,0 or 1
   ZERO	  loc 1, loc 2
   ZERO	  entry addr,load org
   ZERO	  tra,bufloc

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-23)

*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get addres of arg_list */

/**	Verify 3 word name list available.	**/
	if (fixed (nameloc)+2) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_drlsav_",
		4,
		"DRLSAV: 3 word name list outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	name_list_ptr = addrel (gseg, nameloc);


/**	Verify name of perm file is in AFT.	**/
	call gtss_aft_$find ((ascii_file_name), fn, code);
	if code = 1 then do;			/* Not in AFT. */
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_drlsav_",
		42,
		err42,				/* H* file name not in aft. */
		fixed (scu.ilc, 18),
		ascii_file_name);
	     return;
	end;
	temp = divide (file_size (fn), 64, 24, 0);
	if temp > max_for_18_bits
	then file_size_in_blocks = max_for_18_bits;
	else file_size_in_blocks = temp;

	if name_list.bcd_program_name = "0"b then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		54,
		err54,				/* H* File program name required */
		fixed (scu.ilc, 18),
		ascii_file_name);
	     return;
	end;

	if ^gtss_disk (fn).permissions.write then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		25,
		err25,				/* Write attempted on read only file */
		fixed (scu.ilc, 18),
		ascii_file_name);
	     return;
	end;

	if ^gtss_disk (fn).pat_body.random then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		52,
		err52,				/* H* file must be random */
		fixed (scu.ilc, 18),
		ascii_file_name);
	     return;
	end;
	if arg_list.loc_1 >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		4,				/* Invalid derail argument */
		"DRLSAV: Initial data address outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	if arg_list.loc_2 >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		4,				/* Invalid derail argument */
		"DRLSAV: Final data address outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	words_in_element = fixed (loc_2) - fixed (loc_1) + 1;
	blocks_in_element = divide (words_in_element+63, 64, 18, 0);
	if words_in_element < 1 then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		50,
		err50,				/* Bad DRL DRLSAV data loc */
		fixed (scu.ilc, 18));
	     return;
	end;

/* Return 0 in A register if successful */
	mc.regs.a = "0"b;

	if arg_list.tra >= gtss_ust.lsize.limit
	| fixed (arg_list.tra) < 100 then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		4,
		err4,				/* Bad derail argument */
		fixed (scu.ilc, 18));
	     return;
	end;
	if fixed (arg_list.bufloc)+63 >= fixed (gtss_ust.lsize.limit)
	| fixed (arg_list.bufloc, 18) < 100 then do;
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		4,
		err4,				/* Bad derail argument */
		fixed (scu.ilc, 18));
	     return;
	end;
	buffer_ptr = addrel (gseg, arg_list.bufloc);

/* Now all the arguments have been verified and the
   actual save processing starts. */

	if arg_list.not_first_name then do;
	     call locate_catalog_entry;
	end;
	else do;					/* First program on H* file */

/* Clear buffer */
	     unspec (catalog_block) = "0"b;
	     catalog_block.blk_num = 1;
	     catalog_entry = 1;
	     initial_block_of_element = 2;
	end;
	call add_element_to_catalog_block;
	call update_available_space_block;
	call make_data_block;

final_transfer: ;
	increment = fixed (arg_list.tra, 18) - fixed (scu.ilc, 18) - 1;
ret:	;
	return;


add_element_to_catalog_block: proc;

/* When this routine is called catalog_entry must indicate where to add the new element in the
   catalog. initial_block_of_element indicates where in the file the data element will be
   placed.  blocks_in_element indicates the number of 64 word blocks needed for the
   program being added excluding the data control block. */

	     cat (catalog_entry).bcd_name = name_list.bcd_program_name;

/* Add one for control block when computing element size */
	     cat (catalog_entry).element_size = bit (fixed (blocks_in_element+1, 18), 18);
	     cat (catalog_entry).initial_block = bit (initial_block_of_element, 18);

/* Determine if file is large enough */
	     temp = blocks_in_element + initial_block_of_element+1;
	     if temp > max_for_18_bits then do;
program_too_large:	;
		mc.regs.a = (35)"0"b||"1"b;
		go to final_transfer;
	     end;
	     else blocks_used_in_file = temp;
	     if blocks_used_in_file > file_size_in_blocks then go to program_too_large;

/* Do not include old checksum in new => check first 63 words. */
	     catalog_block.checksum = checksum (buffer_ptr, 63);
	     call write_buffer (0, fixed (arg_list.bufloc));
	end add_element_to_catalog_block;

locate_catalog_entry: proc;

/* This routine reads the catalog block and determines where in the H* file
   the new program will be placed. */

	     if ^gtss_disk (fn).pat_body.write_performed
	     then do;
not_initialized:	;
		call gtss_abort_subsystem_ (
		     mcp,
		     "gtss_drl_drlsav_",
		     51,
		     err51,			/* H* file not initialized */
		     fixed (scu.ilc, 18),
		     ascii_file_name);
		go to ret;
	     end;

/* Read the catalog block */
	     call read_buffer (0, fixed (arg_list.bufloc));

/* Make sure this looks like a catalog */
	     if catalog_block.blk_num ^= 1 | catalog_block.fill2 ^= "0"b
	     then go to not_initialized;

/* Find the first empty slot in the catalog */
	     element_name = "1"b;
	     do i = 1 to hbound (cat, 1);
		element_name = cat (i).bcd_name;
		if element_name = "0"b then go to found_slot;
	     end;

/* If we fall through the catalog is full */
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		48,
		err48,				/* H* file catalog full */
		fixed (scu.ilc, 18),
		ascii_file_name);
	     goto ret;

found_slot:    ;
	     catalog_entry = i;

/* Guard against first name on catalog being zero */
	     if i < 1 then go to not_initialized;
	     i = i-1;
	     initial_block_of_element = fixed (cat (i).element_size)+fixed (cat (i).initial_block);
	end locate_catalog_entry;

make_data_block: proc;

/* When this routine is called initial_block_of_element must indicate the
   block within the file where the data control block for this element is to be
   written.  words_in_element indicates the number of words in the program
   element being added. */

/* Clear the buffer again */
	     unspec (data_control_block) = "0"b;

	     data_control_block.number_of_data_blocks = bit (blocks_in_element, 18);
	     data_control_block.entry_address = arg_list.entry_address;
	     data_control_block.load_origin = arg_list.load_origin;
	     data_control_block.bcd_name = name_list.bcd_program_name;

/* Make DCW's for control block */

/* For some reason Gcos offsets the address field of each DCW by
   2000 octal = 1024 from the load origin. */
	     memory_loc = fixed (arg_list.load_origin, 18)+1024;
	     words_remaining = words_in_element;
	     word_count = "7400"b3;			/* 7400 octal = 3840 = one link */
	     do i = 1 to hbound (data_control_block.dcws, 1);
		if words_remaining < 3841 then go to last_dcw;
		data_control_block.dcws (i).memory_loc = bit (memory_loc, 18);
		data_control_block.dcws (i).action_code = "001"b; /* IOTP */
		data_control_block.dcws (i).word_count = substr(word_count,1,12);
		memory_loc = memory_loc+3840;
		words_remaining = words_remaining - 3840;
	     end;

/* If we fall through, the program is too large to save. */

	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_drlsav_",
		4,				/* Bad drl argument */
		"DRL DRLSAV (^6o) program size ^i words exceeds maximum 58 links",
		fixed (scu.ilc, 18),
		words_in_element);
	     return;

last_dcw:	     ;
	     data_control_block.dcws (i).memory_loc =
		bit (memory_loc, 18);
	     data_control_block.dcws (i).action_code = "000"b; /* IOTD */
	     data_control_block.dcws (i).word_count = bit (fixed (words_remaining, 12), 12);

/* Checksum the data */
	     data_ptr = addrel (gseg, arg_list.loc_1);
	     data_control_block.data_checksum = checksum (data_ptr, words_in_element);

/* Checksum the control block */
	     data_control_block.control_block_checksum = checksum (buffer_ptr, 64);
	     call write_buffer (initial_block_of_element, fixed (arg_list.bufloc));
	     call write_data (initial_block_of_element+1, fixed (arg_list.loc_1));
	end make_data_block;

update_available_space_block: proc;

/* When this routine is called blocks_used_in_file must reflect the space used in
   the file including the new program being added.  file_size_in_blocks must be the total
   size of the file in 64  word blocks. */

/* Clear the buffer */
	     unspec (available_space_block) = "0"b;

/* Fill in the available space block */
	     available_space_block.blocks_used = bit (blocks_used_in_file, 18);
	     available_space_block.blocks_remaining =
		bit (fixed (file_size_in_blocks - blocks_used_in_file, 18), 18);
	     available_space_block.checksum =
		available_space_block.blocks_used||available_space_block.blocks_remaining;
	     call write_buffer (1, fixed (arg_list.bufloc));
	end update_available_space_block;

%include gtss_checksum;

/**	Variables for gtss_drl_drlsav_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel builtin;
dcl  arg_list_ptr ptr init (null ());
dcl  blocks_in_element fixed bin (18);
dcl  blocks_used_in_file fixed bin (18);
dcl  catalog_entry fixed bin (18);
dcl  code fixed bin (35);
dcl  data_ptr ptr init (null ());
dcl  fixed builtin;
dcl  fn fixed bin (24);
dcl  gseg ptr init (null ());
dcl  gtss_fail condition;
dcl  initial_block_of_element fixed bin (18);
dcl  me char (32) static int options (constant) init ("gtss_drl_drlsav_");
dcl  name_list_ptr ptr init (null ());
dcl  status fixed bin (24);
dcl  to_from char (16) static int options (constant) init ("write program to");
dcl  word_count bit (18);

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 nameloc bit (18)unal
     , 2 not_first_name bit (18) unal
     , 2 loc_1 bit (18)unal
     , 2 loc_2 bit (18)unal
     , 2 entry_address bit (18)unal
     , 2 load_origin bit (18)unal
     , 2 tra bit (18)unal
     , 2 bufloc bit (18)unal
     ;

dcl 1 name_list aligned based (name_list_ptr)
     , 2 ascii_file_name char (8)
     , 2 bcd_program_name bit (36)
     ;


%include gtss_ext_;

%include mc;

%include gtss_pnterr;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_save_restore_data_;

%include gtss_device_cmds;

%include gtss_dfd_ext_;

%include gtss_hstar;
     end						/* gtss_drl_drlsav_ */;
  



		    gtss_drl_filact_.pl1            12/11/84  1349.3rew 12/10/84  1043.1       75825


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

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

/**	gtss permanent file facilities

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	02/24/79 $db debug switch.
   Changed: Bob Alvarado      07/22/79 added call to funct08_
   Changed: Dave Ward         1981     sorted dcl, added %page
**/

/**

   DRL FILACT, PERMANENT FILE ACTIVITIES (octal 36)

   Grouped under DRL FILACT are the  following  permanent  file
   functions:

   Create Catalog (CC)
   Create File (CF)
   Access File (AF)
   Purge Catalog (PC)
   Purge File (PF)
   Release File (RF)
   Modify Catalog (MC)
   Modify File (MF)
   Special Access to Relocatable Subroutine Library

   They  are differentiated by a function number that is passed
   in the upper half of word 3 of the  calling  sequence.   The  DRL
   FILACT  handles all permanent file requests with the exception of
   file deaccesses.  These are handled by DRL RETFIL.

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-36)

**/
%page;
/*		P R O C E D U R E 			*/

	scup = addr (mc.scu);			/* Get the system conditions */

	high_b = gtss_ust.lsize.limit;		/* Highest memory offset available. */
	high_i = fixed (high_b, 18);			/* (also as fixed binary) */
	increment = 2;				/* All routines have two filact_args */

/**	Obtain pointer to GCOS caller's "memory"	**/
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

/**	Obtain filact derail calling sequence parameters.		**/
	if ((fixed (scu.ilc, 18)+1) < low_i) |
	((fixed (scu.ilc, 18)+2)>high_i) then do;	/* Outside of memory. */
return_err4:   ;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_filact_"
		, 4
		, gtss_pnterr.err4
		, fixed (scu.ilc, 18)
		);
	     goto ret;
	end;
	arg_ptr = addrel (gseg, fixed (scu.ilc, 18)+1);

/**	Assure that the filact function number is in range.	**/
	if (Function_number >= lbound (function, 1)) & (Function_number <= hbound (function, 1)) then do;
	     if have_buffer (Function_number) then do;


/**	Verify caller's buffer within acceptable memory.	**/
		if (every_entry.L_buffer<low_b) |
		((fixed (every_entry.L_buffer, 18) +size (callers_buffer)-1) > high_i) then goto return_err4;

/**	Assure the caller's arg list does not fall within his buffer.	**/
		if (every_entry.L_arglist >= every_entry.L_buffer) &
		((fixed (every_entry.L_arglist, 18)+1) < (fixed (every_entry.L_buffer, 18) + size (callers_buffer))) then goto return_err4;

		buffer_ptr = addrel (gseg, every_entry.L_buffer);
		unspec (callers_buffer) = "0"b;	/* Zero caller's buffer. */

	     end;
	     else buffer_ptr = null ();

	     if db_drl_filact then
		call gtss_dump_filact_args_ (arg_ptr);
	     goto function (Function_number);		/* goto the appropriate function processor */


	end;
%page;
/*		NEVER IMPLEMENTED			*/
function (00): ;
	call gtss_abort_subsystem_ (
	     mcp
	     , "gtss_drl_filact_"
	     , 30
	     , gtss_pnterr.err30
	     , fixed (scu.ilc, 18)
	     , Function_number
	     );

ret:	;

	return;

/*		NOT IMPLEMENTED FUNCTIONS		*/
function (01): ;

	call gtss_abort_subsystem_ (
	     mcp
	     , "gtss_drl_filact_"
	     , 0
	     , gtss_pnterr.err103
	     , Function_number
	     );
	return;

/* 		(CF) Create Catalog		*/
function (02): ;

	call gtss_filact_funct02_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

/*		(CF) Create File			*/
function (03): ;

	call gtss_filact_funct03_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

/*		(AF) Access File			*/
function (04): ;

	call gtss_filact_funct04_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

/*		Access Subroutine Libraries		*/
function (05): ;

	call gtss_filact_funct05_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

function (06): ;
	goto function (00);

function (07): ;
	goto function (00);


/*	(PC) Purge Catalog.	*/
function (08): ;
	call gtss_filact_funct08_ (
		mcp
		, high_b
		, gseg
		, arg_ptr
		, buffer_ptr
		, code
		);
	if code = 4 then goto return_err4;
	return;


/*	(PF) Purge File.	*/
function (09): ;
	goto function (22);


/*		(MC) Modify Catalog			*/
function (10): ;

	call gtss_filact_funct10_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

/*		(MF) Modify File			*/
function (11): ;

	call gtss_filact_funct11_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

function (12): ;
	goto function (01);

function (13): ;
	goto function (01);

/*		System Master Catalog Query		*/
function (14): ;

	call gtss_filact_funct14_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

function (15): ;
	goto function (01);

function (16): ;
	goto function (01);

function (17): ;
	goto function (01);

/*		Get Current			*/
function (18): ;

	call gtss_filact_funct18_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

/*		Get First			*/
function (19): ;

	call gtss_filact_funct19_ (
	     mcp
	     , (high_b)
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;

function (20): ;
	goto function (01);

function (21): ;

	call gtss_filact_funct21_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;


/*	(RF) Release File.	*/
function (22): ;

	call gtss_filact_funct22_ (
	     mcp
	     , high_b
	     , gseg
	     , arg_ptr
	     , buffer_ptr
	     , code
	     );
	if code = 4 then goto return_err4;
	return;
%page;
/** Declarations for gtss_drl_filact_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  arg_ptr                  ptr init(null());
dcl  code                     fixed bin(35);
dcl  gseg                     ptr init(null());
dcl  gtss_dump_filact_args_	entry(ptr);
dcl  high_b                   bit(18);
dcl  high_i                   fixed bin(18)aligned;
dcl  increment                fixed bin(24)parm;
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  null			builtin;
dcl  size                     builtin;
%page;
dcl  1 every_entry		aligned based(arg_ptr)
,      3 zero		bit(18)unal
,      3 L_arglist		bit(18)unal
,      3 Function_number	fixed bin(17)unal
,      3 L_buffer		bit(18)unal;

dcl  have_buffer              (00:22)bit(1)static int options(constant)init(
  /* 00 */	"0"b
, /* 01 */	"0"b
, /* 02 */	"1"b
, /* 03 */	"1"b
, /* 04 */	"1"b
, /* 05 */	"0"b
, /* 06 */	"0"b
, /* 07 */	"0"b
, /* 08 */	"1"b
, /* 09 */	"1"b
, /* 10 */	"1"b
, /* 11 */	"1"b
, /* 12 */	"0"b
, /* 13 */	"0"b
, /* 14 */	"1"b
, /* 15 */	"0"b
, /* 16 */	"0"b
, /* 17 */	"0"b
, /* 18 */	"1"b
, /* 19 */	"1"b
, /* 20 */	"0"b
, /* 21 */	"1"b
, /* 22 */	"1"b

);
%page;
%include gtss_ust_ext_;
%page;
%include gtss_ext_;
%page;
%include gtss_pnterr;
%page;
%include mc;
%page;
%include gtss_entry_dcls;
%page;
%include gtss_FMS_catalog;
%page;
%include gtss_db_names;
     end						/* gtss_drl_filact_ */;
   



		    gtss_drl_filsp_.pl1             12/11/84  1349.3rew 12/10/84  1043.1       40689


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

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

/**	gtss position a linked (sequential) file.

   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	09/17/79 New gtss_ios_position_ usage.
   **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL FILSP, SPACE A LINKED FILE (octal 13)


   8_________1_6_____________________

   DRL      FILSP
   ZERO     L(fileid),L(n)
   ZERO     L(stat),0

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-50.1)

*/

	increment = 2 ;				/* Two arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get addres of arg_list */

/**	Obtain name of file to position.	**/
	if L_fileid >= gtss_ust.lsize.limit then do;	/* name 2 words. */
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_filsp_",
		4,
		"FILSP: File name outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	afn_ptr = addrel (gseg, L_fileid);

/**	Obtain pointer to return status word.	**/
	if L_stat >= gtss_ust.lsize.limit then do;	/* status 2 words. */
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_filsp_",
		4,
		"FILSP: Status word outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	status_words_ptr = addrel (gseg, L_stat);
	unspec (status_word1) = "0"b;
	gcs = "4000"b3;				/* => drl successful. */

/**	Obtain (fn) the AFT index to the file.	**/
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     gcs = "4100"b3;			/* Device busy. */
	     return;
	end;

/**	Obtain pointer to n.	**/
	if L_n > gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_filsp_",
		4,
		"FILSP: Space value outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	n_ptr = addrel (gseg, L_n);

/**	Reposition the file.	**/
	call gtss_ios_position_ (
	     fn
	     , 0					/* 0 => space forward (n>0) or backward (n<0) */
	     , n					/* Number blocks (320 words) to position. */
	     , status_words.Record_count_residue
	     , status_words_ptr
	     );
	if (gcs ^= "5700"b3) & (gcs ^= "4002"b3) & (gcs ^= "4000"b3) then do;
	     if db_drl_filsp then
		call com_err_ (
		code
		, "gtss_drl_filsp_",
		"File ""^a"" (aft ^i) gtss_ios_position_ status=^w"
		, ascii_file_name
		, fn
		, gcs
		);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_filsp_"
		, 0
		, "FILSP: Unable to position"
		);
	end;
	if db_drl_filsp then
	     call ioa_ ("FILSP: file ^a new position = ^o",
	     ascii_file_name, file_position (fn));
	return;

/**	Variables for gtss_drl_filsp_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char (8)based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  ioa_                     entry options (variable);
dcl  n                        fixed bin (24)aligned based(n_ptr);
dcl  n_ptr                    ptr init(null());

dcl 1 status_word1 aligned based(status_words_ptr),
      2 gcs bit(12)unal,
      2 fill bit(24)unal;

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_fileid bit (18)unal
     , 2 L_n bit (18)unal
     , 2 L_stat bit (18)unal
     , 2 zero bit (18)unal
     ;

%include gtss_dfd_ext_;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_db_names;

%include gtss_io_status_words;
     end						/* gtss_drl_filsp_ */;
   



		    gtss_drl_grow_.pl1              12/11/84  1349.3rew 12/10/84  1043.1       46944


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

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

/* *	gtss grow a file.

   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	10/31/79 Record quota overflow handling.
   * */
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/* *

   DRL GROW, GROW A PERMANENT OR TEMPORARY FILE (octal 50)


   8_________1_6_____________________

   DRL      GROW
   ZERO     L(n),L(fileid)
   ZERO     L(buff),L(stat)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-51)

*/

	increment = 2 ;				/* Two arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/* *	Obtain name of file to grow.	* */
	if L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_grow_"
		, 4				/* Invalid drl argument */
		, "FILE NAME OUTSIDE MEMORY AT (^o)"
		, fixed (scu.ilc, 18)
		);
	     go to ret;
	end;
	afn_ptr = addrel (gseg, L_fileid);

/* *	Obtain pointer to return status word.	* */
	if L_stat >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_grow_"
		, 4				/* Invalid drl argument */
		, "STATUS WORD OUTSIDE MEMORY (^o)"
		, fixed (scu.ilc, 18)
		);
	     go to ret;
	end;
	grow_status_ptr = addrel (gseg, L_stat);

/* *	Obtain (fn) the AFT index to the file.	* */
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     grow_status = "4024"b3;			/* Failure of name scan (not in AFT). */
	     go to ret;
	end;

/* *	Obtain amount to grow file.	* */
	if L_n >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_grow_"
		, 4				/* Invalid drl argument */
		, "ATTEMPT TO GROW FILE OUTSIDE MEMORY (^o)"
		, fixed (scu.ilc, 18)
		);
	     go to ret;
	end;
	n_ptr = addrel (gseg, L_n);

/* *	Grow the file.	* */
	call gtss_ios_change_size_ (
	     fn
	     , fixed (n.add, 24, 0)
	     , in_links
	     , status
	     , code);

/* *	adjust size field in file descriptor in attributes structure.   */
	call gtss_adjust_size_ (gtss_disk.attributes_ptr (fn));

	if status ^= 0 & status ^= 2 then do;
	     if db_drl_grow then
		call com_err_ (
		code
		, "gtss_drl_grow_"
		, "gtss_ios_change_size_ (file ^a) status ^i"
		, ascii_file_name
		, status
		);
	     if code = error_table_$rqover then
		grow_status = "4010"b3;		/* Exhausted links. */
	     else
	     grow_status = "4002"b3;			/* I/O error. */
	     go to ret;
	end;

	grow_status = "4000"b3;			/* No errors. */
ret:	;
	if db_drl_grow then
	     call ioa_ (
	     "GROW: file ^a (aft ^i) by ^o (^i.) ^[links^;llinks^],"
	     ||"^/now ^o (^i.) words. Status ^4o"
	     , ascii_file_name
	     , fn
	     , fixed (n.add, 17)
	     , fixed (n.add, 17)
	     , in_links
	     , file_size (fn)
	     , file_size (fn)
	     , fixed (grow_status, 12)
	     );
	return;

/* *	Variables for gtss_drl_grow_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init (null ());
dcl  arg_list_ptr             ptr init (null ());
dcl  ascii_file_name          char (8)based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  error_table_$rqover	fixed bin(35)ext;
dcl  fn                       fixed bin (24);
dcl  grow_status              bit (12)based (grow_status_ptr);
dcl  grow_status_ptr          ptr init (null ());
dcl  gseg                     ptr init (null ());
dcl  ioa_                     entry options (variable);
dcl  lower                    char(26)aligned static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  n_ptr                    ptr init (null ());
dcl  status                   fixed bin (24);
dcl  UPPER                    char(26)aligned static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_n bit (18)unal
     , 2 L_fileid bit (18)unal
     , 2 L_buf bit (18)unal
     , 2 L_stat bit (18)unal
     ;

dcl 1 n aligned based (n_ptr)
     , 2 in_links bit (01)unal			/* 1 => links, 0 => llinks. */
     , 2 add bit (17)unal				/* Add to file. */
     ;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;

%include gtss_db_names;
     end						/* gtss_drl_grow_ */;



		    gtss_drl_gwake_.pl1             12/11/84  1349.3rew 12/10/84  1043.2       24804


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

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

gtss_drl_gwake_: proc (mcp, increment);

/**
   DRL GWAKE, WAKE ME LATER (octal 66)


   8_________1_8_______

   LDQ      L(time)
   DRL      GWAKE


   Where:


   time - contains the number of seconds, right  justified  the
   user wishes to sleep.


   This  derail  causes  the calling program to be set inactive
   and eligible for swap for the number of seconds specified in  the
   Q-register.   There is an inherent delay of 1 to 2 seconds in the
   derail.  Breaks will cause the user to  be  awakened  before  the
   sleep time has elapsed.

   Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
   Changed:  	Paul Benjamin 10/22/79 	Removed pi handler
   Changed:	Al Dupuis 10/25/79		Added quit handler.
   Changed:	Scott C. Akers 08/17/81	Reset tty_modes on QUIT.
   **/
						/* externals */
dcl quit condition ext;
dcl  timer_manager_$sleep	ext entry (fixed bin (71), bit (2));
dcl  gtss_fix_tty_modes_	ext entry;
/* work variables */
dcl  time fixed bin (71);
dcl  increment fixed bin;
dcl (fixed, addr) builtin;

	increment = 0;
	scup = addr (mc.scu);
						/* time in relative secondes */
	time = fixed (mc.regs.q, 71);
						/* if time > 24 hours no go */
	if time/3600 > 24 then do;
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_gwake_", 58, gtss_pnterr.err58,
		fixed (scu.ilc, 18));
	end;
	gtss_ust.lback.gwake = time;			/* save in ust for some reason */

/* If user is handling breaks, let him, otherwise abort subsystem */
	on quit begin;
	     call gtss_fix_tty_modes_;
	     if gtss_break_vector_$status ()
	     then do;
		call gtss_break_vector_ ();
		gtss_ext_$flags.dispose_of_drl_on_pi = "1"b;
		gtss_ext_$flags.unfinished_drl = "1"b;
		goto gtss_ext_$dispose_of_drl;
	     end;
	     else do;
		call gtss_abort_subsystem_ (
		     mcp,
		     "gtss_drl_gwake_",
		     0,
		     "");
		return;
	     end;
	end;

	call timer_manager_$sleep (time, "11"b);
	return;

%include gtss_pnterr;

%include gtss_ust_ext_;

%include gtss_ext_;
%include mc;

%include gtss_entry_dcls;
     end gtss_drl_gwake_;



		    gtss_drl_jsts_.pl1              12/11/84  1349.3rew 12/10/84  1043.2       37377


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

gtss_drl_jsts_: proc (mcpp, increment);

/**	gtss obtain job status.

	Author:	Mel Wilson			29mar79
 **/
dcl  mcpp                     ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/**

   DRL JSTS, OBTAIN JOB STATUS (octal ('drl_code'))


   8_________1_6_____________________

   DRL      JSTS
on input:
word_1
   BCI     1,snumb
word_2 (optional)
   VFD     18/L_buffer,9/0,6/,3/n

on output:
word_1
   VFD     9/status_code,9/activity_number,18/
word_2, if present, is not affected


    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-13)

*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	if fixed (scu.ilc, 18) + 1 >= fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_jsts_", 0,
	     "DRL parameter list outside memory (^o)", fixed (scu.ilc, 18));
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18) + 1);

	call gtss_bcd_ascii_$lc (arg_list_ptr, 5, addr (given_snumb));

	call gtss_get_user_state_ (u_state_ptr);
	do i = 1 to entry_count while (snumb (i) ^= given_snumb);
	end;
	if i > entry_count then do;			/* given snumb not known */
	     return_status = 18;
	     return_activity = 0;
	end;
	else do;					/* set up status from gtss_user_state_ entry */
	     return_status = status (i);
	     return_activity = activity (i);
	end;
	return_filler = "0"b;

	if opcode ^= "0"b then			/* no optional buffer supplied */
	     increment = 1;
	else do;					/* return status message into buffer, if all is legal */
	     increment = 2;
	     if L_buffer > fixed (gtss_ust.lsize.limit, 18) - max (320, 320*buf_n) then
		call gtss_abort_subsystem_ (mcp, "gtss_drl_jsts_", 0,
		"Buffer outside memory (^o)", fixed (scu.ilc, 18));
	     call gtss_ascii_bcd_ (addr (status_msg (return_status)),length (rtrim (status_msg (return_status))),
		addrel (gseg, L_buffer));
	     ret_tally_adr = L_buffer;		/* set up buffer tally for return */
	     ret_tally_cnt = length (rtrim (status_msg (return_status)));
	     ret_tally_off = 0;
	end;

	return;

/** gtss_drl_jsts_ local declarations */

dcl  arg_list_ptr ptr;
dcl 1 arg_list based (arg_list_ptr),
   2 bcd_snumb unal,
      3 return_status fixed bin (9) unsigned unal,
      3 return_activity fixed bin (9) unsigned unal,
      3 return_filler bit (18),
   2 optional_word_2 unal,
      3 L_buffer fixed bin (18) unsigned unal,
      3 opcode bit (9) unal,
      3 filler1 bit(6) unal,
      3 buf_n fixed bin (3) unsigned unal;

dcl  gseg ptr;
dcl  given_snumb char (5) init ("");
dcl  i fixed bin;

dcl  status_msg (0:20) int static char (16) 
        init ( /* msg_0  */ "status changing",
	     /* msg_1  */ "reading-cr",
	     /* msg_2  */ "reading-mt",
	     /* msg_3  */ "reading-rmt",
	     /* msg_4  */ "wait-aloc",
	     /* msg_5  */ "wait-perip",
	     /* msg_6  */ "wait-core",
	     /* msg_7  */ "in hold",
	     /* msg_8  */ "in limbo",
	     /* msg_9  */ "executing",
	     /* msg_10 */ "swapped",
	     /* msg_11 */ "wait-media",
	     /* msg_12 */ "too-big",
	     /* msg_13 */ "overdue",
	     /* msg_14 */ "in restart",
	     /* msg_15 */ "terminating",
	     /* msg_16 */ "output waiting",
	     /* msg_17 */ "output complete",
	     /* msg_18 */ "not accesible",
	     /* msg_19 */ "not your job",
	     /* msg_20 */ "aborted" );

dcl 1 local_q based (addr(mc.q)),
   2 ret_tally_adr fixed bin (18) unsigned unal,
   2 ret_tally_cnt fixed bin (12) unsigned unal,
   2 ret_tally_off fixed bin (6) unsigned unal;

dcl  gtss_get_user_state_ entry (ptr);

%include gtss_ext_;

%include gtss_snumb_xref_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;
     end gtss_drl_jsts_;
   



		    gtss_drl_kin_.pl1               12/11/84  1349.3rew 12/10/84  1043.2       47088


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

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

/* gtss terminal input.

   DRL KIN, KEYBOARD INPUT LAST LINE (octal 4)

   8_________1_6_____________________

   DRL      KIN
   ZERO     L(dat),L(count)
   ZERO     L(status)

   This derail retrieves the last line of input.  Normally this
   sequence would follow immediately the  KOUTN  sequence;  however,
   this  is not necessary.  KIN may be repeated to retrieve the same
   line of input as many times  as  desired.   The  last  line  will
   remain  in  the  buffer  until  some  output  or additional input
   destroys it.  Dat is the location at which the  string  of  input
   characters  is  to be stored.  Count is a word in which the count
   of characters moved is in the lower part of  the  word.   A  zero
   character  count  is  returned  if  there is no data in the input
   buffer.  The parameter L(status) is not used by current  software
   release.  The purpose of the status word is to receive the status
   of  the  line when it is passed back to the subsystem for certain
   conditions, such as  break,  disconnect,  etc.   In  the  present
   implementation  the  handling  of these conditions is done by the
   Executive, and the status word in the subsystem is  not  altered.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward	08/19/81 Replace \ as final character with CR.
                                       add %page, dcl percission, format changes
*/
dcl  increment                fixed bin parm;
dcl  mcpp                     ptr parm;
	mcp = mcpp;
	increment = 2 ;				/* two arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arglist */
	waste_count, ntc = count_of_characters_transmitted; /* Number of characters available in terminal buffer. */
	if L_count = 0 then count_ptr = addr (waste_count); /* Caller's has not supplied count word. */
	else do;					/* Caller has provided count word. */
	     if L_count > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_kin_",
		     4,
		     gtss_pnterr.err4,
		     fixed (scu.ilc, 18));
		return;
	     end;
	     count_ptr = addrel (gseg, L_count);
	end;
	if ntc<1 then do;				/* No character to provide caller. */
	     if db_drl_kin then
		call gtss_dump_kin_ ("");
	     count_word = 0;
	     return;
	end;
						/* check for addres violations */
	if L_buffer > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_kin_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;
	buffer_ptr = addrel (gseg, L_buffer);
	count_word = ntc;

/*	Check that buffer fits within caller's memory. */
	if (L_buffer + divide ((ntc+3), 4, 17, 0)-1) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_kin_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;
						/* move the data */
	buffer_ptr -> MS = addr (characters_transmitted) -> MS;
	if ntc > 0 then				/* Examine final character. */
	     if substr (buffer_ptr -> MS, ntc, 1) = "\" then
		substr (buffer_ptr -> MS, ntc, 1) = CR; /* Replace \ with carriage return. */
	if db_drl_kin then
	     call gtss_dump_kin_ (buffer_ptr -> MS);
	return;
%page;
/*   Variables for gtss_drl_kin_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  arg_ptr                  ptr init(null());
dcl  buffer_ptr               ptr init(null());
dcl  count_ptr                ptr init(null());
dcl  count_word               fixed bin(24) based (count_ptr);
dcl  fixed                    builtin;
dcl  gseg                     ptr init(null());
dcl  gtss_dump_kin_           entry(aligned char(*));
dcl  i                        fixed bin;
dcl  MS                       aligned char(ntc)based;
dcl  ntc                      fixed bin;
dcl  waste_count              fixed bin(18)unsigned unal;

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

dcl 1 arglist	aligned based(arg_ptr)
,     2 L_buffer	fixed bin(18)unsigned unal
,     2 L_count	fixed bin(18)unsigned unal
,     2 L_status	fixed bin(18)unsigned unal
,     2 not_used	bit(18)unal
;
%page;
%include gtss_pnterr;
%page;
%include gtss_ext_;
%page;
%include mc;
%page;
%include	gtss_ust_ext_;
%page;
%include gtss_entry_dcls;
%page;
%include gtss_db_names;
     end						/* gtss_drl_kin_ */;



		    gtss_drl_kotnow_.pl1            12/11/84  1349.3rew 12/10/84  1043.2      121500


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_drl_kotnow_: gtss_drl_kout_: proc (mcpp, increment);

/* Immediate (not buffered) terminal output.
   Note: gtss implements kout derail to be
   the same as kotnow.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change: Dave Ward	03/20/79 put_chars.
   Change: Bob Alvarado	08/22/79 added output char count to ust.
   Change: Dave Ward	08/19/81 %page;, do_print on error_output, entry before procs.
   Change: Dave Ward	10/07/81 Corrected fallacious pl1 statement, removed prefix include usage.
   */
dcl  increment                fixed bin parm;
dcl  mcpp                     ptr parm;
	mcp = mcpp;
%page;
/*

   DRL KOTNOW, KEYBOARD OUTPUT FROM UNFILLED BUFFER (octal 56)


   8_________1_6_____________________

   DRL      KOTNOW
   ZERO     L(tally),L(char)

   The call for KOTNOW is the same as the call for  KOUT.   The
   action  is  also  the  same,  except  that KOTNOW forces keyboard
   output from a partially filled buffer rather than  waiting  until
   the  buffer  has filled.  This feature allows users to substitute
   KOTNOW for KOUT in subsystems  with  low  output,  where  several
   messages may stack up in the buffer before its content is sent to
   the remote terminal by KOUT.


   KOTNOW  is  a  separate  entry  point  to  the  KOUT coding,
   primarily for setting a flag and providing the test and  decision
   logic  to  retain  control within the derail until the buffer has
   been emptied.


   The KOTNOW flag is tested immediately after the KOUTN  test.
   If  the flag has not been set, normal processing continues with a
   return to the subsystem.  If the flag has been set by an entry at
   KOTNOW, the buffer is emptied and the allocator notified that I/O
   is in progress.  An exit is then made to LINSRV.
   */
%page;
/*

   DRL KOUT, KEYBOARD OUTPUT (octal 2)


   8_________1_6_____________________

   DRL      KOUT
   ZERO     L(tally), L(char)

   The field L(tally) points to a driver tally word pointing in
   turn to a list of TALLY/TALLYB words that  define  each  line  of
   output  of  BCI/ASCII characters to be sent to the terminal.  The
   driver tally has the count of the line tallies in the list.  This
   procedure  allows  the  user  to  define  scattered   lines   not
   necessarily starting at word boundaries.


   It  should  be  noted that the derail processor utilizes the
   tally  words  and  that  they  are  modified  on  return  to  the
   subsystem.   Therefore,  they  must  be  refreshed  prior to each
   execution.

   The optional field L(char) points to a word containing up to
   four characters that will be appended to the end  of  the  output
   defined by each line tally.  These characters could be line feed,
   carriage  return,  etc.   If  this  field  is  not present in the
   calling sequence, characters are not  added.   If  the  field  is
   present,  the  first  character  of  zero  (000)  terminates  the
   appending  of  characters.   In  any  case,  no  more  than  four
   characters will be appended.


   Example:


   DRL     KOUT
   ZERO    DRIVER
   .
   .
   .
   DRIVER   TALLY   *+1,2
   TALLYB  CRLF,4
   TALLY   BCDMSG,16
   BCDMSG   BCI     3,THIS IS BCD TEXT
   CRLF     OCT     015012177177     CR,LF,RO,RO


   This  sequence  prints a line preceded by a carriage return,
   line feed and two rubouts.


   NOTE:  Because of timing considerations  and  character  set
   differences   between   terminal  types,  it  may  be
   necessary to follow the carriage return, or line feed
   characters,  with  a  number   of   delete   (rubout)
   characters.
   */
%page;
	increment = 1;
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_ptr = addrel (gseg, fixed (scu.ilc)+1);

/* Prepare end of line character string	*/
	no_eol_chars = 0;
	if arglist.eol ^= "0"b then do;
	     if (fixed (arglist.eol)) > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_kotnow_",
		     4,
		     "EOL word outside memory at (^6o)",
		     fixed (scu.ilc, 18));
		return;
	     end;
	     eol_ptr = addrel (gseg, fixed (arglist.eol));
	     no_eol_chars = search (eol_chars, NUL)-1;
	     if no_eol_chars<0 then no_eol_chars = length (eol_chars);
	end;

	if arglist.tally = "0"b then do;		/* => There is no tally list. */
	     if no_eol_chars>0 then			/* Output end of line characters. */
		call output (eol_ptr, no_eol_chars);
	     return;
	end;

	if (fixed (arglist.tally)) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_kotnow_",
		4,
		"Print drive tally outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	tally_ptr = addrel (gseg, fixed (arglist.tally));
	tally_address_ptrs = fixed (tally.address) ;
	num_tally = fixed (tally.chars);
	tally_address = fixed (tally.address) -1;
	call tally_id (tally_ptr);

	do i = 1 to num_tally;
	     if (fixed (tally_address+i)) > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_kotnow_",
		     4,
		     "Print tally outside memory at (^6o)",
		     fixed (scu.ilc, 18));
		return;
	     end;
	     tally_ptr = addrel (gseg, tally_address+i);
	     if (fixed (tally.address)) > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_kotnow_",
		     4,
		     "Tally of print string out of memory at (^6o)",
		     fixed (scu.ilc, 18));
		return;
	     end;
	     line_len = fixed (tally.chars);
	     line_ptr = addrel (gseg, fixed (tally.address));
	     if tally.type = "100"b then do;		/* ASCII input. */
		line_ptr = addr (line_buffer (fixed (tally.offset)+1));
		call tallyb_sc (tally_ptr);

print_line:	;
		call output (line_ptr, line_len);
	     end;
	     else
	     if tally.type = "000"b then do;		/* BCD input. */
		call gtss_bcd_ascii_ (
		     addr (bcd_buffer (fixed (tally.offset)+1))
		     , line_len
		     , addr (ascii_line));
		line_ptr = addr (ascii_line);
		call tally_sc (tally_ptr);
		goto print_line;
	     end;
	     else do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_kotnow_",
		     49,
		     gtss_pnterr.err49,
		     fixed (scu.ilc, 18));
		return;
	     end;

	     if no_eol_chars>0 then			/* Output end of line characters. */
		call output (eol_ptr, no_eol_chars);
	end;
	return;
%page;
nop:	entry;

/**	Switch do print flag (nop => no output). */
	do_print = ^do_print;
	return;
%page;
output:	proc (outptr, outlen);
dcl  outlen                   fixed bin (24) parm;
dcl  outptr                   ptr parm;
	     if gtss_ext_$last_k_was_out then do;
		if do_print then do;
		     call gtss_ext_$put_chars (
			iox_$user_output,
			outptr,
			outlen,
			code);
		     if code ^= 0 then do;
error_out:		;
			call gtss_abort_subsystem_
			     (mcp
			     , "gtss_drl_kotnow_"
			     , 4
			     , "unable to output to terminal"
			     );
			return;
		     end;
		end;
		no_of_chars_by_8 = no_of_chars_by_8 + divide (outlen, 8, 24);
		return;
	     end;

/* The last I/O was input which means that Multics (in LF echo mode) has
   issued an extra line feed to the terminal. */

/* We are about to do an output so set the flag. */
	     gtss_ext_$last_k_was_out = "1"b;
	     gtss_ust.lbuf.tally = "1"b;

/* Move output from user's space to automatic buffer. */
	     bufptr = addr (buffer);
	     l = outlen;
	     M = outptr -> M;

/* Find the first line feed in the buffer and change it to
   a rubout character */
	     i = verify (M, look_past_chars);
	     if i > 0 then
		if substr (M, i, 1) = LF then
		     substr (M, i, 1) = rubout;

/* Do the output */
	     if do_print then do;
		call gtss_ext_$put_chars (
		     iox_$user_output,
		     bufptr,
		     l,
		     code);
		if code ^= 0 then goto error_out;
	     end;
	     no_of_chars_by_8 = no_of_chars_by_8 + divide (l, 8, 24);
	     return;

dcl  buffer                   char (4096);
dcl  bufptr                   ptr init(null());
dcl  i                        fixed bin (24);
dcl  l                        fixed bin (24);
dcl  M                        char (l) based (addr (buffer));
dcl  rubout                   char (1) static int options (constant) init ("")  /* octal 177. */;

dcl  look_past_chars          char(3) internal static options(constant)
			   init(" ");						/* Rubout, NULL, CR */
dcl  LF                       char (1) static int options (constant) init ("
");						/* octal 012. */
	end output;
%page;
tally_id:	proc (p);

/* Procedure to update a TALLy word to simulate ID
   modification until tally runout. */

dcl  p                        ptr parm;

	     tally_ptr = p;				/* use local pointer */
	     result = fixed (address) + fixed (tally_count);
	     address = result_r18;
	     tally_count = "0"b;

dcl 1 tally based (tally_ptr) aligned,
    2 address bit (18) unal,
    2 tally_count bit (12) unal,
    2 filler bit (6) unal;
dcl  result                   fixed bin (24);
dcl  tally_ptr                ptr init(null());
dcl 1 result_ov based (addr (result)),
    2 result_l18 bit (18),
    2 result_r18 bit (18);

	end tally_id ;
%page;
tally_sc:	proc (p);

/* Procedure to update a TALLY word to simulate SC
   modification until tally runout. (Processing 6 bit BCD characters.) */

dcl  p                        ptr parm;

	     tally_ptr = p;				/* use local pointer */
	     word_address = fixed (address);
	     count = fixed (tally_count);
	     position = fixed (char_pos);
	     result = mod (position + count, 6);
	     char_pos = substr (result_overlay, 34, 3);
	     result = word_address + divide (position + count, 6, 24, 0);
	     address = substr (result_overlay, 19, 18);
	     tally_count = "0"b;

dcl  tally_ptr                ptr init(null());
dcl 1 tally based (addr (tally_ptr)) aligned,
    2 address bit (18) unal,
    2 tally_count bit (12) unal,
    2 filler bit (3) unal,
    2 char_pos bit (3) unal;
dcl  count                    fixed bin (24);
dcl  position                 fixed bin (24);
dcl  result                   fixed bin (24);
dcl  result_overlay           bit (36) aligned based (addr (result));
dcl  word_address             fixed bin (24);

	end tally_sc ;
%page;
tallyb_sc: proc (p);

/* Procedure to update a TALLYB tally word to simulate
   SC modification until tally runout. */

dcl  p                        ptr parm;

	     tally_ptr = p;				/* use local pointer */
	     new_byte_address = fixed (address||char_pos) + fixed (tally_count);
	     address = new_address;
	     char_pos = new_char_pos;
	     tally_count = "0"b;

dcl 1 tallyb based (tally_ptr) aligned,
    2 address bit (18) unal,
    2 tally_count bit (12) unal,
    2 filler bit (4) unal,
    2 char_pos bit (2) unal;

dcl  new_byte_address         fixed bin (24);
dcl  tally_ptr                ptr init(null());
dcl 1 new_byte_addres_ov based (addr (new_byte_address)) aligned,
    2 filler bit (16) unal,
    2 new_address bit (18) unal,
    2 new_char_pos bit (2) unal;

	end tallyb_sc ;
%page;
/*   Variables for gtss_drl_kotnow_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  arg_ptr                  ptr init (null ());
dcl  ascii_line               char (1000)aligned;
dcl  bcd_buffer               (1000) bit(6) unal based(line_ptr);
dcl  code                     fixed binary (35);
dcl  do_print                 bit(1)static int init("1"b);
dcl  eol_chars                char (4) aligned based (eol_ptr);
dcl  eol_ptr                  ptr init (null ());
dcl  fixed                    builtin;
dcl  gseg                     ptr init(null());
dcl  i                        fixed bin;
dcl  iox_$user_output         ptr ext static;
dcl  line_buffer              (1000)char (1)unal based (line_ptr);
dcl  line_len                 fixed bin (24);
dcl  line_ptr                 ptr init (null ());
dcl  no_eol_chars             fixed bin (24);
dcl  NUL                      char (1)static int options (constant)init (" ")	/* octal 000. */;
dcl  null                     builtin;
dcl  num_tally                fixed bin;
dcl  num_tally_ptrs           fixed binary;
dcl  search                   builtin;
dcl  substr                   builtin;
dcl  tally_address            fixed bin;
dcl  tally_address_ptrs       fixed binary;
dcl  tally_ptr                ptr init (null ());

dcl 1 arglist aligned based (arg_ptr),
    2 tally bit (18) unaligned,
    2 eol bit (18) unaligned;

dcl 1 tally aligned based (tally_ptr),
    2 address bit (18) unaligned,
    2 chars bit (12) unaligned,
    2 type bit (3) unaligned,
    2 offset bit (3) unaligned;
%page;
%include mc;
%page;
%include gtss_ext_;
%page;
%include gtss_pnterr;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_entry_dcls;
     end gtss_drl_kotnow_;



		    gtss_drl_koutn_.pl1             12/11/84  1349.3rew 12/10/84  1043.2       33831


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

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

/**	Terminal output then input.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Al Dupuis 05/08/79
                              To have gtss_ext_$get_line called instead
                              of iox_$get_line. Also bytes_read and code
                              to match gtss_ext_'s declares.
   Changed: Dave Ward	07/01/79 Long input lines.

*/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/*

   DRL KOUTN, KEYBOARD OUTPUT THEN INPUT (octal 3)


   8_________1_6_____________________

   DRL      KOUTN
   ZERO     L(tally),L(char)


   This derail sends output to  the  keyboard  device  with  an
   anticipated reply.  The L(tally) and L(char) fields are identical
   to  those  for  the  KOUT  sequence.   In this case, however, the
   Executive  adds  this  output  message  to  any  data  that   has
   accumulated  in  the  keyboard  output  buffer and sends the data
   directly to the keyboard device.  The transfer  of  data  differs
   from  that for KOUT in that the line is left open for a response.
   The response can be retrieved by means of DRL KIN.

*/

	scup = addr (mc.scu);

/**	Print caller's data on terminal. **/
	call gtss_drl_kotnow_ (mcp, increment);

/**	Refill remote i/o buffer with
	terminal input line. (like build mode).
 **/
reinput:	;
	call gtss_ext_$get_line (iox_$user_input
	     , addr (characters_transmitted)
	     , min (gtss_ust.lrtll.char_length, hbound (characters_transmitted, 1))
	     , bytes_read
	     , code);
	if code ^= 0 then do;
	     if code = error_table_$long_record then do;
		call iox_$control (
		     iox_$user_input
		     , "resetread"
		     , null ()
		     , code
		     );
dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  error_table_$long_record fixed bin (35) ext;
dcl  iox_$user_output         ext ptr;

dcl  retry_message            char(21)static int options(constant)init("RETRANSMIT LAST LINE
");
		call gtss_ext_$put_chars (		/* Print retry message. */
		     iox_$user_output
		     , addr (retry_message)
		     , length (retry_message)
		     , code);
		goto reinput;
	     end;
	     call com_err_ (code, "gtss_drl_koutn_", "Terminal failure.");
	     signal cond (gtss_fail);
	end;
	count_of_characters_transmitted = bytes_read;
	number_words_transmitted =
	     divide ((bytes_read+3), 4, 24, 0);
	characters_transmitted (bytes_read) = CR;

	increment = 1;
	gtss_ext_$last_k_was_out = "0"b;		/* Last tty i/o was not output. */
	gtss_ust.lbuf.tally = "0"b;
	return;

/**	Variables for gtss_drl_koutn_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  bytes_read               fixed bin (21);
dcl  code                     fixed bin (35);
dcl  gtss_fail                condition ext;
dcl  iox_$user_input          ext ptr;

dcl
	CR char (1) static int options(constant) init ("");

%include gtss_ext_;

%include gtss_ust_ext_;

%include mc;

%include gtss_entry_dcls;
     end						/* gtss_drl_koutn_ */;
 



		    gtss_drl_morlnk_.pl1            12/11/84  1349.3rew 12/10/84  1043.2       39537


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

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

/**	gtss grow a temp file.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	10/31/79 Fixed code for perm file.
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL MORLNK, ADD LINKS TO TEMPORARY FILE (octal 34)


   8_________1_6_____________________

   DRL      MORLNK
   ZERO     L(n),L(fileid)

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-52)

*/

	increment = 1 ;				/* One argument */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/**	Obtain name of file to grow.	**/
	if L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_morlnk_",
		4,				/* Invalid drl argument */
		"File name outside memory at (^o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	afn_ptr = addrel (gseg, L_fileid);

/**	Obtain amount to grow file.	**/
	if L_n >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_morlnk_",
		4,				/* Invalid drl argument */
		"Amount to grow file outside memory (^o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	n_ptr = addrel (gseg, L_n);
	request = links_to_add;
	morlnk_status = "0"b;

/**	Obtain (fn) the AFT index to the file.	**/
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     morlnk_status = morlnk_status | "000100"b;	/* Failure of name scan (not in AFT). */
	end;


/** Permanent files should not use this derail. */
	if gtss_disk (fn).pat_body.perm then do;
	     morlnk_status = morlnk_status | "001000"b;	/* file is a permanent file */
	end;

	if request = "0"b then
	     morlnk_status = morlnk_status | "000010"b;	/* No links requested. */

	if morlnk_status then do;
	     links_obtained = "0"b;
	     return;
	end;

/**	Grow the file.	**/
	call gtss_ios_change_size_ (
	     fn
	     , fixed (request, 24)
	     , "1"b				/* size is in links */
	     , status
	     , code);

/**	adjust size field in file descriptor in attributes structure.   */
	call gtss_adjust_size_ (gtss_disk.attributes_ptr (fn));

	if status>0 then do;
	     if db_drl_morlnk then
		call com_err_ (
		code
		, "gtss_drl_morlnk_"
		, "gtss_ios_change_size_ (file ^a) status ^i"
		, ascii_file_name
		, status
		);
	     morlnk_status = morlnk_status | "010000"b;	/* link space exhausted */
	     links_obtained = "0"b;
	     return;
	end;

	links_obtained = request;
	return;

/**	Variables for gtss_drl_morlnk_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  n_ptr                    ptr init(null());
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char(8)based(afn_ptr);
dcl  code                     fixed bin(35);
dcl  fn                       fixed bin(24);
dcl  gseg                     ptr init(null());
dcl  request		bit(18);
dcl  status                   fixed bin(24);

dcl 1 arg_list		aligned based(arg_list_ptr)
,     2 L_n		bit(18)unal
,     2 L_fileid		bit(18)unal
;

dcl 1 n			aligned based(n_ptr)
,     2 links_to_add	bit(18)unal
,     2 fill		bit(18)unal
;

dcl 1 n_overaly		aligned based(n_ptr),
      2 morlnk_status	bit(6)unal,
      2 fill		bit(12)unal,
      2 links_obtained	bit(18)unal;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;

%include gtss_db_names;
     end						/* gtss_drl_morlnk_ */;
   



		    gtss_drl_msub_.pl1              12/11/84  1349.3rew 12/10/84  1043.2       36189


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

gtss_drl_msub_: proc (mcpp, increment);

/**	gtss call a Multics subroutine.

	Author:	Dave Ward			05/04/79
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL msub, CALL A MULTICS SUBROUTINE (octal -12)


   8_________1_6_____________________

   DRL      msub
   ZERO	L(status),version
   ZERO	L(entry),name-length
   ZERO	L(input),input-length
   ZERO	L(output),output-length

   A one word status is returned (offset L_status):
   0 => success.
   1 => failure.

   Version is a half word (2 ascii characters)
   indicating the version of this derail.

   L(entry) is an offset to an ascii string
   (name-length characters) naming a Multics
   entry to call.

   L(input & output) are offsets to corresponding
   input and output spaces in the GCOS caller's
   memory (limited by input & output -length). Their
   interpretation is particular to each subroutine
   usage.

	This derail is particular to gtss.

*/

	increment = 4 ;				/* 4 arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	msub_arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get address of msub_arg_list */
	if (fixed (scu.ilc, 18)+3) >= fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (mcp,
	     "gtss_drl_msub_",
	     0,
	     "File name outside memory (^o)",
	     fixed (scu.ilc, 18)
	     );

/* Check name, input, output and
   status within memory.
*/
	np = pointer (msub_arg_list_ptr, L_entry);
dcl  pointer                  builtin;
	if db_drl_msub then do;			/* Print arguments. */
	     call ioa_ ("PARM    OFFSET^-VALUE (parms at ^p)", msub_arg_list_ptr);
	     call ioa_ ("entry  ^6o^-^i^-""^a""", L_entry, en, name);
	     call ioa_ ("input  ^6o^-^i", L_input, in);
	     call ioa_ ("output ^6o^-^i", L_output, in);
	     call ioa_ ("status ^6o", L_status);
	     call ioa_ ("version^-^-^i", version);
	end;

/* Obtain a pointer to the Multics entry
   named in the caller's arguments.
*/
dcl  hcs_$make_ptr            entry(ptr,char(*),char(*),ptr,fixed bin(35));

/* Obtain segment and entry names. */
	i = search (name, "$");
	if i = 0 then				/* Both the same. */
	     seg_name, entry_name = name;
	else do;					/* Different. */
	     seg_name = substr (name, 1, i-1);
	     entry_name = substr (name, i+1);
	end;

	call hcs_$make_ptr (
	     null ()				/* no calling dir. */
	     , seg_name
	     , entry_name
	     , ep
	     , code
	     );
	if code ^= 0 then do;
	     call com_err_ (code, "gtss_drl_msub_",
		"For ""^a$^a""", seg_name, entry_name);
	     status = 1;
	     return;
	end;

	call cu_$ptr_call (ep, msub_arg_list_ptr);
	status = 0;
	return;

/**	Variables for gtss_drl_msub_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  code                     fixed bin(35);
dcl  cu_$ptr_call             entry options(variable);
dcl  entry_name               char(32);
dcl  ep                       ptr init(null());
dcl  fn                       fixed bin(24);
dcl  gseg                     ptr;
dcl  i                        fixed bin;
dcl  ioa_                     entry options(variable);
dcl  name                     char(en) aligned based(np);
dcl  np                       ptr;
dcl  seg_name                 char(32);
dcl  status                   fixed bin(35) based(pointer(msub_arg_list_ptr,L_status));

%include gtss_msub_args;

%include mc;

%include gtss_ext_;

%include gtss_entry_dcls;

%include gtss_ust_ext_;

%include gtss_db_names;
     end						/* gtss_drl_msub_ */;
   



		    gtss_drl_objtim_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       51552


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

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

gtss_drl_objtim_: proc (mcpp, increment);

/* *	gtss check memory and time limits.

   Authors:	Robert J. Grimes	Created
                    Albert N. Kepner	  1978
                    Robert M. May
                    David B. Ward
   Changed:  Ron Barstad  06/11/82  Fixed stringsize condition on tra
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL OBJTIM, PROCESSOR TIME AND CORE SIZE LIMIT (octal 57)


   8_________1_6______

   DRL      OBJTIM


   This derail causes the object-program elapsed processor time
   and program memory size to be checked  against  installation-  or
   user-specified  limits.  If the installation has not assembled or
   patched the time and size limits into TSSA or a derail DRLIMT has
   not been done, this DRL will have no effect other than  notifying
   the Executive that control is being passed to a user program.


   In  addition,  this derail exists primarily for installation
   use in setting  size  and  time  limits  for  FORTRAN  and  BASIC
   programs.   Even  if  these  limits  are  set,  they  may  not be
   satisfactory values for the subsystem  being  designed.   If  the
   user  desires  to  set a separate processor object time limit for
   the subsystem or allow the subsystem user to set one,  he  should
   use DRL DRLIMT.


   OBJTIM  sets bit 14 of .LFLG2, which makes the limits stored
   in TSSA effective for the current interaction. (The  memory  size
   limit  is  stored in .TASSZ in number of words; the time limit is
   stored in .TASTM in number of clock pulses--seconds*64000.)


   If bit 14 of .LFLG2 is  set,  TSSM  places  the  contents  of
   .TASTM  in  .LIMTR  of  the  UST.   When  OBJTIM  and  DRLIMT are
   concurrently in  effect  the  smaller  of  the  two  time  limits
   (installation- or user-specified) is placed in .LIMTR.  Each time
   through TSSM, the contents of .LIMTR is decremented until it runs
   out or the interaction ends.


   Memory  size  is  checked  in TSSL at the time of the derail
   OBJTIM and at the time of any later ADDMEM request.


   When either limit is exceeded, word .LSZTM (21 octal) of the
   subsystem data area is checked for a valid transfer  instruction.
   If  present,  TSS  action  is  as  described in Section III under
   "Subsystem Data Area  and  Fault  Vector"  (except  that  only  a
   certain  small  time  limit is given for wrapup).  Bit 34 in word
   .LSZTM is set when the size limit is exceeded; bit 35 is set when
   the time limit is exceeded.  If no valid transfer is present, TSS
   types one of the following messages and returns  to  the  calling
   level:


   064   - EXECUTE TIME LIMIT EXCEEDED

   065   - OBJECT PROGRAM SIZE LIMIT EXCEEDED


   The  time  limit  in  .LIMTR  (and  the  limit in .LIMIT, if
   present), word .LSZTM of the subsystem data area, and bit  14  of
   .LFLG2 are reset when the program terminates.

*/


/* work variables */
dcl  fixed builtin;
dcl  addr builtin;
dcl  gseg ptr init(null());
dcl  timer_manager_$cpu_call entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call entry (entry);

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	increment = 0;				/* No arguments. */
	gtss_ust.lflg2.b14 = "1"b;			/* set bit in flagword indicating execution */

/* If user did a drl drlimt (limit non zero) then set up timer,
   but if one subsystem calls another, and it wants to set up a timer also,
   they do not have a nested timer effect. i.e. If subsystem one sets
   a 10 second timer, and subsystem two sets a 100 second timer and only
   uses 5 seconds, when control goes back to subsystem one the 100 second
   timer is still ticking away. (Strange, but GCOS does it that way.) */
	if gtss_ust_ext_$ust.gtss_ust.limit ^= 0 then do;
/* If a timer is already ticking, kill it.	*/
	     if gtss_ext_$flags.ss_time_limit_set then
		call timer_manager_$reset_cpu_call (
		gtss_fault_processor_$timer_runout);
	     call timer_manager_$cpu_call (
		divide (divide (gtss_ust_ext_$ust.gtss_ust.limit, 64, 36), 1000, 71),
		"11"b, gtss_fault_processor_$timer_runout);
	     gtss_ext_$flags.ss_time_limit_set = "1"b;
	end;

	if fixed (gtss_ust.lsize.limit, 18, 0)>gtss_install_values_$memory_limit then do;
	     gtss_spa.lsztm.b34 = "1"b;
	     if gtss_spa.lsztm.tra ^= "0"b then do;	/* Caller providing code for exceeding memory condition. */

/* *	Adjust increment parameter to cause transfer
   to caller's code.
   * */
		gtss_spa.losti.ilc = substr(gtss_spa.lsztm.tra,1,18); /* Set return address in slave prefix. */
		gtss_spa.losti.ir = "0"b;		/* Zero indicators. */
		increment = fixed (tra, 18, 0) - fixed (scu.ilc, 18, 0) -1;
		return;
	     end;

	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_objtim_",
		45,
		gtss_pnterr.err45);
	end;
	return;

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;

%include gtss_pnterr;

%include gtss_spa;

%include gtss_entry_dcls;

%include gtss_install_values_;
     end						/* gtss_drl_objtim_ */;



		    gtss_drl_part_.pl1              12/11/84  1349.3rew 12/10/84  1043.3       41859


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

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

/*	gtss release portion of temporary file.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward		09/17/79 New ios$position usage.
   Change:  Dave Ward	10/31/79 Record quota overflow specific.
   */
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/*

   DRL PART, PARTIAL RELEASE OF TEMPORARY FILEoctal 47)


   8_________1_6_____________________

   DRL      PART
   ZERO     L(fileid),n

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-53)

*/

	increment = 1 ;				/* One arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/*	Obtain name of file to release.	*/
	if L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_part_"
		, 4
		, "PART: FILE NAME OUTSIDE MEMORY AT (^6o)"
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	afn_ptr = addrel (gseg, L_fileid);

/*	Obtain (fn) the AFT index to the file.	*/
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
failed:	     ;
	     AU = 1;
	     return;
	end;

/*	Check that the file is temporary.		*/
	if gtss_disk (fn).pat_body.perm then goto failed;

/*	Change size.	*/
	call gtss_ios_change_size_ (
	     fn
	     , -n
	     , "1"b				/* Size in links (not llinks). */
	     , status
	     , code);
	if status>1 then do;
	     if db_drl_part then
		call com_err_ (
		code
		, "gtss_drl_part_"
		, "gtss_ios_change_size_ status ^i."
		, status
		);
	     if code = error_table_$rqover then
		call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_part_"
		, 0
		, "PART(^6o) EXCEEDED AVAILABLE LINKS ^a"
		, fixed (scu.ilc, 18)
		, translate (ascii_file_name, UPPER, lower)
		);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_part_"
		, 0
		, "PART(^6o) FILE ^a"
		, fixed (scu.ilc, 18)
		, translate (ascii_file_name, UPPER, lower)
		);
	     return;
	end;

/*	Rewind the file.	*/
	call gtss_ios_position_ (
	     fn
	     , -1					/* Position to beginning. */
	     , 0
	     , rcr				/* record count residue (not used). */
	     , addr (gstats)
	     );
	if gsc ^= "4002"b3 then do;
	     if db_drl_part then
		call com_err_ (
		code
		, "gtss_drl_part_"
		, "File ""^a"" (aft ^i) gtss_ios_position_ status=^w"
		, ascii_file_name
		, fn
		, gsc
		);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_part_"
		, 0
		, "PART: UNABLE TO REWIND AT (^6o)"
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	AU = 0;					/* Request satisfied. */
	return;

/*	Variables for gtss_drl_part_:
   IDENTIFIER		ATTRIBUTES	*/
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char (8)based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  error_table_$rqover	fixed bin(35)ext;
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  lower                    char(26)aligned static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  rcr                      bit(6)unal;
dcl  status                   fixed bin (24);
dcl  UPPER                    char(26)aligned static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

dcl 1 gstats aligned,
      2 gsc bit(12)unal,
      2 fill bit(60)unal;

dcl 1 A_reg aligned based (addr (mc.regs.a)),
    2 AU fixed bin (17)unal,
    2 AL fixed bin (17)unal;

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_fileid bit (18)unal
     , 2 n fixed bin (17)unal
     ;

%include gtss_ext_;

%include mc;

%include gtss_dfd_ext_;

%include gtss_entry_dcls;

%include gtss_ust_ext_;

%include gtss_db_names;
     end						/* gtss_drl_part_ */;
 



		    gtss_drl_pasaft_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       51066


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

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

/** 	Pass aft name(s) to caller.

   Author:	Bob Grimes		04/01/78
   Authors:	Robert J. Grimes	Created
                    Albert N. Kepner	  1978
                    Robert M. May
                    David B. Ward
   Changed:	Dave Ward			06/02/78
                    Incorporated call to gtss_aft_ to
                    obtain names in aft.
   Changed:         Paul Benjamin		09/28/79
		Changed behavior when L(max) <= 20 or max = 0
   **/
dcl  mcpp ptr parm;
dcl  increment fixed bin (24)parm;

/* *
   DRL PASAFT, PASS LIST OF FILES TO SUBSYSTEM (octal 22)

   8_________1_6_____________________

   DRL      PASAFT
   ZERO     L(buff),L(max) or 0
   0 => pass all names in aft.

   Where format of max word is:

   0	          17|18	         35
   -|-------------------|-------------------|
   |        n         |    - - - - -     |
   -|-------------------|-------------------|

   max         n            - - - - -

   n    = maximum number of file names to be passed.

   buff = BSS 2*(number of files in AFT)+1

   This  sequence places either the first n names or all user's
   file names (n = 0) in the area  specified.   The  format  of  the
   table passed back at location table is:

   -|-------------------------------------|
   |        No. of active files         |
   |            (bits 18-35)            | word 1
   -|-------------------------------------|
   |       Filename 1, chars 1-4        | word 2
   -|-------------------------------------|
   |       Filename 1, chars 5-8        |      3
   -|-------------------------------------|
   |                 .                  |      .
   -|-------------------------------------|
   |                 .                  |      .
   -|-------------------------------------|
   |                 .                  |      .
   -|-------------------------------------|
   |       Filename n, chars 1-4        | word n*2
   -|-------------------------------------|
   |       Filename n, chars 5-8        |      n*2+1
   -|-------------------------------------|
*/


	mcp = mcpp;				/* Set local value. */
	increment = 1;				/* one arguement */
	scup = addr (mc.scu);

/* *	Obtain pointer to caller's "memory".	* */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

/* *	Obtain pointer to 1 word drl argument list.	* */
	arg_ptr = addrel (gseg, fixed (scu.ilc)+1);

/* *	Check location of caller's buffer.	* */
	if arglist.buffer_offset > gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pasaft_",
		4,
		"Argument outside bounds at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;

/* *	Set pointer to caller's buffer.	* */
	buffer_ptr = addrel (gseg, fixed (arglist.buffer_offset));

	if arglist.num_files_offset = "0"b then num_files = hbound (aft_entry, 1); /* All aft names. */
	else if arglist.num_files_offset <= "000000000000010100"b /* loc <= aft limit */
	then num_files = bin (arglist.num_files_offset, 17, 0); /* must mean number of files */
	else do;					/* Obtain number of files word. */

/* *	Check location of number of files word. * */
	     if arglist.num_files_offset > gtss_ust.lsize.limit then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_pasaft_",
		     4,
		     "Offset to number files word out of memory at (^6o)",
		     fixed (scu.ilc, 18));
		return;
	     end;

/* *	Obtain pointer to number files word.	* */
	     number_files_ptr = addrel (gseg, arglist.num_files_offset);

/* *	Set local value.		* */
	     num_files = number_files.max_n;
	     if num_files = 0 then num_files = hbound (aft_entry, 1); /* all files */
	end;

/* *	Move names from aft to caller's buffer.		* */
	aftx = gtss_ext_$aft.first_added;		/* Index to aft_entry. */
	n = 0;					/* Number of names moved. */
	do while ((aftx>0)& (n<num_files));
	     n = n+1;
	     buffer.aft (n).name = aft_entry (aftx).altname;
	     aftx = aft_entry (aftx).next_add;		/* Link to next name added to aft. */
	end;

/* *	Note: No check is made that there were num_files in aft.
   * */

	buffer.number = n;				/* Record number of names moved. */

	return;

/*		external definitions	*/


/*		work variables		*/

dcl  i fixed bin;
dcl  num_files fixed binary;
dcl  gseg ptr init(null());
dcl  aftx fixed bin (24);
dcl  n fixed bin (24);

dcl  arg_ptr ptr ;
dcl 1 arglist aligned based (arg_ptr),
    2 buffer_offset bit (18) unaligned,
    2 num_files_offset bit (18) unaligned;

dcl  buffer_ptr ptr init(null());
dcl 1 buffer aligned based (buffer_ptr),
    2 number fixed binary (35),
    2 aft (hbound (aft_entry, 1)),
      3 name char (8) aligned;

dcl  number_files_ptr ptr init(null());
dcl 1 number_files aligned based (number_files_ptr),
    2 max_n fixed bin (17)unal,
    2 fill1 bit (18)unal;

dcl (addrel, addr, string, fixed, null) builtin;

%include gtss_ust_ext_;

%include	gtss_file_attributes;

%include	gtss_ext_;

%include	mc;

%include gtss_entry_dcls;
     end gtss_drl_pasaft_;
  



		    gtss_drl_pasdes_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       39780


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

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

/** 	Pass aft names(s) and file description(s) to caller.

   Author:	Dave Ward			06/02/78
   Authors:	Robert J. Grimes	Created
                    Albert N. Kepner	  1978
                    Robert M. May
                    David B. Ward
   Change		Paul Benjamin	09/28/79	Change behavior when L(max) <= 20 or max = 0
    **/
dcl  mcpp ptr parm;
dcl  increment fixed bin (24)parm;

/* *
   DRL PASDES, PASS AFT FILE NAMES AND DESCRIPTIONS (octal 44)

   8_________1_6_____________________

   DRL      PASDES
   ZERO     L(buff),L(max) or 0
   0 => pass all aft names.

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-18)

*/


	mcp = mcpp;				/* Set local value. */
	increment = 1;				/* one arguement */
	scup = addr (mc.scu);

/* *	Obtain pointer to caller's "memory".	* */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

/* *	Obtain pointer to 1 word drl argument list.	* */
	arg_ptr = addrel (gseg, fixed (scu.ilc)+1);

/* *	Check location of caller's buffer.	* */
	if arglist.buffer_offset > gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pasdes_",
		4,
		"Argument outside bounds at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;

/* *	Set pointer to caller's buffer.	* */
	buffer_ptr = addrel (gseg, fixed (arglist.buffer_offset));

	if arglist.num_files_offset = "0"b then num_files = hbound (aft_entry, 1); /* All aft names. */
	else if arglist.num_files_offset <= "000000000000010100"b /* loc <= aft limit */
	then num_files = bin (arglist.num_files_offset, 17, 0); /* must mean number of files */
	else do;					/* Obtain number of files word. */

/* *	Check location of number of files word. * */
	     if arglist.num_files_offset > gtss_ust.lsize.limit then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_pasdes_",
		     4,
		     "Offset to number files out of memory at (^6o)",
		     fixed (scu.ilc, 18));
		return;
	     end;

/* *	Obtain pointer to number files word.	* */
	     number_files_ptr = addrel (gseg, arglist.num_files_offset);

/* *	Set local value.		* */
	     num_files = number_files.max_n;
	     if num_files = 0 then num_files = hbound (aft_entry, 1); /* all files */
	end;

/* *	Move names from aft to caller's buffer.		* */
	aftx = gtss_ext_$aft.first_added;		/* Index to aft_entry. */
	n = 0;					/* Number of names moved. */
	do while ((aftx>0)& (n<num_files));
	     n = n+1;
	     buffer.aft (n).name = aft_entry (aftx).altname;
	     buffer.aft (n).desc =
		unspec (gtss_disk.attributes_ptr (aftx) -> gtss_file_attributes.descriptor);
	     aftx = aft_entry (aftx).next_add;		/* Link to next name added to aft. */
	end;

/* *	Note: No check is made that there were num_files in aft.
   * */

	buffer.number = n;				/* Record number of names moved. */

	return;

/*		external definitions	*/


/*		work variables		*/

dcl  i fixed bin;
dcl  num_files fixed binary;
dcl  gseg ptr init(null());
dcl  aftx fixed bin (24);
dcl  n fixed bin (24);

dcl  arg_ptr ptr ;
dcl 1 arglist aligned based (arg_ptr),
    2 buffer_offset bit (18) unaligned,
    2 num_files_offset bit (18) unaligned;

dcl  buffer_ptr ptr init(null());
dcl 1 buffer aligned based (buffer_ptr),
    2 number fixed binary (35),
    2 aft (hbound (aft_entry, 1)),
      3 name char (8),
      3 desc bit (36);

dcl  number_files_ptr ptr init(null());
dcl 1 number_files aligned based (number_files_ptr),
    2 max_n fixed bin (17)unal,
    2 fill1 bit (18)unal;

dcl (addrel, addr, string, fixed, null) builtin;

%include gtss_ust_ext_;

%include	gtss_file_attributes;

%include	gtss_dfd_ext_;

%include	gtss_ext_;

%include	mc;

%include gtss_entry_dcls;
     end gtss_drl_pasdes_;



		    gtss_drl_pasust_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       31401


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

/**	gtss pass UST or SY** information to caller.

	Authors:	Al Kepner
	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
		Bob Alvarado	08/22/79 added cpu time to ust.
		Paul Benjamin 	08/31/79 corrected upper bound of SPA.
  Modified: Ron Barstad  83-06-29  To 4js3 version where Num words is an offset and number of words
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL PASUST, PASS UST TO SUBSYSTEM (octal 33)


   8________16_____________________

   DRL      PASUST
   ZERO     L(buffer),N

    (See TSS Reference Manual
         DJ31-A, Sept. 1980, page 6-58)

*/
%page;
	increment = 1 ;				/* One arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get addres of arg_list */
	n = arg_list.N;				/* Number of words to move from UST. */
	gtss_ust.lsprt = gtss_ust.lsprt + (total_cpu_time_ ()/1000);
	if n = -1 then do;				/* => Move SY** to caller's buffer. */
	     n = 640;				/* Size of SY** */
	     n4 = n*4;				/* "n" words in characters. */
	     if (arg_list.L_buffer < "000144"b3) |	/* 144oct = 100dec. */
	     ((fixed (arg_list.L_buffer, 18)+n)> fixed (gtss_ust.lsize.limit, 18)) then goto failed;
	     addrel (gseg, arg_list.L_buffer) -> n_words =
		gtss_disk (gtss_ext_$SYstarstar_file_no).single_segment_ptr -> n_words;
	     return;
	end;

	n = arg_list_2.YYY;
	offset = arg_list_2.XXX;
	if (n>size (gtss_ust_ext_$ust)-1) | (n<1) then n = size (gtss_ust_ext_$ust)-1;
	if (arg_list.L_buffer < "000144"b3) |		/* 144oct = 100dec. */
	((fixed (arg_list.L_buffer, 18)+n)> fixed (gtss_ust.lsize.limit, 18)) then do;
failed:	     ;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_pasust"
		, 4
		, gtss_pnterr.err4
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	n4 = n*4;					/* "n" words in characters. */
	addrel (gseg, arg_list.L_buffer) -> n_words = addrel (addr(gtss_ust), offset) -> n_words;
	return;
%page;
/**	Variables for gtss_drl_pasust_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  (addr,
      addrel,
      fixed,
      null,
      size)                   builtin;
dcl  arg_list_ptr             ptr init(null());
dcl  gseg                     ptr init(null());
dcl  n                        fixed bin(24);
dcl  n4                       fixed bin(24);
dcl  n_words                  char(n4)aligned based;
dcl  offset                   fixed bin(24);

dcl 1 arg_list		aligned based(arg_list_ptr)
,     2 L_buffer		bit(18)unal
,     2 N			fixed bin(17)unal
;

dcl 1 arg_list_2		aligned based(arg_list_ptr)
,     2 L_buffer		bit(18)unal
,     2 N			unal
,       3 XXX                 unsigned fixed bin(9) unal  /* offset into UST */
,       3 YYY                 unsigned fixed bin(9) unal  /* number of words to move */
;

dcl  total_cpu_time_          entry returns (fixed bin (71));
%page;
%include gtss_pnterr;
%page;
%include gtss_dfd_ext_;
%page;
%include gtss_ext_;
%page;
%include gtss_ust_ext_;
%page;
%include mc;
%page;
%include gtss_entry_dcls;
     end gtss_drl_pasust_;
   



		    gtss_drl_pdio_.pl1              12/11/84  1349.3rew 12/10/84  1043.3       50418


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

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

/**	gtss system disk i/o.


   Author:  Al Dupuis	06/28/79.
   Change:  Dave Ward	10/30/79 Error for quota overflow.
*/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL PDIO, DO I/O ON SYSTEM FILE (octal 24)


   8_________1_6_____________________

   DRL      PDIO
   Seek command
   ZERO     L(fileid),L(dcw1)
   Read/Write command
   ZERO     L(fileid),L(dcw2)
   ZERO     L(status),0

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-xx)

*/

	increment = 5 ;				/* Five arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get address of arglist */

/**	Obtain name of file on which to do i/o.	**/
	if seek_locs.L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pdio_",
		4,
		"PDIO: file name outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	afn_ptr = addrel (gseg, seek_locs.L_fileid);

/**	Obtain pointer to return status word.	**/
	if L_status >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pdio_",
		4,
		"PDIO: Status word outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	status_words_ptr = addrel (gseg, L_status);
	unspec (status_words.WORD1) = "0"b;		/* => Major status = 0. */
	Termination_indicator = "1"b;

/* Convert bcd name to ascii */
	ascii_file_name = "";
	call gtss_bcd_ascii_ (addr (bcd_file_name (5)), 2, addr (ascii_file_name));

/**	Obtain (fn) the AFT index to the file.	**/
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     Major_status = "0001"b;			/* Device busy. */
	     return;
	end;
	if db_drl_dio then
	     call com_err_ (
	     0
	     , "gtss_drl_pdio_"
	     , "^a on file ""^a"" (aft ^i)"
	     , iocmd (read_write_cmd.device_command)
	     , translate (ascii_file_name, UPPER, lower)
	     , fn
	     );

	call gtss_ios_io_ (
	     fn
	     , arg_list_ptr
	     , arg_list_ptr
	     , fixed (gtss_ust.lsize.limit, 24)
	     , status
	     , code);
	if (status ^= 0) & (status ^= 1) then do;	/* Not success and not eof. */
	     if db_drl_dio then
		call com_err_ (
		code
		, "gtss_drl_pdio_"
		, "File ""^a"" (aft ^i) gtss_ios_io_ status=^i"
		, translate (ascii_file_name, UPPER, lower)
		, fn
		, status
		);
	     if (status = 2) then
		call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_pdio_"
		, 0
		, "PDIO(^6o) WRITE ATTEMPTED ON READ-ONLY FILE - ^a"
		, fixed (scu.ilc, 18)
		, translate (ascii_file_name, UPPER, lower)
		);
	     else
	     if (status = 16) then
		call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_pdio_"
		, 0
		, "PDIO(^6o) ^a EXCEEDED LLINKS AVAILABLE - ^a"
		, fixed (scu.ilc, 18)
		, iocmd (read_write_cmd.device_command)
		, translate (ascii_file_name, UPPER, lower)
		);
	     else
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_pdio_"
		, 0
		, "PDIO (^6o) ^a FAILED FILE ""^a"" (AFT ^i)"
		, fixed (scu.ilc, 18)
		, iocmd (read_write_cmd.device_command)
		, translate (ascii_file_name, UPPER, lower)
		, fn
		);
	     return;
	end;
	return;

/**	Variables for gtss_drl_pdio_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char (8);
dcl  bcd_file_name            (6)	bit (6) unaligned based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  lower                    char(26)aligned static int options(constant)init("abcdefghijklmnopqrstuvwxyz");
dcl  status                   fixed bin (24);
dcl  UPPER                    char(26)aligned static int options(constant)init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

dcl 1 arg_list aligned based (arg_list_ptr)
     , 3 seek_cmd
     , 4 device_command bit (06)unal
     , 4 zeroes_1 bit (12)unal
     , 4 IOC_Command bit (05)unal
     , 4 zeroes_2 bit (01)unal
     , 4 control bit (06)unal
     , 4 count bit (06)unal

     , 3 seek_locs
     , 4 L_fileid bit (18)unal
     , 4 L_dcw1 bit (18)unal

     , 3 read_write_cmd
     , 4 device_command bit (06)unal
     , 4 zeroes_1 bit (12)unal
     , 4 IOC_Command bit (05)unal
     , 4 zeroes_2 bit (01)unal
     , 4 control bit (06)unal
     , 4 count bit (06)unal

     , 3 read_write_locs
     , 4 L_fileid bit (18)unal
     , 4 L_dcw2 bit (18)unal

     , 3 L_status bit (18)unal
     , 3 zeroes_3 bit (18)unal
     ;

%include gtss_ext_;

%include mc;


%include gtss_io_status_words;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_device_cmds;

%include gtss_db_names;

%include gtss_iocmd;
     end						/* gtss_drl_pdio_ */;
  



		    gtss_drl_prgdes_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       30852


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

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

/* *	gtss move program descriptor information to caller.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL PRGDES, PASS PROGRAM DESCRIPTOR TO SUBSYSTEM (octal 65)


   8_________1_6_____________________

   DRL      PRGDES
   ASCII    1,ssname
   ZERO     L(buf),0

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-19)

*/

	increment = 2 ;				/* Two arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/* *	Obtain pointer to caller's buffer.	* */
	if (fixed (L_buf, 18)+8) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_prgdes_",
		4,
		"DRL_PRGDES: Buffer outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	buf_ptr = addrel (gseg, L_buf);

	addr (A_reg) -> b36 = "0"b;			/* A register zero as default. */

/* *	Look up callers subsystem name.	* */
	sub_system = ssname;			/* Local value. */
	do i = 1 to hbound (gtss_prgdes_ext_$prgdes, 1);
	     if sub_system = ss_name (i) then do;	/* Found. */
		buf = first_9_words (i);

/* *	Examine name of first primitive.	* */

/* Locate command language for this subsystem */
		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);

/* get 1st primitive */
		primitive = gtss_prgdes_ext_$primitives (cmd_list_len+1);
		if primitive_overlay.prim_op = 1 then	/* CALLP primitive. */
		     A_reg =
		     gtss_prgdes_ext_$prgdes (callp_desc).ss_name;
		return;
	     end;
	end;

/* *	Not found.	* */
	buf_9_zeroes = 0;
	return;

/* *	Variables for gtss_drl_prgdes_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  addrel builtin;
dcl  arg_list_ptr ptr init(null());
dcl  A_reg char (4)aligned based (addr (mc.regs.a));
dcl  b36 bit (36)aligned based;
dcl  buf char (36)aligned based (buf_ptr);
dcl  buf_9_zeroes (9)fixed bin (24)aligned based (buf_ptr);
dcl  buf_ptr ptr init(null());
dcl  code fixed bin (35);
dcl  gseg ptr init(null());
dcl  i fixed bin (24);
dcl  status fixed bin (24);
dcl  sub_system char (4)aligned;

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 ssname char (4)
     , 2 L_buf bit (18)unal
     , 2 zero fixed bin (17)unal
     ;

%include gtss_ext_;

%include mc;

%include gtss_primitives_;

%include gtss_prgdes_;

%include gtss_entry_dcls;

%include gtss_ust_ext_;
     end						/* gtss_drl_prgdes_ */;



		    gtss_drl_pseudo_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       34884


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

gtss_drl_pseudo_: proc (mcpp, increment);

/* *	gtss pseudo terminal input

   Author:	Bob Grimes		06/09/78
   Changed:	Dave Ward			06/23/78
   Corrected usage of remote io buffer.
   Changed:	Paul Benjamin		10/25/79
   Turn off lbuf.tally
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL PSEUDO, SIMULATED KEYBOARD INPUT (octal 64)


   8_________1_6_____________________

   DRL      PSEUDO
   ZERO     L(tally),L(stat)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-20)

*/


/*	External Entries 		*/


/*	Work Variables		*/

dcl  gesg ptr init(null());
dcl  move_string char (number_chars) based;
dcl  initial_tally_char (0:number_chars+3)char (1)based (addrel (gseg, tally.address));
dcl  number_chars fixed bin (17);
dcl  number_words fixed bin (17);

dcl  arg_ptr ptr init(null());
dcl 1 arglist aligned based (arg_ptr),
    2 tally fixed bin (17) unaligned,
    2 status fixed bin (17) unaligned;

dcl  tally_ptr ptr init(null());
dcl 1 tally aligned based (tally_ptr),
    2 address fixed bin (17) unaligned,
    2 chars fixed bin (11) unaligned,
    2 type bit (3) unaligned,
    2 offset fixed bin (2) unaligned;

dcl  gseg ptr init(null());

dcl (addr, addrel, substr) builtin;


	scup = addr (mc.scu);
						/* only one arguement */
	increment = 1;
						/* get pointer to segment */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_ptr = addrel (gseg, fixed (scu.ilc)+1);
						/* check bounds for the arguments */
	if arglist.tally > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;

	if arglist.status > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;

/*	Set up to find his tally */
	tally_ptr = addrel (gseg, arglist.tally);
						/* check for only tallyb */
	if tally.type ^= "100"b then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		49,
		gtss_pnterr.err49,
		fixed (scu.ilc, 18));
	     return;
	end;
						/* allow no more than 244 characters to be placed */
	if tally.chars > 244 then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		49,
		gtss_pnterr.err49,
		fixed (scu.ilc, 18));
	     return;
	end;
						/* make sure the tally address doesn't go out of bounds */
	if tally.address > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;

	number_chars = tally.chars;
	number_words = divide ((number_chars+3), 4, 24, 0);

/* also look at the end of his string to move for boundry check */
	if (tally.address+ number_words) > fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_pseudo_",
		4,
		gtss_pnterr.err4,
		fixed (scu.ilc, 18));
	     return;
	end;
	number_words_transmitted = number_words;
	count_of_characters_transmitted = number_chars;
	addr (characters_transmitted) -> move_string =
	     addr (initial_tally_char (tally.offset)) -> move_string;
	gtss_ust_ext_$ust.gtss_ust.lbuf.tally = "0"b;
	return;

%include gtss_ust_ext_;

%include gtss_pnterr;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;
     end gtss_drl_pseudo_;



		    gtss_drl_relmem_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       36702


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

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

/**	gtss release memory.

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

dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL RELMEM, RELEASE MEMORY (octal 15)


   8_________1_6_____________________

   DRL      RELMEM
   C(A)     return location,0
   C(Q)     number  words low,number words high

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-21)

*/

	increment = 0 ;				/* Zero arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	lw = divide (QU, 1024, 24)*1024;
	hw = divide (QL, 1024, 24)*1024;

	nl = fixed (gtss_ust.lsize.limit, 18, 0) - lw - hw; /* Calculate new length of memory. */

	if nl <1024 then do;

/* Exceeds installation limit. */
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_relmem_"
		, 0
		, gtss_pnterr.err101
		, fixed (scu.ilc, 18)
		);
	     return;
	end;

	if (AU>nl) | (AL ^= 0) then do;
	     call com_err_ (0, "gtss_drl_relmem_",
		"Improper return address: AU=^6o AL=^6o lisize.limit=^6o",
		AU, AL, nl);

/* Improper return address */
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_relmem_"
		, 4
		, gtss_pnterr.err4
		, fixed (scu.ilc, 18)
		);
	     return;
	end;

/**	Reduce memory.	**/
	if lw>0 then do;				/* Move memory if lower words specified. */
	     nc = nl*4;				/* New memory length in characters. */
	     gseg -> MS = addrel (gseg, lw) -> MS;
	end;

	if gse_ext_$modes.gdb then
	     if gtss_ext_$gdb_name ^= " " then do;
		call gcos_debug_$loadtime (
		     "-gtss"			/* memory segment name */
		     , gtss_ext_$gdb_name
		     , ""
		     , 0
		     );
		gtss_ext_$gdb_name = " ";
	     end;

	gtss_ust.lswap.size, gtss_ust.lsize.limit = nl_r18; /* Save new limit in ust */

	gtss_ust.lsize.bar = divide (nl+511, 512, 17, 0);
	call gtss_set_slave_$load_bar (fixed (gtss_ust.lsize.bar, 18, 0)); /* Reset BAR register. */

	gtss_spa.losti.ilc = bit (AU);		/* set up the return address in the slave area */
	gtss_spa.losti.ir = "0"b;			/* zero the indicators */

	increment = AU - fixed (scu.ilc, 18, 0) -1;	/* Restart execution of user's code return location. */

	return;

/**	Variables for gtss_drl_relmem_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  code                     fixed bin (35);
dcl  gcos_debug_$loadtime     entry (char (*), char (*), char (*), fixed bin (24));
dcl  gseg                     ptr init(null());
dcl  hw                       fixed bin (24);
dcl  lw                       fixed bin (24);
dcl  MS                       char (nc)aligned based;
dcl  nc                       fixed bin (24);
dcl  nl                       fixed bin (35);
dcl  status                   fixed bin (35);

dcl 1 nl_overlay aligned based (addr (nl)),
    2 nl_l18 bit (18)unal,
    2 nl_r18 bit (18)unal;

dcl 1 Q_reg aligned based (addr (mc.regs.q)),
    2 QU fixed bin(18)unsigned unal,
    2 QL fixed bin(18)unsigned unal;

dcl 1 A_reg aligned based (addr (mc.regs.a)),
    2 AU fixed bin(18)unsigned unal,
    2 AL fixed bin(18)unsigned unal;

%include gtss_spa;

%include gtss_ust_ext_;

%include gtss_pnterr;

%include gtss_ext_;

%include mc;

%include gtss_entry_dcls;

%include gtss_install_values_;

%include gse_ext_;
     end						/* gtss_drl_relmem_ */;
  



		    gtss_drl_restor_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       93348


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

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

gtss_drl_restor_: proc (mcpp, increment);

/**	gtss bring on overlay for current subsystem.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward	5/29/79  h* gdb name parm.
   **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL RESTOR, OVERLAY-LOAD A SUBSYSTEM (octal 25)


   8_________1_6_____________________

   DRL	  RESTOR
   ASCII    1,name
   ZERO     loc,0 or non-0
   ZERO     tra,0

   or

   DRL	  RESTOR
   ZERO	  nameloc,0 or 1
   ZERO     loc,0 or non-0
   ZERO	  tra,bufloc

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-21)

*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

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

	if substr (arg_list2.not_first_name, 1, 17) ^= "0"b then do;

/**	Cause an overlay to be placed in the current memory
   for the current executing subsystem. Transfer execution
   back into the current subsystem.
   **/

	     prog_name = ascii_program_name;		/* Local value. */
	     do i = 1 to hbound (gtss_prgdes_ext_$prgdes, 1); /* Lookup name in program descriptors. */
		if prog_name = gtss_prgdes_ext_$prgdes (i).ss_name then do; /* Found */
		     call gtss_run_subsystem_$restor (i, arg_list_ptr); /* AND DO NOT RETURN! */
		     call gtss_abort_subsystem_ (
			mcp
			, "gtss_drl_restor_"
			, 0
			, "RESTOR: Improper return? at (^6o)"
			, fixed (scu.ilc, 18)
			);
		     return;
		end;
	     end;
						/* Not found. */
	     call com_err_ (0, "gtss_drl_restor_",
		"""^a"" not found as a program descriptor name.", prog_name);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 0
		, "RESTOR: ??? at (^6o)"
		, fixed (scu.ilc, 18)
		);
	     return;
	end;

/**	Overlay-load a permanent file or a program
   from a multiprogram permanent file.
   **/

/**	Verify 3 word name list available.	**/
	if (fixed (nameloc)+2) > fixed (gtss_ust.lsize.limit, 18)
	| fixed (nameloc) < 100 then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 4
		, "RESTOR: 3 word name list outside memory at (^60)"
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	name_list_ptr = addrel (gseg, nameloc);

/**	Verify name of perm file is in AFT.	**/
	call gtss_aft_$find ((ascii_file_name), fn, code);
	if code = 1 then do;			/* Not in AFT. */
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 0
		, "RESTOR: SAVE/RESTOR FILE NAME (^a) NOT IN AFT at (^6o)"
		, ascii_file_name
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	temp = divide (file_size (fn), 64, 24, 0);
	if temp > max_for_18_bits
	then file_size_in_blocks = max_for_18_bits;
	else file_size_in_blocks = temp;

/* Make sure file is not null */

	if ^gtss_disk (fn).pat_body.write_performed
	then do;
not_initialized: ;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 51
		, err51				/* H* file not initialized */
		, fixed (scu.ilc, 18)
		, ascii_file_name
		);
	     return;
	end;

/* Make sure the buffer is within memory */
	if fixed (arg_list2.bufloc)+63 >= fixed (gtss_ust.lsize.limit)
	| fixed (arg_list2.bufloc, 18) < 100 then do;
bad_arg:	     ;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 4
		, err4				/* Bad derail argument */
		, fixed (scu.ilc, 18)
		);
	     return;
	end;
	buffer_ptr = addrel (gseg, arg_list2.bufloc);

/* Make sure file name is not within buffer */
	call check (fixed (nameloc), fixed (nameloc)+1);

/* Make sure Derail call sequence is not within buffer */
	call check (fixed (scu.ilc), fixed (scu.ilc)+3);


/* At this point the arguments have been checked and the restore of
   the user's H* can proceed. */

	if arg_list2.not_first_name then do;
	     last_catalog = "0"b;
	     next_catalog = 0;
	     control_block = 0;
	     do while (^last_catalog);
		call read_buffer (next_catalog, fixed (arg_list2.bufloc));
		call search_for_object (next_catalog, control_block);
		if control_block ^= 0 then go to read_control_block;
		last_catalog = (next_catalog <= 0);
		if next_catalog >= file_size_in_blocks then go to undefined;
	     end;

undefined:     ;
	     gtss_ext_$gdb_name = " ";
	     call gtss_bcd_ascii_$lc (addr (bcd_program_name), 6, addr (gtss_ext_$gdb_name));
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 47
		, err47				/* H* program name undefined */
		, fixed (scu.ilc, 18)
		, gtss_ext_$gdb_name
		);
	     return;
	end;
	else control_block = 2;

read_control_block: ;
	if control_block >= file_size_in_blocks then go to undefined;
	call read_buffer (control_block, fixed (arg_list2.bufloc));
	call analyze_control_block;
	call read_data (control_block+1, memory_loc);
	call gtss_update_safe_store_ (mcp);
	call gtss_run_subsystem_$restor_perm (0, arg_list_ptr, fixed (entry_address, 18));
ret:	;
	return;

analyze_control_block: proc;

/* Place entry address and load origin in the Q register. */
	     mc.regs.q = data_control_block.entry_address||
		data_control_block.load_origin;

/* Determine where to resume execution. */
	     entry_address = data_control_block.entry_address;
	     if arg_list2.tra ^= "0"b
	     then entry_address = arg_list2.tra;
	     if entry_address >= gtss_ust.lsize.limit
	     then go to bad_arg;

/* Determine where in memory to put data being restored. */
	     if arg_list2.program_0_at_loc
	     then load_origin = "0"b;
	     else do;
		if data_control_block.load_origin > "0"b
		then load_origin = data_control_block.load_origin;
		else do;
		     temp = fixed (data_control_block.dcws (1).memory_loc, 18)-1024;
		     if temp < 0 then go to undefined;
		     load_origin = bit (fixed (temp, 18), 18);
		end;
	     end;
	     memory_loc = fixed (load_origin, 18)+fixed (arg_list2.loc, 18);

/* Determine length of data block to be restored. */
	     words_in_element = 0;
	     do i = 1 to hbound (data_control_block.dcws, 1);

/* Check for IONTP */
		if dcws (i).action_code = "011"b then do;
		     call gtss_abort_subsystem_ (
			mcp
			, "gtss_drl_restor_"
			, 4			/* Bad derail arg */
			, "Unimplemented function: IONTP DCW by DRL RESTOR at (^6o)"
			, fixed (scu.ilc, 18)
			);
		     go to ret;
		end;

		if data_control_block.dcws (i).word_count = "0"b
		then words_in_element = words_in_element + 4096;
		else words_in_element = words_in_element +
		     fixed (data_control_block.dcws (i).word_count);

/* Check for IOTD. */
		if dcws (i).action_code = "000"b
		then go to last_dcw;

/* Check for IOTP */
		if dcws (i).action_code ^= "001"b then do;
		     call gtss_abort_subsystem_ (
			mcp
			, "gtss_drl_restor_"
			, 3
			, err3			/* Invalid DCW */
			, fixed (scu.ilc, 18)
			);
		     go to ret;
		end;
	     end;

last_dcw:	     ;
	     mc.regs.a =
		bit (fixed (words_in_element+fixed (load_origin, 18), 18), 18)||
		load_origin;
	     if words_in_element+memory_loc >= fixed (gtss_ust.lsize.limit) then
		go to bad_arg;
	end analyze_control_block;

check:	proc (l1, l2);

/* This routine verifies that the range of addresses from l1 to l2
   does not overlap the user's buffer */
dcl (l1, l2) fixed bin (18) parm;

	     if l2 < fixed (arg_list2.bufloc) then return;
	     if l1 > fixed (arg_list2.bufloc) then return;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_restor_"
		, 4
		, err4				/* Bad derail argument */
		, fixed (scu.ilc, 18)
		);
	     go to ret;
	end check;

search_for_object: proc (next_catalog, control_block);
dcl  next_catalog             fixed bin (18) parm;
dcl  control_block            fixed bin (18) parm;
	     next_catalog = fixed (catalog_block.continue_catalog, 18);
	     do i = 1 to hbound (cat, 1);
		if bcd_program_name = cat (i).bcd_name then do;
		     gtss_ext_$gdb_name = " ";
		     call gtss_bcd_ascii_$lc (addr (bcd_program_name), 6, addr (gtss_ext_$gdb_name));
		     control_block = fixed (cat (i).initial_block, 18);
		     return;
		end;
	     end;
	end search_for_object;

/**	Variables for gtss_drl_restor_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  arg_list_ptr             ptr init(null());
dcl  code                     fixed bin (35);
dcl  control_block            fixed bin (18);
dcl  entry_address            bit (18);
dcl  fixed                    builtin;
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  last_catalog             bit (1);
dcl  load_origin              bit (18);
dcl  me                       char (32) int static options (constant) init ("gtss_drl_restor_");
dcl  name_list_ptr            ptr init(null());
dcl  next_catalog             fixed bin (18);
dcl  prog_name                char (4)aligned;
dcl  status                   fixed bin (24);
dcl  to_from                  char (17) int static options (constant) init ("read program from");

%include gtss_restor_arg_list1;

dcl 1 arg_list2 aligned based (arg_list_ptr)
     , 2 nameloc bit (18)unal
     , 2 not_first_name bit (18)unal
     , 2 loc bit (18)unal
     , 2 program_0_at_loc bit (18)unal
     , 2 tra bit (18)unal
     , 2 bufloc bit (18)unal
     ;

dcl 1 name_list aligned based (name_list_ptr)
     , 2 ascii_file_name char (8)
     , 2 bcd_program_name bit (36)
     ;

%include gtss_ext_;

%include mc;

%include gtss_pnterr;
%include gtss_prgdes_;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_dfd_ext_;

%include gtss_device_cmds;

%include gtss_hstar;

%include gtss_save_restore_data_;
     end						/* gtss_drl_restor_ */;



		    gtss_drl_retfil_.pl1            12/11/84  1349.3rew 12/10/84  1043.3       39375


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

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

/* *	Close file and remove from aft.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change: Dave Ward	04/13/79 db_ debug code.
   Change: Dave Ward	08/03/79 Revised ios close call.
   Change: Bob Alvarado	12/05/79 Added code to not let sy** be removed.
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin (24)parm;

/*

   DRL RETFIL, RETURN A FILE (octal 14)


   8_________1_6_____________________

   DRL      RETFIL
   ZERO     L(filed),L(buff)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-53)

*/


	mcp = mcpp;				/* Set local value. */
	increment = 1;				/* one arguement */
	scup = addr (mc.scu);

/* *	Obtain pointer to callers "memory".	* */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

/* *	Obtain pointer to 1 word drl argument list.	* */
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);

/* *	Check location of caller's fileid.	* */
	if fixed (arg_list.L_fileid, 18)>fixed (gtss_ust.lsize.limit, 18) then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_retfil_",
		4,
		"RETFIL: Fileid out of memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;

/* *	Obtain pointer to caller's fileid.	* */
	fileid_ptr = addrel (gseg, arg_list.L_fileid);

	if right_char = (9)"1"b then do;		/* Octal 777 => all but SY** */
	     if db_drl_retfil then
		call com_err_ (0, "gtss_drl_retfil_",
		" Returning all but SY**");
	     call all_but ("SY**");
	     return;
	end;

	if right_char = "111111110"b then do;		/* Octal 776 => all but *CF */
	     if db_drl_retfil then
		call com_err_ (0, "gtss_drl_retfil_",
		"Returning all but *CF");
	     call all_but ("*CF");
	     return;
	end;

/* *	Otherwise, designated file. * */
	if db_drl_retfil then
	     call com_err_ (0, "gtss_drl_retfil_",
	     "Returning file ""^a""",
	     fileid);
	call remove (fileid);
	return;

all_but:	proc (fileid);

/* *	Remove all files except that
   named by parameter fileid.
   * */
dcl  fileid char (8) parm;
	     do i = 1 to hbound (aft_entry, 1);
		if used (i) then
		     if fileid ^= altname (i) then call remove (fileid);
	     end;
	     return;

dcl  i fixed bin (24);
	end					/* all_but */;

remove:	proc (fileid);

/* *	Remove file named by fileid.	* */
dcl  fileid char (8) parm;
	     unspec (fms_status) = "0"b;
/** SY** cannot be removed  **/
	     if fileid = "SY**    " then return;
	     call gtss_aft_$delete (fileid, fn, code);
	     if code = 0 then do;
		call gtss_ios_close_ (fn, addr (fms_status), code);
		if fms_status.bit12 ^= "4000"b3 then do;
dcl 1 fms_status aligned,
      2 bit12 bit(12)unal,
      2 bit60 bit(60)unal;
		     call gtss_abort_subsystem_ (
			mcp
			, "gtss_drl_retfil_"
			, 0
			, "RETFIL: Can not return ""^a"" (DRL at ^6o) gtss_ios_close_ status=^w"
			, fileid
			, fixed (scu.ilc, 18)
			, fms_status
			);
		end;
	     end;

	     return;

dcl  fn fixed bin (24);
dcl  code fixed bin (35);
	end					/* remove */;

/* *	Variables for gtss_drl_retfil_:
   IDENTIFIER	ATTRIBUTES	* */
dcl  addrel builtin;
dcl  arg_list_ptr ptr init(null());
dcl  code fixed bin (35);
dcl  fileid char (8) based (fileid_ptr);
dcl  fileid_ptr ptr init(null());
dcl  fn fixed bin (24);
dcl  gseg ptr init(null());

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_fileid bit (18)unal
     , 2 L_buff bit (18)unal
     ;

dcl 1 fileid_2 aligned based (fileid_ptr)
     , 2 filler bit (27)unal
     , 2 right_char bit (9)
     ;

%include	gtss_ext_;

%include gtss_ust_ext_;

%include	mc;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_drl_retfil_ */;
 



		    gtss_drl_return_.pl1            12/11/84  1349.3rew 12/10/84  1043.4       14292


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

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


/* *	Normal return from subsystem.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
*/
dcl  mcpp ptr parm;
dcl  increment fixed bin (24)parm;

/* *

   DRL RETURN, RETURN TO PRIMITIVE LIST (octal 5)


   8_________1_6______

   DRL      RETURN


   This derail indicates to the Executive that  this  subsystem
   process  has  reached  a  normal  termination.   The  TSSH module
   selects the next primitive in the  sequence  defined  within  the
   program  descriptor  and,  based on this primitive, initiates the
   next process. (Refer to the description of primitives in  Section
   IV.)
*/
/* Reset "pass break" indicator. */
	gtss_ust.lswth.b7 = "0"b;
	go to gtss_ext_$drl_rtrn (gtss_ext_$stack_level_); /* return to gtss_run_subsystem_ */

%include gtss_ext_;

%include gtss_ust_ext_;
     end gtss_drl_return_;



		    gtss_drl_rew_.pl1               12/11/84  1349.3rew 12/10/84  1043.4       34857


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

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

/**	gtss rewind a linked (sequential) file.

   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	09/17/79 New gtss_ios_position_ usage.
   **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL REW, REWIND A LINKED FILE (octal 12)


   8_________1_6_____________________

   DRL      REW
   ZERO     L(fileid),L(stat)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-54)

*/

	increment = 1 ;				/* One arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/**	Obtain name of file to rewind.	**/
	if L_fileid >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_rew_",
		4,
		"REW: file name outside memory at (^o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	afn_ptr = addrel (gseg, L_fileid);
	if db_drl_rew then
	     call ioa_ ("REW: file ^a", ascii_file_name);

/**	Obtain pointer to return status word.	**/
	if L_stat >= gtss_ust.lsize.limit then do;
	     call gtss_abort_subsystem_ (mcp,
		"gtss_drl_rew_",
		4,
		"REW: Status word outside memory at (^6o)",
		fixed (scu.ilc, 18));
	     return;
	end;
	status_word_ptr = addrel (gseg, L_stat);
	unspec (status_word) = "0"b;
	gcs = "4002"b3;				/* => success (at load point). */

/**	Obtain (fn) the AFT index to the file.	**/
	call gtss_aft_$find (ascii_file_name, fn, code);
	if code = 1 then do;			/* Unknown file (i.e., not in AFT). */
	     gcs = "4100"b3;			/* Device busy. */
	     return;
	end;

/**	Rewind the file.	**/
	call gtss_ios_position_ (
	     fn
	     , -1					/* Position to beginning. */
	     , 0
	     , rcr				/* record count residue (not used). */
	     , status_word_ptr
	     );
	if gcs ^= "4002"b3 then do;
	     if db_drl_rew then
		call com_err_ (
		code
		, "gtss_drl_rew_"
		, "File ""^a"" (aft ^i) gtss_ios_position_ status=^w"
		, ascii_file_name
		, fn
		, gcs
		);
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_rew_"
		, 0
		, "REW: Unable to position"
		);
	end;
	return;

/**	Variables for gtss_drl_rew_:
   IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  afn_ptr                  ptr init(null());
dcl  arg_list_ptr             ptr init(null());
dcl  ascii_file_name          char (8)based (afn_ptr);
dcl  code                     fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr init(null());
dcl  ioa_			entry options(variable);
dcl  rcr			bit(6)unal;
dcl  status                   fixed bin (24);

dcl  status_word_ptr	ptr;
dcl 1 status_word aligned based(status_word_ptr),
      2 gcs bit(12)unal,
      2 fill bit(24)unal;

dcl 1 arg_list aligned based (arg_list_ptr)
     , 2 L_fileid bit (18)unal
     , 2 L_stat bit (18)unal
     ;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_db_names;
     end						/* gtss_drl_rew_ */;
   



		    gtss_drl_rstswh_.pl1            12/11/84  1349.3rew 12/10/84  1043.4       21726


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

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

/*	Reset switch word.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
*/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/*


   DRL RSTSWH, RESET SWITCH WORD (octal 11)


   8_________1_6______

   DRL      RSTSWH  or RSTSWH,* (Refer to  DRL  SETSWH  for  the
   latter usage)

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-23)

*/

	scup = addr (mc.scu);
	increment = 0;				/* no parameter words */

	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_) ; /* GCOS memory. */
	qin = mc.regs.q;
	drl_ptr = addrel (
	     gseg, fixed (scu.ilc));			/* find the modifier to find out which on to do */

	if drl_word.modifier = "0"b then do;
	     mc.regs.q, string (gtss_ust.lswth) = string (gtss_ust.lswth) & ^string (mc.regs.q); /* or q into psw */
	     wh = "1";
	end;
	else do;
	     mc.regs.q, string (gtss_ust.lswt2) = string (gtss_ust.lswt2) & ^string (mc.regs.q); /* or q into psw 2) */
	     wh = "2";
	end;

	if db_drl_rstswh then call pr_sw (wh, "OFF", qin, mc.regs.q);
	return;

/*  Variables for gtss_drl_rstswh_:
   IDENTIFIER		ATTRIBUTES */
dcl  qin                      bit(36);
dcl  wh                       char(1);
dcl  ioa_                     entry options(variable);
dcl  gseg                     pointer;
dcl  drl_ptr                  ptr init(null());
dcl 1 drl_word aligned based (drl_ptr),
    2 fill bit (30) unaligned,
    2 modifier bit (6) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;

%include gtss_db_names;

%include gtss_pr_sw;
     end						/* gtss_drl_rstswh_ */;
  



		    gtss_drl_setlno_.pl1            12/11/84  1349.3rew 12/10/84  1043.4       20475


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

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

/**	gtss set automatic (or autox) build line mode.

	Author:	Bob Grimes		04/01/78
	Changed:	Dave Ward			06/19/78
	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
 **/
dcl  mcpp			ptr parm;
dcl  increment		fixed bin(24)parm;
	mcp = mcpp;
/*
   DRL SETLNO, SET LINE&NUMBER/INCREMENT IN UST (octal 37)


   8_________1_6_____________________

   DRL      SETLNO


   0

   C(A)           Line number

   C(Q)     X         Increment

   This derail initiates the  automatic  line  numbering  mode.
   The  specified  line number and increment value are stored in the
   user status table for use by  Line  Service.   An  indicator  for
   automatic  line-numbering  mode  is  set  in  .LFLG2 (in UST).  A
   blank/no-blank indicator is set in .LFLG2 also, as  specified  by
   bit  0  of the Q-register.  If the bit value (X) is 1, a blank is
   not supplied following the line number.
*/

	increment = 0;
	if (Line_number<0)| (Increment<0) then return;	/* Don't enter auto[x] mode. */
	gtss_ust.lflg2.b24 = X;			/* 1 => do NOT provide space after line number. */
	gtss_ust.lflg2.b25 = "1"b;			/* 1 => auto mode set on. */
	if Line_number>0 then gtss_ust.linno = Line_number; /* Reset only if >0. */
	if Increment>0 then gtss_ust.lincr = Increment;	/* Reset only if >0. */
	return;

dcl 1 a_q			aligned based(addr(mc.regs.a))
,     3 Line_number		fixed bin(35)
,     3 X			bit(1)unal
,     3 Increment		fixed bin(34)unal
;

%include gtss_ust_ext_;

%include mc;

%include gtss_ext_;
     end gtss_drl_setlno_;
 



		    gtss_drl_setswh_.pl1            12/11/84  1349.3rew 12/10/84  1043.4       19998


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

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

/*	Set switch word

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
*/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/*


   DRL SETSWH, SET SWITCH WORD (octal 11)


   8_________1_6______

   DRL      SETSWH  or SETSWH,*

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-25)

*/

	scup = addr (mc.scu);
	increment = 0;				/* no parameter words */

	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_); /* GCOS memory. */
	drl_ptr = addrel (
	     gseg, fixed (scu.ilc));			/* find the modifier to find out which on to do */

	qin = mc.regs.q;
	if drl_word.modifier = "0"b then do;
	     mc.regs.q, string (gtss_ust.lswth) = string (gtss_ust.lswth) | mc.regs.q; /* or q into psw */
	     wh = "1";
	end;
	else do;
	     mc.regs.q, string (gtss_ust.lswt2) = string (gtss_ust.lswt2) | mc.regs.q; /* or q into psw 2 */
	     wh = "2";
	end;

	if db_drl_setswh then call pr_sw (wh, "ON ", qin, mc.regs.q);
	return;

/*   Variables for gtss_drl_setswh_:
   IDENTIFIER		ATTRIBUTES	*/
dcl qin bit(36);
dcl wh char(1);
dcl ioa_ entry options(variable);
dcl  gseg pointer;
dcl  drl_ptr ptr init(null());
dcl 1 drl_word aligned based (drl_ptr),
    2 fill bit (30) unaligned,
    2 modifier bit (6) unaligned;

%include gtss_ust_ext_;

%include gtss_ext_;

%include mc;
%include gtss_db_names;

%include gtss_pr_sw;
     end gtss_drl_setswh_;
  



		    gtss_drl_snumb_.pl1             12/11/84  1349.3rew 12/10/84  1043.4       11970


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

gtss_drl_snumb_: proc (mcpp, increment);

/* *	gtss obtain snumb.

   Author:	Mel Wilson			19mar79
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL SNUMB, OBTAIN SNUMB (octal 20)


   8_________1_6_____________________

   DRL      SNUMB

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-25)

*/

	increment = 0;				/* no argument words */

	call gtss_get_user_state_ (u_state_ptr);
	temp_snumb = snumb_sequence || "T0";
	call gtss_ascii_bcd_ (addr (temp_snumb), 6, addr (mc.a));
	if snumb_sequence = 9999 then snumb_sequence = 0;
	else snumb_sequence = snumb_sequence + 1;
	return;

/* miscellaneous declarations */
dcl  temp_snumb char (6);
dcl  gtss_ascii_bcd_ ext entry (ptr, fixed bin, ptr);
dcl gtss_get_user_state_ entry (ptr);

%include gtss_snumb_xref_;

%include mc;
     end gtss_drl_snumb_;
  



		    gtss_drl_spawn_.pl1             11/05/86  1603.9r w 11/04/86  1034.2       83493


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

gtss_drl_spawn_: proc (mcpp, increment);

/* *	gtss  pass file to batch processor.

   Author:	Mel Wilson			19mar79
  Modified:  Ron Barstad  83-04-25  Add -userlib to gcos command line
   * */
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;

/* *

   DRL SPAWN,  PASS FILE TO BATCH PROCESSOR (octal 26)
   DRL PASFLR, PASS FILE TO REMOTE BATCH PROCESSOR (octal 60, jout option)


   8_________1_6_____________________

   DRL      SPAWN
   ZERO     L(snumb),L(buffer)

   or

   DRL      PASFLR
   ZERO     L(snumb),L(buffer)

   additionally, on entry:
   mc.a bits 0..11 if non-zero give the id for output,
   mc.a bit 35 if non-zero indicates return after batch job complete
   mc.q bits 0..17 point to the name of the bcd source-image file.
   on exit:
   mc.q gives a status code in the range 0..6 .

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Pages 3-19, 3-26)

*/

/*
   drl snumb local declarations
*/
dcl  arg_list_ptr             ptr;
dcl 1 arg_list aligned based (arg_list_ptr),
    2 L_snumb fixed bin (18) unsigned unal,
    2 L_buffer fixed bin (18) unsigned unal;

dcl 1 local_a based (addr (mc.a)),
      3 output_id bit (12) unal,
      3 fill bit (6) unal,
      3 fill1 bit (17) unal,
      3 wait_flag bit (1) unal;

dcl 1 local_q based (addr (mc.q)),
      3 L_filename fixed bin (18) unsigned unal,
      3 fill3 bit (18) unal;

dcl  snumb_ptr                ptr;
dcl  bcd_snumb                bit (36) based (snumb_ptr);
dcl  given_snumb              char (5) init ("");

dcl  filename_ptr             ptr;
dcl  given_filename           char (8) based (filename_ptr);

dcl  c                        fixed bin (35);
dcl  fn                       fixed bin (24);
dcl  gseg                     ptr;
dcl  home_path                char (128);
dcl  i                        fixed bin;
dcl  jout_request             bit;

dcl  bar_mode_stack_ptr       ptr auto;						/* local storage for bar mode ptr during gcos call */

/* gtss_drl_spawn_ entry (mcpp, increment); */
	jout_request = "0"b;
	goto common;


gtss_drl_pasflr_: entry (mcpp, increment);
	jout_request = "1"b;


common:
	mcp = mcpp;
	increment = 1 ;				/* One argument */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18)+1); /* get addres of arg_list */

/* *	Obtain snumb.	* */
	if L_snumb >= fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
	     "Snumb outside memory (^o)", fixed (scu.ilc, 18));
	snumb_ptr = addrel (gseg, L_snumb);
	call gtss_bcd_ascii_$lc (snumb_ptr, 5, addr (given_snumb));

/* *	Validate file_name pointer */
	if L_filename >= fixed (gtss_ust.lsize.limit, 18) - 1 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
	     "File name outside memory (^o)", fixed (scu.ilc, 18));
	filename_ptr = addrel (gseg, L_filename);

/** Validate file name */
	call gtss_aft_$find (given_filename, fn, c);
	if c = 1 then
	     call spawn_error (1);			/* 'undefined file' */

	call gtss_get_user_state_ (u_state_ptr);
	do i = 1 to entry_count;
	     if snumb (i) = given_snumb & status (i) ^= COMPLETE then
		call spawn_error (3);		/* 'duplicate snumb' */
	end;

	do i = 1 to entry_count while (status (i) ^= COMPLETE);
	end;
	if i > hbound (snumb_entry, 1) then
	     call spawn_error (5);			/* 'no program_number available' */

	call user_info_$homedir (home_path);		/* set base directory path for gtss segment creation */

/* * copy formatted temp file to gcos jcl file */
	if gtss_disk (fn).msf then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
	     "Can't handle multi_segment jcl files yet.");

	else call copy_single_segment;

/* * build gcos absin file */
/* * call command processor with absentee instructions */
	call make_gcos_request;

/** Set job id in snumb table */
	if i > entry_count then entry_count = i;
	snumb (i) = given_snumb;			/* initialize new snumb entry */
	jout_id (i) = output_id;
	activity (i) = 0;
	status (i) = INITIATED;
/** wrap-up derail processing */
	gtss_ust.lsnub, llsnb = bcd_snumb;
	mc.q = "0"b;				/* set status code OK */

exit_drl_spawn:
	return;

/* gtss_drl_spawn_ miscellaneous declarations */

dcl  gtss_get_user_state_     entry (ptr);

dcl  cu_$cp                   entry (ptr, fixed bin, 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  hcs_$terminate_noname    entry (ptr, fixed bin (35));
dcl  user_info_$homedir       entry (char (*));

spawn_error: proc (error_number);
dcl  error_number             parm;

	     mc.q = bit (error_number);
	     goto exit_drl_spawn;
	end spawn_error;

copy_single_segment: proc;

	     s = addrel (single_segment_ptr (fn), 320);	/* s -> temp jcl file */

	     call hcs_$make_seg (home_path, given_snumb || ".gtss.gcos", "",
		fixed ("01010"b), d, c);
	     if d = null () then
		call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
		"Error allocating .gtss.gcos, hcs_$make_path returned ^i.", c);

	     prior_blk, prior_recx = 0;
	     do blk = 1 by 1;			/* for each block in given file */
		if rcw_size (blk, blk_size (blk)) = 0 then /* may be end_of_file */
		     do recx = 1 repeat recx + rcw_size (blk, recx) + 1 while (recx <= blk_size (blk));
		     if rcw_size (blk, recx) = 0 then goto found_eof_rec; /* it is */
		     else do;			/* save location in case this is "***eof" */
			prior_blk = blk;
			prior_recx = recx;
		     end;
		end;
	     end;

found_eof_rec:
	     if prior_blk = 0 then			/* input file is null */
		call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
		"Null file passed to spawn.");

	     file_size = prior_blk;
	     d -> source_file = s -> source_file;

	     d -> blk_size (prior_blk) = blk_size (prior_blk) - rcw_size (prior_blk, prior_recx) - 1; /* replace last record ("***eof") with file mark */
	     d -> rcw_size (prior_blk, prior_recx) = 0;
	     d -> rcw_bits (prior_blk, prior_recx) = "170000"b3;

	     call hcs_$set_bc_seg (d, file_size * 320 * 36, c);
	     call hcs_$terminate_noname (d, c);

	     return;


dcl  file_size                fixed bin init ( ((262144-320)/320) );
dcl  s                        ptr;						/* pointer to input jcl */
dcl  d                        ptr;						/* pointer to result jcl */
dcl (recx, prior_recx) fixed bin;
dcl (blk, prior_blk) fixed bin;

dcl 1 source_file based (s),
   2 source_block (file_size),
      3 blk_serial fixed bin (18) unsigned unal,
      3 blk_size fixed bin (18) unsigned unal,
      3 block_rcw (319),
         4 rcw_size fixed bin (18) unsigned unal,
         4 rcw_bits bit (18) unal;

	end copy_single_segment;

make_gcos_request: proc;

	     if wait_flag then
		gcos_req_ptr = addr (gcos_direct_req);
	     else do;
		call hcs_$make_seg (home_path, given_snumb || ".gtss.absin", "",
		     fixed ("01010"b, 5), gcos_req_ptr, c);
		if gcos_req_ptr = null () then
		     call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
		     "Error allocating .gtss.absin");
	     end;

	     gcos_req = "gcos$spawn " || rtrim (home_path) || ">" || given_snumb || ".gtss.gcos -ident -userlib";
	     if jout_request then
		gcos_req = rtrim (gcos_req) || " -hd";

	     if wait_flag then do;
		gcos_req = rtrim (gcos_req) || " -bf";

/* save bar mode stack pointer before calling gcos */
		sb = baseptr (baseno (addr (bar_mode_stack_ptr)));
		bar_mode_stack_ptr = stack_header.bar_mode_sp;
	     end;
	     else do;
		gcos_req = rtrim (gcos_req) || substr (collate (), 11, 1); /* append newline to absin segment */
		call hcs_$set_bc_seg (gcos_req_ptr, length (rtrim (gcos_req)) * 9, c);
		call hcs_$terminate_noname (gcos_req_ptr, c);
		gcos_req_ptr = null;
		gcos_direct_req = "ear " || rtrim (home_path) || ">" || given_snumb || ".gtss.absin -bf" ||
		     substr (collate (), 11, 1);
	     end;

	     call cu_$cp (addr (gcos_direct_req), length (rtrim (gcos_direct_req)), c);

/* restore bar mode stack pointer if necessary */
	     if wait_flag then
		stack_header.bar_mode_sp = bar_mode_stack_ptr;

	     if c ^= 0 then
		call gtss_abort_subsystem_ (mcp, "gtss_drl_spawn_", 0,
		"Error returned by cu_$cp for command^/^-^a^/", gcos_direct_req);

	     return;


dcl  gcos_req_ptr             ptr;
dcl  gcos_req                 char (256) based (gcos_req_ptr);

dcl  gcos_direct_req          char (256);

	end make_gcos_request;

%include gtss_dfd_ext_;

%include gtss_entry_dcls;

%include gtss_ext_;

%include gtss_snumb_xref_;

%include gtss_ust_ext_;

%include mc;
%include stack_header;

dcl (addr, addrel, baseno, baseptr, bit, collate, fixed, hbound, length, null, rtrim, substr) builtin;

     end gtss_drl_spawn_;
   



		    gtss_drl_stoppt_.pl1            12/11/84  1349.3rew 12/10/84  1043.4        9018


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

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

/* *	Stop paper tape input.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* This is currently a dummy routine */
	return;

%include mc;
     end gtss_drl_stoppt_;
  



		    gtss_drl_switch_.pl1            12/11/84  1349.3rew 12/10/84  1043.4       44262


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

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

/* *	gtss exchange two temp files.

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Change:  Dave Ward	03/28/79 Added aborts, debug code.
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL SWITCH, SWITCH TEMPORARY FILE NAMES (octal 53)


   8_________1_6_____________________

   DRL      SWITCH
   ZERO     L(fileid1),L(fileid2)
   Error return location.
   Successful return location.

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17B, Rev. 0, July 1976
   Page 3-54)

*/
dcl  arg_ptr ptr init(null());

dcl 1 arglist aligned based (arg_ptr),
    2 file_id_1 fixed bin (18) unsigned unaligned,
    2 file_id_2 fixed bin (18) unsigned unaligned;

dcl  file_id_1_ptr ptr init(null());

dcl  file_id_1_name char (8) based (file_id_1_ptr);

dcl  file_id_2_ptr ptr init(null());

dcl  file_id_2_name char (8) based (file_id_2_ptr);

dcl  status fixed bin (24);
dcl  code fixed bin (35);

dcl  file_no_1 fixed bin (24);
dcl  file_no_2 fixed bin (24);

dcl  gseg ptr init(null());

dcl 1 T aligned like gtss_file_attributes;


/*		P R O C E D U R E 			*/


	scup = addr (mc.scu);			/* get the system conditions */

	increment = 1;				/* set up for possible error */

	mc.regs.a = "0"b;				/* set up for error possiblity */

	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_); /* save pointer to this segment */

/* Check for arguments out of bounds. */
	if (fixed (scu.ilc, 18)+2) >= fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (
	     mcp,
	     "gtss_drl_switch_",
	     4,
	     gtss_pnterr.err4,
	     fixed (scu.ilc, 18));

	arg_ptr = addrel (gseg, fixed (scu.ilc) + 1);	/* wrap pointer around the arguments */

/* Check for arguments out of bounds. */
	if (arglist.file_id_1+1) > fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (
	     mcp,
	     "gtss_drl_switch_",
	     4,
	     gtss_pnterr.err4,
	     fixed (scu.ilc, 18));

/* Check for arguments out of bounds. */
	if (arglist.file_id_2+1) > fixed (gtss_ust.lsize.limit, 18) then
	     call gtss_abort_subsystem_ (
	     mcp,
	     "gtss_drl_switch_",
	     4,
	     gtss_pnterr.err4,
	     fixed (scu.ilc, 18));

	file_id_1_ptr = addrel (gseg, arglist.file_id_1);
	file_id_2_ptr = addrel (gseg, arglist.file_id_2);

	call gtss_aft_$find (file_id_1_name, file_no_1, code);
	if code ^= 0 then
	     call gtss_abort_subsystem_ (
	     mcp
	     , 0
	     , "1st name ""^a"" not in aft."
	     , file_id_1_name
	     );

	call gtss_aft_$find (file_id_2_name, file_no_2, code);
	if code ^= 0 then
	     call gtss_abort_subsystem_ (
	     mcp
	     , 0
	     , "2nd name ""^a"" not in aft."
	     , file_id_2_name
	     );

	call gtss_ios_exchange_names_ (file_no_1, file_no_2, status, code);
	if status = 13 then mc.regs.a = (36)"1"b;	/* => Exchanging perm file. */
	else
	if status = 14 then do;			/* => file not open. */
	     call com_err_ (0, "gtss_drl_switch_",
		"File not open but in aft ""^a"" (^i) ""^a"" (^i).",
		file_id_1_name, file_no_1,
		file_id_2_name, file_no_2);
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_switch_",
		0,
		"DRL_SWITCH: IN AFT BUT NOT OPEN (BUG?) at (^60)",
		fixed (scu.ilc, 18));
	end;
	else
	if status = 15 then do;			/* Bad file number. */
	     call com_err_ (0, "gtss_drl_switch_",
		"Bad file nos for exchange ^i ^i.",
		file_no_1, file_no_2);
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_switch_",
		0,
		"DRL_SWITCH: BAD FILE NUMBERS? at (^6o)",
		fixed (scu.ilc, 18));
	end;
	else
	increment = 2;				/* go back to good return */

	if db_drl_switch then
	     call com_err_ (0, "gtss_drl_switch_"
	     , "file ""^a"" (aft ^i) switched with ""^a"" (^i)."
	     , file_id_1_name, file_no_1
	     , file_id_2_name, file_no_2
	     );

/* Exchange attributes blocks for files being switched */

	T = temp_file (file_no_1);
	temp_file (file_no_1) = temp_file (file_no_2);
	temp_file (file_no_2) = T;

	return;

%include gtss_ext_;

%include gtss_pnterr;

%include mc;

%include gtss_entry_dcls;

%include gtss_ust_ext_;

%include gtss_tfa_ext_;

%include gtss_db_names;
     end						/* gtss_drl_switch_ */;
  



		    gtss_drl_sysret_.pl1            12/11/84  1349.3rew 12/10/84  1043.5       12789


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

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

/*

   Authors: Robert J. Grimes	Created
   -	  Albert N. Kepner	  1978
   -	  Robert M. May
   -	  David B. Ward
   Changed: Dave Ward	03/27/79 abandon.
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;

/* *

   DRL SYSRET, RETURN TO SYSTEM (octal 40)


   8_________1_6_____________________

   DRL      SYSRET

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1977
   Page 3-27)

*/

	call gtss_abandon_CFP_;

/* The following call does not return. The sysret entry point causes
   the process stack to be unwound to the first invocation of
   the primitive interpreter. */
	call gtss_interp_prim_$sysret ();


%include gtss_entry_dcls;
     end gtss_drl_sysret_;
   



		    gtss_drl_t_cfio_.pl1            12/11/84  1349.3rew 12/10/84  1043.5      106218


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

gtss_drl_t_cfio_: proc (mcpp, increment);

/**          CRUN and DRUN support functions. (7 distinct functions)

   Author:  Dave Ward          03/20/79.
   Changed: Al Dupuis          12/04/79. Rewritten to use cout term codes.
   Changed: Ron Barstad        83-03-31  Added function 8
**/

dcl mcpp ptr parm;
dcl increment fixed bin parm;

	mcp = mcpp;
	increment = 1;
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	drl_args_ptr = addrel (gseg, fixed (scu.ilc, 18) + 1);
	if ((drl_args.function_no < 1)
	| (drl_args.function_no > 8))
	then do;
	     err_mess = "INVALID USE OF DRL T.CFIO";
	     gtss_ust.lcfst.start_term = 5;
	     call common_error;
	     return;
	end;
	if db_drl_t_cfio
	then call ioa_ (
	     "gtss_drl_t_cfio_: function ^i.", drl_args.function_no);
	call function (drl_args.function_no);
	return;

function_1: proc;


	     call verify_arglist (3);
	     if code ^= 0 then return;
	     call gtss_aft_$find ("*CFP", fn, code);
	     if code ^= 0
	     then do;
		err_mess = "COMMAND FILE NONEXISTENT";
		gtss_ust.lcfst.start_term = 1;
		call common_error;
		return;
	     end;
	     gtss_starCF_$FILE.cf.aft_indx = fn;
	     gtss_starCF_$FILE.ID1.fcb_loc,
		gtss_starCF_$FILE.ID2.fcb_loc
		= rel (addr (gtss_starCF_$FILE.cf));
	     CFP_in_progress = "1"b;
	     n_words = 3;
	     addr (gtss_ust.lcfio) -> words
		= addrel (gseg, drl_args.L_arglist) -> words;
	     if gtss_ext_$get_line ^= iox_$get_line
	     then do;
		if ^cout_called | ^cpos_called
		then gtss_starCF_$FILE.cf.first_time = "1"b;
		else;
	     end;
	     else do;
		gtss_ext_$get_line = gtss_CFP_input_;
		gtss_ext_$put_chars = gtss_CFP_output_;
		if gtss_ust.lcmpt ^= "0"b   /** Set any execution timer **/
		then do;
		     time = fixed (gtss_ust.lcmpt, 36)
			- (gtss_ust.lsprt + gtss_ust.lspts);
		     time = divide (divide (time, 64, 36), 1000, 36);
		     call timer_manager_$cpu_call (
			time, "11"b, gtss_abs_$cpu_runout);
		end;
		else;
		if gtss_ust.lcjid ^= "0"b
		then do;
		     /** If drun is executing under absentee, skip the line
                             intended for Gcos login and generate banner **/
		     gtss_ust.lcfio.sect_in = gtss_ust.lcfio.sect_in + 1;
		     gcos_banner = gtss_abs_login_banner_ ();
		     gtss_starCF_$FILE.RECORD.chars = gcos_banner;
		     call gtss_write_starCFP_ (
			null (), addr (gtss_starCF_$FILE.RECORD.chars),
			length (gcos_banner), code);
		     if code ^= 0 then return;
		     else;
		end;
		else;
	     end;
	     return;
	end;

function_2: proc;


	     cout_called = "0"b;
	     call gtss_abandon_CFP_;
	     gtss_ust.lswth.b7 = "0"b;
	     if gtss_ust.lcjid = "0"b then return;
		/** drun is executing, terminate it and read bye from absin **/
	     call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_t_cfio_",
		0);
	     return;
	     
	end;

function_3: proc;

	     call verify_arglist (9);
	     if code ^= 0 then return;
	     if drl_args.L_arglist > 0
	     then do;
		if gtss_ext_$com_reg.tsdmx.dit = 0
		then call init_dq;
		call gtss_aft_$find ("#D", fn, code);
		if code ^= 0
		then do;
		     call gtss_dq_$open_gen (error);
		     if error
		     then do;
			err_mess = "Couldn't find #D";
			gtss_ust.lcfst.start_term = 5;
			call common_error;
			return;
		     end;
		     call gtss_aft_$find ("#D", fn, code);
		end;
		n_words = 1;
		if gtss_disk.attributes_ptr (fn) ^= null ()
		then gtss_ext_$com_reg.tcdfr =
		     addr (gtss_disk.attributes_ptr (fn) -> gtss_file_attributes.descriptor) -> words;
		else do;
		     err_mess = "Attributes pointer was null.";
		     gtss_ust.lcfst.start_term = 2;
		     call common_error;
		     return;
		end;
		addrel (gseg, drl_args.L_arglist) -> nine_words (*) =
		     addr (gtss_ext_$com_reg) -> nine_words (*);
		addrel (gseg, drl_args.L_arglist) -> nine_words (9) =
		     gtss_ext_$com_reg.tcdfr;
	     end;
	     call decode_clock_value_ (
		clock_ (),
		month,
		day_of_month,
		year,
		time_of_day,
		day_of_week,
		time_zone);
	     ascii_date.yr = mod (year, 100);
	     ascii_date.mo = month;
	     ascii_date.dy = day_of_month;
	          /** Place bcd date in A register (yymmdd) **/
	     call gtss_ascii_bcd_ (addr (ascii_date), 6, addr (mc.regs.a));
		/** Place time of day in 64ths of mil in Q register **/
	     milsec = divide (time_of_day, 1000, 71);
	     milsec64ths = milsec * 64;
	     mc.regs.q = unspec (milsec64ths);
	     return;
	end;

function_4: proc;

	     call verify_arglist (5);
	     if code ^= 0 then return;
	     n_words = 5;
	     addr (gtss_ext_$com_reg.tsdid) -> words =
		addrel (gseg, drl_args.L_arglist) -> words;
	     return;
	end;

function_5: proc;

	     if gtss_ext_$com_reg.tsdmx.dit = 0
	     then call init_dq;
	     if gtss_ext_$com_reg.tsdgt.ust_loc ^= 1
	     then do;
		call gtss_dq_$open_exc (error);
		if error
		then do;
		     err_mess = "Couldn't open #D.";
		     gtss_ust.lcfst.start_term = 5;
		     call common_error;
		     return;
		end;
		gtss_ext_$com_reg.tsdgt.ust_loc = 1;
	     end;
	     return;
	end;

function_6: proc;

	     if gtss_ext_$com_reg.tsdgt.ust_loc ^= 0
	     then do;
		call gtss_dq_$open_gen (error);
		if error
		then do;
		     err_mess = "Couldn't open #D.";
		     gtss_ust.lcfst.start_term = 5;
		     call common_error;
		     return;
		end;
		gtss_ext_$com_reg.tsdgt.ust_loc = 0;
	     end;
		/** Perform the equivalent absentee function **/
	     call gtss_abs_$abs_equiv;
	     return;
	end;

function_7: proc;

	     call verify_arglist (1);
	     if code ^= 0 then return;
	     call gtss_bcd_ascii_ (addrel (gseg, drl_args.L_arglist),
		5, addr (ascii_lcjid));
	     call hcs_$initiate_count (gtss_ext_$homedir, "drun_restart."
		|| ascii_lcjid, "", bit_count, 1, rp, code);
	     if (rp ^= null ()) & (bit_count > 0)
	     then do;
		my_message = 1;
		process_id = rp -> event_info.sender;
		call hcs_$wakeup (process_id, rp -> event_info.channel_id,
		     my_message, code);
		if code ^= 0
		then do;
		     if code ^= error_table_$invalid_channel
		     then call convert_ipc_code_ (code);
		     call com_err_ (code, "gtss_drl_t_cfio_",
			"Sending DABT signal to ^a.", ascii_lcjid);
		     err_mess = "INVALID USE OF DRL T.CFIO";
		     gtss_ust.lcfst.start_term = 5;
		     call common_error;
		     return;
		end;
	     end;
	     if code ^= 0
	     then call com_err_ (code, "gtss_drl_t_cfio_",
		"drun_restart.^a is zero length segment.", ascii_lcjid);
	     if rp ^= null ()
	     then call hcs_$terminate_noname (rp, code);
	     return;
	end;
%page;
function_8: proc;
/** A dummy function intended for ETS (extended Time Sharing) 
    this routines simply returns the expected status
    The subfunction is the upper half of the word pointed to by L_arglist
    and the return status is the lower half.
    For subfunction 1 and 2 set the first bit of status on (bit 18 of word)
    and for subfunction 3 set status to zero. 
**/
	  arg_list_ptr = addrel(gseg, drl_args.L_arglist);
	  if (sub_function = 1) | (sub_function = 2)
	       then return_status = "100000000000000000"b;
	  else if sub_function = 3
	       then return_status = "0"b;
	  /* if not sub_function 1,2 or 3 do nothing */
	  return;
	  
dcl arg_list_ptr ptr;
dcl 1 function_8_arg_list aligned based(arg_list_ptr),
	  2 sub_function fixed bin(17) unaligned,
	  2 return_status bit(18) unaligned;
       end;
%page;
verify_arglist: proc (no_of_words);

	     code = 0;
	     if (drl_args.L_arglist + no_of_words)
	     > fixed (gtss_ust.lsize.limit, 18)
	     then do;
		code = 1;
		call com_err_$suppress_name (0, "gtss_drl_t_cfio_",
		     "drl_t_cfio arglist outside of memory at (^60)",
		     fixed (scu.ilc, 18));
		err_mess = "INVALID USE OF DRL T.CFIO";
		gtss_ust.lcfst.start_term = 5;
		call common_error;
		return;
	     end;
dcl no_of_words fixed bin (24) parm;
	end;


common_error: proc;


	     if err_mess ^= ""
	     then call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_t_cfio_",
		0,
		err_mess);
	     else call gtss_abort_subsystem_ (
		mcp,
		"gtss_drl_t_cfio_",
		0);
	     return;
	end;

init_dq:	proc;

	     gtss_ext_$com_reg.tsdmx.dit = 180;
	     gtss_ext_$com_reg.tsdjb = -1;
	     call hcs_$status_minf (gtss_ext_$homedir, "drun_#d_q",
		1, type, bit_count, code);
	     if code = error_table_$noentry
	     then do;
		call gtss_dq_$create (error);
		if error
		then do;
		     err_mess = "Couldn't create #D file.";
		     gtss_ust.lcfst.start_term = 5;
		     call common_error;
		     return;
		end;
	     end;
	     call gtss_dq_$open_gen (error);
	     if ^error then return;
	     err_mess = "Couldn't open #D file.";
	     gtss_ust.lcfst.start_term = 5;
	     call common_error;
	     return;
	end;

/** Variables for gtss_drl_t_cfio_ **/

dcl ascii_lcjid char (5);
dcl bit_count fixed bin (24);
dcl clock_ entry returns (fixed bin (71));
dcl code fixed bin (35) init (0);
dcl com_err_$suppress_name entry options (variable);
dcl convert_ipc_code_ entry (fixed bin (35));
dcl day_of_month fixed bin;
dcl day_of_week fixed bin;
dcl decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3) aligned);
dcl drl_args_ptr ptr;
dcl err_mess char (250) init ("");
dcl error bit (1) init ("0"b);
dcl error_table_$invalid_channel fixed bin (35) ext static;
dcl error_table_$noentry fixed bin (35) ext static;
dcl fn fixed bin (24);
dcl function (1:8) entry init (
	function_1,
	function_2,
	function_3,
	function_4,
	function_5,
	function_6,
	function_7,
	function_8);
dcl gcos_banner char (256) varying;
dcl gseg ptr;
dcl gtss_fail condition ext;
dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl ioa_ entry options (variable);
dcl iox_$get_line entry;
dcl iox_$put_chars entry;
dcl milsec fixed bin (71);
dcl milsec64ths fixed bin (35);
dcl month fixed bin;
dcl my_message fixed bin (71);
dcl n_words fixed bin (24);
dcl nine_words (9) bit (36) based;
dcl process_id bit (36) aligned;
dcl rp ptr init (null());
dcl status fixed bin (24);
dcl time fixed bin (71);
dcl time_of_day fixed bin (71);
dcl timer_manager_$cpu_call entry (fixed bin (71), bit (2), entry);
dcl time_zone char (3) aligned;
dcl type fixed bin (2);
dcl words bit (36 * n_words) based;
dcl year fixed bin;

dcl 1 ascii_date aligned,
      2 yr pic "99" unaligned,
      2 mo pic "99" unaligned,
      2 dy pic "99" unaligned;

dcl 1 drl_args aligned based (drl_args_ptr),
      2 L_arglist fixed bin (18) unsigned unaligned,
      2 function_no fixed bin (18) unsigned unaligned;

dcl 1 event_info based (rp),
      2 channel_id fixed bin (71),
      2 message fixed bin (71),
      2 sender bit (36),
      2 origin,
        3 dev_signal bit (18) unaligned,
        3 ring bit (18) unaligned,
      2 channel_index fixed bin;

%include gtss_CFP_bits;

%include gtss_starCF_;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_entry_dcls;

%include gtss_db_names;

%include gtss_deferred_queue;

%include gtss_dfd_ext_;

%include gtss_device_cmds;

%include gtss_file_attributes;
     end;

  



		    gtss_drl_t_cmov_.pl1            12/11/84  1349.3rew 12/10/84  1043.5       25875


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

/**	gtss read and write memory.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
  Modified: Ron Barstad 83-06-29 Return permission denied status with return
                                 rather than drl incomplete message and abort	
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL T.CMOV, READ AND WRITE MEMORY (octal 73)


   8________16_____________________

   DRL      T.CMOV
   ZERO     from,P#
   ZERO     to,n

    (See TSS Reference Manual
         DJ31-A, Sept. 1980, page 6-79)

*/
%page;
	increment = 2 ;				/* Two arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/**	Provide (only) printer page length function.
**/
	if Pno = 0 then				/* Addressing is absolute */
	     if from = "001120"b3 then		/* => Printer page length value. */
		if n = 0 then do;			/* => Return in A/Q register. */
		     A_upper = 55;			/* GCOS default. */
		     A_lower = "0"b;
		     Q_reg = 0;			/* => Successful. */
		     return;
		end;

	if gtss_ust.lcjid ^= "0"b then do;
	     gtss_ust.lswth.b7 = "0"b;
	     goto gtss_ext_$drl_rtrn (gtss_ext_$stack_level_);
	end;

/* No simulator subsystem can have permission to read or write memory
    and since there is no GCOS or TSS memory to read or write we won't 
*/
	A_upper = 0;
	A_lower = "0"b;
	Q_reg = 5; /* status for permission denied */
/* used to do:
	call gtss_abort_subsystem_ (
	     mcp
	     , "gtss_drl_t_cmov_"
	     , 0
	     , "DRL T.CMOV (at ^6o) not complete: from=^6o P#=^i to=^6o n=^i"
	     , fixed (scu.ilc, 18)
	     , fixed (from, 18)
	     , Pno
	     , fixed (to, 18)
	     , n
	     );
*/
	return;
%page;
/**	Variables for gtss_drl_t_cmov_:
     IDENTIFIER		ATTRIBUTES	**/
dcl 1 a_register		aligned based(addr(mc.a)),
      2 A_upper		fixed bin(17)unal,
      2 A_lower		bit(18)unal;
dcl Q_reg fixed bin(35)based(addr(mc.q));
dcl  (addr,
      addrel,
      fixed,
      null)                   builtin;
dcl  arg_list_ptr             ptr init(null());
dcl  gseg                     ptr init(null());

dcl 1 arg_list		aligned based(arg_list_ptr)
,     2 from		bit(18)unal
,     2 Pno		fixed bin(17)unal
,     2 to		bit(18)unal
,     2 n			fixed bin(17)unal
;
%page;
%include gtss_ext_;
%page;
%include mc;
%page;
%include gtss_ust_ext_;
%page;
%include gtss_entry_dcls;
     end gtss_drl_t_cmov_;
 



		    gtss_drl_t_err_.pl1             12/11/84  1349.3rew 12/10/84  1043.5       23751


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

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

/**	gtss error detected by a subsystem.

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

   Changed:	Al Dupuis	10/09/79. Added tests for lflg2.b8,
				lflg2.b4 and lswt2.b5.
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL T.ERR, ERROR DETECTED (octal 103)


   8_________1_6_____________________

   DRL      T.ERR

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1976
   Page 3-33.1)

*/

	increment = 0 ;				/* Zero arguments */
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	gtss_spa.lwrap.b23 = "1"b;
	if gtss_ust.lflg2.b8 then gtss_ust.lcfst.start_term = 14;
	initial_lxxx = fixed (rel (addr (gtss_ust.lxxx)))-fixed (rel (addr (gtss_ust)));
	ssname = gtss_prgdes_ext_$prgdes.ss_name
	     (gtss_ust.lprgs.b0_17 (gtss_ust.lxxx.b0_17 - initial_lxxx));
	ssname = translate (ssname, "ABCDEFGHIJKLMNOPQRSTUVWXYZ",
	     "abcdefghijklmnopqrstuvwxyz");
	if gtss_ust.lswt2.b6 then do;
	     gtss_ext_$flags.gtss_com_err_sw = "1"b;
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_t_err_", 0,
		"<67> ERROR DETECTED IN ^a PROCESSING", ssname);
	     return;
	end;
	if ^((gtss_ust.lflg2.b8) & (^gtss_ust.lflg2.b4))	/* If CFP on  and TALK off go on, else return */
	then return;
	if gtss_ust.lswt2.b5 then return;		/* trap mode disabled */
	gtss_ext_$flags.gtss_com_err_sw = "1"b;
	call gtss_abort_subsystem_ (mcp, "gtss_drl_t_err_", 0,
	     "<67> ERROR DETECTED IN ^a PROCESSING", ssname);
	return;

/* *	Variables for gtss_drl_t_err_:
   IDENTIFIER		ATTRIBUTES	* */
dcl  code fixed bin (35);
dcl  gseg ptr init (null ());
dcl  initial_lxxx fixed bin (17);
dcl  ssname char (4) init ("????");
dcl  status fixed bin (24);

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;

%include gtss_spa;

%include gtss_entry_dcls;

%include gtss_prgdes_;
     end						/* gtss_drl_t_err_ */;
 



		    gtss_drl_t_goto_.pl1            12/11/84  1349.3rew 12/10/84  1043.5       19827


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

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

/*	Call from one subsystem to another.

   Authors:	Robert J. Grimes	Created
   Albert N. Kepner	  1978
   Robert M. May
   David B. Ward
   * */
dcl  mcpp ptr parm;
dcl  increment fixed bin parm;
	mcp = mcpp;

/* *

   DRL T.GOTO, CALL FROM ONE SUBSYSTEM TO ANOTHER (octal 72)


   8_________1_6_____________________

   DRL      T.GOTO
   ASCII    1,name

   (See TSS SYSTEM PROGRAMMER'S
   REFERENCE MANUAL DD17C, Rev. 0, July 1977
   Page 3-32.1)

*/

	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc)+1);	/* get addres of arg_list */

/* If drun is executing in batch, don't let him schedule the new (logon) subsystem */
	if gtss_ust.lcjid ^= "0"b then
	     if ss_name = "new" | ss_name = "NEW" then do;
		gtss_ust.lswth.b7 = "0"b;		/* reset "pass break" indicatotr */
		goto gtss_ext_$drl_rtrn (gtss_ext_$stack_level_);
	     end;
	call gtss_interp_prim_$t_goto (ss_name);

/* The above call does not return. The t_goto entry point causes
   the process stack to be unwound to the previous invocation of
   the primitive interpreter. */

/* *      Variables for gtss_drl_t_goto_:
   IDENTIFIER                 ATTRIBUTES          * */
dcl  arg_list_ptr ptr init(null());
dcl  gseg ptr init(null());

dcl 1 arg_list aligned based (arg_list_ptr),
    2 ss_name char (4) unal;

%include gtss_ext_;

%include mc;


%include gtss_entry_dcls;

%include gtss_ust_ext_;
     end gtss_drl_t_goto_;
 



		    gtss_drl_t_linl_.pl1            12/11/84  1349.3rew 12/10/84  1043.6       18468


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

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

/**	gtss obtain or reset terminal input line length.

   Author: Dave Ward	07/03/79
 **/
dcl  mcpp			ptr parm;
dcl  increment		fixed bin parm;
	mcp = mcpp;

/**

   DRL T.LINL, CHANGE TERMINAL INPUT LINE LENGTH (octal 74)


   8_________1_6_____________________

   DRL      T.LINL

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-33)

*/

	increment = 0 ;				/* Zero arguments */
	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

	if mc.regs.q = "0"b then do;			/* Caller wants current line length. */
	     QL = gtss_ust.lrtll.char_length;
	     AL = 4;				/* Success. */
	     return;
	end;

	if (QL<81) | (QL>161) then do;		/* Line length out of range. */
	     AL = 0;				/* ^=4 => failure. */
	     return;
	end;

	gtss_ust.lrtll.char_length = QL;		/* Set new line length. */
	AL = 4;					/* Success. */
	return;

/**	Variables for gtss_drl_t_linl_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  gseg			ptr init(null());

dcl  1 A_reg		aligned based(addr(mc.regs.a)),
       2 AU		fixed bin(17)unal,
       2 AL		fixed bin(17)unal;

dcl  1 Q_reg		aligned based(addr(mc.regs.q)),
       2 QU		fixed bin(17)unal,
       2 QL		fixed bin(17)unal;

%include gtss_ext_;

%include mc;

%include gtss_ust_ext_;
     end						/* gtss_drl_t_linl_ */;



		    gtss_drl_t_rscc_.pl1            12/11/84  1349.3rew 12/10/84  1043.6       11052


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

gtss_drl_t_rscc_: proc (mcpp, increment);

/**	gtss read system controller clock.

	Author:	Mel Wilson			05/01/79
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL T_RSCC, READ SYSTEM CONTROLLER CLOCK (octal 101)


   8_________1_6_____________________

   DRL      T_RSCC

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-33.1)

*/

	increment = 0;				/* no drl arguments */
	scu_clock = clock_ ();
	return;


dcl  scu_clock fixed bin (71) based (addr(mc.a));

dcl  clock_ entry returns (fixed bin (71));


%include gtss_ext_;

%include mc;

%include gtss_io_status_words;

%include gtss_ust_ext_;

%include gtss_entry_dcls;
     end gtss_drl_t_rscc_;



		    gtss_drl_tapein_.pl1            12/11/84  1349.3rew 12/10/84  1043.6       81567


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

gtss_drl_tapein_: proc (mcpp, increment);

/**	gtss accept paper tape input.
	Author:   Bob Alvarado		05/15/79
	Changed:	Scott C. Akers		08/17/81
					Reset tty_modes on QUIT.
**/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL tapein, START PAPER TAPE INPUT (octal 27)


   8_________1_6_____________________

   DRL      tapein
   ZERO     L(tally),L(char)

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-27)

*/

	increment = 1 ;				/* One arguments */
/* output any message. */

	call gtss_drl_kotnow_ (
	     mcp, (1));

	call gtss_aft_$find ("TAP*", fn, code);
	if code ^= 0 then do;
	     call gtss_abort_subsystem_ (
		mcp
		, "gtss_drl_tapein_"
		, 0
		, "TAP* not available."
		);
	end;

/** Initialize data base used for file IO by
    gtss_drl_tapein_ **/
	unspec (gtss_tapstar_$FILE) = "0"b;
	gtss_tapstar_$FILE.OP1.Device_Command = seek_cmd;
	gtss_tapstar_$FILE.OP1.Count = 2;
/* 2=> two operations  */
	gtss_tapstar_$FILE.OP2.Device_Command = write_cmd;
	gtss_tapstar_$FILE.ID1.DCW_list_loc = rel (addr (gtss_tapstar_$FILE.Seek_Word));
	gtss_tapstar_$FILE.ID2.DCW_list_loc = rel (addr (gtss_tapstar_$FILE.DCW));
	gtss_tapstar_$FILE.Seek_loc = rel (addr (gtss_tapstar_$FILE.Seek_Address));
	gtss_tapstar_$FILE.Status_loc = rel (addr (gtss_tapstar_$FILE.STATUS));
	gtss_tapstar_$FILE.Seek_count = 1;
	gtss_tapstar_$FILE.ID1.fcb_loc = rel (addr (gtss_tapstar_$FILE.aft_tap_name));
	gtss_tapstar_$FILE.ID2.fcb_loc = rel (addr (gtss_tapstar_$FILE.aft_tap_name));
	gtss_tapstar_$FILE.aft_tap_name = "tap*";
	gtss_tapstar_$FILE.DCW.memory_loc = rel (addr (gtss_tapstar_$FILE.file));
	gtss_tapstar_$FILE.DCW.word_count = 64;
	local_seek_addr = 0;
	no_words = 0;
	rel_block_ct = 0;
	process_state = 0;
	call iox_$attach_name (
	     "gtss_ppt_input"
	     , gtss_ext_$ppt
	     , "syn_ user_input"
	     , null ()
	     , code
	     );
	if code ^= 0 then
	     if code ^= error_table_$not_detached then do;
		call com_err_ (
		     code
		     , "gtss_drl_tapein_"
		     , "unable to attach gtss_ppt_input file"
		     );
		signal cond (gtss_fail);
		return;
	     end;
	process_state = 1;
	frame_end = "";
/* set frame begin and end characters */
	call iox_$control (
	     gtss_ext_$ppt
	     , "set_framing_chars"
	     , addr (framing_chars)
	     , code
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gtss_drl_tapein_"
		, "unable to set framing  chars via $control"
		);
	     signal cond (gtss_fail);
	     return;
	end;
	process_state = 2;
	call iox_$modes (
	     gtss_ext_$ppt
	     , "^crecho,^lfecho,^tabecho,^fulldpx,^echoplex,rawi,ctl_char,blk_xfer"
	     , tty_modes
	     , code
	     );
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gtss_drl_tapein_"
		, "unable to set frame chars via $modes"
		);
	     signal cond (gtss_fail);
	     return;
	end;
	tp = addr (records (1));
	process_state = 3;
	on quit begin;
	     call gtss_fix_tty_modes_;
	     in_quit_state = "1"b;
	     goto quit_get_chars;
	end;
get_chars:
	call iox_$get_chars (
	     gtss_ext_$ppt
	     , addr (tape_rec)
	     , hbound (tape_rec, 1)
	     , bytes_read
	     , code
	     );
	if tape_rec (bytes_read) = XOFF then do;
	     words_read = divide (bytes_read + 3, 4, 24) + 1;
	     if (no_words + words_read)
	     > hbound (gtss_tapstar_$FILE.file.records, 1) then
		call write_tape;
	     no_words = no_words + words_read;
	     unspec (rcw) = "0"b;
	     rcw.y = "1"b;
	     rcw.m = bytes_read;
	     string (input_rec.rec) = string (tape_rec);
	     call write_tape;
	     goto quit_get_chars;
	end;
	if code ^= 0 then do;
	     call com_err_ (
		code
		, "gtss_drl_tapein_"
		, "unable to get ppt input"
		);
	     signal cond (gtss_fail);
	     return;
	end;
	words_read = divide (bytes_read+3, 4, 24) + 1;
	if (no_words + words_read)
	> hbound (gtss_tapstar_$FILE.file.records, 1) then
	     call write_tape;
	no_words = no_words + words_read;
	unspec (rcw) = "0"b;
	rcw.m = bytes_read;
	string (input_rec.rec) = string (tape_rec);
	tp = addrel (tp, size (tp_rec));
	goto get_chars;
quit_get_chars:
	if process_state = 3 then do;
	     call iox_$modes (
		gtss_ext_$ppt
		, tty_modes
		, tty_modes_old
		, code
		);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gtss_drl_tapein_"
		     , "unable to reset frame chars via $modes"
		     );
		signal cond (gtss_fail);
		return;
	     end;
	end;
	if process_state > 1 then do;
	     frame_end = " ";
	     call iox_$control (
		gtss_ext_$ppt
		, "set_framing_chars"
		, addr (framing_chars)
		, code
		);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gtss_drl_tapein_"
		     , "unable to reset framing chars via $modes"
		     );
		signal cond (gtss_fail);
		return;
	     end;
	end;
	if process_state > 0 then do;
	     call iox_$detach_iocb (
		gtss_ext_$ppt
		, code
		);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gtss_drl_tapein_"
		     , "unable to detach gtss_ppt_input"
		     );
		signal cond (gtss_fail);
		return;
	     end;
	end;
	if in_quit_state then do;
	     call gtss_ios_close_ (
		fn
		, addr (fms_status)
		, code
		);
dcl 1 fms_status aligned,
      2 bit12 bit(12)unal,
      2 bit60 bit(60)unal;
	     if fms_status.bit12 ^= "4000"b3 then do;
		call com_err_ (
		     "gtss_drl_tapein_"
		     , "unable to close TAP* on quit condition (status ^w)"
		     , fms_status
		     );
		signal cond (gtss_fail);
		return;
	     end;
	     call gtss_aft_$delete (
		"TAP*"
		, fn
		, code
		);
	     if code ^= 0 then do;
		call gtss_abort_subsystem_ (
		     mcp
		     , "gtss_drl_tapein_"
		     , 0
		     , "unable to delete TAP*"
		     );
	     end;
	     revert quit;
	     signal quit;
	end;
	gtss_ust_ext_$ust.gtss_ust.lflg2.b27 = "1"b;
	gtss_ust_ext_$ust.gtss_ust.lflg2.b28 = "1"b;
	return;

write_tape: proc;
	     gtss_tapstar_$FILE.Seek_Address = local_seek_addr;
	     call gtss_ios_io_ (
		fn
		, addr (select_sequence)
		, addr (select_sequence)
		, fixed (rel (addr (gtss_tapstar_$FILE.records (hbound (records, 1)))))
		, status
		, code
		);
	     if status ^= 0 then do;
		call com_err_ (
		     "gtss_drl_tapein_"
		     , "unable to write TAP* file (status ^i)"
		     , status
		     );
		signal cond (gtss_fail);
		return;
	     end;
	     local_seek_addr = local_seek_addr + 1;
	     no_words = 0;
	     rel_block_ct = rel_block_ct + 1;
	     tp = addr (records (1));
	     return;
	end;

/**	Variables for gtss_drl_tapein_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  addrel                   builtin;
dcl  size                     builtin;
dcl  arg_list_ptr             ptr;
dcl  code                     fixed bin(35);
dcl  fn                       fixed bin(24);
dcl  gtss_fail                condition ext;
dcl  gtss_fix_tty_modes_	ext entry;
dcl  quit			condition ext;
dcl  gseg                     ptr;
dcl  status                   fixed bin(24);
dcl  bytes_read               fixed bin(21);
dcl  process_state		fixed bin(18) unsigned;
dcl  in_quit_state		bit(1) init("0"b);
dcl  words_read		fixed bin (24);
dcl  local_seek_addr	fixed bin (35);
dcl  i                        fixed bin(18);
dcl  tape_rec (120) bit(9) unal;
dcl  tp ptr;
dcl  1 tp_rec based (tp) aligned
,      2 rcw
,        3 m fixed bin (18) unsigned unal
,        3 fil1    bit (15) unal
,        3 x bit (1) unal
,        3 y bit (1) unal
,        3 fil2 bit (1) unal
,      2 input_rec
,         3 rec (tp_rec.m) bit (9) unal;
dcl 1 framing_chars aligned
	,2 frame_begin char(1) unal
        , 2 frame_end char(1) unal;
dcl iox_$user_input ext ptr;
dcl error_table_$not_detached ext fixed bin(35);
dcl tty_modes char(256);
dcl tty_modes_old char(256);
dcl iox_$get_chars entry (
        ptr
       ,ptr
       ,fixed bin (21)
       ,fixed bin (21)
       ,fixed bin (35));
dcl iox_$attach_name entry (
        char (*)
       ,ptr
       ,char (*)
       ,ptr
       ,fixed bin (35)
       );
dcl iox_$control entry (
       ptr
       ,char (*)
       ,ptr
       ,fixed bin (35)
       );
dcl iox_$modes entry (
		ptr
		,char(*)
		,char(*)
		,fixed bin(35)
		);
dcl iox_$detach_iocb entry (
        ptr
        ,fixed bin (35)
        );

dcl 1 arg_list		aligned based(arg_list_ptr)
,     2 L_tally		bit(18)unal
,     2 L_char		bit(18)unal
;
dcl  XOFF bit (9) static int options (constant) init ("023"b3);

%include gtss_tapstar_;

%include gtss_device_cmds;

%include gtss_ext_;

%include mc;

%include gtss_io_status_words;

%include gtss_ust_ext_;

%include gtss_entry_dcls;
     end						/* gtss_drl_tapein_ */;
 



		    gtss_drl_task_.pl1              11/05/86  1603.9r w 11/04/86  1034.2       76149


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

gtss_drl_task_: proc (mcpp, increment);

/**	gtss spawn a special batch activity.

	Author:	Mel Wilson			06/01/79
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL TASK, SPAWN A SPECIAL BATCH ACTIVITY (octal 63)


   8_________1_6_____________________

   DRL      TASK
   ZERO     L_SSA_buf,L_filelist	offsets of ssa buffer and file list

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-27.1)

*/

	scup = addr (mc.scu);
	increment = 1;
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);
	arg_list_ptr = addrel (gseg, fixed (scu.ilc, 18) + 1);

	if fixed (scu.ilc, 18) > fixed (gtss_ust.lsize.limit) -3 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "Calling sequence outside memory at ^o.", fixed (scu.ilc, 18));

	if L_SSA_buf > fixed (gtss_ust.lsize.limit) - 965 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "SSA buffer outside memory (at ^o).", L_SSA_buf);
	SSA_buf_ptr = addrel (gseg, L_SSA_buf);

	if L_filelist >= fixed (gtss_ust.lsize.limit) then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "File list outside memory (at ^o).", L_filelist);
	filelist_ptr = addrel (gseg, L_filelist);

	if L_filelist >= fixed (gtss_ust.lsize.limit) - filelist_entries * 3 - 1 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "File list extends outside memory (^o+^o).", L_filelist, filelist_entries * 3);


	call gtss_bcd_ascii_$lc (addr (snumb), 5, addr (asc_snumb));
	call gtss_bcd_ascii_$lc (addr (actname), 6, addr (asc_actname));
	call gtss_bcd_ascii_$lc (addr (ident_text), 60, addr (asc_ident));
	call gtss_bcd_ascii_$lc (addr (comment_text), 60, addr (asc_comment));

	call ioa_ ("SSA_buf_ptr -> ^p^/File list ptr -> ^p", SSA_buf_ptr, filelist_ptr);
	call ioa_ ("Urgency ^i (^o)^/Snumb ^a^/Activity name ^a", urgc, urgc, asc_snumb, asc_actname);
	call ioa_ ("IO time limit ^f^/Job time limit ^f^/Job io time limit ^f",
	     float (io_limit)/ (64000*3600), float (job_time)/ (64000*3600), float (job_io_time)/ (64000*3600));
	call ioa_ ("PSW ^w^/Geload limit ^w", switch, geload_lim);
	call ioa_ ("$ ident   ^a^/$ comment ^a", asc_ident, asc_comment);
	call ioa_ ("^/file list .. ^i entries", filelist_entries);
	do i = 1 to filelist_entries;
	     call gtss_bcd_ascii_ (addr (filecode (i)), 2, addr (asc_filecode));
	     call ioa_ ("^a ^a", filename (i), asc_filecode);
	end;

	call hcs_$make_seg (get_pdir_ (), "gtss_task", "", fixed ("01010"b), tx_ptr, code);
	if tx_ptr = null () then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "Can't create temporary jcl segment.");
	call hcs_$truncate_seg (tx_ptr, 0, code);
	if code ^= 0 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "Can't truncate jcl segment ^a>^a .", rtrim (get_pdir_ ()), "gtss_task");

	call append_jcl (dollar || snumbc || asc_snumb || newline
	     || dollar || identc || asc_ident || newline
	     || dollar || programc || asc_actname || newline);

	if SSA_buf.switch ^= (36) "0"b then do;
	     set_sws = "";
	     do swx = 0 to 35;
		if substr (switch, swx+1, 1) then
		     set_sws = set_sws || "," || char (swx);
	     end;
	     call append_jcl (dollar || setc || substr (set_sws, 2) || newline);
	end;

	do i = 1 to filelist_entries;
	     call gtss_bcd_ascii_$lc (addr (filecode (i)), 2, addr (asc_filecode));
	     if asc_filecode = "*j" then goto next_file;
	     call gtss_aft_$find (filename (i), fn, code);
	     if code ^= 0 then do;
		if asc_filecode = "l*" | asc_filecode = "*l" then goto next_file;
		call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
		     "Can't locate file named ^a .", filename (i));
	     end;


	     call adjust_bit_count_ ((gtss_disk (fn).dir_name), (gtss_disk (fn).entry_name), "0"b, bit_count, code);

	     call append_jcl (dollar || prmflc || asc_filecode || ","
		|| asc_prms (fixed (gtss_disk.write (fn))) || "," || asc_mode (fixed (gtss_disk.pat_body.random (fn))) || ","
		|| rtrim (gtss_disk (fn).dir_name) || ">" || newline
		|| dollar || etcc || rtrim (gtss_disk (fn).entry_name) || newline);
next_file:
	end;

	call append_jcl (dollar || endjobc || newline);
	call hcs_$set_bc_seg (tx_ptr, (jx - 1) * 9, code);
	if code ^= 0 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "Can't set bit count on ^a .", rtrim (get_pdir_ ()) || ">" || "gtss_task");

/* save bar mode stack pointer before calling another bar mode program i.e. gcos */
	sb = baseptr (baseno (addr (bar_mode_stack_ptr)));
	bar_mode_stack_ptr = stack_header.bar_mode_sp;


	cmd_stg = "gcos$task [pd]>gtss_task -aci -ls -sd [pd]";
	call cu_$cp (addr (cmd_stg), length (rtrim (cmd_stg)), code);

/* restore bar mode stack pointer after gcos return */
	stack_header.bar_mode_sp = bar_mode_stack_ptr;

	if code ^= 0 then
	     call gtss_abort_subsystem_ (mcp, "gtss_drl_task_", 0,
	     "Can't issue gcos command ^a .", cmd_stg);

	mc.a = "0"b; /* set good status */

	return;

append_jcl: proc (newstg);
dcl newstg char(*);

	     substr (jcl_stg, jx, length (newstg)) = newstg;
	     jx = jx + length (newstg);
	     return;


	end append_jcl;

dcl  SSA_buf_ptr ptr;
dcl 1 SSA_buf based (SSA_buf_ptr),
   2 fill0 (0:14) bit (36),
   2 urgc fixed bin,
   2 fill16 (16:55) bit (36),
   2 snumb bit (36),
   2 fill57 bit (36),
   2 actname bit (36),
   2 fill59 (59:624) bit (36),
   2 io_limit fixed bin (35),
   2 fill626 (626:892) bit (36),
   2 job_time fixed bin (35),
   2 fill894 bit(36),
   2 job_io_time fixed bin (35),
   2 fill896 (896:928) bit (36),
   2 switch bit (36),
   2 fill930 (930:938) bit (36),
   2 geload_lim fixed bin (35),
   2 ident_text (10) bit(36),
   2  comment_text (10) bit (36),
   2  fill960 (960:964) bit (36);


dcl filelist_ptr ptr;
dcl 1 filelist based (filelist_ptr) aligned,
   2 filelist_entries fixed bin (35) unal,
   2 filelist_entry (filelist_entries) unal,
      3 filename char (8) unal,
      3 fill1 bit(24) unal,
      3 filecode bit (12) unal;


dcl  arg_list_ptr ptr;
dcl 1 arg_list based (arg_list_ptr) aligned,
   2 L_SSA_buf fixed bin (18) unsigned unal,
   2 L_filelist fixed bin (18) unsigned unal;


dcl  asc_snumb char (5);
dcl  asc_actname char (6);
dcl  asc_ident char (60);
dcl  asc_comment char (60);
dcl  asc_filecode char (2);

dcl  bar_mode_stack_ptr ptr auto;
dcl  bit_count fixed bin (35);

dcl  cmd_stg char (100);
dcl  set_sws char (57) varying;
dcl (newline init (substr (collate(), 11, 1)) char (1),
     dollar init ("$" || substr (collate (), 10, 1)) char (2),
    (snumbc init ("snumb"),
     identc init ("ident"),
     setc init ("set"),
     limitc init ("limit"),
     prmflc init ("prmfl"),
     etcc init ("etc"),
     programc init ("program"),
     endjobc init ("endjob")) char (8)
     );
dcl  asc_prms (0:1) char (1) init ("r", "w") int static options (constant);
dcl  asc_mode (0:1) char (1) init ("s", "r") int static options (constant);

dcl  gseg ptr;
dcl  tx_ptr ptr;
dcl  jcl_stg char (100000) based (tx_ptr);
dcl  jx fixed bin init (1);
dcl  i fixed bin;
dcl  swx pic "99";
dcl  fn fixed bin (24);
dcl  code fixed bin (35);

dcl  adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit aligned, fixed bin (35), fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));
dcl  get_pdir_ entry returns (char (168));
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  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rs entry options (variable);

dcl (addr, addrel, baseno, baseptr, char, collate, fixed, float, length, null, rtrim, substr) builtin;

%include gtss_dfd_ext_;

%include gtss_entry_dcls;

%include gtss_ext_;

%include gtss_io_status_words;

%include gtss_ust_ext_;

%include mc;
%include stack_header;
     end gtss_drl_task_;
   



		    gtss_drl_termtp_.pl1            12/11/84  1349.3rew 12/10/84  1043.6       13932


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

gtss_drl_termtp_: proc (mcpp, increment);

/**	gtss return caller's terminal type and line no.

	Author:	Dave Ward			06/28/79
 **/
dcl  mcpp                     ptr parm;
dcl  increment                fixed bin parm;
	mcp = mcpp;

/**

   DRL termtp, TERMINAL TYPE AND LINE NUMBER (octal 23)


   8_________1_6_____________________

   DRL      termtp

    (See TSS SYSTEM PROGRAMMER'S
         REFERENCE MANUAL DD17C, Rev. 0, July 1976
         Page 3-30)

*/

	increment = 0 ;				/* No arguments */
	scup = addr (mc.scu);
	mc.regs.a = "0"b;				/* Zero the A register. */
	a_reg.term_code.b1 = gtss_ust.lflg2.b7;		/* 1st bit */
	a_reg.term_code.b5 = gtss_ust.lbuf.terminal_type; /* Remaining 5 bits. */
	a_reg.line_no = gtss_ust.lbuf.station_id;
	return;

/**	Variables for gtss_drl_termtp_:
     IDENTIFIER		ATTRIBUTES	**/
dcl  gseg                     ptr;

dcl 1 a_reg aligned based(addr(mc.regs.a))
,     2 fill bit(18)unal
,     2 term_code unal
,       3 b1 bit(1)unal
,       3 b5 bit(5)unal
,     2 line_no bit(12)unal
;

%include gtss_ust_ext_;

%include mc;
     end gtss_drl_termtp_;



		    gtss_drl_time_.pl1              12/11/84  1349.3rew 12/10/84  1043.7       36666


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

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

gtss_drl_time_: proc (mcp, increment);

/*	Obtain processor time and time of day.

	Authors:	Robert J. Grimes	Created
		Albert N. Kepner	  1978
		Robert M. May
		David B. Ward
  Changed: Ron Barstad  02/04/83  To fix size error in convert to 64ths msec
*/

/*
   DRL TIME, OBTAIN PROCESSOR TIME AND TIME&OF&DAY (octal 21)


   8_________1_6______

   DRL      TIME
   ZERO     L(date)


   From this derail, the processor time  used  by  the  current
   user, the time of day, and (optionally) the date are returned, in
   the following form:


   C(A)    Processor time

   C(Q)    Time of day


   The unit of time is 1/64 of a millisecond.


   At  location  date, the date is entered, in ASCII code, with
   slashes inserted between the values in the following form:


   DATE    M   M   /   D

   +1      D   /   Y   Y


   Where:


   MM is the month
   DD is the day
   YY is the year


   If the value of L(date) is zero, the date is not stored.
   */
/* 	D E C L A R A T I O N S					 */


/* 	External Entries						 */

dcl  clock_ ext entry returns (fixed bin (71));
dcl  date_time_ ext entry (fixed bin (71), char (*));
dcl  decode_clock_value_ ext entry
    (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3) aligned);

/* 	Work Variables						 */

dcl  increment fixed bin;				/* no of param words to skip */
dcl  time fixed bin (71);				/* time in microseconds */
dcl  time64ths fixed bin (35) based;                        /* time in 64ths of a msec */
dcl  date_ptr ptr init(null());
dcl  processor_time fixed bin (35);
dcl  date char (8) based (date_ptr);
dcl  arg_ptr ptr init(null());
dcl 1 arglist aligned based (arg_ptr),
    2 address fixed bin (17) unaligned,
    2 fill bit (18) unaligned;
dcl  date_time char (8);				/* ascii date and time */

dcl  gseg ptr ;
dcl  i fixed bin (71);				/* temp */
dcl (j, m, d, y, w) fixed bin;
dcl  z char (3) aligned;
dcl (addrel, fixed, unspec, addr, divide) builtin;

/* 	P     R     O     C     E     D     U     R     E		 */


	scup = addr (mc.scu);
	gseg = gtss_ext_$gtss_slave_area_seg (gtss_ext_$stack_level_);

	increment = 1;				/* one parameter */
	time = clock_ ();				/* get current time */

	call date_time_ (time, date_time);		/* get ascii date and time */


/*  look for date location required */
	arg_ptr = addrel (gseg, fixed (scu.ilc) + 1);
	if arglist.address ^= 0 then
	     do;
						/* check  for buffer address out of bounds */
	     if arglist.address > fixed (gtss_ust.lsize.limit, 18)
	     | (arglist.address+1) > fixed (gtss_ust.lsize.limit, 18) then do;
		call gtss_abort_subsystem_ (mcp,
		     "gtss_drl_time_",
		     4,
		     gtss_pnterr.err4,
		     fixed (scu.ilc, 18));
		return;
	     end;
	     date_ptr = addrel (gseg, arglist.address);
	     date = date_time;
	end;
						/* get total proc time used before ss started and time so far by ss */
	processor_time = gtss_ust.lsprt+gtss_ust.lspts;
	mc.regs.a = unspec (processor_time);

	call decode_clock_value_ (time, m, d, y, i, w, z); /* just to get time since midnight local time,
						   in microseconds, into i */

	i = divide (i, 1000, 71, 0);			/* convert to msecs */
	addr (mc.regs.q) -> time64ths = i * 64;           /* convert to 64ths of a msec */
	return;

%include gtss_pnterr;

%include gtss_ext_;

%include gtss_ust_ext_;

%include mc;

%include gtss_entry_dcls;
     end gtss_drl_time_;
  



		    gtss_drun_.pl1                  12/11/84  1349.3rew 12/10/84  1043.7      115299


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

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

gtss_drun_: proc (error);

/*	Author: Al Dupuis 09/13/79

   When this procedure is called the first time, it sets
   up the necessary environment for the subsystem DRUN to
   execute, if it is being called under absentee. If the process
   is an interactive one, it checks for any jobs that were executing
   and the system crashed (jobs that were not entered with restart
   argument). If one of these are found, it changes it's catalog entry
   in the #D queue to reflect it.
   When it is called the second time, it resets the environment
   expecting the absentee process to terminate, or the simulator to terminate if interactive.
   It is called the first time from gtss intialize procedure,
   and the second time from gtss termination procedure.
*/


	if first_time_called then do;
	     first_time_called = "0"b;
	     second_time_called = "1"b;
	     if gtss_ust.lcjid = "0"b then call inter_init;
	     else call abs_init;
	end;
	else if second_time_called then do;
	     second_time_called = "0"b;
	     first_time_called = "1"b;
	     call terminate;
	end;
	else do;
	     call com_err_ (0, caller,
		"Bug, first_time and second_time indicators were not set");
	     error = "1"b;
	end;

	return;

abs_init:	proc;

/* Open the deferred queue file (#D)		*/
	     call gtss_dq_$open_exc (error_occured);
	     if error_occured then do;
		call com_err_ (0, caller,
		     "Couldn't open the #D file");
		error = "1"b;
		return;
	     end;

/* Create restart file in homedir, put ipc_ event channel id in it */
	     call hcs_$make_seg (gtss_ext_$homedir, "drun_restart."
		|| gtss_ext_$drun_jid, "", 10, gtss_ext_$restart_seg_ptr, code);
	     if code = error_table_$namedup then
		call gtss_dq_$mod_js (gtss_ext_$drun_jid, 2, error_occured); /* change to resheduled due to system crash */
	     call hcs_$status_mins (gtss_ext_$restart_seg_ptr, type,
		bit_count, code);
	     if bit_count = 0 then do;
		call ipc_$create_ev_chn (event_info.channel_id, code);
		if code ^= 0 then do;
		     call convert_ipc_code_ (code);
		     call com_err_ (code, caller,
			"Couldn't create event channel.");
		     error = "1"b;
		     return;
		end;
		event_info.sender = get_process_id_ ();
		call hcs_$set_bc_seg (gtss_ext_$restart_seg_ptr, 72*2+36, code);
		if code ^= 0 then do;
		     call com_err_ (code, caller,
			"Couldn't set bit count.");
		     error = "1"b;
		     return;
		end;
	     end;
	     gtss_ext_$event_channel = event_info.channel_id;
	     call timer_manager_$cpu_call (30, "11"b, gtss_abs_$dabt_check);


/* Intialize communication region		*/
	     gtss_ext_$com_reg.tsdgt.ust_loc = 1;
	     gtss_ext_$com_reg.tsdmx.dit = 180;
	     call gtss_bcd_ascii_ (addr (gtss_ust.lcjid), 5, addr (gtss_ext_$drun_jid));
	     call gtss_dq_$catp (gtss_ext_$drun_jid, dc_ptr, cat_entry);
	     if dc_ptr = null () then do;
		call com_err_ (0, caller,
		     "Couldn't read ^a #D catalog entry", gtss_ext_$drun_jid);
		error = "1"b;
		return;
	     end;

	     gtss_ext_$com_reg.tsdid = dc_ptr -> dq_catalog.dcuid;
	     gtss_ext_$com_reg.tsdsd = dc_ptr -> dq_catalog.dcdsd;
	     gtss_ext_$com_reg.tsdst = dc_ptr -> dq_catalog.dcdst;
	     addr (gtss_ext_$com_reg.tsdjb) -> one_word = gtss_ust.lcjid;

/* If the user has a ..init file, reset lcjid and start_term so that it
   will be processed under crun. When crun shuts down these indicators
   will be reset by gtss_abandon_CFP_ and DRUN execution will then begin.
   Otherwise DRUN execution will begin now.		*/
	     string = gtss_abs_$get_drm ();
	     string = after (string, "gse -drm ");
	     if substr (string, 1, 2) = "wd"
	     then dir_name = rtrim (get_wdir_ ());
	     else if substr (string, 1, 3) = "smc"
	     then dir_name =
		rtrim (gse_ext_$smc_pathname) || ">"
		|| rtrim (gse_ext_$umc_name);
	     else if substr (string, 1, 3) = "umc"
	     then dir_name =
		">udd>" || rtrim (gse_ext_$umc_name)
		|| ">" || rtrim (gse_ext_$umc_name);
	     else do;
		call com_err_ (0, caller,
		     "Bug, couldn't get dir_mapping (^a)",
		     string);
		signal condition (gtss_fail);
	     end;
	     call hcs_$initiate_count (dir_name, "..init",
		"", bit_count, 1, seg_ptr, code);
	     if seg_ptr = null ()
	     then return;
	     gtss_ust.lcjid = "0"b;
	     gtss_ust.lcfst.start_term = 0;
	     gtss_ext_$put_chars = gtss_CFP_output_;
	     
	end;					/* abs_init */

inter_init: proc;

/*
   If a DRUN job id, and a Multics absentee request id both exist there is no
   action taken. If a DRUN job id exists, a Multics id doesn't,
   and the catalog status in the #D queue file is marked as still executing,
   the following takes place. If the drun restart file exists
   the entry is marked as aborted due to a system crash. (This means the user
   entered the request without the restart argument, and the catalog entry
   is changed now, versus real Gcos where it would be changed as soon as Gcos
   came back up). If the restart file did not exist, it was deleted by the
   finish condition begin block in gtss (examples of this would be if a user
   did an escape logout while under the simulator (normally the
   caleanup condition handler would change the catalog status, but it is not
   signaled in this case.)) In this case the catalog status would be changed
   to terminated abnormally. (Has to be done from here because finish condition
   handler is invoked after gtss_ios goodies are destroyed).
*/

/* Open the deferred queue file (#D) for read while writers */
	     call gtss_dq_$open_gen (error_occured);
	     if error_occured then do;
		call com_err_ (0, caller,
		     "Couldn't open the #D file");
		error = "1"b;
		return;
	     end;
	     call gtss_dq_$entries_info (addr (dq_info), 315, no_of_entries_found);
	     if no_of_entries_found ^= 0
	     then do;

/* Reopen the file for exclusive use as we may have to update it */
		call gtss_dq_$open_exc (error_occured);
		if error_occured then do;
		     call com_err_ (0, caller,
			"Couldn't open the #D file");
		     error = "1"b;
		     return;
		end;
		do i = 1 to no_of_entries_found;
		     if ((dq_info.js (i) = 3) & (dq_info.aid (i) = " ")) then do;
			call hcs_$initiate_count (gtss_ext_$homedir,
			     "drun_restart." || dq_info.did (i), "",
			     bit_count, 1, gtss_ext_$restart_seg_ptr, code);
			if gtss_ext_$restart_seg_ptr ^= null () then do;
			     call delete_$ptr (gtss_ext_$restart_seg_ptr, "100100"b, caller, code);
			     if code ^= 0 then do;
				call com_err_ (code, caller,
				     "Couldn't delete [hd]>drun_restart.^a", dq_info.did (i));
				error = "1"b;
				return;
			     end;
			     call gtss_dq_$mod_js (dq_info.did (i), 7, error_occured);
			end;
			else do;
			     call gtss_dq_$mod_js (dq_info.did (i), 6, error_occured);
			     call com_err_ (0, "",
				"^a terminated abnormally, check ^a>drun_control.^a.absout please.",
				dq_info.did (i), rtrim (gtss_ext_$homedir), dq_info.did (i));
			end;
		     end;
		end;
/* And revert opening back to read while changing	*/
		call gtss_dq_$open_gen (error_occured);
		if error_occured then do;
		     call com_err_ (0, caller,
			"Couldn't open the #D file");
		     error = "1"b;
		     return;
		end;
	     end;

/* Delete any absout files that don't have a corresponding entry in the
   deferred queue file.			*/
	     hdir = gtss_ext_$homedir;
	     call check_star_name_$entry (star_name, code);
	     if code ^= 1
	     then do;
		call com_err_ (code, caller,
		     "Bug, star name was ^a.", star_name);
		return;
	     end;
	     call hcs_$star_ (hdir, star_name,
		star_BRANCHES_ONLY, addr (our_area),
		star_entry_count, star_entry_ptr,
		star_names_ptr, code);
	     if code = error_table_$notalloc
	     then do;
		call com_err_ (code, caller,
		     "Bug, not enough room in our_area.");
		return;
	     end;
	     if code = error_table_$nomatch
	     then return;
	     in_def_q = "0"b;
	     do i = 1 to star_entry_count;
		if no_of_entries_found ^= 0
		then do j = 1 to no_of_entries_found;
		     if star_names (star_entries (i).nindex) =
		     "drun_control."
		     || dq_info.did (j)
		     || ".absout"
		     then do;
			in_def_q = "1"b;
			j = no_of_entries_found;
		     end;
		end;
		if ^ in_def_q
		then call delete_$path (hdir,
		     star_names (star_entries (i).nindex),
		     "010100"b, caller, code);
		else in_def_q = "0"b;
	     end;
	end;					/* inter_init */

terminate: proc;


	     call timer_manager_$reset_cpu_call (gtss_abs_$dabt_check);
	     call timer_manager_$reset_cpu_call (gtss_abs_$cpu_runout);
	     if gtss_ext_$flags.ss_time_limit_set then
		call timer_manager_$reset_cpu_call (gtss_fault_processor_$timer_runout);

/* If executing under absentee, clean things up */
	     if gtss_ust.lcjid ^= "0"b then do;
		call ipc_$delete_ev_chn (gtss_ext_$event_channel, code);
		call delete_$ptr (gtss_ext_$restart_seg_ptr, "100100"b, caller, code);
		call gtss_dq_$catp (gtss_ext_$drun_jid, dc_ptr, cat_entry);
		if dc_ptr -> dq_catalog.dcjid.job_status = 3 then do;
/* Open the deferred queue file (#D)		*/
		     call gtss_dq_$open_exc (error_occured);
		     if error_occured then do;
			call com_err_ (0, caller,
			     "Couldn't open the #D file");
			error = "1"b;
			return;
		     end;
		     call gtss_dq_$mod_js (gtss_ext_$drun_jid, 6, error_occured);
		     call com_err_ (0, caller,
			"When simulator termination occured, the catalog job status was marked as still executing.");
		end;
	     end;

	end;					/* termination */

/* gtss_drun_ declares		*/

dcl  addr			builtin;
dcl  binary		builtin;
dcl  bit_count		fixed bin (24);
dcl  caller		char (10) static int options (constant) init ("gtss_drun_");
dcl  cat_entry		fixed bin (18) unsigned;
dcl  check_star_name_$entry	entry (char (*), fixed bin (35));
dcl  code			fixed bin (35);
dcl  convert_ipc_code_	entry (fixed bin (35));
dcl  dc_ptr		ptr init (null());
dcl  dir_name		char (168);
dcl  delete_$path		entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  delete_$ptr		entry (ptr, bit (6), char (*), fixed bin (35));
dcl  error		bit (1) parm;
dcl  error_occured		bit (1);
dcl  error_table_$namedup	fixed bin (35) ext;
dcl  error_table_$nomatch	fixed bin (35) ext;
dcl  error_table_$notalloc	fixed bin (35) ext;
dcl  first_time_called	bit (1) static int init ("1"b);
dcl  get_process_id_	entry returns (bit (36));
dcl  get_wdir_		entry returns (char (168));
dcl  gtss_fail		condition ext;
dcl  hcs_$initiate_count	entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, 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  hcs_$star_		entry (char(*),char(*),fixed bin(2),ptr, fixed bin,ptr,ptr,fixed bin(35));
dcl  hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  hdir			char (64);
dcl  i			fixed bin (18) unsigned;
dcl  in_def_q		bit (1);
dcl  ipc_$create_ev_chn	entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn	entry (fixed bin (71), fixed bin (35));
dcl  j			fixed bin (18) unsigned;
dcl  no_of_entries_found	fixed bin (18) unsigned;
dcl  one_word		bit (36) based;
dcl  our_area		area (1024*5);
dcl  second_time_called	bit (1) static int init ("0"b);
dcl  seg_ptr		ptr init (null());
dcl  star_name		char (21) static int options (constant) init ("drun_control.*.absout");
dcl  string		char (256) varying;
dcl  sum			builtin;
dcl  time			fixed bin (71);
dcl  timer_manager_$cpu_call	entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call	entry (entry);
dcl  type			fixed bin (2);

dcl 1 event_info based (gtss_ext_$restart_seg_ptr),
      2 channel_id fixed bin (71),
      2 message fixed bin (71),
      2 sender bit (36),
      2 origin,
        3 dev_signal bit (18) unal,
        3 ring bit (18) unal,
      2 channel_index fixed bin;

dcl 1 dq_info (315),
      2 did char (5),
      2 aid char (19),
      2 js fixed bin (6) unsigned;

%include gtss_entry_dcls;

%include gtss_ext_;

%include gtss_deferred_queue;

%include gtss_ust_ext_;

%include gse_ext_;

%include star_structures;
     end;						/* gtss_drun_ */
 



		    gtss_dsd_lookup_.pl1            12/11/84  1349.3rew 12/10/84  1043.7       13680


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

gtss_dsd_lookup_: proc (rt) returns (fixed bin (24));

/**     This function, given a character request type,
        returns the CFP_request_value as defined in the
        include file gtss_CFP_request_types. The value is
        set to zero if the type is not found.

        Author:   Al Dupuis 04/19/79
**/
	do while (length (rt) ^> 3);			/* pad the parameter to make it four characters */
	     rt = rt || " ";
	end;

	string = substr (rt, 1, 4);
	i = 1;
	j = hbound (CFP_request_types, 1);

	do while (i <= j);				/* binary table search */
	     k = divide (i + j, 2, 24);
	     if string = substr (CFP_request_types (k), 1, 4)
	     then return (CFP_request_value (k));	/* hit */
	     if string < substr (CFP_request_types (k), 1, 4)
	     then j = k - 1;
	     else i = k + 1;
	end;

	return (0);				/* miss */
/**

Variables for gtss_dsd_lookup_
**/

dcl rt char (8) varying parameter;
dcl string char (4);
dcl (i,j,k) fixed bin (24);
dcl (hbound, divide, length, substr) builtin;
/** 
**/
%include gtss_CFP_request_types;

     end						/* gtss_dsd_lookup_ */;



		    gtss_dsd_process_.pl1           12/11/84  1349.3rew 12/10/84  1043.7      115929


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

gtss_dsd_process_: proc (up, bp, ml, rl, ec);

/**      Process the $*$ request line from CRUN/DRUN application.

	Author:   Al Dupuis  04/20/79
	Changed:	Al Dupuis  09/26/79 To display blank line to terminal when
				line contains only $*$mark.

**/


	rll = rl;
	if rll >= 4
	then do;
	     cp = index (string_3, "$*$");
	     rls = substr (string_3, cp + 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 cs = substr (rls, 1, 4); /* pick up keyword */
	     else cs = substr (rls, 1, 3);
	     save_cs = cs;
	     cs = translate (cs, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", /* make it upper */
		"abcdefghijklmnopqrstuvwxyz");
	     type = gtss_dsd_lookup_ (cs);		/* find out which one */
	end;
	else type = 0;				/* line contains only $*$ */

	proper_rtn = rtn_table (type);		/* set up with the desired proc */
	call proper_rtn;				/* and call it */


/** 
**/
dsd_error: proc;

/** Unrecognizable $*$ request
**/

/* Apparently Gcos just treats it as data	*/
	     no_input_yet = "0"b;

	end					/* dsd_error */;

/**  **/

dsd_build: proc;

	     if ^build_mode then do;
		call gtss_write_starCFP_ (up, bp, rl, ec);
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_build",
		     0,
		     "Couldn't write to *CFP: ^a",
		     string_3
		     );
		call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_build",
		     0,
		     "<67>BUILD LEVEL SYNCHRONIZATION ERROR"
		     );
	     end;

	end /* dsd_build */ ;
/**
**/
dsd_brk:	proc;

/** Behaves as though the break key was pressed
**/

	     break_flag = "1"b;
	     signal condition (quit);

	end					/* dsd_brk */;

/** 
**/

dsd_copy:	proc;

	     if gtss_ust.lcjid ^= (36)"0"b then return;	/* DRUN in progress */

	     i = index (string_3, save_cs);
	     if i = 0 then				/* copy shouldn' have been called if copy not present */
		call gtss_abort_subsystem_ (
		null (),
		"gtss_dsd_process_$dsd_copy",
		0,
		"Copy not present in line, bug: ^a",
		string_3
		);
	     if (rll >= i + 8) then do;
		rls = substr (string_3, i + 4);	/* everything after copy */
		rls = ltrim (rls);			/* get rid of any blanks before second keyword */
		if length (rls) >= 4 then do;		/* long enough for "off" */
		     if (substr (rls, 1, 3) = "off") | (substr (rls, 1, 3) = "OFF")
		     then copy_on = "0"b;
		     else copy_on = "1"b;
		end;
		else copy_on = "1"b;		/* not long enough */
	     end;
	     else copy_on = "1"b;			/* string not long enough to contain off */

	end					/* dsd_copy */;
/** 
**/

dsd_dele:	proc;

	     i = index (string_3, save_cs);
	     if i = 0 then				/* dele shouldn' have been called if dele not present */
		call gtss_abort_subsystem_ (
		null (),
		"gtss_dsd_process_$dsd_dele",
		0,
		"Copy not present in line, bug: ^a",
		string_3
		);
	     if (rll >= i + 8) then do;
		rls = substr (string_3, i + 4);	/* everything after dele */
		rls = ltrim (rls);			/* get rid of any blanks before second keyword */
		if length (rls) >= 4 then do;		/* long enough for "off" */
		     if (substr (rls, 1, 3) = "off") | (substr (rls, 1, 3) = "OFF")
		     then dele_on = "0"b;
		     else dele_on = "1"b;
		end;
		else dele_on = "1"b;		/* not long enough */
	     end;
	     else dele_on = "1"b;			/* string not long enough to contain off */

	end					/* dsd_dele */;
/**  **/


dsd_exec:	proc;

	     if ^user_code then do;
		call gtss_write_starCFP_ (up, bp, rl, ec);
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_exec",
		     0,
		     "Couldn't write to *CFP: ^a",
		     string_3
		     );
		call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_exec",
		     0,
		     "<67>EXECUTION LEVEL SYNCHRONIZATION ERROR"
		     );
	     end;

	end					/* dsd_exec */;
/**  **/
dsd_file:	proc;

	     talk_on = "0"b;			/* go back to *CFP input */

	end					/* dsd_file */;
/**  **/


dsd_lbl:	proc;

	     call com_err_ (0, "gtss_dsd_process_$dsd_lbl",
		"Label line encountered ^a", string_3);

	end					/* dsd_lbl */;
/**  **/

dsd_mark:	proc;


						/* display the line to user as soon as encountered */
	     if rll < 9 then do;			/* line contains only $*$mark */
		rll = 10;
		string_1 (9) = " ";			/* fill line out with blank and CR */
		string_1 (10) = string_1 (8);
	     end;
	     sp2 = addr (string_1 (9));		/* overlay from position 9 */
/* If under drun processing ..init file, write to *CFP */
	     if gtss_ext_$process_type = 2
	     & gtss_ust.lcjid = "0"b
	     & gtss_ext_$drun_jid ^= " "
	     then call gtss_write_starCFP_ (up, sp2, rll - 8, code);
	     else call iox_$put_chars (iox_$user_output, sp2, rll - 8, code);
	     if code ^= 0 then
		call gtss_abort_subsystem_ (
		null (),
		"gtss_dsd_process_$dsd_mark",
		0,
		"Unable to write MARK info to terminal ^a",
		string_3);

	end					/* dsd_mark */;
/**  **/

dsd_nbuild: proc;

	     if build_mode then do;
		call gtss_write_starCFP_ (up, bp, rl, ec);
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_nbuild",
		     0,
		     "Couldn't write to *CFP: ^a",
		     string_3
		     );
		call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_nbuild",
		     0,
		     "<67>BUILD LEVEL SYNCHRONIZATION ERROR"
		     );
	     end;

	end /* dsd_nbuild */ ;
/**  **/


dsd_nexec: proc;

	     if user_code then do;
		call gtss_write_starCFP_ (up, bp, rl, ec);
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_nexec",
		     0,
		     "Couldn't write to *CFP: ^a",
		     string_3
		     );
		call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_nexec",
		     0,
		     "<67>EXECUTION LEVEL SYNCHRONIZATION ERROR"
		     );
	     end;

	end					/* dsd_nexec */;
/**  **/

dsd_nsys:	proc;

		/** IGNORED IN GCOS 4J **/

	end					/* dsd_nsys */;
/**  **/

dsd_null:	proc;

	     rll, rl = 2;				/* send null line (CR) to caller */
	     string_3 = CR || NL;
	     if ((^dele_on) & (^gtss_starCF_$FILE.cf.exclude_on))
	     then call gtss_write_starCFP_ (up, bp, rl, ec); /* and send it to *CFP */
	     if ec ^= 0 then call gtss_abort_subsystem_ (
		null (),
		"gtss_dsd_process_$dsd_nbuild",
		0,
		"Couldn't write to *CFP: ^a",
		string_3
		);
	     no_input_yet = "0"b;

	end					/* dsd_null */;
/**  **/

dsd_quit:	proc;


	     if gtss_ust.lcjid ^= (36)"0"b then do;	/* DRUN in progress */
		cout_called = "0"b;
		call gtss_abandon_CFP_;
		lswt2.b6 = "0"b;
		no_input_yet = "0"b;
		return;
	     end;

						/* determine if =text option being used */
	     i = index (string_3, save_cs || "=");
	     if i ^= 0 then do;			/* yes, put text prompt in buffer */
		string_3 = substr (string_3, i + 5);
		rll = rll - (i + 4);
		bl = rll;
		call iox_$put_chars (iox_$user_output, bp, bl, ec); /* display msg to user */
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_quit",
		     0,
		     "Unable to write QUIT info to terminal ^a",
		     string_3);
	     end;

	     if (^dele_on) then do;			/* if there was a prompt */
		call gtss_read_starCFP_$last_os (up, bp, ml, rl, ec); /* get it */
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_dsd_quit",
		     0,
		     "Can't read last output sector on *CFP"
		     );
		call iox_$put_chars (iox_$user_output, bp, rl, ec); /* and display it to user */
		if ec ^= 0 then call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_quit",
		     0,
		     "Unable to write last prompt to terminal ^a",
		     string_3);
	     end;
	     cout_called = "0"b;
	     call gtss_abandon_CFP_;			/* quitting command file processing */
	     lswt2.b6 = "0"b;			/* DD17C, page 3-33.2 */
	     call iox_$get_line (iox_$user_input, bp, ml, rl, ec); /* get his response */
	     no_input_yet = "0"b;			/* and let gtss_CFP_input_ know we have our input */

	end					/* dsd_quit */;
/**  **/

dsd_rem:	proc;

	     call com_err_ (0, "gtss_dsd_process_$dsd_rem",
		"Remark line encountered ^a", string_3);

	end					/* dsd_rem */;
/**  **/

dsd_system: proc;

		/** IGNORED IN GCOS 4J **/

	end					/* dsd_system */;
/**  **/


dsd_talk: dsd_user: proc;

	     if gtss_ust.lcjid ^= (36)"0"b then return;	/* DRUN in progress */

	     if cs = "TALK" then talk_on = "1"b;
						/* determine if user is using =text option */
	     i = index (string_3, save_cs || "=");
	     if i ^= 0 then do;			/* yes, put text prompt in buffer */
		string_3 = substr (string_3, i + 5);
		rll = rll - (i + 4);
	     end;
	     else do;				/* no, it will come from *CFP */
		if ^dele_on then do;		/* if dele_on there is no output file */
						/* get the prompt from *CFP's last output sector */
		     call gtss_read_starCFP_$last_os (up, bp, ml, rl, ec);
		     if ec ^= 0 then call gtss_abort_subsystem_ (
			null (),
			"gtss_dsd_process_$dsd_talk/dsd_user",
			0,
			"Can't read last output sector on *CFP"
			);
		     else rll = rl;
		end;
	     end;
						/* write prompt to terminal */
	     if ((i ^= 0) | (^dele_on)) then do;	/* there is a prompt */
		bl = rll;
		call iox_$put_chars (iox_$user_output, bp, bl, ec);
		if ec ^= 0 then
		     call gtss_abort_subsystem_ (
		     null (),
		     "gtss_dsd_process_$dsd_talk/dsd_user",
		     0,
		     "Can't display prompt to user"
		     );
	     end;
	     else;				/* there was no prompt */
	     if ^talk_on then do;
		talk_on = "1"b;			/* user request, so fudge talk_on for one input */
		call gtss_CFP_input_ (up, bp, ml, rl, ec); /* get line from terminal */
		talk_on = "0"b;			/* turn off fudged mode */
		no_input_yet = "0"b;		/* let gtss_CFP_input_ know we have our line */
	     end;
	     else;				/* let gtss_CFP_input_ get line normally */
	end					/* dsd_user dsd_talk */;
/*  * */


dsd_trap:	proc;


	     i = index (string_3, save_cs);
	     if i = 0 then				/* trap shouldn' have been called if trap not present */
		call gtss_abort_subsystem_ (
		null (),
		"gtss_dsd_process_$dsd_trap",
		0,
		"Trap not present in line, bug: ^a",
		string_3
		);
	     if (rll >= i + 8) then do;
		rls = substr (string_3, i + 4);	/* everything after trap */
		rls = ltrim (rls);			/* get rid of any blanks before second keyword */
		if length (rls) >= 4 then do;		/* long enough for "off" */
		     if (substr (rls, 1, 3) = "off") | (substr (rls, 1, 3) = "OFF")
		     then trap_off = "1"b;
		     else trap_off = "0"b;
		end;
		else trap_off = "0"b;		/* not long enough */
	     end;
	     else trap_off = "0"b;			/* string not long enough to contain off */

	end					/* dsd_trap */;


/**        gtss_dsd_process_ local dcl's
**/
dcl  up                       ptr parm /* (NOT USED. Needed for iox_ compatibility). */;
dcl  bp                       ptr parm /* (input) Callers buffer. */;
dcl  ml                       fixed bin(21)parm /* (input) Buffer length limit. */;
dcl  rl                       fixed bin(21)parm /* (output) Number characters returned. */;
dcl  ec                       fixed bin(35)parm /* (output) Multics error ec. */;
dcl  CR                       char(1)static int options(constant) init("");
dcl NL			char(1) static int options(constant) init ("
");
dcl  rls char (252) varying;
dcl string_1 (rll) char (1) based (bp);
dcl string_2 (rll - 9) char (1) based (sp2);
dcl  string_3 char (rll) based (bp);
dcl sp2 ptr init (null());
dcl (cs, save_cs) char (8) varying;
dcl (rll, cp, type, i) fixed bin (24);
dcl bl fixed bin (21);
dcl code fixed bin (35) init (0);
dcl (ltrim, null, substr, index, addr, length, translate) builtin;
dcl quit condition external;
dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl iox_$user_input ptr ext;
dcl iox_$user_output ptr ext;
dcl proper_rtn entry int variable;
dcl rtn_table (0:18) entry init (
	dsd_error,
	dsd_brk,
	dsd_build,
	dsd_copy,
	dsd_dele,
	dsd_exec,
	dsd_file,
	dsd_lbl,
	dsd_mark,
	dsd_nbuild,
	dsd_nexec,
	dsd_nsys,
	dsd_null,
	dsd_quit,
	dsd_rem,
	dsd_system,
	dsd_talk,
	dsd_trap,
	dsd_user);


%include gtss_CFP_bits;
/** 
**/
%include gtss_starCF_;
/** 
**/
%include gtss_ust_ext_;
/** 
**/
%include gtss_ext_;
/** 
**/
%include gtss_entry_dcls;
finish:	;
     end						/* gtss_dsd_process_ */;
   



		    gtss_dump_filact_args_.pl1      12/11/84  1349.3rew 12/10/84  1043.8       49194


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

gtss_dump_filact_args_: proc (apv);

/** Dump conplete arguments for filact drl.

    Author: Dave Ward  07/14/79
**/
dcl apv ptr parm;
	ap = apv;
	if (fn >= lbound (f, 1))& (fn <= hbound (f, 1)) then do;
	     call ioa_$nnl ("DRL FILACT (function ^2i)^/", fn);
	     goto f (fn);
	end;
	call com_err_ (0, "gtss_dump_filcat_args_",
	     "Function # ^i out of range ^i to ^i",
	     fn,
	     lbound (f, 1),
	     hbound (f, 1));
	return;

f (11):	; /** Modify file. **/
	alp = pointer (ap, all);
	cfp = pointer (ap, cfl);

/* Display file/catalog description. */
	nu = 1;
more_name: ;
	if nu = 1 then do;
	     if user (1).id ^= (72)"1"b then do;
		call gtss_bcd_ascii_ (addr (user (1).id), 12, addr (nascii));
		call ioa_$nnl ("^a", nascii);
	     end;
	end;
	else do;
	     call ioa_$nnl ("/");
	     call gtss_bcd_ascii_ (addr (user (nu).id), 12, addr (nascii));
	     call ioa_$nnl ("^a", nascii);
	end;
	if cf.eol ^= -1 then do;
	     nu = nu+1;
	     goto more_name;
	end;
	call ioa_$nnl ("^/");

/* Display general permissions. */
	call ioa_$nnl ("General permissions:");
	pp = pointer (ap, pl);
	if string (pp -> b36) = (36)"1"b then
	     call ioa_$nnl (" UNCHANGED.^/");
	else
	if pp -> fb18 = 0 then
	     call ioa_$nnl (" DELETED.^/");
	else
	call pr_perms (pp);
	call ioa_$nnl ("012345678901234567890123456789012345^/^36b^/^/", string (pp -> b36));

/* Display new name. */
	nnp = pointer (ap, nnl);
	if nn.name = (72)"1"b then
	     call ioa_$nnl ("Name not changed.^/");
	else do;
	     call gtss_bcd_ascii_ (addr (nn.name), 12, addr (nascii));
	     call ioa_$nnl ("New name ""^a""^/", nascii);
	end;

/* Display options. */
	op = pointer (ap, ol);
	if string (ob) = "0"b then
	     call ioa_$nnl ("No option bits set.^/");
	else do;
	     call ioa_$nnl ("Option bit:");
	     do i = 0 to 17;
		if ob (i) then call ioa_$nnl (" ^i", i);
	     end;
	     if ob (4) then
		if max_size = -1 then call ioa_$nnl ("  New nax size UNLIMITED.");
		else call ioa_$nnl ("  New max size ^i", max_size);
	     call ioa_$nnl ("^/");
	end;

/* Display specific permissions. */
	nsp = 0;
next_sp:	;
	if nsp = 1 then call ioa_$nnl ("Specific permissions:^/");
	if nsp>0 then do;
	     call gtss_bcd_ascii_ (addr (userid (nsp)), 12, addr (nascii));
	     call ioa_$nnl ("  ^a", nascii);
	     pp = addr (usp (nsp, 0));
	     if pp -> fb19 = 1 then
		call ioa_$nnl (" retain name permissions NONE.^/");
	     else
	     if pp -> fb19 = 0 then
		call ioa_$nnl (" DELETED.^/");
	     else
	     call pr_perms (pp);
	     call ioa_$nnl ("012345678901234567890123456789012345^/^36b^/^/", string (pp -> b36));
	end;
	if o.eol ^= -1 then do;
	     nsp = nsp+1;
	     goto next_sp;
	end;
	if nsp = 0 then
	     call ioa_$nnl ("No user specific permissions.^/");

/* Display user attributes. */
	if ob (8) then
	     call ioa_$nnl ("User attributes ^35b^/", user_attr);
	else
	call ioa_$nnl ("No user specified attributes.^/");
	return;

pr_perms:	proc (pp);

/* Print permissions. */
dcl pp ptr parm;
	     if pp -> b36 (0) then call ioa_$nnl (" read");
	     if pp -> b36 (1) then call ioa_$nnl (" write");
	     if pp -> b36 (2) then call ioa_$nnl (" append");
	     if pp -> b36 (3) then call ioa_$nnl (" execute");
	     if pp -> b36 (4) then call ioa_$nnl (" purge");
	     if pp -> b36 (5) then call ioa_$nnl (" modify");
	     if pp -> b36 (6) then call ioa_$nnl (" lock");
	     if pp -> b36 (8) then call ioa_$nnl (" create");
	     if pp -> b36 (9) then call ioa_$nnl (" recovery");
	     call ioa_$nnl ("^/");
	end					/* pr_perms */;

dcl alp ptr;
dcl ap ptr;
dcl b36 (0:35)bit(1)unal based;
dcl cfp ptr;
dcl com_err_ entry options(variable);
dcl fb18 fixed bin(18)unsigned unal based;
dcl fb19 fixed bin(19)unsigned unal based;
dcl gtss_bcd_ascii_ entry(ptr,fixed bin(24),ptr);
dcl i fixed bin;
dcl ioa_$nnl entry options(variable);
dcl nascii char(12);
dcl nnp ptr;
dcl nsp fixed bin init(0);
dcl nu fixed bin;
dcl op ptr;
dcl pp ptr;

dcl 1 a aligned based(ap),
      2 v1 fixed bin(17)unal,
      2 all fixed bin(18)unsigned unal,
      2 fn fixed bin(17)unal,
      2 bl  fixed bin(18)unsigned unal;

dcl 1 al aligned based(alp),
      2 sl fixed bin(18)unsigned unal,
      2 v2 bit(18)unal,
      2 cfl fixed bin(18)unsigned unal,
      2 pl fixed bin(18)unsigned unal,
      2 ol fixed bin(18)unsigned unal,
      2 nnl fixed bin(18)unsigned unal;

dcl 1 cf aligned based(cfp),
      2 user (nu),
        3 id bit(72),
        3 passwrd bit(72),
      2 eol fixed bin(35);

dcl 1 nn aligned based(nnp),
      2 name bit(72),
      2 passwrd bit(72);

dcl 1 o aligned based(op),
      2 w1,
        3 ob (0:17)bit(1)unal,
        3 dn bit(12)unal,
        3 v3 bit(6)unal,
      2 w2,
        3 init_size fixed bin(18)unsigned unal,
        3 max_size  fixed bin(17) unal,
      2 specific_permission (nsp),
        3 userid bit(72),
        3 usp (0:35)bit(1)unal,
      2 eol fixed bin(35),
      2 user_attr,
        3 b1 bit(1)unal,
        3 b35 bit(35)unal;
     end						/* gtss_dump_filact_agrs_ */;
  



		    gtss_fix_tty_modes_.pl1         12/11/84  1349.3rew 12/10/84  1043.8       10080


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


gtss_fix_tty_modes_: proc;

/*
	This procedure resets the tty_modes after QUIT

	Author:  Scott C. Akers   14 August 81
*/
%page;
	on condition (quit);			/* Cannot allow QUITs here!  */
	call iox_$modes (iox_$user_output,
		       "edited,^can,ll190",
		       ignored_modes, code);

	revert quit;				/* O.K. to have QUITs now.  */
	return;
%page;
dcl  iox_$modes		entry (ptr, char (*), char (400), fixed bin (35));
dcl  iox_$user_output	ptr ext;
dcl  ignored_modes		char (400);		/* These are ignored. */
dcl  code			fixed bin (35);		/* This is ignored, too. */
dcl  quit			condition;

end gtss_fix_tty_modes_;



		    gtss_ios_io_.pl1                12/11/84  1349.3rew 12/10/84  1043.8      342522


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

gtss_ios_io_: proc (file_no, select_ptr, memory_ptr, memory_limit, status, code);

/*
   "		     This entry performs random or sequential input or output  on
   "		the  designated file according to the select sequence provided by
   "		the user.

   Author: Dave Ward	03/04/80 (derived from gtss_ios_)
*/
dcl  code                     fixed bin (35) parm;
dcl  file_no                  fixed bin (24) parm;
dcl  memory_limit             fixed bin (24) parm;
dcl  memory_ptr               ptr parm;
dcl  select_ptr               ptr parm;
dcl status fixed bin(24)parm;

	fn = file_no;				/* Use local variables */
	sp = select_ptr;
	storlimit = memory_limit+1;			/* The memory_limit parameter passed to gtss_ios_io_
						   is the address of the highest location in the segment which
						   may be accessed.  The storlimit variable represents the
						   number of words at the beginning of te segment which
						   may be accessed. */
	ap = gtss_disk.attributes_ptr (fn);

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

	seeksw = "0"b;
	slave_status = "400000000000"b3;
	idptr = addrel (sp, 1);			/* get pointer to first identifier word */
	ta_seg_ptr = baseptr (baseno (memory_ptr));	/* get pointer to beginning of
						   user's memory segment */
	select_seg_ptr = baseptr (baseno (sp));		/* get pointer to beginning of
						   segment containing select sequence */
	select_seq_in_memory = (select_seg_ptr = ta_seg_ptr);
	opptr = addrel (idptr, -1);			/* build pointer to operation word */
	sptr = addrel (idptr, 1);			/* build pointer to return word */
	dcw_offset = fixed (id_word.dcwp);		/* get dcw list pointer */
	count = 1;
	if db_ios then
	     call ioa_ ("Select Sequence for file ^i:", fn);
						/* Make sure file number is valid and file is open */
	if bad_file_status (fn, status) then do;
	     call return_stat;
	     return;
	end;
	data_moved = 0;
	da_residue = 0;
	wc_residue = 0;

lookup:	;

	do i = 1 to hbound (io_commands, 1);
	     cmd_word = io_commands (i);		/* get command */
	     if substr (cmd_word, 1, 6) = op_word.dev_com then /* are device and */
		if substr (cmd_word, 19, 5) = op_word.ioc_com then do; /* ioc commands = ? */

		     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_io_: record quota overflow.");
			code = error_table_$rqover;
			call return_stat;
			status = 16;		/* Record quota overflow. */
			goto fin_io;
		     end;
		     gtss_disk (41) = gtss_disk (fn);	/* Save state of file fn. */
		     goto com_proc (i);		/* goto processing rtn */
		end;
	end;					/* no...continue */


	status = 3;				/* unsupported I/O command */
	call return_stat;
fin_io:	;

	return;

com_proc (1): ;					/* disk or drum seek */

	if count >= 2 then do;
	     status = 13;				/* second I/O command cannot be seek */
	     call return_stat;
	     return;
	end;

	seeksw = "1"b;				/* indicate seek to be done */


	if pat_body (fn).random then do;		/* no seek necessary for sequential file */

	     if select_seq_in_memory then
		if dcw_offset >= storlimit then do;	/* dcw addr OOB? */
		     status = 4;			/* DCW is outside of slave limits */
		     if db_ios then call ioa_ ("dcw_offset = ^i; storlimit = ^i",
			dcw_offset, storlimit);
		     call return_stat;
		     return;
		end;

	     dcw_ptr = addrel (select_seg_ptr, dcw_offset); /* get address of dcw */
	     if select_seq_in_memory then
		if fixed (dcw.data_addr) >= storlimit	/* data address OOB? */
		then do;
		     status = 5;			/* DCW points outside of slave limits */
		     call return_stat;
		     return;
		end;

	     if fixed (dcw.count) ^= 1 then do;
		status = 6;			/* Seek DCW count is not 1 */
		call return_stat;
		return;
	     end;

	     seek_ptr = addrel (select_seg_ptr, dcw.data_addr);
	     i = seek_ptr -> seek_address;		/* grab seek address */
	     file_position (fn) = i*64;		/* multiply by block size */
	     seek_ptr -> seek_address = 0;		/* Clobber user's seek address */
	end;

	if db_ios then
	     if pat_body (fn).random then
		call ioa_ ("SDIA seek_address = ^o", i);
	     else call ioa_ ("SDIA (linked file)");

	component (fn) = divide (file_position (fn), sys_info$max_seg_size, 24, 0);
	last_component = (component (fn) + 1 >= no_components (fn));
	if last_component then
	     if file_size (fn) <= 0
	     then seg_length = 0;
	     else
	     seg_length = mod (file_size (fn)-1, sys_info$max_seg_size)+1;
	else seg_length = sys_info$max_seg_size;
	offset (fn) = mod (file_position (fn), sys_info$max_seg_size);
	if msf (fn) then
	     file_ptr = msf_array_ptr (fn) -> msf_components (component (fn));
	else file_ptr = single_segment_ptr (fn);
	file_ptr = addrel (file_ptr, offset (fn));

	if ^pat_body (fn).random then do;
	     if mod (file_position (fn), 320) ^= 0 then do;
		call com_err_ (0, "gtss_ios_", "Bug: file_position = ^i; not a multiple of 320",
		     file_position (fn));
dcl  gtss_ios_bug             condition;
		signal condition (gtss_ios_bug);
	     end;
	end;


bump:	;

	idptr = addrel (idptr, 2);			/* get ptr to new id word */
	opptr = addrel (idptr, -1);			/* build pointer to operation word */
	sptr = addrel (idptr, 1);			/* build pointer to return word */
	dcw_offset = fixed (id_word.dcwp);		/* get dcw list pointer */
	count = count + 1;
	goto lookup;

com_proc (2): ;					/* read disk continuous */

	if db_ios then call ioa_ ("RDIC");
	if ^seeksw then do;				/* read must be preceded by a seek */
	     status = 7;				/* Disk read or write not preceeded by a seek */
	     call return_stat;
	     return;
	end;

/* A null file cannot be read */
	if ^ap -> non_null then do;
	     status = 0;				/* eof encountered */
	     substr (slave_status, 7, 12) = "1700"b3;	/* set null file bit */

/* * ADD status word 1 record count residue setting? * */
	     call return_stat;
	     return;
	end;

	if select_seq_in_memory then
	     if dcw_offset >= storlimit then do;	/* dcw addr OOB? */
		status = 4;			/* DCW is outside of slave limits */
		call return_stat;
		return;
	     end;

	dcw_ptr = addrel (select_seg_ptr, dcw_offset);	/* get address of dcw */


/* Read Operation */

	disconnect = "0"b;
	tdcw_previous = "1"b;			/* Insure that the first DCW
						   will be rejected if a TDCW. */

read_loop: do dcw_number = 1 to 4096;

/* At this point dcw_ptr points to the next
   DCW to be interpreted. */

	     goto read_case (fixed (dcw.action));

read_case (4): ;
read_case (5): ;
read_case (6): ;
read_case (7): ;
	     status = 10;				/* Bad action code in DCW */
	     call return_stat;
	     return;

read_case (0): ;					/* IOTD */
	     disconnect = "1"b;

read_case (1): ;					/* IOTP */
	     if db_ios then do;
		if disconnect then call ioa_
		     ("IOTD count = ^o, address = ^o", fixed (dcw.count), fixed (dcw.data_addr));
		else call ioa_
		     ("IOTP count = ^o, address = ^o", fixed (dcw.count), fixed (dcw.data_addr));
	     end;
	     ta_offset = fixed (dcw.data_addr);
	     l = fixed (dcw.count);
	     if l = 0 then l = 4096;

restart_read:  ;
	     ta_ptr = addrel (ta_seg_ptr, ta_offset);
	     if ta_offset + l > storlimit | offset (fn) + l > seg_length
	     then do;

/* Control is transferred here when either
   1. The current DCW references outside the user's slave memory limits.
   or
   2. The end of file will be crossed by the current DCW.
   or
   3. The end of a file component will be crossed by the current DCW.
*/

		if read_memory_fault () then do;
		     call return_stat;
		     return;
		end;
		if read_end_of_file ("1"b) then do;
		     call return_stat;
		     return;
		end;
		call read_next_component ("1"b);
		goto restart_read;
	     end;
	     ta_ptr -> M = file_ptr -> M;		/* Data transfer */

/* Remember last address + 1 of data transferred */
	     da_residue = ta_offset + l;

read_file_posit: ;					/* Update position in file */
	     offset (fn) = offset (fn) + l;
	     file_ptr = addrel (file_ptr, l);
	     data_moved = data_moved +l;

	     if disconnect then do;
		wc_residue = 0;
		call return_stat;
		return;
	     end;

/* Move to next DCW */
	     dcw_offset = dcw_offset + 1;
	     if select_seq_in_memory then
		if dcw_offset > storlimit then do;
		     status = 4;			/* DCW is outside of slave limits */
		     call return_stat;
		     return;
		end;
	     dcw_ptr = addrel (select_seg_ptr, dcw_offset);
	     tdcw_previous = "0"b;
	     goto finished_read_dcw;

read_case (3): ;					/* IONTP */
	     if db_ios then
		call ioa_ ("IONTP count = ^o", fixed (dcw.count));
	     l = fixed (dcw.count);
	     if l = 0 then l = 4096;
restart_nonread: ;
	     if offset (fn) + l > seg_length then do;
		if read_end_of_file ("0"b) then do;
		     call return_stat;
		     return;
		end;
		call read_next_component ("0"b);
		goto restart_nonread;
	     end;
	     goto read_file_posit;			/* Update position in file */

read_case (2): ;					/* TDCW */
	     if db_ios then
		call ioa_ ("TDCW address = ^o", fixed (dcw.data_addr));
	     if tdcw_previous then do;
		status = 11;			/* Two TDCW's in a row */
		wc_residue = 0;
		call return_stat;
		return;
	     end;
	     tdcw_previous = "1"b;
	     dcw_offset = fixed (dcw.data_addr);
	     if select_seq_in_memory then
		if dcw_offset > storlimit then do;
		     status = 4;			/* DCW is outside of slave limits */
		     wc_residue = 0;
		     call return_stat;
		     return;
		end;
	     dcw_ptr = addrel (select_seg_ptr, dcw_offset);

finished_read_dcw: ;
	end read_loop;

	status = 12;				/* Maximum of 4096 DCW's exceeded */
	call return_stat;
	return;

com_proc (3): ;					/* write disk continuous */

	if db_ios then call ioa_ ("WDIC");
	if ^seeksw then do;				/* write must be preceded by a seek */
	     status = 7;				/* Disk read or write not preceeded by a seek */
	     call return_stat;
	     return;
	end;

	if ^permissions (fn).write then do;		/* write not allowed ? */
	     status = 2;				/* a write was attempted on a file which was
						   opened in read mode */
	     call return_stat;
	     return;
	end;

	if select_seq_in_memory then
	     if dcw_offset >= storlimit then do;	/* dcw addr OOB? */
		status = 4;			/* DCW is outside of slave limits */
		call return_stat;
		return;
	     end;

	dcw_ptr = addrel (select_seg_ptr, dcw_offset);	/* get address of dcw */

/* Write Operation */

	if ^ap -> non_null then do;
	     ap -> non_null = "1"b;
	     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.null_file = "1"b;
		gtss_file_values.data_flags.null_file = "0"b;

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

	end;
	write_performed (fn) = "1"b;
	disconnect = "0"b;
	tdcw_previous = "1"b;			/* Insure that the first DCW
						   will be rejected if a TDCW. */

	do dcw_number = 1 to 4096;

/* At this point dcw_ptr points to the next
   DCW to be interpreted. */

	     i = fixed (dcw.action);
	     goto write_case (i);

write_case (4): ;
write_case (5): ;
write_case (6): ;
write_case (7): ;
	     status = 10;				/* Bad action code in DCW */
	     call return_stat;
	     return;

write_case (0): ;					/* IOTD */
	     disconnect = "1"b;

write_case (1): ;					/* IOTP */
	     if db_ios then do;
		if disconnect then call ioa_
		     ("IOTD count = ^o, address = ^o", fixed (dcw.count), fixed (dcw.data_addr));
		else call ioa_
		     ("IOTP count = ^o, address = ^o", fixed (dcw.count), fixed (dcw.data_addr));
	     end;
	     ta_offset = fixed (dcw.data_addr);
	     l = fixed (dcw.count);
	     if l = 0 then l = 4096;

restart_write: ;
	     ta_ptr = addrel (ta_seg_ptr, ta_offset);
	     if ta_offset + l > storlimit | offset (fn) + l > seg_length
	     then do;

/* Control is transferred here when either
   1. The current DCW references outside the user's slave memory limits.
   or
   2. The end of file will be crossed by the current DCW.
   or
   3. The end of a file component will be crossed by the current DCW.
*/

		if write_memory_fault () then do;
		     call return_stat;
		     return;
		end;
		if write_end_of_file ("1"b) then do;
		     call return_stat;
		     return;
		end;
		call write_next_component ("1"b);
		goto restart_write;
	     end;
	     file_ptr -> M = ta_ptr -> M;		/* Data transfer */

/* Remember last address + 1 of data transferred */
	     da_residue = ta_offset + l;

write_file_posit: ;					/* Update position in file */
	     offset (fn) = offset (fn) + l;
	     file_ptr = addrel (file_ptr, l);
	     data_moved = data_moved +l;

	     if disconnect then do;
		wc_residue = 0;
		call write_to_end_of_sector;
		call return_stat;
		return;
	     end;

/* Move to next DCW */
	     dcw_offset = dcw_offset + 1;
	     if select_seq_in_memory then
		if dcw_offset > storlimit then do;
		     status = 4;			/* DCW is outside of slave limits */
		     call return_stat;
		     return;
		end;
	     dcw_ptr = addrel (select_seg_ptr, dcw_offset);
	     tdcw_previous = "0"b;
	     goto finished_write_dcw;

write_case (3): ;					/* IONTP */
	     if db_ios then
		call ioa_ ("IONTP count = ^o", fixed (dcw.count));
	     l = fixed (dcw.count);
	     if l = 0 then l = 4096;
restart_nonwrite: ;
	     if offset (fn) + l > seg_length then do;
		if write_end_of_file ("0"b) then do;
		     call return_stat;
		     return;
		end;
		call write_next_component ("0"b);
		goto restart_nonwrite;
	     end;
	     unspec (file_ptr -> M) = "0"b;		/* Nondata transfer */
	     goto write_file_posit;			/* Update position in file */

write_case (2): ;					/* TDCW */
	     if db_ios then
		call ioa_ ("TDCW address = ^o", fixed (dcw.data_addr));
	     if tdcw_previous then do;
		status = 11;			/* Two TDCW's in a row */
		wc_residue = 0;
		call return_stat;
		return;
	     end;
	     tdcw_previous = "1"b;
	     dcw_offset = fixed (dcw.data_addr);
	     if select_seq_in_memory then
		if dcw_offset > storlimit then do;
		     status = 4;			/* DCW is outside of slave limits */
		     wc_residue = 0;
		     call return_stat;
		     return;
		end;
	     dcw_ptr = addrel (select_seg_ptr, dcw_offset);

finished_write_dcw: ;
	end;					/* End write loop do. */

	status = 12;				/* Maximum of 4096 DCW's exceeded */
	call return_stat;
	return;


com_proc (4): ;					/* rewind disk/drum */

	if db_ios then call ioa_ ("REW");
	if pat_body (fn).random then do;		/* abort if random */
	     status = 8;				/* attempt to space or rewind random file */
	     call return_stat;
	     return;
	end;

	file_position (fn) = 0;
	call return_stat;
	return;

com_proc (5): ;					/* backspace disk/drum */

	bksp_sw = "1"b;				/* remember backspace */
	if db_ios then
	     call ioa_ ("BSR count = ^o", fixed (op_word.count));


bksp_share:

	if pat_body (fn).random then do;		/* abort if random */
	     status = 8;				/* attempt to space or rewind random file */
	     call return_stat;
	     return;
	end;
	if ^ap -> non_null then do;			/* is this a null file ? */
	     status = 1;				/* eof encountered */

/* * ADD status word 1 record count residue setting? * */
	     call return_stat;
	     return;
	end;

	j = fixed (op_word.count);			/* extract fixed(op_word.count) */
	if j = 0 then j = 64;			/* zero count means 64 */
	j = 320*j;
	if bksp_sw then j = -j;

	file_position (fn) = file_position (fn) + j;

/* * NOTE:  Add code to provide:
   1) load point status of positioned off front of file.
   2) setting status word 1 record count residue (right 6bits)
   if positioned off either end of the file.
   * */
	if file_position (fn) < 0 then file_position (fn) = 0; /* allow for backspace too far */
	if file_position (fn) > file_size (fn) then do;	/* check for end of file */
	     status = 1;				/* end of file encountered */

	     rec_ct_residue = divide (file_position (fn) - file_size (fn), 320, 17, 0);
	     substr (slave_status, 31, 6) = substr (unspec (rec_ct_residue), 31, 6);

	     file_position (fn) = file_size (fn);

	end;


	call return_stat;
	return;					/* process status */

com_proc (6): ;					/* forward space disc/drum */

	bksp_sw = "0"b;				/* remember forward space */
	if db_ios then
	     call ioa_ ("FSR count = ^o", fixed (op_word.count));

	goto bksp_share;				/* now go share backspace code */

com_proc (7): ;					/* reset status for disk/drum */

	if db_ios then call ioa_ ("RESS");
	call return_stat;
	return;

com_proc (8): ;					/* request status for disk/drum */

	if db_ios then call ioa_ ("REQS");
	call return_stat;
	return;
/* 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;

read_end_of_file: proc (data_transfer) returns (bit (1) aligned);

dcl  data_transfer            bit (1) aligned parm	/* Input parameter which indicates
				whether data is to be transferred to memory ("1"b)
				or skipped ("0"b). */;


/* This routine checks to see if the current DCW causes the end of file boundary
   to be crossed.  If so, and the data_transfer flag is on, this routine
   transfers as much data as possible.	The end of file is indicated for random files by
   returning "1"b.	If no end of file, no data is transferred and "0"b is returned.
*/

/* Determine whether end of file is the problem */
	     wc_residue = l;
	     l = seg_length - offset (fn);
	     data_moved = data_moved +l;
	     if last_component then do;
		status = 1;			/* eof encountered */
		if l < 1 then return ("1"b);		/* Indicate end of file */;
		if data_transfer then do;
		     ta_ptr -> M = file_ptr -> M;	/* Data transfer */
		     da_residue = ta_offset + l;
		end;
		wc_residue = wc_residue - l;
dcl  x                        fixed bin;
		x = divide (wc_residue, 320, 17);
		if db_ios then call ioa_ ("ios: wc_residue=^i (mod 320 ^a) rec_count_residue=^i"
		     , wc_residue
		     , substr ("no yes", (fixed (mod (wc_residue, 320) = 0, 17)*3)+1, 3)
		     , x);
		substr (slave_status, 31, 6) = bit (fixed (x, 6)); /* => Record count residue. */
		return ("1"b);			/* Indicate end of file */
	     end;
	     return ("0"b);				/* Not end of file */
	end read_end_of_file;

read_memory_fault: proc returns (bit (1) aligned);


/* This routine checks to see if the current DCW would cause
   data to be transferred outside of the user's slave memory limits.
   If so this routine transfers as much data as possible and
   returns "1"b.  If not, no data is transferred and "0"b is returned.
   In the special case that the current DCW would cause the end of
   file to be encountered before exceeding memory limits, then no data
   is transferred and "0"b is returned.
*/

	     if ta_offset - storlimit > offset (fn) - seg_length
	     then do;				/* Slave memory is the most severe
						   limitation on this read. */
		status = 5;			/* DCW references outside of slave limits */
		wc_residue = l;
		l = storlimit - ta_offset;
		if l < 1 then return ("1"b);		/* Indicate memory fault */;
		wc_residue = wc_residue -l;
		ta_ptr -> M = file_ptr -> M;		/* Data transfer */
		da_residue = ta_offset + l;
		data_moved = data_moved +l;
		return ("1"b);			/* Indicate memory fault */
	     end;
	     return ("0"b);				/* No memory fault */
	end read_memory_fault;

read_next_component: proc (data_transfer);

dcl  data_transfer            bit (1) aligned parm	/* Input parameter which indicates
				whether data is to be transferred to memory ("1"b)
				or skipped ("0"b). */;

/* This routine handles the case that the end of the current component
   of a multisegment file will be crossed by the current DCW when
   the current component is not the last one.  The remaining data in
   the current component is transferred to slave memory (if the data_transfer
   flag is on) and the next component is made current.
*/

	     if l >= 1 & data_transfer then do;
		ta_ptr -> M = file_ptr -> M;		/* Data Transfer */
		da_residue, ta_offset = ta_offset + l;
	     end;

	     l = wc_residue - l;
	     component (fn) = component (fn) + 1;
	     last_component = (component (fn) + 1 >= no_components (fn));
	     file_ptr = msf_array_ptr (fn) -> msf_components (component (fn));
	     offset (fn) = 0;
	     if last_component then
		seg_length = mod (file_size (fn)-1, sys_info$max_seg_size)+1;
	     else seg_length = sys_info$max_seg_size;
	     return;
	end read_next_component;

return_stat: proc;


/* If this is a five word select sequence then the pointer to the status return address,
   sptr, may have to be adjusted. */
	     if count = 1 then do;
		cmd_word = io_commands (1);		/* seek command */
		if substr (cmd_word, 1, 6) = op_word.dev_com then /* are device and */
		     if substr (cmd_word, 19, 5) = op_word.ioc_com then /* ioc commands = ? */
			sptr = addrel (sptr, 2);
	     end;
	     if ^pat_body (fn).random then do;
		file_position (fn) = file_position (fn) + data_moved;
		i = mod (file_position (fn), 320);
		if i > 0 then file_position (fn) = file_position (fn) + 320 - i;
	     end;
	     if db_ios then
		call ioa_ ("Status return address = ^o", fixed (return_word.status_return));
	     if select_seq_in_memory &
	     fixed (return_word.status_return) >= storlimit then do;
		if status = 0 then status = 9;	/* Status return address is
						   outside of slave limits */
		swptr = addr (scratch_status);
	     end;
	     else do;
		if return_word.status_return = (18)"0"b then /* program doesn't want status */
		     swptr = addr (scratch_status);	/* so fake a return area */

		else swptr = addrel (select_seg_ptr, return_word.status_return); /* get address of status words */
	     end;

	     sw1 = slave_status;			/* move status into slave */
	     sw2 = "0"b;

	     substr (sw2, 25, 12) = substr (unspec (wc_residue), 25, 12); /* return word count */
	     substr (sw2, 1, 18) = substr (unspec (da_residue), 19, 18); /* and data address residues */
	     if status < lbound (err_case, 1) | status > hbound (err_case, 1) then return;
	     goto err_case (status);

err_case (0):  ;
err_case (2):  ;
err_case (3):  ;
err_case (4):  ;
err_case (5):  ;
err_case (6):  ;
err_case (7):  ;
err_case (8):  ;
err_case (9):  ;
err_case (10): ;
err_case (13): ;
	     goto done_stat;

err_case (1):  ;					/* End of file was encountered */
	     substr (sw1, 3, 4) = "1111"b;
	     goto done_stat;

err_case (11): ;					/* Two TDCW's in a row */
	     substr (sw1, 22, 3) = "010"b;
	     goto done_stat;

err_case (12): ;					/* Maximum of 4096 DCW's exceeded */
	     substr (sw1, 22, 3) = "001"b;
	     goto done_stat;

done_stat:     ;
	     if db_ios then
		call ioa_ ("Status =  Word1: ^12o Word2: ^12o", fixed (sw1), fixed (sw2));

	     return;
dcl  i                        fixed bin (24);
	end					/* return_stat */;

write_end_of_file: proc (data_transfer) returns (bit (1) aligned);

dcl  data_transfer            bit (1) aligned parm	/* Input parameter which indicates
				whether data is to be transferred to memory ("1"b)
				or skipped ("0"b). */;


/* This routine checks to see if the current DCW causes the end of file boundary
   to be crossed.  If so, and the data_transfer flag is on, this routine
   transfers as much data as possible.	The end of file is indicated by
   returning "1"b.	If no end of file, no data is transferred and "0"b is returned.
*/

/* Determine whether end of file is the problem */
	     wc_residue = l;
	     l = seg_length - offset (fn);
	     data_moved = data_moved +l;
	     if last_component then do;
		status = 1;			/* eof encountered */
		if l < 1 then return ("1"b);		/* Indicate end of file */;
		if data_transfer then do;
		     file_ptr -> M = ta_ptr -> M;	/* Data transfer */
		     da_residue = ta_offset + l;
		end;
		else unspec (file_ptr -> M) = "0"b;	/* Nondata transfer */
		wc_residue = wc_residue - l;
dcl  x                        fixed bin;
		x = divide (wc_residue, 320, 17);
		if db_ios then call ioa_ ("ios: wc_residue=^i (mod 320 ^a) rec_count_residue=^i"
		     , wc_residue
		     , substr ("no yes", (fixed (mod (wc_residue, 320) = 0, 17)*3)+1, 3)
		     , x);
		substr (slave_status, 31, 6) = bit (fixed (x, 6)); /* => Record count residue. */
		return ("1"b);			/* Indicate end of file */
	     end;
	     return ("0"b);				/* Not end of file */
	end write_end_of_file;

write_memory_fault: proc returns (bit (1) aligned);


/* This routine checks to see if the current DCW would cause
   data to be transferred outside of the user's slave memory limits.
   If so this routine transfers as much data as possible and
   returns "1"b.  If not, no data is transferred and "0"b is returned.
   In the special case that the current DCW would cause the end of
   file to be encountered before exceeding memory limits, then no data
   is transferred and "0"b is returned.
*/

	     if ta_offset - storlimit > offset (fn) - seg_length
	     then do;				/* Slave memory is the most severe
						   limitation on this write. */
		status = 5;			/* DCW references outside of slave limits */
		wc_residue = l;
		l = storlimit - ta_offset;
		if l < 1 then return ("1"b);		/* Indicate memory fault */;
		wc_residue = wc_residue -l;
		file_ptr -> M = ta_ptr -> M;		/* Data transfer */
		da_residue = ta_offset + l;
		data_moved = data_moved +l;
		return ("1"b);			/* Indicate memory fault */
	     end;
	     return ("0"b);				/* No memory fault */
	end write_memory_fault;

write_next_component: proc (data_transfer);

dcl  data_transfer            bit (1) aligned parm	/* Input parameter which indicates
				whether data is to be transferred to memory ("1"b)
				or skipped ("0"b). */;

/* This routine handles the case that the end of the current component
   of a multisegment file will be crossed by the current DCW when
   the current component is not the last one.  The remaining data in
   the current component is transferred from slave memory (if the data_transfer
   flag is on) and the next component is made current.
*/

	     if l >= 1 & data_transfer then do;
		file_ptr -> M = ta_ptr -> M;		/* Data Transfer */
		da_residue, ta_offset = ta_offset + l;
	     end;
	     else unspec (file_ptr -> M) = "0"b;	/* Nondata transfer */

	     l = wc_residue - l;
	     component (fn) = component (fn) + 1;
	     last_component = (component (fn) + 1 >= no_components (fn));
	     file_ptr = msf_array_ptr (fn) -> msf_components (component (fn));
	     offset (fn) = 0;
	     if last_component then
		seg_length = mod (file_size (fn)-1, sys_info$max_seg_size)+1;
	     else seg_length = sys_info$max_seg_size;
	     return;
	end write_next_component;

write_to_end_of_sector: proc;

/* This routine writes zeros from the current file position to the
   nearest sector (64 word) boundary.  If the file is currently
   positioned at a sector boundary, no writing is done.
*/

	     i = mod (offset (fn), 64);
	     if i > 0 then do;
		l = 64 - i;
		unspec (file_ptr -> M) = "0"b;
	     end;
	     return;

dcl  i                        fixed bin (24);

	end write_to_end_of_sector;

/* 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_io_ */;
  



		    gtss_verify_access_.pl1         12/11/84  1349.3rew 12/10/84  1043.8      107280


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

/* *************************************************************
   *						   *
   * Copyright (c) 1979 by Honeywell Information Systems, Inc. *
   *						   *
   ************************************************************* */
gtss_verify_access_: proc (dname, ename, fn, permissions, gcos_status);

/* This program attempts to simulate the method in which GCOS propagates permissions
   thru catalogs.  On each catalog created by gtss, the 10-bit permissions word passed
   to filact is converted to a character string and placed in the person field of an acl.
   The project field is either "*" for general permissions or an all upper-case project
   name for specific permissions.  The tag field is always "g".  On files, filact puts
   the permissions in a more typical Multics acl with *.*.* for general and *.project.*
   for specific, project again being all upper case.  Because of the way GCOS does things,
   and because of the way in which we have implemented this on Multics, it is possible
   that a user may be able to access a file on which he does not have the appropriate
   Multics access.  In such a case, the appropriate access is forced for that individual
   (person.project.*), a bit is set in the aft to indicate that this has been done, and
   at gtss_ios_close_ time, a call is made to gtss_verify_access_$check_forced_access
   who removes that forced access if it is there.

   Author:  Paul W. Benjamin	12/14/79

   Change:  Paul Benjamin	01/10/79	Resolve problems when accessing libraries.
   Change:  Paul Benjamin     04/03/80  Additional error checking.
*/

dcl (dname, ename) char (*) parameter;
dcl  fn fixed bin (24) parameter;
dcl  permissions bit (6) parameter;
dcl  gcos_status bit (12) aligned parameter;

	gtss_ext_$aft.aft_entry.forced (fn) = "0"b;
	call user_info_ (person, umc, acct);
	UMC = translate (umc, "QWERTYUIOPASDFGHJKLZXCVBNM", "qwertyuiopasdfghjklzxcvbnm");
	call hcs_$get_author (
	     dname
	     , ename
	     , 1b
	     , originator
	     , code
	     );
	if code ^= 0 then do;
	     gcos_status = "4003"b3;
	     return;
	end;
	originator = substr (originator, index (originator, ".")+1);
	originator = substr (originator, 1, index (originator, ".")-1);
	if originator = umc then do;
	     a = empty ();
	     call msf_manager_$acl_list (
		fcb_ptr (fn)
		, gtss_ext_$hcs_work_area_ptr
		, sa_ptr
		, null ()
		, sa_count
		, code
		);
	     if code ^= 0 then do;
		gcos_status = "4003"b3;
		return;
	     end;
	     mu_need = "10"b||substr (permissions, 2, 1);
	     goto force_access;
	end;
	drm_len = length (rtrim (gtss_ext_$drm_path));
	temp_dir = gtss_ext_$drm_path;
	temp_name = substr (dname, drm_len+2);

	do i = 1 to 10;				/* Find levels betwixt umc and files */
	     if index (temp_name, ">") ^= 0 then do;
		cat_dir (i) = temp_dir;
		cat_name (i) = substr (temp_name, 1, index (temp_name, ">")-1);
		temp_dir = rtrim (temp_dir)||">"||cat_name (i);
		temp_name = substr (temp_name, index (temp_name, ">")+1);
	     end;
	     else do;
		cat_dir (i) = temp_dir;
		cat_name (i) = temp_name;
		cat_dir (i+1) = "";
		cat_num = i;
		i = 10;
	     end;
	end;

	do i = 1 to cat_num;			/* Find propagation acls for general and specific at each level.  */
	     a = empty ();
	     call hcs_$list_dir_acl (
		cat_dir (i)
		, cat_name (i)
		, gtss_ext_$hcs_work_area_ptr
		, da_ptr
		, null ()
		, da_count
		, code
		);
	     found_sp, found_gp = "0"b;
	     if code ^= 0 then do;
		gcos_status = "4003"b3;
		return;
	     end;
	     do j = 1 to da_count;
		if index (da_name (j), "."||rtrim (UMC)||".g") ^= 0 then do;
		     cat.sp (i) = substr (da_name (j), 1, 10);
		     found_sp = "1"b;
		end;
		else if index (da_name (j), ".*.g") ^= 0 then do;
		     cat.gp (i) = substr (da_name (j), 1, 10);
		     found_gp = "1"b;
		end;
		if found_gp & found_sp then j = da_count;
		if j = da_count & ^found_gp then cat.gp (i) = "NONE";
		if j = da_count & ^found_sp then cat.sp (i) = "NONE";
	     end;
	end;
	gp_result, sp_result = "0000000000"b;		/* Initialize accumulated permissions to empty. */
	exclude = "0"b;

	do i = 1 to cat_num;			/* Accumulate permissions thru each catalog level. */
	     if cat.gp (i) ^= "NONE" then gp_result = bit (cat.gp (i), 10)|gp_result;
	     if cat.sp (i) ^= "NONE" then do;
		if cat.sp (i) = "0000000000" then do;
		     exclude = "1"b;
		     sp_result = "0"b;
		end;
		else sp_result = bit (cat.sp (i), 10)|sp_result;
	     end;
	end;

	request = bin (permissions);			/* Determine needed access. */
	goto check_request (request);
check_request (5):
check_request (6):
check_request (7):
check_request (9):
check_request (10):
check_request (11):
check_request (12):
check_request (13):
check_request (14):
check_request (15):
check_request (18):
check_request (19):
check_request (21):
check_request (22):
check_request (23):
check_request (24):
check_request (25):
check_request (26):
check_request (27):
check_request (28):
check_request (29):
check_request (30):
check_request (31):
check_request (34):
check_request (35):
check_request (36):
check_request (37):
check_request (38):
check_request (39):
check_request (41):
check_request (42):
check_request (43):
check_request (45):
check_request (46):
check_request (47):
check_request (50):
check_request (51):
check_request (52):
check_request (53):
check_request (54):
check_request (55):
check_request (56):
check_request (57):
check_request (58):
check_request (59):
check_request (61):
check_request (62):
check_request (63):
	gcos_status = "4044"b3;			/* Illegal options combination. */
	return;
check_request (0):
check_request (1):
check_request (2):
check_request (3):
check_request (32):
check_request (33):
check_request (44):
	gc_need = "1000000000"b;			/* GCOS r, Multics r */
	mu_need = "100"b;
	goto check_end;
check_request (4):
	gc_need = "0001000000"b;			/* GCOS e, Multics r */
	mu_need = "100"b;
	goto check_end;
check_request (8):
	gc_need = "0010000000"b;			/* GCOS a, Multics r */
	mu_need = "100"b;
	goto check_end;
check_request (16):
check_request (17):
check_request (20):
check_request (48):
check_request (49):
	gc_need = "0100000000"b;			/* GCOS w, Multics rw */
	mu_need = "101"b;
	goto check_end;
check_request (40):
	gc_need = "1010000000"b;			/* GCOS ra, Multics r */
	mu_need = "100"b;
	goto check_end;
check_request (60):
	gc_need = "0000000001"b;			/* GCOS x, Multics rw */
	mu_need = "101"b;
check_end:

	a = empty ();				/* Look at segment acl */
	call msf_manager_$acl_list (
	     fcb_ptr (fn)
	     , gtss_ext_$hcs_work_area_ptr
	     , sa_ptr
	     , null ()
	     , sa_count
	     , code
	     );
	if code ^= 0 then do;
	     gcos_status = "4003"b3;
	     return;
	end;
	found_gp, found_sp = "0"b;
	do i = 1 to sa_count;
	     if sa_name (i) = "*.*.*" then do;
		sa_gp = substr (sa_modes (i), 1, 3);
		found_gp = "1"b;
	     end;
	     else if sa_name (i) = "*."||rtrim (UMC)||".*" then do;
		sa_sp = substr (sa_modes (i), 1, 3);
		found_sp = "1"b;
	     end;
	     if found_gp & found_sp then i = sa_count;
	end;

	if exclude | sp_result ^= "0"b | found_sp then do; /* Must check SPECIFIC permissions. */

	     if (^gc_need | sp_result) ^= "1111111111"b then do; /* Have NOT accumulated enough permission thru catalogs. */
		if (^(mu_need) | sa_sp) ^= "111"b then goto permission_denied; /* Haven't on file, either */
		else goto force_access;		/* Do have access to file but acl may be upper case. */
	     end;
						/* HAVE accumulated enough permission thru catalogs */
	     else if ^found_sp then goto force_access;	/* But not on file, go force */
	     else if sa_sp = "000"b then goto permission_denied; /* Specifically excluded from file */
	     else if (^(mu_need) | sa_sp) ^= "111"b then goto force_access; /* Not enough on file, force */
	     else goto force_access;			/* Again acl may be upper case */
	end;
	else do;					/* Must check GENERAL permissions. */
	     if (^gc_need | gp_result) ^= "1111111111"b then do; /* Have NOT accumulated enough permission thru catalogs. */
		if (^(mu_need) | sa_gp) ^= "111"b then goto permission_denied; /* Haven't on file either. */
		else goto permission_granted;		/* Do have the access on the file */
	     end;
						/* HAVE accumulated enough permissions thru catalogs. */
	     else if ^found_gp then goto force_access;
	     else if sa_gp = "000"b then goto permission_denied; /* Specifically excluded. */
	     else if (^(mu_need) | sa_gp) ^= "111"b then goto force_access; /* Not enough on file, force. */
	     goto permission_granted;			/* Everything's cool */
	end;
permission_denied:
	gcos_status = "4003"b3;			/* Permissions denied. */
	return;
permission_granted:
	gcos_status = "4000"b3;			/* Successful. */
	return;
force_access:
	gtss_ext_$aft.aft_entry.forced (fn) = "1"b;
	do i = 1 to sa_count;			/* Check for real (upper&lower case) acl */
	     if sa_name (i) = "*.*.*"
	     | sa_name (i) = "*."||rtrim (umc)||".*"
	     | sa_name (i) = rtrim (person)||"."||rtrim (umc)||".*"
	     | sa_name (i) = rtrim (person)||".*.*" then do;

/* Found it and don't need to force access. */
		if (^(mu_need)|substr (sa_modes (i), 1, 3)) = "111"b then do;
		     gtss_ext_$aft.aft_entry.forced (fn) = "0"b;
		     i = sa_count;
		end;
	     end;
	end;
	if gtss_ext_$aft.aft_entry.forced (fn) = "1"b then do;
	     sa_count = 1;
	     sa_name (1) = rtrim (person)||"."||rtrim (umc)||".*";
	     sa_modes (1) = mu_need;
	     call msf_manager_$acl_add (		/* FORCE IT! */
		fcb_ptr (fn)
		, sa_ptr
		, 1
		, code
		);
	     if code ^= 0 then goto permission_denied;
	end;
	goto permission_granted;

check_forced_access: entry (dname, ename, fn);

/* Remove forced acl, if set. */

	if gtss_ext_$aft.aft_entry.forced (fn) then do;
	     call user_info_ (
		person
		, umc
		, acct
		);
	     dl_name = rtrim (person)||"."||rtrim (umc)||".*";
	     call msf_manager_$acl_delete (
		fcb_ptr (fn)
		, addr (dl_array)
		, 1
		, code
		);
	end;
	return;

dcl  a area (1000) based (gtss_ext_$hcs_work_area_ptr);
dcl  acct char (32);
dcl 1 cat (7),
    2 cat_dir char (168),
    2 cat_name char (32),
    2 gp char (10),
    2 sp char (10);
dcl  cat_num fixed;
dcl  code fixed bin (35);
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  da_count fixed bin;
dcl  da_ptr ptr;
dcl 1 dl_array,
    2 dl_name char (32),
    2 dl_code fixed bin (35);
dcl  drm_len fixed;
dcl  exclude bit (1);
dcl (found_gp, found_sp) bit (1);
dcl  gc_need bit (10);
dcl  gp_result bit (10);
dcl  hcs_$get_author entry (char (*), char (*), fixed bin (1), char (*), fixed bin (35));
dcl  hcs_$list_dir_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl (i, j) fixed bin;
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  msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl  mu_need bit (3);
dcl  originator char (32);
dcl  person char (22);
dcl  request fixed bin;
dcl 1 sa_array (sa_count) based (sa_ptr),
    2 sa_name char (32),
    2 sa_modes bit (36),
    2 sa_pad bit (36),
    2 sa_code fixed bin (35);
dcl  sa_count fixed bin;
dcl  sa_gp bit (3);
dcl  sa_ptr ptr;
dcl  sa_sp bit (3);
dcl  sp_result bit (10);
dcl  temp_dir char (168);
dcl  temp_name char (32);
dcl (umc, UMC) char (9);
dcl  user_info_ entry (char (*), char (*), char (*));

%include gtss_ext_;

%include gtss_dfd_ext_;
     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

*/