



		    PNOTICE_gcos.alm                11/14/89  1100.2r w 11/14/89  1100.1        3555



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

	aci	"C1GBEM0B0000"
	aci	"C2GBEM0B0000"
	aci	"C3GBEM0B0000"
	end




		    gcos.pl1                        12/11/84  1357.5rew 12/10/84  1035.9      319680



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos: gc: proc;

/*

   This procedure is invoked when a user types the "gcos" command.

   It  interprets  all  of the command arguments, setting switches
   and  storing  values  in  external  static  variables,  and  it
   verifies  the existence of the input segment(s).  It then calls
   gcos_gein_, which processes the gcos job deck and runs the job.

*/
%page;
/*

  Author: T. CASEY		MAR 1973
  Change: T. CASEY		OCT 1973
			FEB 1974
			APR 1974
			MAY 1974
			AUG 1974
  Change: D. KAYDEN		FEB 1975
  Change: M. R. JORDAN	JUN 1976	To process "-smc" control argument.
  Change: Mel Wilson	MAR 1979	For gtss interface and -ident option.
  Change: Mel Wilson	OCT 1979	For gtss ring_bracket compatibility.
  Change: Dave Ward		MAY 1981	DBS entry, source reorganized.
  Change: Scott Akers   	DEC 1981	Fix "-syot_dir" control_arg.
				Change "expand_path_" to "expand_pathname_."
		    2.5	FEB 1982	Add "-block" control_arg.
  Change: Ron Barstad   2.5   Sep 1982  Fix usage statement to be only 1 line
  Change: Ron Barstad   3.0   Feb 1983  Change version to "3.0" for 4JS3
  Change: Ron Barstad   3.1   83-02-15  Add init for $param vaules to ""
                                        Fix bug: was not processing past first
                                        -param value! missplaced label end_arg_loop
                                        Allow non-control args to start with "-" by adding -string arg
                                        Allow null "" param after -param.
  Change: Ron Barstad   3.2   83-04-28  Delete long gcos$dbs usage message
                                        Update spawn & task versions
                                        Make default buffer size 4096, remove workspace.acs check
                                        Declared some undeclared builtins
  Change: Ron Barstad  3.3  83-08-02    Added activity_card_num to ext static
  Change: Ron Barstad  3.4  83-08-10    Added 4js3 control cards

*/
%page;

	me = "gcos (4.0)";
	goto gcos_common;

spawn:	entry;
	temp_spawnflag = "1"b;
	me = "gcos$spawn (4.0)";
	goto gcos_common;

task:	entry;
	temp_taskflag = "1"b;
	me = "gcos$task (4.0)";
	goto gcos_common;

dbs:	entry;
	call cu_$arg_ptr (i, pp, lp, code);
	call gcos_dbs;
	goto exit_gcos;

gcos_common:

	on condition (cleanup) begin;
	     simulator_already_active = "0"b;
	end;

	if   simulator_already_active
	then do;
	     call com_err_ (
		0
		, me
		, "job already active, you must complete it (""start"")"
		||"^/or terminate it (""release"") before starting another one."
		);
	     goto fatal_error;
	     end;

	call initialize_routine;			/* Do all the init stuff. */

	call process_args;				/* Now, dink around with the args. */


/*	NOW ALL ARGUMENTS HAVE BEEN PROCESSED - SEE IF THERE WERE ANY PROBLEMS */

	if ^job_deck
	then do;					/* If job deck pathname not given, complain. */
	     call com_err_ (error_table_$noarg,
			me, "No job deck pathname given.");
	     goto fatal_error;
	     end;

	if expecting
	then do;					/* If we were waiting for something, complain. */
	     call com_err_ (error_table_$noarg,
			me, "^/Could not find expected argument after ""^a"" ",
			targ);
	     goto fatal_error;
	     end;

/* check for job deck segment pathname to be used as job id */

	if id_jd | gcos_ext_stat_$job_id = "" then do;	/* default, if not specified */
						/* get rid of ".gcos" appendage, if it's there */
	     i = index (jd_ename, ".gcos");		/* look for .gcos */
	     if i = 0 then				/* if not there */
		i = length (rtrim (jd_ename))+1;

	     if i > 19				/* If job ID longer than 18 characters, */
	     then do;				/* truncate it and warn user. */

		i = 19;				/* 19 since i-1 is used below */
		call com_err_ (0, me,
			     "Job ID too long. Using first 18 chracters"
			  || " (""^a"")", (substr (jd_ename, 1, 18)));

		end;

	     gcos_ext_stat_$job_id = substr (jd_ename, 1, i-1);

	end;					/* end of id_jd do group */

/*     SET SYSOUT OPTIONS  */

	if dpo_given then
	     gcos_ext_stat_$save_data.dprint = "1"b;	/* if dprint (or dpunch) options given */
	else gcos_ext_stat_$dpo = "-dl";		/* the default is delete */
	if dpno_given then
	     gcos_ext_stat_$save_data.dpunch = "1"b;	/* then dprint (or dpunch) is implied */
	else gcos_ext_stat_$dpno = "-dl";		/* the default is delete */

	if gcos_ext_stat_$save_data.dprint then gcos_ext_stat_$save_data.list = "1"b; /* if dprint (or dpunch) to be done */
	if gcos_ext_stat_$save_data.dpunch then gcos_ext_stat_$save_data.raw = "1"b; /* then conversion from bcd is implied */

/* see if defaults are to be used */

	if ^hold_given then do;			/* set defaults, if not told to skip it */
	     if ^gcos_ext_stat_$save_data.raw then	/* if nothing said about punch files */
		gcos_ext_stat_$save_data.raw, gcos_ext_stat_$save_data.dpunch = "1"b; /* the default is convert and punch */

	     if ^gcos_ext_stat_$save_data.list then	/* if nothing said about print files */
		gcos_ext_stat_$save_data.list, gcos_ext_stat_$save_data.dprint = "1"b; /* the default is convert and print */
	end;					/* end of set defaults do group */


	gcos_ext_stat_$dpno = gcos_ext_stat_$dpno || " -raw"; /* raw option always used, since any other
						   way would produce garbage on the cards */

/*    FUSSY WARNING MESSAGES */

	if gcos_ext_stat_$save_data.gcos then
	     if gcos_ext_stat_$save_data.no_canonicalize then do;
		warning_return = ignored_ncan;
		err_msg = "-no_canonicalize ignored - valid only for ascii job deck segment";
com_err_inconsistent:
		call com_err_ (0, me, "Warning:" || err_msg);

		goto warning_return;
	     end;

ignored_ncan:
	if gcos_ext_stat_$save_data.gcos then if gcos_ext_stat_$save_data.truncate then do;
		warning_return = ignored_truncate;
		err_msg = "-truncate ignored - valid only for ascii job deck segment";
		goto com_err_inconsistent;
	     end;

ignored_truncate:

/*	END OF ARGUMENT LIST PROCESSING */

/* for debugging arg list processing */

	if gcos_ext_stat_$stop_code = 1 then do;
	     call ioa_ ("Results of arg list processing:");
	     call ioa_ ("gcos_ext_stat_$save_data.flgs: ^12.3b", unspec (gcos_ext_stat_$save_data.flgs));
	     call ioa_ ("job id: ^a", gcos_ext_stat_$job_id);
	     call ioa_ ("temp_dir: ^a", gcos_ext_stat_$temp_dir);
	     call ioa_ ("input seg: ^a", gcos_ext_stat_$input_segment_path);
	     call ioa_ ("jd_ename: ^a", jd_ename);
	     call ioa_ ("dprint options: ^a", gcos_ext_stat_$dpo);
	     call ioa_ ("dpunch options: ^a", gcos_ext_stat_$dpno);
	     call ioa_ ("pdir: ^a", gcos_ext_stat_$pdir);
	     call ioa_ ("save_dir: ^a", gcos_ext_stat_$save_dir);
	     call ioa_ ("nargs: ^d", nargs);
	     call ioa_ ("DB:");
	     call db;
						/* to allow looking at others */
						/* .q to get out of db */
	     goto fatal_error;			/* to get any necessary cleaning up done */
	end;

	gcos_ext_stat_$abort_return = fatal_error;	/* set up abort nonlocal goto */

	gcos_ext_stat_$validation_level = get_ring_ ();	/* set up ring numbers for created branches */
	if gcos_ext_stat_$save_data.gtssflag & (gcos_ext_stat_$validation_level < 4) then do;
	     gcos_ext_stat_$dir_rings (1) = gcos_ext_stat_$validation_level;
	     gcos_ext_stat_$dir_rings (2), gcos_ext_stat_$dir_rings (3)
		, gcos_ext_stat_$seg_rings (*)
		= 4;
	end;
	else gcos_ext_stat_$dir_rings (*), gcos_ext_stat_$seg_rings (*) = gcos_ext_stat_$validation_level;

	call gcos_gein_ ;				/* go read job deck and run job */

fatal_error:					/* if an abort occurs, control returns here via a nonlocal
						   transfer to gcos_ext_stat_$abort_return, causing the stack
						   to be cleaned up, and cleanup handlers to be invoked */
	simulator_already_active = "0"b;		/* allow simulator to be invoked again */

exit_gcos:	;

	return;
%page;
gcos_dbs: proc;

/* Process argument(s) to switch debug switches.
*/
	do i = 1 by 1;
	     call cu_$arg_ptr (i, pp, lp, code);
	     if code ^= 0 then do;
		if i<2
		then call print_dbs_usage;
		goto fatal_error;
	     end;
	     if targ = "-print" | targ = "-pr" then do;
		do j = 1 to hbound (dbs_names, 1);
		     call ioa_ (
			"^3i. ^[ ON^;OFF^] ^a"
			, j
			, dbsv (j)
			, dbs_names (j)
			);
		end;
	     end;
	     else do;
		if lp<2 then targ_fc, tl = length (targ); /* Use whole targ. */
		else do;				/* Examine for leading "^" and comma. */
		     if substr (targ, 1, 1) = "^" then targ_fc = 2; /* Start with 2nd character of targ, exclude "^". */
		     else targ_fc = 1;		/* Start with 1st character of targ. */
		     tl = index (substr (targ, targ_fc), ",");
		     if tl = 0 then			/* No comma in argument string. */
			tl = length (targ) - targ_fc + 1; /* Use the whole available string. */
		     else				/* There is a comma. */
		     tl = tl - 1;			/* Use the available string up to the comma. */
		end;
		do j = 1 to hbound (dbs_names, 1);
		     if substr (targ, targ_fc, tl) = dbs_names (j) then do;
			dbsv (j) = (targ_fc = 1);

/* Locate the portion of "targ" after the first comma. */
			if (targ_fc+tl) > length (targ) then do; /* There is none. */
			     ta_fc = 1;		/* Let 1st character be at one, */
			     ta_ln = 0;		/* but the length is zero (to allow substring). */
			end;
			else do;			/* Ther is a comma. */
			     ta_fc = targ_fc+tl+1;	/* Location of 1st character after comma. */
			     ta_ln = length (targ) - ta_fc +1; /* Number of character. */
			end;
			if substr (targ, targ_fc, tl) = "filecode" then
			     call gcos_mme_inos_$inos_trace_filecode (substr (targ, ta_fc, ta_ln));
			else if substr (targ, targ_fc, tl) = "trace_mme" then
			     call gcos_process_mme_$mme_trace (substr (targ, ta_fc, ta_ln));
			else if substr (targ, targ_fc, tl) = "stop_mme" then
			     call gcos_process_mme_$mme_stop (substr (targ, ta_fc, ta_ln));
			goto dbs_next;
		     end;
		end;
		call com_err_ (			/* Report dbs arg error. */
		     0
		     , "gcos$dbs"
		     , "Arg ^i ""^a"" unknown. Need -print (-pr) or switch name."
		     , i
		     , substr (targ, targ_fc, tl)
		     );
dbs_next:		;
	     end;
	end;

	return;

end gcos_dbs;
%page;
print_dbs_usage: proc;				/* Prints gcos_dbs usage message. */
		     call gcos_print_call_ (
		     "Usage: gcos$dbs arg ..."
/* DON'T PRINT THIS:     , "args:"
		     , " -print, -pr|Print names of switches."
		     , " name or ^name|Switch name value from following:"
		     , "|attach_file"
		     , "|open_file"
		     , "|msf_test"
		     , "|dollar"
		     , "|nondollar"
		     , "|filecode{,-print,file-code[DEFAULT all codes]}"
		     , "|mme_inos_trace"
		     , "|mme_inos_stop"
		     , "|mme_call"
		     , "|trace_mme{,-print,-all[DEFAULT],-on[DEFAULT],-off,-clear,mme#|mme-name}"
		     , "|stop_mme{,-print,-all[DEFAULT],-on[DEFAULT],-off,-clear,mme#|mme-name}"
*/		     );

	return;

end print_dbs_usage;
%page;
initialize_routine: proc;				/* Perform initialization */

/*   INITIALIZE EXTERNAL STATICS USED IN ARGUMENT PROCESSING */

	simulator_already_active = "1"b;
	query_info.yes_or_no_sw = "1"b;
	expecting = "0"b;
	literal_string = "0"b;
	buffsize_next = "0"b;
	string (gcos_ext_stat_$dbs) = string (dbsv);
	save_data.activity_no = 0;
	gcos_ext_stat_$incode,
	     gcos_ext_stat_$gf = 0;
	gcos_ext_stat_$last_mme = 0;
	gcos_ext_stat_$ldrss = 0;
	gcos_ext_stat_$max_activities = 63;
	gcos_ext_stat_$save_data.param = "";
	gcos_ext_stat_$tape_buffer_size = 4096;
	save_data.sqindex = 1;
	unspec (gcos_ext_stat_$save_data.flgs) = (72)"0"b; /* zero out gcos_ext_stat_$save_data before argument processing */
	gcos_ext_stat_$job_id = "";			/* must be initialized to blanks so we can tell whether to
						   set it to default after all args processed */
	gcos_ext_stat_$er
	     , gcos_ext_stat_$gcos_slave_area_seg
	     , gcos_ext_stat_$patchfile_ptr
	     , gcos_ext_stat_$pch
	     , gcos_ext_stat_$prt
	     , gcos_ext_stat_$rs
	     , gcos_ext_stat_$saveseg_ptr
	     , gcos_ext_stat_$sig_ptr
	     , gcos_ext_stat_$temp_seg_ptr
	     = null ();
	gcos_ext_stat_$system_free_pointer = get_system_free_area_ ();
						/* get pointer to free area for allocating things in */


	gcos_ext_stat_$save_data.spawnflag = temp_spawnflag; /* set entry point gcos_ext_stat_$save_data */
	gcos_ext_stat_$save_data.gtssflag = temp_spawnflag;
	gcos_ext_stat_$save_data.taskflag = temp_taskflag;


/*	GET PROCESS, WORKING AND DEFAULT WORKING DIRECTORY PATHNAMES FOR USE IN FILE NAMES */

	gcos_ext_stat_$temp_dir,			/* temp_dir = pdir, by default */
	     gcos_ext_stat_$pdir = rtrim (get_pdir_ ());	/* put it in ext static varying string */

	save_data.syot_dir,				/* syot_dir and save_dir = wdir, by default */
	     gcos_ext_stat_$save_dir = rtrim (get_wdir_ ()); /* put in ext static varying string */

	save_data.pathname_prefix = rtrim (get_default_wdir_ ()) ; /* pathname_prefix = default_wdir_ by default */
	save_data.skip_umc = "1"b ;

	return;

end initialize_routine;
%page;
print_call: proc;

/* Display on caller's terminal the calling sequence.
*/
	     call gcos_print_call_ (
		"Usage: gcos JOB_DECK_PATH {-control_args}"
/*		, ""
		, "job_deck_path|Pathname of JCL file, can be a Multics segment or GCOS file"
		||" regulated by control argument and suffix."
		, ""
		, "control_args:"
		, " -gcos, -gc|Job deck segment is in gcos file format (not required if pathname ends in "".gcos"")."
		, " -ascii, -aci|Job deck segment is Multics ascii format (to override "".gcos"")."
		, " -nosave, -nosv|Do not save (make restartable) any activities (in a resumed job)."
		, " -hold, -hd|Do not perform default conversion and output of sysout files (needed only when some sysout files are to be left in gcos bcd format, since any"
		||" of -ls -dp -dpo (or -raw -dpn -dpno) override the defaults for print (punch) files.)."
		, " -list, -ls|Translate sysout print files to Multics ascii."
		, " -brief, -bf|Do not print any except fatal error messages on the terminal."
		, " -long, -lg|Duplicate certain lines from the execution report on the terminal."
		, " -debug, -db|Give user option of calling debug before aborting job."
		, " -no_bar,|Do not run slave program in BAR mode (used for debugging.)."
		, " -nobar, -nb"
		, " -no_canonicalize,|Do not canonicalize (ascii) job deck segment - it is already"
		||" in canonical form (no tabs, and all fields in right columns)."
		, " -nocan, -no"
		, " -job_id ID,|ID, used in output file names."
		, " -id ID"
		, "  ID from:"
		, "  <string>|Job id given as character string (max 18 char)."
		, "  -unique|Use shriekname (result of unique_chars_) as job id."
		, "  -jd_seg, -jd|Use entry name of job deck segment as job id."
		, ""
		, " -stop n|Debugging: print results, call db, then return, at stopping point n."
		, " -temp_dir TD,|TD ispathname of ""gcos pool"" directory, to be used for temporary files."
		, " -tp TD"
		, " -syot_dir, -sd|Pathname of ""gcos pool"" directory, to be used for sysout files."
		, " -smc|Pathname of directory to be used as the gcos SMC in processing prmfl cards."
		, " -raw|Convert sysout punch files from bcd."
		, " -dprint, -dp|Dprint -delete converted sysout print files (implies -list)."
		, " -dpunch, -dpn|Dpunch -delete -raw converted sysout punch files (implies -raw)."
		, " -dprint_options O,|O are options to use in dprint call (implies -dprint)."
		, " -dpo O"
		, " -dpunch_options O,|O are options to use in dpunch call (implies -dpunch)."
		, " -dpno O"
		, " -userlib|Allow use of libraries other than the installed ones. (see gcos_gein_)."
		, " -truncate,|Truncate without warning any ascii input lines longer than 80 characters."
		, " -tnc, -tc"
		, " -continue, -ctu|Continue executing job when nonfatal erros occur."
		, " -lower_case,|Translate BCD sysout and print files to lower case ASCII"
		||" (the default is uppercase ASCII, simulating the appearance of BCD printer output)."
		, " -lc"
		, " -gtss|Update gtss_user_state_ during execution."
		, " -ident|Use $ident fields for print & punch banners."
		, " -block N, -bk N|Specify tape buffer size. (Default = 4096)"
*/
		);
	     return;
end print_call;
%page;
process_args: proc;					/* Process the arguments. */
/*   PROCESS ARGUMENT LIST */

	call cu_$arg_count (nargs, code);		/* get number of arguments */
	if code ^= 0 then do;
	     call com_err_ (			/* arg count failed. */
		code
		, "gcos"
		);
	     return;
	end;
	if nargs = 0 then do;			/* if no args, complain */
usage:	     ;
	     call com_err_ (			/* Print the USAGE msgs. */
		error_table_$noarg
		, me
		);
	     call print_call;
/*	     call print_dbs_usage;     */
	     goto fatal_error;
	end;

	do i = 1 to nargs;				/* process all arguments in this loop */
	     call cu_$arg_ptr (i, pp, lp, code);	/* get pointer to, and length of, argument */
						/* targ is declared char(lp) based(pp) */
	     if code ^= 0 then do;			/* if something wrong with it */
		call com_err_ (code, me, targ);	/* complain, print the arg, if it's there */
		goto usage;			/* and then go print the usage message */
	     end;



/*     NOW, WHAT DO WE HAVE, AND WHAT DO WE NEED? */

	     /* special handling of -string arg: following arg is NOT a control arg */
	     if ^literal_string           /* can have "-string -string" */
		then if (targ = "-string" | targ = "-str") then do;
		     literal_string = "1"b;
		     goto end_arg_loop;
		end;
		
               /* determine type arg we have */
	     num_arg = cv_dec_check_ (targ, code);	/* in case it is numeric */
	     if lp = 0 then control = "0"b;
	     else if (substr (targ, 1, 1) = "-" & ^literal_string) 
		then do;
		     control = "1"b;
		     processing_params = "0"b;          /* no more params */
		end;
	          else control = "0"b;

	     /* process substitution parameters for gcos JCL */ 	
	     if processing_params then do;
		if i-param_base > hbound (save_data.param, 1) then do;
		     call com_err_ (error_table_$too_many_args, "gcos"
			     , "Maximum number of -parameter arguments is ^d."
			     , hbound (save_data.param, 1));
		     return;
		end;
		if literal_string then param_base = param_base +1;
		save_data.param (i-param_base) = targ;
		literal_string = "0"b;
		goto end_arg_loop;
	     end;
	     
/* it is a control arg or a value following one */
	     if expecting then do;			/* if we were expecting a value after a control arg */
						/* then see if this is it */
		if temp_dir_next then do;
		     if control then do;		/* if not a pathname, complain */

			err_msg = "(pathname, between -temp_dir and ^a)";
com_err_noarg:		call com_err_ (error_table_$noarg, me, err_msg, targ);
			if print_usage then goto usage; /* optionally, print the usage message */
			goto fatal_error;		/* otherwise, quit */
		     end;

/* get the directory pathname */
get_dir: ;					/* come here from syot_dir */

		     call expand_pathname_ ((substr (targ, 1, lp)), fullname, ename, code);

		     if code ^= 0 then goto ex_error;

		     call hcs_$status_minf ((fullname), (ename), chase, type, bit_count, code);
		     if code ^= 0 then goto in_error;

/* make sure it is a directory */
		     if type ^= 2 | bit_count ^= 0 then do;
			call com_err_ (0, me, "expected directory path is that of a ^a:^/^a>^a",
			     type_name (type), fullname, ename);
			goto fatal_error;
		     end;

/* put pathname back together and save it in external static */
		     itemp = index (fullname, " ");
		     if itemp = 0 then itemp = 169;

		     jtemp = index (ename, " ");
		     if jtemp = 0 then jtemp = 33;
		     fullname = substr (fullname, 1, itemp-1) || ">" || substr (ename, 1, jtemp-1);

		     itemp = itemp + jtemp - 1;	/* length of full pathname */

		     if temp_dir_next then
			gcos_ext_stat_$save_dir
			, gcos_ext_stat_$temp_dir = substr (fullname, 1, itemp);
		     else if syot_dir_next then
			save_data.syot_dir = substr (fullname, 1, itemp);
		     else save_data.pathname_prefix = substr (fullname, 1, itemp) ;


		     syot_dir_next, smc_next
			, expecting, temp_dir_next = "0"b; /* turn off , expecting switches */

		end;

		else if syot_dir_next then do;
		     if control then do;
			err_msg = "(pathname, between -syot_dir and ^a)";
			goto com_err_noarg;
		     end;
		     goto get_dir;			/* share code with temp_dir */
		end;

		else if smc_next then do ;

		     save_data.skip_umc = "0"b ;

		     if control then do ;		/* must be a string */
			err_msg = "(pathname, between -smc and ^a)" ;
			goto com_err_noarg ;
		     end ;
		     else goto get_dir ;
		end ;

		else if stop_code_next then do;

/* if stop code expected, save it */
		     if code ^= 0 then do;		/* if it was non numeric, complain */
			err_msg = "(numeric, between -stop and ^a)";
			goto com_err_noarg;
		     end;				/* end of non numeric stop code do group */

		     gcos_ext_stat_$stop_code = num_arg;
		     expecting, stop_code_next = "0"b;	/* turn off expecting switches */

		end;

		else if buffsize_next
		     then do;
			if ^valid_buffsize (targ)
			then goto fatal_error;	/* Bail out if buffer size not legal.
						   Error was reported by valid_buffsize. */
			buffsize_next = "0"b;
			expecting = "0"b;
			end;

		else if dpo_next then do;
		     gcos_ext_stat_$dpo = targ;	/* copy without checking validity */
		     expecting, dpo_next = "0"b;	/* turn off expecting switches */
		     dpo_given = "1"b;		/* remember that we read it */
		end;

		else if dpno_next then do;
		     gcos_ext_stat_$dpno = targ;	/* copy without checking validity */
		     expecting, dpno_next = "0"b;	/* turn off expecting switches */
		     dpno_given = "1"b;		/* remember that we read it */

		end;

		else if job_id_next then do;
		     if ^control then do;		/* must be a string */
						/* impose limit of 18 characters on
						   id (14 more chars max in entry names) */
			if lp > 18 then do;
			     lp = 18;		/* this cuts end off targ */

/* *****
   ***** TEMPORARY FIX TO PREVENT DAEMON JOBS FROM COMPLAINING VIA com_err_
   ***** REMOVE WHEN DAEMON IS FIXED TO SUPPLY 18 CHAR JOB ID. TAC, 6 JUNE 74
   *****
   */

			     if substr (targ, 7, 1) = "!" then
				goto ignored_string_end;
			     err_msg = targ;	/* this puts first 18 chars of targ in err_msg */
			     warning_return = ignored_string_end; /* come back here */
com_err_id_too_long:	     call com_err_ (0, me, "job id too long; using first 18 characters: ^a", err_msg);
			     goto warning_return;	/* continue processing */
			end;			/* end too long do group */

ignored_string_end:
			gcos_ext_stat_$job_id = targ;
		     end;				/* end of job id = string do group */

		     else if targ = "-unique" then do;	/* unique job id wanted */
			gcos_ext_stat_$job_id = unique_chars_ ("0"b);
		     end;				/* end of -unique do group */


		     else if targ = "-jd" | targ = "-jd_seg" then do; /* jd seg name wanted as job id */
			id_jd = "1"b;		/* might not have jd seg path yet. remember to use it later */
		     end;				/* end of -jd do group */

/* NOTE*	 WE CAN NEVER USE THE SNUMB AS THE JOB ID
   (UNLESS THE DAEMON GIVES IT TO US AS -id <string> )
   SINCE WE HAVE TO USE IT IN FILE PATHNAMES BEFORE WE
   START READING THE JOB DECK TO GET THE SNUMB CARD */

		     else do;			/* control arg after -id. complain */
			err_msg = "(job id, between -job_id and ^a)";
			goto com_err_noarg;
		     end;

		     expecting, job_id_next = "0"b;	/* turn off expecting switches */
		end;

		else do;				/* should never get here */
		     err_msg = "ERROR IN GCOS. Flags not reset properly.";
		     goto com_err_noarg;
		end;				/* end of ERROR IN GCOS do group */
	     end;


	     else if control then do;			/* if a control arg */
		if targ = "-gc" | targ = "-gcos" then gcos_ext_stat_$save_data.gcos = "1"b;

		else if targ = "-nosv" | targ = "-nosave" then gcos_ext_stat_$save_data.nosave = "1"b;


		else if targ = "-hd" | targ = "-hold" then hold_given = "1"b;

		else if targ = "-ls" | targ = "-list" then gcos_ext_stat_$save_data.list = "1"b;

		else if targ = "-bf" | targ = "-brief" then gcos_ext_stat_$save_data.brief = "1"b;

		else if targ = "-lg" | targ = "-long" then gcos_ext_stat_$save_data.long = "1"b;

		else if targ = "-db" | targ = "-debug" then gcos_ext_stat_$save_data.debug = "1"b;

		else if targ = "-nb" | targ = "-nobar" | targ = "-no_bar" then gcos_ext_stat_$save_data.no_bar = "1"b;

		else if targ = "-tnc" | targ = "-tc" | targ = "-truncate" then gcos_ext_stat_$save_data.truncate = "1"b;

		else if targ = "-ctu" | targ = "-continue" then gcos_ext_stat_$save_data.continue = "1"b;

		else if targ = "-userlib" then gcos_ext_stat_$save_data.userlib = "1"b;

		else if targ = "-no" | targ = "-no_canonicalize" | targ = "-nocan" then
		     gcos_ext_stat_$save_data.no_canonicalize = "1"b;

		else if targ = "-aci" | targ = "-ascii" then do;
		     ascii_given = "1"b;
		     gcos_ext_stat_$save_data.gcos = "0"b;
		end;

		else if targ = "-id" | targ = "-job_id" then expecting, job_id_next = "1"b;

		else if targ = "-stop" then expecting, stop_code_next = "1"b;

		else if targ = "-td" | targ = "-temp_dir" then expecting, temp_dir_next = "1"b;

		else if targ = "-sd" | targ = "-syot_dir" then expecting, syot_dir_next = "1"b;

		else if targ = "-raw" then gcos_ext_stat_$save_data.raw = "1"b;

		else if targ = "-dp" | targ = "-dprint" then gcos_ext_stat_$save_data.dprint = "1"b;

		else if targ = "-dpn" | targ = "-dpunch" then gcos_ext_stat_$save_data.dpunch = "1"b;

		else if targ = "-dpo" | targ = "-dprint_options" then expecting, dpo_next = "1"b;

		else if targ = "-dpno" | targ = "-dpunch_options" then expecting, dpno_next = "1"b;

		else if targ = "-lc" | targ = "-lower_case" then gcos_ext_stat_$save_data.lower_case = "1"b;

		else if targ = "-unique" then do;	/* unique not after job id - complain */
unexpected_id:					/* can come here from below, too */
		     err_msg = "immediately following -job_id";
		     call com_err_ (0, me, "-unique out of place - only allowed following -job_id");
		     goto fatal_error;
		end;

		else if targ = "-jd" | targ = "-jd_seg" then goto unexpected_id; /* -jd not after -id so complain */

		else if targ = "-smc" then expecting, smc_next = "1"b ;

		else if (targ = "-parameter" | targ = "-pm" | targ = "-param") then do;
		     processing_params = "1"b;
		     param_base = i;
		end;

		else if targ = "-gtss" then gcos_ext_stat_$save_data.gtssflag = "1"b;

		else if targ = "-ident" then gcos_ext_stat_$save_data.identflag = "1"b;

		else if targ = "-block" | targ = "-bk" then expecting, buffsize_next = "1"b;


		else do;				/* complain about unrecognized control argument */
		     call com_err_ (error_table_$badopt, me, targ);
		     goto fatal_error;
		end;
	     end;


/*	IT MUST BE A PATHNAME. DO WE WANT ONE? */

/* since we were not expecting anything special, it is either the job deck pathname, or an error */

	     else if ^job_deck then do;		/* if job deck pathname not read yet, this must be it */

		job_deck = "1"b;			/* remember that we read it */

		call expand_pathname_ ((substr (targ, 1, lp)), fullname, ename, code);
		if code ^= 0 then do;		/* if unable to expand... */
ex_error:		     call com_err_ (code, me, targ);	/* print error and */
		     goto fatal_error;		/* exit stage left */
		end;

		jd_ename = ename;			/* save entry name for possible use in job id */

/*	See if the segment is there	*/

		call hcs_$status_minf ((fullname), (ename), chase, type, bit_count, code);
		if code ^= 0 then do;		/* if any problem */
in_error:		     call com_err_ (code, me, "^a>^a", fullname, ename); /* print error msg and */
		     goto fatal_error;		/* exit stage rear */
		end;

		if bit_count = 0 then do;		/* put out error msg if zero length segment */
		     call com_err_ (0, me, "zero length job deck segment: ^a>^a", fullname, ename);
		     goto fatal_error;
		end;

/* if it looks OK, save its pathname for later use     */

		itemp = index (fullname, " ");	/* find first blank */
		if itemp = 0 then itemp = 169;	/* if none, 168 char dirname */
		gcos_ext_stat_$input_segment_path = substr (fullname, 1, itemp-1)||">";

		itemp = index (ename, " ");		/* find end */
		if itemp = 0 then itemp = 33;
		gcos_ext_stat_$input_segment_path = gcos_ext_stat_$input_segment_path||substr (ename, 1, itemp-1);

/* if segment has suffix ".gcos", then it is in gcos file format, as
   gotten from the gcos daemon, gcos utility, or IMCV tape */

		if ^ascii_given then		/* (unless told to ignore .gcos by -ascii) */
		     if lp > length (".gcos") then
			if substr (targ, lp-length (".gcos")+1, length (".gcos")) = ".gcos" then
			     gcos_ext_stat_$save_data.gcos = "1"b;
	     end;					/* end processing of job deck pathname */

	     else do;				/* complain about unrecognized NON-control argument */
		call com_err_ (0, me, "Unidentified non-control argument: ^a", targ);
		goto usage;			/* and go print usage message */
	     end;

	     literal_string = "0"b;                       /* just once */

end_arg_loop:	;
	end;


	return;

end process_args;
%page;
valid_buffsize: proc (charbuffsize) returns (bit(1));	/* Check buffer size for validity, report errors
						   if it's not kosher. Set gcos_ext_stat_$tape_buffer_size
						   if it's O.K. */

dcl  charbuffsize char (*) parm;
dcl  buffsize fixed bin (35);


	code = 0;

	buffsize = cv_dec_check_ (ltrim (rtrim (charbuffsize)), code);


	if   buffsize < 1
	   | buffsize > 4096
	   | code ^= 0
	then do;
	     code = error_table_$bad_conversion;
	     call com_err_ (code, me,
			"Could not use ""^a"" as buffer size."
			|| "^/Permissible values are 1 <= buffsize <= 4096^/^/",
			ltrim (rtrim (charbuffsize)));
	     goto exit_valid_buffsize;
	     end;

	gcos_ext_stat_$tape_buffer_size = buffsize;

exit_valid_buffsize: ;

	     return (code = 0);

end valid_buffsize;
%page;
/*   Variables for gcos:			 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  bit_count                fixed bin(24)		/* length of input segment in bits */;
dcl  buffsize_next		bit (1);
dcl  chase                    fixed bin(1) init (1);
dcl  cleanup                  condition;
dcl  code                     fixed bin(35)		/* return param. for passing error codes */;
dcl  com_err_                 entry options(variable);
dcl  cu_$arg_count            entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr              entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cv_dec_check_            entry (char(*), fixed bin(35)) returns (fixed bin);
dcl  db                       entry options(variable);
dcl  dbsv                     (36)bit(1)static int init((36)(1)"0"b);
dcl  ename                    char (32) 		/* holds entry name of input seg */;
dcl  error_table_$badopt      fixed bin(35) ext static;
dcl  error_table_$bad_conversion fixed bin(35) ext static;
dcl  error_table_$big_ws_req	fixed bin(35) ext static;
dcl  error_table_$noarg       fixed bin(35) ext static;
dcl  error_table_$too_many_args fixed bin(35) ext static;
dcl  err_msg                  char(100) varying		/* varying error message, to save com_err_ calls */;
dcl  expand_pathname_	entry (char(*), char(*), char(*), fixed bin(35));
dcl  fullname                 char(168) 		/* holds pathname of input seg */;
dcl  gcos_gein_               entry;
dcl  gcos_mme_inos_$inos_trace_filecode entry(char(*));
dcl  gcos_process_mme_$mme_stop entry(char(*));
dcl  gcos_process_mme_$mme_trace entry(char(*));
dcl  gcos_print_call_         entry options(variable);
dcl  get_default_wdir_        entry returns (char(168) aligned);
dcl  get_pdir_                entry returns (char(168) aligned);
dcl  get_ring_                entry returns (fixed bin(3));
dcl  get_system_free_area_    entry returns (ptr);
dcl  get_wdir_                entry returns (char(168) aligned);
dcl  hbound                   builtin;
dcl  i                        fixed bin(17);
dcl  index                    builtin;
dcl  ioa_                     entry options(variable);
dcl  j                        fixed bin(24);
dcl  jd_ename                 char(32)			/* to hold job deck entry name for possible -id -jd */;
dcl  length                   builtin;
dcl  literal_string           bit(1);                        /* allow non control args to start with - */
dcl  ltrim                    builtin;
dcl  me                       char(16)			/* command name, for error messages */;
dcl  null                     builtin;
dcl  rtrim                    builtin;
dcl  send_message_            entry (char(*), char(*), char(*), fixed bin(35));
dcl  simulator_already_active bit (1) aligned int static init ("0"b);
dcl  size                     builtin;
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  targ_fc                  fixed bin(24);
dcl  ta_fc                    fixed bin(24);
dcl  ta_ln                    fixed bin;
dcl  tl                       fixed bin(24);
dcl  type                     fixed bin(2)		/* entry type returned by status_minf calls */;
dcl  unique_chars_            entry (bit (*)) returns (char(15));
dcl  unspec                   builtin;
dcl  warning_return           label local		/* to continue after warning messages */;


dcl  type_name                (0:2) char(8) int static init (
     "link",
     "segment",
     "msf");

dcl 1 statbuff 		automatic aligned like status_branch.short;

dcl  lp                       fixed bin(21),		/* length of argument */
     pp ptr,					/* pointer to argument */
     targ char(lp) based (pp);			/* argument from command line */

dcl (print_usage,					/* switch on to print usage message */
     control,					/* switch on if arg begins with "-" */
     expecting,					/* switch on if specific argument expected next */
     stop_code_next,				/* switch on when stop code expected next */
     dpo_next,					/* switch on when dprint options expected next */
     dpno_next,					/* switch on when dpunch options expected next */
     job_id_next,					/* switch on when job id expected next */
     temp_dir_next,					/* switch on when temp dir expected next */
     syot_dir_next,					/* switch on when syot dir expected next */
     smc_next,					/* switch on when ssmc dir expected next */
     id_jd,					/* switch on when jd seg name wanted as job id */
     job_deck,					/* switch on when job deck path read */
     hold_given,					/* switch on if hold option read */
     processing_params,				/* switch on if -parameter control argument has been encountered */
     dpo_given,					/* switch on if dpo option read */
     dpno_given,					/* switch on if dpno option given */
     temp_spawnflag,				/* switch on if entry via gcos$spawn */
     temp_taskflag,					/* switch on if entry via gcos$task */
     ascii_given)					/* switch on if -ascii given */
     bit (1) init ("0"b);				/* switches initially off */

dcl (nargs,					/* number of arguments */
     num_arg,					/* place to put converted numeric argument */
     param_base,					/* argument number of the -parameter control argument */
     jtemp,
     itemp)					/* temporary */
     fixed bin(17)init (0);

dcl  hcs_$status_		entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl  hcs_$status_minf         entry (char(*) aligned, char(*) aligned, fixed bin(1),
     fixed bin(2), fixed bin(24), fixed bin(35));
%page;
%include gcos_ext_stat_;
%page;
%include query_info;
%page;
%include gcos_dbs_names;
%page;
%include status_structures;
     end gcos;




		    gcos_abort_.pl1                 09/09/83  1400.3rew 09/09/83  1006.7       29655



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


/* *  THIS PROCEDURE IS CALLED WITH A TWO CHARACTER ABORT CODE (RATHER THAN A
   *  MULTICS ERROR TABLE CODE). IT WILL PRINT THE ABORT CODE AND THE NAME OF
   *  THE CALLING PROCEDURE. IF ANY ADDITIONAL ARGUMENTS ARE PRESENT, IT WILL
   *  REFORMAT THE ARG LIST TO DELETE THE FIRST ARGUMENT, AND THEN CALL ioa_
   *  TO PRINT THE ADDITIONAL ARGUMENTS. THEN IT WILL CALL gcos_error_ WITH
   *  AN ERROR TABLE CODE OF 9999. gcos_error_ WILL ABORT THE JOB.
   *
   *  WRITTEN BY DICK SNYDER IN 1971
   *  MODIFIED BY T. CASEY NOVEMBER 1973
   *
   */
gcos_abort_: proc (code);
dcl  code char (*);
dcl (i, ii) fixed bin(18);
dcl (j, offset) fixed bin(24);
dcl  name char (j) aligned based (z);
dcl 1 frame based (p),
    2 ab (4) fixed bin(24),
    2 lp pointer,
    2 sp pointer,
    2 regs (8) fixed bin(24),
    2 backp pointer,
    2 nxt pointer,
    2 ret pointer;

dcl 1 arg_list aligned based (p),
    2 arg_count fixed bin(17) unaligned,
    2 display bit (18) unaligned,
    2 descriptor_count fixed bin(17) unaligned,
    2 fill bit (18) unaligned,
    2 arg_pointers (1) fixed bin(71) aligned;						/* if we declare these pointers as pointers,
						   pointer registers will be used to move them,
						   and faults will occur if any are invalid pointers */

dcl  p pointer;
dcl  cu_$stack_frame_ptr ext entry (pointer);
dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$gen_call ext entry (entry, pointer);
dcl  ioa_ ext entry options (variable);
dcl  pl1_frame_$name ext entry (ptr, ptr, fixed bin(24));
dcl  gcos_error_ ext entry (fixed bin(24));
dcl  z pointer;

dcl (divide, fixed, rel, substr, unspec) builtin;




	call cu_$stack_frame_ptr (p);
	p = backp;				/* get caller's frame */
	unspec (offset) = (18)"0"b||substr (rel (ret), 1, 18);
	call pl1_frame_$name (p, z, j);		/* get caller name */
out:	call ioa_ ("Abort ^a from ^a at ^o", code, name, offset);
	call cu_$arg_list_ptr (p);			/* get ptr to my arg list */
	ii, i = arg_count;				/* get no of args */
	if i = 2 then go to skip;			/* only one arg */
	ii, i = i-2;				/* decrement arg count */
	arg_count = i;				/* put new count in arg list */
	i = descriptor_count;			/* get no. of descriptors */
	if i ^= 0 then do;				/* adjust descriptors and count if necessary */
	     descriptor_count = i-2;
	     do j = divide (ii+4, 2, 18, 0) to ii;	/* shift descriptors left one to */
						/* wipe out descriptor for arg 1 (abort cause) */
		arg_pointers (j) = arg_pointers (j+1);
	     end;

	end;
	else ii = divide (ii, 2, 18, 0);		/* no descriptors so adjust move variable */
	do j = 1 to ii;
	     arg_pointers (j) = arg_pointers (j+1);	/* move arg pointers */
	end;
	call cu_$gen_call (ioa_, p);			/* let ioa_ print out any other info */
skip:	call gcos_error_ (9999);
	return;					/* just in case */
     end;




		    gcos_attach_file_.pl1           09/09/83  1400.3rew 09/09/83  1006.7      156510



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

/*

   This  module  will attach a file and associate it with a fib.
   The fib is assumed to have been  initialized  by  a  call  to
   gcos_open_file_.

   The parameter is a pointer to the fib defining the file.  For
   a perm file, fib.pathnm is the full pathname (168 characters)
   of  a  file  to  be  associated  with  the fib.  Otherwise, a
   scratch file will be created.   This  file  will  be  created
   in  the  sysout  directory  if  the  file  is print or punch.
   Otherwise, it will be created  in  the  temporary  directory.
   (The  sysout directory is, by default, the working directory,
   and the temporary  directory,  the  process  directory.   The
   user  can  set  them to any other directories, such as a pool
   directory reserved for  short  term  storage  of  vary  large
   output files.)

   If  the file size has not been specified in fib.size, it will
   be set to 3840 words (one GCOS link).  The file will  be  set
   to the rewound position.

*/
%page;
/*

   Author: Dick Snyder	Dec 15, 1970
   Change: T. Casey	Apr 1973, Feb 1974
   Change: D. Kayden	May 1974, Jul 1974, Jan 1975, Mar 1975
   Change: R.H. Morrison	Jun 1975
   Change: M. R. Jordan	Sep 1976
   Change: Mel Wilson	Oct 1979 for gtss compatibility, Jan 1980 for gtss 2.4
   Change: S.C. Akers	Aug 1981 Clean up format
			Dec 1981 Fix sysout bug. Put printer & punch files
			         in SYSOUT directory, not SAVE directory.
			FEB 1982 Add tape-buffer size checking, and pass buffer
			         size to tape DIM.
   Change: R. Barstad         Oct 1982 Provide concurrent access control for IDS2 files
   Channge: R. Barstad         Nov 1982 Fix format of actid for console msgs
*/
%page;
gcos_attach_file_: proc (fp);

dcl  a_code		fixed bin(35)	parm;
dcl  fp			ptr		parm;


	fibptr = fp;
	reattachsw = "0"b;
	if fib.console | fib.null then goto done;	/* this device does not get attached */

	if fib.stream ^= "" then
	     file_id = fib.stream;			/* file id is provided by caller */
	else
	do i = 1 to hbound (save_data.fibs, 1);		/* otherwise use file code for file id */
	     if fct.fibptr (i) = fibptr then do;	/* find first file code for this file */
		file_id = fct.filecode (i);
		goto set_actid;
	     end;
	end;					/* a match must always be found */

set_actid: ;
	if save_data.activity_no = 0
	| substr (file_id, 6) ^= "" then actid = "";	/* don't put actid with syspunch, etc. */
	else
	if substr (save_data.actid, 7, 1) = "0" then	/* activity no. < 10 */
	     actid = "a" || substr (save_data.actid, 8, 1); /* yes - remove leading zero */
	else
	actid = "a" || substr (save_data.actid, 7, 2);	/*  ascii activity number */

	if length (actid) > 0 then name = actid || "_" || file_id; /* now construct stream name */
	else name = file_id;
	fib.stream = name;				/* save stream name */

	if fib.perm then goto attch;			/* perm file has a complete pathname already specified */

	if fib.tape then goto attach_tape;

/* CONSTRUCT A PATHNAME FOR THE FILE
   Put print and punch files in a permanent directory so that they
   can be printed or punched at a later date without disappearing
   with the process directory when the user is logged out
   Put other files in a temporary directory (might be process directory or a "pool" directory)
*/

	if fib.print | fib.punch then
	     fib.pathnm = save_data.syot_dir;		/* Find the SYSOUT directory. */
	else
	if substr (fib.disp, 1, 1) then
	     fib.pathnm = gcos_ext_stat_$save_dir;
	else fib.pathnm = gcos_ext_stat_$temp_dir;

/* CONSTRUCT ENTRY NAME OF THE FORM:

   <job id>.a<activity number>.<+filecode>

   where the < and > are part of the description - not part of the entry name, and

   <job id> 		was determined during command argument processing;

   <activity number>	is the current activity number (omitted if act. no. = 0);

   <+filecode>		is the filecode, with *'s replaced by +'s.
   (or a name placed in fib.pathnm by the caller)

*/
	fib.pathnm =
	     rtrim (fib.pathnm)
	     || ">"

	     || rtrim (gcos_ext_stat_$job_id)
	     || "."
	     || actid
	     || translate (file_id, "+", "*")
	     ;



/* Attach file */


attch:	;
	if gcos_ext_stat_$save_data.gtssflag then	/* create the new entry, setting ring brackets */
	     if fib.perm | fib.print | fib.punch then do;
		call expand_pathname_ ((fib.pathnm), dir_name, entryname, code);
		if code ^= 0 then do;
		     err_msg = "from expand_pathname_ ^a";
		     goto error_rtrn;
		end;
		call user_info_ (persid, projid, acct);
		call hcs_$append_branchx (dir_name, entryname, 01010b, gcos_ext_stat_$seg_rings
		     , "*." || rtrim (projid) || ".*", 0b, 0b, 0, code);
		if (code ^= 0) & (code ^= error_table_$namedup) & (code ^= error_table_$incorrect_access) then do;
		     err_msg = "from hcs_$append_branchx ^a";
		     goto error_rtrn;
		end;
						/* do gtss allocation */

		if fib.perm & (fib.plud ^= "435453"b3) then do;
		     call gcos_verify_tss_access_ (dir_name, entryname, fib.read || fib.write || "0000"b
			, null (), fib.forced_acl_flag, gcs_status_bits);
		     if gcs_status.status = "4003"b3 then do;
			code = error_table_$notalloc;
			err_msg = "No permission on ^a .";
			goto error_rtrn;
		     end;
		     else
		     if gcs_status.status ^= "4000"b3 then do;
			err_msg = "Error verifying access on ^a .";
			goto error_rtrn;
		     end;

/* FOLLOWING CODE BLOCKED FOR 9.0. Provides concurrent access control.
   call get_lock_id_ (lock_id);
   call random_$set_seed (fixed (substr (bit(clock (), 72), 38, 35), 35, 0));
   alloc_count = 0;
   alloc_start_blocked = clock ();
   try_allocation:;
   call gtss_mcfc_$open (dir_name, entryname, fib.read||fib.write, lock_id, fib.unique_file_id
   , addr (gcs_status), code);
   if gcs_status.status = "4004"b3 then do; / * file busy * /
   alloc_count = alloc_count + 1;
   if mod (alloc_count, 5) = 0 then do;
   call date_time_ (alloc_start_blocked, ascii_time);
   call ioa_ ("Allocation of ^a>^a blocked since ^a, for ^i attempts."
   , dir_name, entryname, ascii_time, alloc_count);
   end;
   call random_$normal (flt_delay);
   call timer_manager_$sleep (fixed (flt_delay*10.0, 71, 0)+61, "11"b); / * wait 60 seconds average * /
   gcs_status.status = "4000"b3;
   goto try_allocation;
   end;
   else
   if code ^= 0 then do;
   err_msg = "from gtss_mcfc_$open ^a";
   goto error_rtrn;
   end;
*/
		end;

	     end;

          /* check for IDS2 file */
          if fib.perm & fib.type /* random */ 
             then do;
	     call expand_pathname_ ((fib.pathnm), dir_name, entryname, code);
	     if code ^= 0 then do;
		err_msg = "from expand_pathname_ ^a";
		goto error_rtrn;
		end;
               /* check for IDS2 file being initialized in Q2UTIL activity */
               if gcos_ext_stat_$activity_name = "q2util" 
                 then do;
                   call gcos_ids2_concur_$create_control(dir_name,entryname,code);
	         if code = error_table_$namedup | code = error_table_$segknown
		    then goto try_allocation;
	         if code ^= 0
		    then do;
		       err_msg = "from gcos_ids2_concur_$create_control ^a";
		       goto error_rtrn;
	              end;
	         end;
                 else /* check if this IDS2 file has an extrinsic id */
                   if gcos_ids2_concur_$have_xid(dir_name,entryname,code)
                     then do;
		       if code ^= 0 then do;
			  err_msg = "from gcos_ids2_concur_$have_xid ^a";
			  goto error_rtrn;
			  end;
try_allocation:	   alloc_count = 0;
		   ascii_snumb = substr(gcos_ext_stat_$save_data.actid,1,5);
try_alloc_again:	   call gcos_ids2_concur_$allocate
                            (dir_name, entryname, fib.read, fib.write,
                             busy_status,code);
                       if code^=0 then do;
                         err_msg = "from gcos_ids2_concur_$allocate ^a";
                         goto error_rtrn;
		     end;
                       if busy_status /* busy */ then do;
		        alloc_count = alloc_count +1;
		        if mod(alloc_count,5) = 0 then do;
			   call date_time_(clock(), ascii_date_time);
			   ascii_time = substr(ascii_date_time, 11,6);
			   call ioa_("*S^5a NEEDS ^2a PRMFL @ ^a",
			        ascii_snumb, file_id, ascii_time);
			   end; 
		        call timer_manager_$sleep(50, "11"b);
		        goto try_alloc_again;
		        end;
                     end;
          end;

	if fib.read & ^fib.write then
	     mode = "r";
	else mode = "rw";

	call ios_$attach (name, "file", fib.pathnm, mode, status); /* attach */
	if code ^= 0 then do;
	     err_msg = "from ios_$attach ^a";
	     goto error_rtrn;
	end;

	call ios_$setsize (name, 36, status);		/* set elsize to one word */
	if code ^= 0 then do;			/* fatal error */
	     err_msg = "from ios_$setsize ^a";
	     goto error_rtrn;
	end;

	if reattachsw then goto reattach_position;

	if fib.perm then do;			/* for permanent files only, determine actual file size */
	     call ios_$tell (name, "last", "first", fib.last, status); /* get last pointer for fib */
	     if code ^= 0 then do;			/* fatal error */
		err_msg = "from ios_$tell last first ^a";
		goto error_rtrn;
	     end;
	     fib.size = divide (fib.last+319, 320, 17, 0) * 320; /* round size up to multiple of 320 */
	end;
	if fib.size = 0 then
	     fib.size = 3840;			/* if file still has no size, give it one link */

	if ^fib.perm then do;			/* truncate all temporary files */
	     call ios_$seek (name, "last", "first", 0, status);
	     if code ^= 0 then do;			/* fatal error */
		err_msg = "from ios_$seek last first ^a";
		goto error_rtrn;
	     end;

	     fib.last = 0;
	end;

	if dbs_attach_file then
	     call ioa_ ("gcos_attach_file_ stream=^a, file=^a", fib.stream, fib.pathnm);
	goto done;
%page;
attach_tape: ;
	if
	fib.serial_no = (5)"20"b3			/* 5 BCD spaces. */
	| fib.serial_no = (5)"11"b3			/* 5 BCD 9's */
	then do;					/* => scratch tape. */
	     scratch = "1"b;
	     label = "scratch";
	end;
	else do;					/* => Specific reel designated. */
	     scratch = "0"b;
	     label = (5)"X";			/* Set initially to length 5. */
	     call gcos_cv_gebcd_ascii_ (		/* Convert BCD reel number to ascii. */
		addr (fib.serial_no)
		, 5
		, addrel (addr (label), 1)
		);
	end;
	if fib.tracks = "01"b then label = label||",7track"; /* 7 track tape requested */
	else
	if fib.tracks = "10"b then label = label||",9track"; /* 9 track tape requested */
						/* else use installation default */
	label = label || ",blk=" || ltrim (char (gcos_ext_stat_$tape_buffer_size));
	do j = 1 to hbound (dens, 1) ;
	     if fib.density = dens (j) then do ;
		label = label||",den=";
		label = label||dens_string (j);
		goto determine_mode ;
	     end ;
	end ;

determine_mode: ;

	if fib.write then
	     mode = "rw";				/* attach with ring */
	else mode = "r";				/* attach with no ring */

	call ios_$attach ((name), tape_module, (label), mode, status);
	if code ^= 0 then				/* attach error */
	     call gcos_error_ (code, "tape attach error: label = ^a", label);

	if scratch then do;
	     call ios_$order ((name), "rewind", null, status);
	     call ios_$write ((name), addr (tape_label), 0, 14, nwr, status);
	     call ios_$order ((name), "rewind", null, status);
	end;
	if dbs_attach_file then
	     call ioa_ ("gcos_attach_file_ stream=^a, tape=^a", name, label);

done:	;
	fib.attached = "1"b;			/* attachment is complete */
	return;
%page;
error_rtrn: ;

/* Come here on all errors from ios_ */

	if reattachsw then goto reattach_return;
	call gcos_error_ (code, err_msg, fib.pathnm);	/* pass error code on */
	return;
%page;
reattach:	entry (fp, a_code);

/* called by gcos_save_$restart */
	fibptr = fp;
	if fib.console | fib.null then
	     goto reattach_return;
	reattachsw = "1"b;
	name = fib.stream;
	goto attch;

reattach_position: ;
	if fib.last > 0 then do;			/* if file was non-null, see if it exists */
	     call ios_$tell (name, "last", "first", l, status);
	     if code = 0 then
		if l = 0 then			/* this means file is lost */
		     code = 1;			/* fake an error code */
	     if code ^= 0 then do;			/* real or fake error code */
		err_msg = "from ios_$tell last first ^a";
		goto reattach_return;
	     end;
	end;

	call ios_$seek (name, "read", "first", fib.current, status);
	if code ^= 0 then do;
	     err_msg = "from ios_$seek read first ^a";
	     goto reattach_return;
	end;

	if mode = "rw" then
	     call ios_$seek (name, "write", "first", fib.current, status);
	if code ^= 0 then
	     err_msg = "from ios_$seek write first ^a";

reattach_return: ;
	a_code = code;
	if code ^= 0 & ^gcos_ext_stat_$save_data.brief then
	     call com_err_ (code, "gcos_attach_file", err_msg, fib.pathnm);
	return;
%page;
/*   Variables for gcos_attach_file_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  acct                     char;
dcl  actid                    char(3) var;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  alloc_count              fixed bin(24)	/* count of allocation delays for a file */;
dcl  ascii_date_time          char(24);
dcl  ascii_time               char(6);
dcl  ascii_snumb              char(5);
dcl  busy_status              bit(1);
dcl  char			builtin;
dcl  clock                    builtin;
dcl  com_err_                 entry options (variable);
dcl  date_time_               entry (fixed bin(71), char(*));
dcl  dens                     (5) bit(4) int static options(constant) init("0001"b, "0010"b, "0100"b, "1001"b, "1100"b);
dcl  dens_string              (5) char(4) int static options(constant) init("200", "556", "800", "1600", "6250");
dcl  dir_name                 char(168);
dcl  divide                   builtin;
dcl  entryname                char(32);
dcl  error_table_$incorrect_access fixed bin(35)ext;
dcl  error_table_$namedup     fixed bin(35)ext;
dcl  error_table_$notalloc    fixed bin(35)ext;
dcl  error_table_$segknown    fixed bin(35) ext static;
dcl  err_msg                  char(100) varying;
dcl  expand_pathname_         entry (char(*), char(*), char(*), fixed bin(35));
dcl  file_id                  char(8)	/* temp */;
dcl  gcos_cv_gebcd_ascii_     ext entry (ptr, fixed bin(24), ptr);
dcl  gcos_error_              ext entry options (variable);
dcl  gcos_ids2_concur_$allocate  entry (char(*), char(*), bit(1), bit(1), bit(1), fixed bin (35));
dcl  gcos_ids2_concur_$create_control  entry (char(*), char(*), fixed bin(35));
dcl  gcos_ids2_concur_$have_xid  entry (char(*), char(*), fixed bin(35)) returns (bit(1));
dcl  gcos_verify_tss_access_  entry (char(*), char(*), bit(6), ptr, bit(1) unal, bit(72));
dcl  gcs_status_bits          bit(72) based (addr (gcs_status));
dcl  hbound                   builtin;
dcl  hcs_$append_branchx      entry (char(*), char(*), fixed bin(5), (3) fixed bin(3), char(*), fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35));
dcl  ioa_                     ext entry options (variable);
dcl  l                        fixed bin(21);
dcl  label                    char(40)varying aligned;
dcl  length                   builtin;
dcl  ltrim		builtin;
dcl  mod                      builtin;
dcl  mode                     char(2);
dcl  name                     char(8);
dcl  null                     builtin;
dcl  nwr                      fixed bin(21);
dcl  persid                   char;
dcl  projid                   char(9);
dcl  reattachsw               bit(1)	/* reattach entry switch */;
dcl  rtrim                    builtin;
dcl  scratch                  bit(1)	/* scratch tape flag */;
dcl  substr                   builtin;
dcl  tape_module              char(5) int static options(constant) init("nstd_");
dcl  timer_manager_$sleep     entry (fixed bin(71), bit(2));
dcl  translate                builtin;
dcl  user_info_               entry (char(*), char(*), char(*));
dcl (i,j)fixed bin(24);

dcl 1 tape_label	aligned int static options(constant),
    2 identifier	(2)bit(36) init("272520200600"b3, "002022634320"b3), /* "GE  600 BTL " */
    2 installation	bit(36) init("272562202020"b3),	/* "ges   " */
    2 rsn		bit(36) init((6)"20"b3),			/* "      " */
    2 fsn		bit(36) init((6)"20"b3),			/* "      " */
    2 rlsn	bit(36) init("202000000001"b3),
    2 crdate	bit(36) init("0"b),
    2 rdays	bit(36) init("0"b),
    2 filename	bit(72) init("0"b),
    2 data	(4)bit(36) init((4) (6)"20"b3);

dcl 1 gcs_status,
      2 status	bit(12) unal init("4000"b3),
      2 pad1	bit(60) unal;

/* variables for gtss concurrency control -- commented out
dcl  alloc_start_blocked      fixed bin(71)	/ * time of entering blocked state on file allocation * /;
dcl  fixed                    builtin;
dcl  flt_delay                float bin (27);
dcl  get_lock_id_             entry (bit(36) aligned);
dcl  gtss_mcfc_$open          entry (char(*), char(*), bit(6), bit(36) aligned, bit(36) aligned, ptr, fixed bin(35));
dcl  index                    builtin;
dcl  lock_id                  bit(36) aligned;
dcl  random_$normal           entry (float bin (27));
dcl  random_$set_seed         entry (fixed bin(35));
*/
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dbs_names;
%page;
%include gcos_dcl_ios_;
     end gcos_attach_file_;




		    gcos_build_pathname_.pl1        12/11/84  1357.5rew 12/10/84  1036.0       35235



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


/* *******************************************************************************************
   *******************************************************************************************
   *
   *
   *	Written by M. R. Jordan, October 1977
   *  Modified:  Ron Barstad  83-08-02  Added "_" as a valid fms name char.
   *  Modified:  Ron Barstad  84-02-21  Fixed fence check for userid 
   *
   *******************************************************************************************
   ******************************************************************************************* */
%page;
gcos_build_pathname_: proc (a_cfdesc_ptr, buf_ptr, dir_name, entry_name, fms_code);

	cfdesc_ptr = a_cfdesc_ptr;			/* Initialize any data items needed. */
	fms_code = (72)"0"b;
	fms_return_code_ptr = addr (fms_code);
	fms_return_code.termination_indicator = "1"b;
%page;
/*

   Now start to build the pathname.  First we must get the proper prefix
   for the user's current mode of operation.

*/


	pathname = save_data.pathname_prefix;
	if cfdesc_name = (72)"1"b then do;
	     if (^save_data.skip_umc) & gcos_ext_stat_$userid = "" then
		call gcos_mme_bort_$system (gcos_et_$unimp_mme,
		"A $ USERID card is necessary if UMC substitution is to be performed by the system.");
	     else name = gcos_ext_stat_$userid;
	end;
	else call bcd_to_ascii_ (cfdesc_name, name);
	if verify (rtrim (name), VALID_FMS_CHARS) ^= 0 then do ;


bad_char:

	     code = gcos_et_$fms_bad_cfdesc;
	     fms_return_code.bad_name_loc = rel (cfdesc_ptr);


report_error:

	     call gcos_fms_error_ (code, buf_ptr, fms_code);
	     return;
	end;
	if ^save_data.skip_umc then pathname = pathname || ">" || rtrim (name);
%page;
/*

   At this point we are ready to process the catalog/filename description
   past the umc name.  We must continuously check for the fence (a
   word equal to minus one) and for an out of bounds condition.

*/


	cfdesc_ptr = addrel (cfdesc_ptr, 4);

	do while (fence ^= (36)"1"b);
	     call bcd_to_ascii_ (cfdesc_name, name);
	     if verify (rtrim (name), VALID_FMS_CHARS) ^= 0 then goto bad_char ;
	     pathname = pathname || ">" || rtrim (name);
	     cfdesc_ptr = addrel (cfdesc_ptr, 4);
	end;
%page;
	call expand_pathname_ ((pathname), dir_name, entry_name, code);
	if code ^= 0
	then call gcos_mme_bort_$system (code,
	     """^a"" - attempting to build a Multics pathname from a GCOS catalog/filename description",
	     pathname);

	return;
%page;
dcl  VALID_FMS_CHARS char (39) static internal options (constant) init (".-0123456789_abcdefghijklmnopqrstuvwxyz");
dcl  a_cfdesc_ptr ptr;
dcl  addrel builtin;
dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  buf_ptr ptr;
dcl  cfdesc_name bit (72) based (cfdesc_ptr);
dcl  cfdesc_ptr ptr;
dcl  code fixed bin(35);
dcl  dir_name char (*);
dcl  entry_name char (*);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin(35));
dcl  fence bit (36) aligned based (cfdesc_ptr);
dcl  fms_code bit (72) aligned;
dcl  gcos_et_$fms_bad_cfdesc fixed bin(35) ext;
dcl  gcos_et_$unimp_mme fixed bin(35) ext;
dcl  gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned);
dcl  gcos_mme_bort_$system entry options (variable);
dcl  name char (12);
dcl  pathname char (256) varying;
dcl  rel builtin;
dcl  rtrim builtin;
dcl  verify builtin;
%page;
%include	gcos_ext_stat_;
%page;
%include gcos_fms_return_code_;

end gcos_build_pathname_;




		    gcos_cc_abort_.pl1              09/09/83  1400.3rew 09/09/83  1006.7       19377



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


gcos_cc_abort_: proc;

/* This procedure processes the $ ABORT card.

   When this card is encountered, we set up to put UTILITY directive cards
   onto U*, and continue processing until a terminator is found, at which
   time we run the activity. If the activity aborts, gcos_run_activity_ will
   build a MME GECALL UTILITY in the slave prefix, and transfer control to it,
   with U* being there and waiting for it.

   We turn on gcos_ext_stat_$save_data.abort_card to tell the rest of the simulator that the
   $ ABORT card was encountered.

   If PSW bit 1 is off, we turn on bit 12 so the slave program can look to see
   if a $ ABORT card was encountered. We use gcos_ext_stat_$save_data.abort_card rather than
   PSw bit 12 to decide whether to run UTILITY after an abort, and we will
   only do so in an EXECUTE activity. It is not clear to us whether this is
   correct: should the slave program be able to create a U* file and turn
   on bit 12 (in its wrapup, for example) to force an abort subactivity even
   though there was no $ ABORT card? is it true that abort subactivities are
   only run in EXECUTE activities, or are they run in all but FORTY and GMAP
   activities? and what is done if a $ ABORT card is encountered in an illegal
   context?


   WRITTEN BY T. CASEY DECEMBER 1973
   MODIFIED BY T. CASEY FEBRUARY 1974

   */

%include gcos_ext_stat_;

dcl (addr, substr) builtin;


	gcos_ext_stat_$nongcos = "u*";

	gcos_ext_stat_$save_data.abort_card = "1"b;

	if ^substr (save_data.psw, 2, 1) then	/* if bit 1 off */
	     substr (save_data.psw, 13, 1) = "1"b;	/* turn on bit 12 */

	return;

     end gcos_cc_abort_;




		    gcos_cc_activity_cards_.pl1     09/09/83  1400.3rew 09/09/83  1006.8      123975



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_cc_activity_cards_: proc (card, indx, gcos_record);

/*
   This procedure is called whenever an activity definition card (e.g.
   $ execute, $ fortran) is encountered. A structure is selected from
   an array of structures in gcos_control_tables_. The information in
   this structure is used to direct the setting of activity dependent
   variables such as psw bits, execute flag, time, line, and storage
   limits etc. Files needed for the activity are opened, as specified
   in the structure. Once the common processing is completed, specific
   routines are executed for each card type. Finally, the operands of
   the card are processed and a return is made to the caller.

   The format of an activity defining card is as follows.


   CONTROL CARD:	activity definition


   FORMAT:	$     activ     arg1,arg2,arg3,...argn


   FIELDS:

   arg1-argn: any of the parameters allowed for this type of activity card.
   Parameters are deck, ndeck, comdk, ncomdk, etc. See the GCOS III manual for
   description of parameters for each activity card type

   Author: DICK SNYDER AUGUST 24,1970
   Change: T.CASEY DECEMBER 1972, SEPTEMBER 1973, DECEMBER 1973, FEBRUARY 1974, AUGUST 1974
   Change: D. KAYDEN  MAY 1974
   Change: R.H. MORRISON  MAY 1975
   Change: M. R. Jordan, August 1977
   Change: Dave Ward	06/17/81 Reorganized.
   Change: Ron Barstad  82-11-16  Fixed format of actid for console msgs
   Change: Ron Barstad  83-08-02  Added activity_card_number initialization
                                  Added support for 4js3 new cards
*/
dcl  card                     char(80) parm	/* card image */;
dcl  gcos_record              char(*) parm	/* bcd card image, ovarlayed by char(*) variable */;
dcl  indx                     fixed bin(24)parm	/* offset in cardtable where card type was found */;

	unspec (zeros) = "0"b;			/* init zeros */
	gcos_ext_stat_$save_data.activ = "1"b;		/* indicate that activity is being defined */
	j, save_data.activity_no = save_data.activity_no + 1; /* Increment activity number. */

	pic = j;
	substr (save_data.actid, 7, 2) = pic;

	if ^gcos_ext_stat_$save_data.nosave then	/* if save then/restart  */
	     restart_control.na_hold = "0"b;		/* default activity restart option is "REST" */

	if save_data.activity_no >= save_data.last_execute_act_no then
	     substr (save_data.psw, 6, 1) = "0"b;

	gcos_ext_stat_$save_data.this_act_abort,
	     gcos_ext_stat_$save_data.dstar, gcos_ext_stat_$save_data.write_etc = "0"b; /* clear gcos_ext_stat_$save_data used for this card */

	gcos_ext_stat_$activity_card_num = gcos_ext_stat_$card_num;

/* 	Activity cards will now be processed using the activity descriptions */
/* 	found in segment gcos_control_tables_. See gcos_control_tables_.alm for description.	 */
	actptr = addr (gcos_control_tables_$activity_table); /* addr of base of table */
	actptr = addrel (actptr, (indx-gcos_control_tables_$exc_offset)*3); /* compute address of activity */
						/* description associated with this activity */

	gcos_ext_stat_$nongcos = "";
	gcos_ext_stat_$default_nondollar = substr (nondolr, 1, 2); /* get the default nondollar filecode */
	gcos_ext_stat_$nondollar = "";		/* blank out nondollar file code */
						/* it gets set to the default the first time nondollar cards
						   are found outside a $ DATA deck */


/* 	Compute address of variable information block		 */
	actptr = pointer (addr (gcos_control_tables_$), vib_offset);
	gcos_ext_stat_$activity_name = vib.activity;	/* save activity name */
	substr (save_data.psw, 1, 5) = substr (vib.psw, 1, 5); /* set psw bits 0-4 */
	substr (save_data.psw, 7, 12) = substr (vib.psw, 7, 12); /* set psw bits 6-17 */

/* 	Set time, storage, and sysout line limits		 */

/* ADD CODE TO SET time AND sysout LIMITS TO min(JOB LIMIT,vib.whatever) */
	gcos_ext_stat_$time_limit = vib.time;
	gcos_ext_stat_$storage_limit = vib.storage;
	gcos_ext_stat_$sysout_limit = vib.sysout;
	gcos_ext_stat_$sysout_lines = 0;

	op_ofs = vib.op_ofs;			/* Record options info. */
	op_len = vib.op_len;
	gcos_ext_stat_$ldrss = 0;			/* set loader shared storage to 0 */

/* 	Loop to open files required by this activity */
	actptr = addrel (actptr, 5);			/* bump ptr to variable info */

	do while (vib_file.filecode ^= zeros);		/* do until find 00 */

	     if substr (control, 5, 1) then		/* sysout file */
		call gcos_open_file_$sysout (vib_file.filecode, "0"b);
	     else do;
		if substr (control, 1, 1) then	/* flag says to use a lud */
		     lud = vib_file.filecode || "$";	/* create a lud from the filecode */
		else lud = "";

		call gcos_open_file_ (vib_file.filecode, lud, fibptr, present);

/* 	Set indicators in fib based on settings of control bits in vib */

		fib.read = "1"b;
		if substr (control, 2, 1) then fib.disp = "10"b;
		fib.write = substr (control, 3, 1);
		fib.type = substr (control, 4, 1);
		if ^present then fib.size = fixed (substr (control, 13, 6)) * 3840;

	     end;
	     actptr = addrel (actptr, 1);		/* Locate next file code */
	end;

	call gcos_open_file_$sysout ("p*", "0"b);	/* open p* */

	call gcos_open_file_ ("t*", "ty1", fibptr, present); /* open t* with unique lud */

	fib.console = "1"b;
	fib.disp = "10"b;

	go to wrapup (indx-gcos_control_tables_$exc_offset);

/*
   Finish up the processing of a $ EXECUTE card.
*/
wrapup (0):					/* EXECUTE */

	call gcos_open_file_ ("", "b*$", fibptr, present); /* open b* */
	if present then do;				/* but only if already there */
	     call gcos_open_file_ ("b*", "b*$", fibptr, present); /* call again with filecode */
	     fib.disp = "01"b;			/* set disp = "R" */
	end;
	else fib.used = "0"b;			/* otherwise forget it */

	do i = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (i) = "" then go to rs_hit;	/* locate available entry */
	end;
rs_hit:	fct.filecode (i) = "r*";			/* change its file code */
	fct.sysout (i) = "0"b;
	fibptr = gcos_ext_stat_$rs;
	fct.fibptr (i) = fibptr;
	fib.gein = "1"b;
	call gcos_write_$ptr (gcos_ext_stat_$rs, execute, "10000000"b); /* write $ execute */
	gcos_ext_stat_$nongcos = "r*";		/* indicate where nongcos dollar cards go */

	call gcos_open_file_ ("", "", fibptr, present);	/* set up a new r* file for next geload */
	gcos_ext_stat_$rs = fibptr;			/* save pointer to fib */

	fib.stream = "rstar";
	fib.disp = "10"b;

	go to evaluate;				/* go evaluate options */


/*
   Finish up the language control cards.
*/
wrapup (9):					/* FORTRAN */
wrapup (10):					/* PL1 */
wrapup (11):					/* COBOL */
wrapup (12):					/* GMAP */
wrapup (13):					/* 355MAP */
wrapup (14):					/* ALGOL */
wrapup (15):					/* FORTA */
wrapup (16):					/* FORTY */
wrapup (17):					/* JOVIAL */
wrapup (18):					/* ASM66 */
wrapup (19):					/* CBL74 */
wrapup (20):					/* CBL68 */
wrapup (21):					/* MALT */
wrapup (22):					/* ILANG */
wrapup (23):					/* IDS */
wrapup (24):					/* IDS2 */
wrapup (25):					/* 4TRAN */
wrapup (26):					/* G3EDIT */
wrapup (27):					/* FORT77 */
wrapup (28):					/* FORTX */
wrapup (29):					/* CIDS2 */
wrapup (30):					/* RPG2 */
	call gcos_write_$ptr (gcos_ext_stat_$rs, source, "10000000"b); /* write $ source */
	go to evaluate;				/* go evaluate options */


/*

   Finish up the processing of the $ PROGRAM card.
*/
wrapup (2):					/* PROGRAM */

	call gcos_get_cc_field_ (card, field, rtrn);	/* get name of prog to be loaded */
	if rtrn ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "Program name missing.^/^a^2x^a", gcos_ext_stat_$card_num, card);
						/* abort if no field */
	gcos_ext_stat_$activity_name = field;		/* put prog name in as activity to be run */
	go to evaluate;				/* go evaluate options */


/*
   Finish the processing of the $ FILEDIT card.
*/
wrapup (4):					/* FILEDIT */

/* write the filedit card on  F* and make provision for a following etc
   card to be written there, too */

	call gcos_write_$record ("f*", gcos_record, (8)"0"b);

	gcos_ext_stat_$save_data.write_etc = "1"b;	/* remember to write any etc card on F* */
	gcos_ext_stat_$etc_filecode = "f*";
	gcos_ext_stat_$save_data.dstar = "1"b;		/* lie, to prevent stranger option from
						   causing card to be written on d* also */
	goto evaluate;				/* all done */


/*
   Finish up then CONVER card (BMC).
*/
wrapup (3):					/* CONVER */

	gcos_ext_stat_$nongcos = "mc";

	go to evaluate;


/*
   Finish up the $ UTILITY card.
*/
wrapup (6):					/* UTILITY */
	gcos_ext_stat_$nongcos = "u*";
	go to evaluate;


/*
   Finish the processing of $ 355SIM or $ SYSEDIT cards.
*/
wrapup (1):					/* 355SIM */
wrapup (5):					/* SYSEDIT */
wrapup (7):					/* UTL2 */
wrapup (8):					/* CONVRT */



/* 	Come here to evaluate options on card				 */


/* 	Calculate address of and number of entries in option table from */
/* 	saved info.						 */

evaluate:	;
	j = divide (op_len, 3, 17);			/* Determine number of entries. */
	actptr = pointer (addr (gcos_control_tables_$), op_ofs); /* Location of options table. */

eval_loop: ;
	call gcos_get_cc_field_ (card, field, rtrn);	/* get field from card */
	if rtrn = END_OF_CARD then do;		/* quit if end of card */
	     gcos_ext_stat_$save_data.dstar, gcos_ext_stat_$save_data.write_etc = "0"b; /* turn off switches when finished with card */
	     return;
	end;

	if rtrn = NULL_FIELD then go to eval_loop;	/* continue if null field */

	do i = 1 to j;
	     if field = optab (i).option_type then do;
		if optab (i).idx = 1 then
		     save_data.psw = save_data.psw | optab (i).bits; /* Set bits ON. */
		else
		save_data.psw = save_data.psw & ^(optab (i).bits || (18)"0"b); /* Set bits OFF. */
		goto eval_loop;
	     end;
						/* if field matches type, go process */
	end;

/* Save/restart options  */

	if ^gcos_ext_stat_$save_data.nosave then do;
	     if field = "nrest" then restart_control.na_hold = "1"b; /* no activity restart */
	     else
	     if field = "njrest" then restart_control.nj_restart = "1"b; /* no job restart */
	     else
	     if field = "jrest" then restart_control.nj_restart = "0"b; /* restart job */
	     else
	     if field = "rest" then restart_control.na_hold = "0"b; /* restart activity */
	     else goto unknown_option;
	     goto eval_loop;
	end;

unknown_option: ;					/* unknown option causes card to be written on d* file */
	if ^gcos_ext_stat_$save_data.dstar then do;	/* if we did not already write it, do so */
	     gcos_ext_stat_$save_data.dstar = "1"b;	/* remember that we are going to write it */
	     gcos_ext_stat_$etc_filecode = "d*";	/*   and also tell get_cc_field to write any etc cards on d* */
	     gcos_ext_stat_$save_data.write_etc = "1"b;

/* truncate trailing words of blanks, as gcos does for the d* file */
	     i = 13;				/* 13th word of record (12th word of data) is cols 67-72 */
trunc_loop:    ;
	     if gcos_record_word (i) = six_bcd_blanks then do; /* if word is blank */
		i = i - 1;			/* truncate the word */
		goto trunc_loop;			/* and go look at the previous word */
	     end;

	     i = (i-1)*4;				/* compute length of char(*) overlay for what is left of the card
						   (the -1 gets rid of the rcw - it has wrong length now) */

/* gcos_write_ will create d* and set its disp to release for us */
	     call gcos_write_$bcd ("d*", substr (gcos_record, 5, i), "10000000"b);
	end;
	goto eval_loop;
%page;
/*   Variables for gcos_cc_activity_cards_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  actptr                   ptr;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  divide                   builtin;
dcl  END_OF_CARD              fixed bin(24)static internal options (constant) init (2);
dcl  execute                  char(80) int static options(constant) init ("$"||(6)" "||"execute");
dcl  field                    char(6)	/* return paramater from gcos_get_cc_field_ */;
dcl  fixed                    builtin;
dcl  gcos_error_              entry options (variable);
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_get_cc_field_       ext entry (char(80), char(*), fixed bin);
dcl  gcos_open_file_          ext entry (char(*), char(*), ptr, bit(1));
dcl  gcos_open_file_$sysout   ext entry (char(*), bit(1));
dcl  gcos_record_word         (13) bit(36) based (addr (gcos_record))	/* overlay for bcd card image */;
dcl  gcos_write_$bcd          ext entry (char(*), char(*), bit(8));
dcl  gcos_write_$ptr          ext entry (ptr, char(*), bit(8));
dcl  gcos_write_$record       ext entry (char(*), char(*), bit(8));
dcl  i                        fixed bin(24);
dcl  j                        fixed bin(24);
dcl  lud                      char(3)	/* holds a logical unit designator */;
dcl  NULL_FIELD               fixed bin(24)static internal options (constant) init (1);
dcl  op_len                   fixed bin(18)unsigned;
dcl  op_ofs                   fixed bin(18)unsigned;
dcl  pic                      pic "99";
dcl  pointer                  builtin;
dcl  present                  bit(1)	/* file present flag */;
dcl  rtrn                     fixed bin(17);
dcl  six_bcd_blanks           bit(36) int static init ((6)"20"b3   )	;
dcl  size                     builtin;
dcl  source                   char(80) int static options(constant) init ("$"||(6)" "||"source");
dcl  substr                   builtin;
dcl  unspec                   builtin;
dcl  zeros                    char(2)	/* holds 16 0 bits */;
%page;
%include gcos_restart_control_;
%page;
%include gcos_control_tables_;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_contrl_tables_data;
     end gcos_cc_activity_cards_;




		    gcos_cc_data_.pl1               12/11/84  1357.5rew 12/10/84  1036.0       73008



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



gcos_cc_data_: proc (card);

/* *****************************************************************************************
   *******************************************************************************************
   *
   *
   *	G C O S   $   D A T A   C A R D   P R O C E S S I N G
   *
   *
   *  This procedure handles the processing of the $  DATA card. This card has the
   *  following format:
   *
   *	$  DATA  FC,Options
   *
   *	Where FC is a two character file code and options are as follows:
   *
   *		C_K_S_U_M_	Binary checksums will be checked.
   *		NCKSUM	No checksums will be checked.
   *		COPY	All $ control cards will be copied
   *			up to a $ ENDCOPY card.
   *		N_C_O_P_Y_	No $ control cards will be copied.
   *		TAKEc	Card decks not punched by GE punches
   *			will be read. Any invalid punches will
   *			be replaced by the character following
   *			the TAKE (c).
   *		SEQ	Check sequence and delete activity if error.
   *			The COPY option overrides SEQ.
   *		CKSEQ	Check sequence and flag errors but don't
   *			delete activity.  The COPY option overrides CKSEQ.
   *		N_S_E_Q_	No sequence check.
   *		ENDFC	Match this $ DATA card with corresponding $ ENDCOPY.
   *		IBMF	IBM Fortran set
   *		IBMC	IBM Cobol set
   *		IBMEL	IBM Extended Language set (029 keypunch codes)
   *		IBMPL	PL/I set
   *		GE225	Model G-225 set
   *
   *	NOTE: If no options are specified, the underlined options
   *		  will be in effect.
   *
   *	CAUTION: The following options are the only ones implemented currently:
   *		COPY, NCOPY, CKSUM, NCKSUM, ENDFC, and NSEQ.
   *                Other options are recognized, and a warning message is issued.
   *
   *	WRITTEN BY DICK SNYDER JANUARY 8,1971
   *      MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973
   *      MODIFIED BY R.H. MORRISON ON APRIL 5, 1974
   *	MODIFIED BY D. KAYDEN APRIL 1974
   *	Modified by M. R. Jordan, April 1977 to process ENDFC option
   *	Modified by M. R. Jordan, August 1977 to process incode specifications.
   *	Change: Dave Ward	07/28/81 Allow period in name (By Dick Hemes)
   *      Change: Ron Barstad  84-11-19  Added # and $ as valid file code chars
   *
   *********************************************************************************************
   ****************************************************************************************** */

dcl  END_OF_CARD fixed bin(24)init (2) static int options (constant);
dcl  NULL_FIELD fixed bin(24)init (1) static int options (constant);
dcl  addr builtin;
dcl  card char (80);						/* input card image */
dcl  field char (6);						/* holder for field */
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_fc fixed bin(35) ext;
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_get_cc_field_ ext entry (char (*), char (6), fixed bin(24));
dcl  gcos_write_to_er_ entry options (variable);
dcl  result fixed bin(24);						/* result from gcos_get_cc_field_ */
dcl  substr builtin;
dcl  verify builtin;

/*

   Begin processing the $ DATA control card.  If the user has specified a DATA file outside an activity
   let him know about our ignoring it.

*/


	if ^gcos_ext_stat_$save_data.activ then do;
	     call gcos_write_to_er_ (
		"Warning:  The following $ DATA card is outside an activity definition.  It is being ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;


/*

   Get the file code from the $ DATA card.  If there is no file code,
   let the user know about our assumption of the file code i*.

*/


	call gcos_get_cc_field_ (card, field, result);

	if result ^= 0 then do;
	     field = "i*";
	     call gcos_write_to_er_ ("Warning:  i* used as default for data.^/^a^2x^a", gcos_ext_stat_$card_num, card);
	end;

/*

   Make sure the file code value is good (i.e., meets all of the requirements
   for a good file code).  Then save the file code for gcos_gein_ to use.

*/


	if verify (substr (field, 1, 2), "abcdefghijklmnopqrstuvwxyz0123456789.*#$") ^= 0 then
	     call gcos_error_ (gcos_et_$cc_bad_fc, "File code characters must be alphanumeric or .*#$   ""^a""^/^a^2x^a",
	     field, gcos_ext_stat_$card_num, card);
	if substr (field, 3) = " " then ;
	else if substr (field, 3) ^= "s" then
	     call gcos_error_ (gcos_et_$cc_bad_fc, "Disposition must be ""s"".  ""^a""^/^a^2x^a",
	     field, gcos_ext_stat_$card_num, card);
	else if verify (substr (field, 2, 1), "0123456789.*#$") ^= 0 then
	     call gcos_error_ (gcos_et_$cc_bad_fc, "Second file code character must be numeric or * when s disposition is specified.  ""^a""^/""^a^4x^a""",
	     field, gcos_ext_stat_$card_num, card);
	else do;
	     call gcos_error_ (0,
		"The saving of DATA files is not yet supported by the Multics GCOS Environment Simulator.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	end;

	gcos_ext_stat_$nondollar = substr (field, 1, 2);
	gcos_ext_stat_$save_data.nondollar = "1"b;


/*

   If no options appear then quit now.  Otherwise, initialize things and continue processing.

*/


	gcos_ext_stat_$save_data.copy, gcos_ext_stat_$save_data.cksum, gcos_ext_stat_$save_data.endfc = "0"b;
	gcos_ext_stat_$incode = 0;

	if result = END_OF_CARD then return;

/*

   Now process the optins on the $ DATA card one at a time.

*/


get:
	call gcos_get_cc_field_ (card, field, result);

	if result = END_OF_CARD then do;
	     if gcos_ext_stat_$save_data.endfc then
		if ^gcos_ext_stat_$save_data.copy then call gcos_error_ (gcos_et_$cc_bad_field,
		     "The ENDFC option requires the COPY option.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
	     if gcos_ext_stat_$incode ^= 0 then
		if ^gcos_ext_stat_$save_data.copy then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Incode specifications require the COPY option.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
	     return;
	end;
	if result = NULL_FIELD then go to get;


/*

   For COPY simply set the flag to say watch for a $ ENDCOPY card.

*/


	if field = "copy" then do;
	     gcos_ext_stat_$save_data.copy = "1"b;
	     go to get;
	end;


/*

   For ENDFC we need to set the flag and remember the file code.

*/


	if field = "endfc" then do;
	     gcos_ext_stat_$endfc = gcos_ext_stat_$nondollar;
	     gcos_ext_stat_$save_data.endfc = "1"b;
	     goto get;
	end;

/*

   The CKSUM and NCOPY options are defaults so we need to do very little.

*/


	if field = "cksum" then do;
	     gcos_ext_stat_$save_data.cksum = "0"b;
	     goto get;
	end;


	if field = "ncopy" then do;
	     gcos_ext_stat_$save_data.copy = "0"b;
	     goto get;
	end;


/*

   For NCKSUM mark no checksum checking.

*/


	if field = "ncksum" then do;
	     gcos_ext_stat_$save_data.cksum = "1"b;
	     go to get;
	end;


/*

   Process incode specifications.

*/


	if field = "ibmf" then do;
	     gcos_ext_stat_$incode = 1;
	     goto get;
	end;

	if field = "ibmc" then do;
	     gcos_ext_stat_$incode = 2;
	     goto get;
	end;

	if field = "ibmel" then do;
	     gcos_ext_stat_$incode = 3;
	     goto get;
	end;


/*

   The following processing is of options we recognize but do not support.

*/


	if field = "seq" | field = "nseq" | field = "ckseq" | substr (field, 1, 4) = "take" | field = "ge225"
	| field = "ibmpl" then do;
	     call gcos_write_to_er_ ("Warning:  ""^a"" is an unimplemented option on $ DATA cards.^/^a^2x^a",
		field, gcos_ext_stat_$card_num, card);
	     go to get;
	end;


/*

   We have found an unrecognized option.  Abort processing.

*/


	call gcos_error_ (gcos_et_$cc_bad_field, """^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card);

%include gcos_ext_stat_;


     end gcos_cc_data_;




		    gcos_cc_directive_cards_.pl1    09/09/83  1400.3rew 09/09/83  1006.8       50355



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



/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	PROCESS  ASSORTED  DIRECTIVE  CARDS
   *
   *
   *  This module processes assorted directive cards for BMC (CONVER),
   *  FILEDIT (the editor), the loader, and UTILITY.  This processing
   *  includes recognizing these control cards outside the activities
   *  for which they are meaningful and warning the user.  If the cards
   *  are found in the proper context, they are written to the proper
   *  file and processing is terminated.
   *
   *
   *  The following control cards are processed within:
   *
   *
   *	$	COMPILE
   *	$	COPY
   *	$	DELETE
   *	$	DUMP
   *	$	ENDEDIT
   *	$	ENDLD
   *	$	FFILE
   *	$	FORM
   *	$	FUTIL
   *	$	INCLUDE
   *	$	INPUT
   *	$	LIST
   *	$	MODIFY
   *	$	MULTI
   *	$	OUTPUT
   *	$	PATCH
   *	$	QUTIL
   *	$	SEQ
   *	$	SETSQ
   *	$	SYSLD
   *
   *
   *	Written by T. Casey,  November 1973
   *	Modified by D. Kayden,  April 1974
   *	Modified by M. R. Jordan,  July 1977
   *
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_cc_directive_cards_: proc (card, indx, gcos_record);

dcl  card char (80);						/* ascii card image */
dcl  indx fixed bin(24);						/* position in card table - not used here */
dcl  gcos_record char (*);						/* bcd card image overlayed by char (*) variable */
dcl  gcos_write_$record ext entry (char (*), char (*), bit (8));
dcl  gcos_write_to_er_ options (variable);
dcl  fc char (2);						/* temp for holding file code value */
dcl  addr builtin;

/*

   Process FILEDIT directives.  Note that we should never get one of these directives
   if the user has a good input file.  FILEDIT directives should only appear on *C.

*/


cc_editor: entry (card, indx, gcos_record);


	call gcos_write_to_er_ (
	     "Warning:  The following FILEDIT directive appears out of place.  It will be ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
	return;

/*

   Process SYSEDIT directives.  Note that we should never get one of these directives
   if the user has a good input file.  SYSEDIT directives should only appear on *C.

*/


cc_sysedit: entry (card, indx, gcos_record);


	call gcos_write_to_er_ (
	     "Warning:  The following SYSEDIT directive appears out of place.  It will be ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
	return;

/*

   Process SCED directives.  Note that we should never get one of these directives
   if the user has a good input file.  SCED directives should only appear on *C.

*/


cc_sced:	entry (card, indx, gcos_record);


	call gcos_write_to_er_ (
	     "Warning:  The following SCED (*C editor) directive appears out of place.  It will be ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
	return;

/*

   Process BMC (CONVER) directives.

*/


cc_bmc:	entry (card, indx, gcos_record);


	if gcos_ext_stat_$activity_name ^= "conver" then do;
	     call gcos_write_to_er_ (
		"Warning:  The following BMC (CONVER) directive appears out of place.  It will be ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;
	else go to write_it;

/*

   Process a $ FFILE control card.

*/

cc_ffile:	entry (card, indx, gcos_record);


	if gcos_ext_stat_$activity_name ^= "utilit" & gcos_ext_stat_$activity_name ^= "geload" then do;
	     call gcos_write_to_er_ (
		"Warning:  The following $ FFILE card appears out of place.  It will be ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;

	go to write_it;

/*

   Process a $ DUMP control card.

*/


cc_dump:	entry (card, indx, gcos_record);


	if gcos_ext_stat_$activity_name ^= "geload" then do;
	     call gcos_write_to_er_ (
		"Warning:  The following $ DUMP card appears out of place.  It will be ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;

	gcos_ext_stat_$save_data.nondollar = "1"b;
	gcos_ext_stat_$nondollar = "r*";		/* nondollar cards may follow this card */

	go to write_it;

/*

   Process a UTILITY directive card.

*/


cc_utility: entry (card, indx, gcos_record);


	if gcos_ext_stat_$activity_name ^= "utilit" then do;
	     call gcos_write_to_er_ (
		"Warning:  The following UTILITY directive appears out of place.  It will be ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;
	else goto write_it;

/*

   The following code is used by all entries in this module.  It will write the
   $ card to the proper file and get things set up for a $ ETC card following.

*/


write_it:

	fc = gcos_ext_stat_$nongcos;
	call gcos_write_$record (fc, gcos_record, (8)"0"b);


/*

   Now get things set up for a $ ETC card following this card.

*/


	gcos_ext_stat_$save_data.write_etc = "1"b;			/* in case it is continued */
	gcos_ext_stat_$etc_filecode = fc;

	return;

%include gcos_ext_stat_;

     end gcos_cc_directive_cards_;




		    gcos_cc_endjob_.pl1             09/09/83  1400.3rew 09/09/83  1006.8       98766



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


/* ***************************************************************************************
   *****************************************************************************************
   *
   *
   * 	$  E N D J O B  C A R D  P R O C E S S O R
   *
   *
   *  This procedure processes $ ENDJOB cards which have the following format:
   *
   *
   *     CONTROL CARD:		ENDJOB
   *
   *
   *     FORMAT:		$    ENDJOB
   *
   *
   *     FIELDS:		none
   *
   *  This procedure writes termination messages on console and execution report;
   *  finishes writing (and outputs) the execution report, sysout, print, and punch
   *  files; closes all files; and terminates the simulation via a nonlocal GOTO
   *  to a label in procedure gcos_gein_, thus cleaning up the stack.
   *
   *  This procedure is called:
   *
   *	1) when a $ ENDJOB card is encountered by gcos_gein_;
   *
   *	2) when the job is to be terminated for any reason other than a $ ENDJOB card,
   *	   (provided that it has not already been called once - thus an error in
   *	   this procedure or one that it calls cannot cause an infinite loop).
   *
   *
   *
   *****************************************************************************************
   *************************************************************************************** */
%page;
/*
   *
   *	WRITTEN BY DICK SNYDER	SEP 70
   *      MODIFIED BY T.CASEY		DEC 72
   *				OCT 73
   *				APR 74
   *				AUG 74
   *	MODIFIED BY D. KAYDEN	APR 74
   *				FEB 75
   *	MODIFIED BY R.H. MORRISON	MAY 75
   *	MODIFIED BY S.C. AKERS	DEC 81	Change \014 to %page;
  Modified:  Ron Barstad  82-11-00  Fix format of EOJ console msg
  Modified:  Ron Barstad  83-04-28  Print EOJ only if not abort and before dprint queued message
*/
%page;
gcos_cc_endjob_: proc (card);

	gcos_ext_stat_$save_data.endjob = "1"b;		/* remember that this procedure has been called
						   in this job, and therefore should not be
						   called again after any fault or error */

	er = gcos_ext_stat_$er;			/* copy fib pointer for speed */

	sysprint_stream = gcos_ext_stat_$prt -> fib.stream; /* copy stream names for speed */
	er_stream = er -> fib.stream;

/* job accounting */

	call gcos_time_convert_ ((clock_ ())-gcos_ext_stat_$job_real_time, rtt.time); /* get real time for job */

	call gcos_write_$ptr (er, string (rtt), "11111100"b); /* write on execution report */

	call hcs_$get_usage_values (k, cptime, k);	/* get current cputime */

	call gcos_time_convert_ (cptime-gcos_ext_stat_$job_cpu_time, ptt.time); /* get cp time for job */

	call gcos_write_$ptr (er, string (ptt), "11111100"b); /* put on execution report */

	call gcos_write_$ptr (er, eoj, "11111100"b);	/* end job on execution report */

	call gcos_write_$ptr (er, "", (8)"0"b);		/* eof on execution report */

/* Append execution report to sysout print collector file. First, though,
   write an ASCII record on that file, flagging the start of the execution report,
   force out the block containing that record, find the offset in the file of the
   next block (which will be the first block of the execution report), and write
   that offset, and the snumb of the job, into a record at the beginning of the
   sysout print collector file, that was written there earlier, to reserve
   space for this information. This facilitates printing the file in a GCOS-like
   format, by gcos_sysprint. */

	call gcos_write_$record_ptr (gcos_ext_stat_$prt, endrecord, (8)"0"b); /* write "start ex rpt" */

	call gcos_write_$force_ptr (gcos_ext_stat_$prt);	/* force out the block */

	call ios_$tell (sysprint_stream, "write", "first", ex_rpt_offset, status); /* get offset of next block */
	if code ^= 0 then do;
	     error_entry = "tell";
p_error:	     error_stream = sysprint_stream;
ios_error:     call gcos_error_ (code, "from ios_$^a ^a", error_entry, error_stream);
	end;

	call ios_$seek (sysprint_stream, "write", "first", 4, status); /* seek to word 4 (counting from zero)
						   0=bcw,1=rcw,2=newline,3=rec1,4=offset */
	if code ^= 0 then do;
seek_error:    error_entry = "seek";
	     goto p_error;
	end;

	first_record_subset.er_offset = ex_rpt_offset;	/* put in offset of first block */
	first_record_subset.snumb = substr (save_data.actid, 1, 5); /* put in snumb */

	call ios_$write (sysprint_stream, addr (first_record_subset), 0, 3, j, status); /* write 3 words */
	if code ^= 0 then do;
	     error_entry = "write";
	     goto p_error;
	end;

	call ios_$seek (sysprint_stream, "write", "first", ex_rpt_offset, status);
						/* seek write pointer back to first block */
	if code ^= 0 then goto seek_error;

	call ios_$seek (er_stream, "read", "first", 0, status); /* seek read pointer to start of file */
	if code ^= 0 then do;
	     error_entry = "seek";
er_error:	     error_stream = er_stream;
	     goto ios_error;
	end;

	eofsw = ""b;
	do while (^eofsw);				/* read 'til eof on execution report */
	     call ios_$read (er_stream, addr (buffer), 0, 320, j, status); /* read exec. report block */
	     if code ^= 0 then do;
		error_entry = "read";
		goto er_error;
	     end;

	     eofsw = substr (status, 46, 1);		/* save eof switch returned by ios_$read */

	     call gcos_write_$block_ptr (gcos_ext_stat_$prt, buffer); /* write block on sysout print collector */
						/* we use gcos_write_$block_ptr instead of ios_$write, here,
						   because the former puts the correct bsn into the bcw before
						   writing, thus avoiding bsn errors while reading it back */

	end;					/* end of do-while group */
						/* we fall thru here when we hit eof */
	er -> fib.print = "0"b;			/* reset so close_file_ will not queue it for sysout */


/* avoid writing EOF on an otherwise empty sysout punch collector file */

	if gcos_ext_stat_$pch -> fib.buffer ^= null then	/* if file not empty */
	     call gcos_write_$record_ptr (gcos_ext_stat_$pch, "", (8)"0"b); /* write EOF on it */

	if ^gcos_ext_stat_$save_data.nosave then	/* if save/restart specified */
	     call gcos_restart_$save;			/* save restart data */

restart:	entry;					/* entry for restart */

	if ^gcos_ext_stat_$save_data.brief & ^gcos_ext_stat_$save_data.this_act_abort
	     then do;	/* print end of job message on terminal,
						   unless user said -brief */
	     call date_time_ ((clock_ ()), holdtime);	/* get date and time */
	     call ioa_ (" *EOJ  ^a  @^a", save_data.actid, substr (holdtime, 11, 6));
	end;
/* queue sysout and close files */

	fibptr = addr (save_data.fibs);		/* close all remaining files */
	do i = 1 to hbound (save_data.fibs, 1);

	     if ^fib.used then go to not_used;
	     fib.disp = "01"b;			/* force file to be released */
	     call gcos_close_file_ (fibptr);

not_used:	     fibptr = addrel (fibptr, size (fib));
	end;

	call ios_$detach ("glib", "", "", status);	/* now detach the software libraries */
	if gcos_ext_stat_$save_data.userlib then
	     call ios_$detach ("slib", "", "", status);


	call gcos_sysout_writer_;			/* dispose of all files which are */
						/* queued in the sysout queue */

	call hcs_$truncate_seg (gcos_ext_stat_$gcos_slave_area_seg, 0, code); /* truncate slave segment */

	call ios_$detach ("gcos_job_stream_", "", "", status); /* in case it was a msf */
	call delete_$path (string (gcos_ext_stat_$save_dir), gcos_ext_stat_$job_id || ".job_deck", "000100"b, "gcos", code);

	if ^gcos_ext_stat_$save_data.nosave then
	     call delete_$path (string (gcos_ext_stat_$save_dir), gcos_ext_stat_$job_id || ".save_data",
	     "000100"b, "gcos", code);		/* get rid of it */
	goto gcos_ext_stat_$normal_return;		/* revert stack and return to gcos_gein_ */
%page;
/* 	D E C L A R A T I O N S				 */


%include gcos_ext_stat_;
/* 	External Entries					 */


dcl (ios_$read, ios_$write) ext entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned);
dcl size builtin;
dcl (ios_$seek, ios_$tell) ext entry (char (*) aligned, char (*), char (*), fixed bin(24), bit (72) aligned);
dcl  ios_$detach ext entry (char (*) aligned, char (*), char (*), bit (72) aligned);
dcl  clock_ ext entry returns (fixed bin(71));
dcl  ioa_ ext entry options (variable);
dcl  gcos_time_convert_ ext entry (fixed bin(71), char (19));
dcl  gcos_write_$ptr ext entry (ptr, char (*), bit (8));
dcl  gcos_write_$record_ptr ext entry (ptr, char (*), bit (8));
dcl  gcos_write_$block_ptr ext entry (ptr, char (*));
dcl  gcos_write_$force_ptr ext entry (ptr);

dcl  hcs_$get_usage_values ext entry (fixed bin(24), fixed bin(71), fixed bin(24));
dcl  hcs_$truncate_seg ext entry (pointer, fixed bin(24), fixed bin(35));
dcl  date_time_ ext entry (fixed bin(71), char (*));

dcl  gcos_close_file_ ext entry (pointer);
dcl  gcos_sysout_writer_ ext entry;

dcl  gcos_error_ ext entry options (variable);

dcl  delete_$path ext entry (char (*) aligned, char (*) aligned, bit (6), char (*), fixed bin(35));

dcl  gcos_restart_$save ext entry;						/* restart procedures */


/* 	Work Variables					 */

dcl  endrecord char (20) based (addr (end_record));
dcl 1 end_record aligned int static,
    2 rcw bit (36) init ("000000000000000100000000000011111100"b), /* length=4,media=3,report=74 */
    2 newline_word bit (36) init ("111111000001000000000000000000000000"b), /* 7701 */
    2 end_message char (12) init ("start ex rpt");

dcl 1 first_record_subset aligned,
    2 er_offset fixed bin(24)aligned,
    2 snumb char (5),
    2 pad char (3);

dcl  buffer char (1280);						/* 320 words */

dcl  ex_rpt_offset fixed bin(24);

dcl  status bit (72) aligned;
dcl  code fixed bin(35) based (addr (status));

dcl  error_entry char (32);
dcl  error_stream char (32);

dcl  eofsw bit (1) aligned;

dcl  er pointer;						/* local for fib pointer of execution report */

dcl  er_stream char (8) aligned;						/* for stream name of execution report */
dcl  sysprint_stream char (8) aligned;						/* stream name of sysprint file */


dcl  card char (80);						/* input card */
dcl (i, j) fixed bin(24);						/* temp */

dcl  k fixed bin(24);						/* temp */
dcl  cptime fixed bin(71);						/* cpu usage */
dcl  holdtime char (24);						/* date and time */
dcl 1 rtt int static,
    2 msg char (18) init ("real time total = "),
    2 time char (19),
    2 nls char (4) init ("



");

dcl (addr, addrel, null, string, substr) builtin;


dcl 1 ptt int static,
    2 msg char (23) init ("processor time total = "),
    2 time char (19),
    2 nls char (2) init ("

");

dcl  eoj char (12) int static init ("end-of-job

");
end gcos_cc_endjob_;




		    gcos_cc_file_cards_.pl1         09/09/83  1400.3rew 09/09/83  1006.8      202023



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


/* ******************************************************************************************
   *******************************************************************************************
   *
   *
   *	G C O S  F I L E  C A R D  P R O C E S S I N G
   *
   *
   *  This is the main driving module for the processing of the various gcos file
   *  assignment control cards. Cards processed by this module are the following:
   *
   *	$  PRINT  FC,LUD
   *	$  PUNCH  FC,LUD
   *	$  READ		(dummy entry - not really implemented )
   *	$  DISK   FC,LUD,ACCESS
   *	$  MASS   FC,LUD,ACCESS
   *  	$  FILE   FC,LUD,ACCESS
   *	$  DRUM   FC,LUD,ACCESS
   *	$  TAPE	FC,LUD,MULTIREEL,SERIAL NO,SEQ NO,FILE NAME,CLASS,DENSITY
   *	$  PRMFL  FC,ACC,MODE,PATH
   *	$  PRMFL  FC/LUD,ACC,MODE,PATH
   *	$  DAC  	FC
   *	$  SYSOUT	FC
   *
   *
   *	CONTROL CARD FIELDS
   *
   *	FC	FILE CODE
   *
   *	LUD	LOGICAL UNIT DESIGNATOR
   *		Channel letter
   *		followed by a channel number
   *		1-99 followed by the disposition
   *		and optional abort disposition
   *		(R=release,S=save,D=dismount,
   *		P=purge and release,
   *		C=continue,or blank = R).
   *
   *	ACCESS	FILE LENGTH AND ACCESS
   *		Length of file in 3840 word
   *		links followed by "l" or "r".
   *		"l" stands for linked or sequential files
   *		and "r" stands for random access files.
   *
   *	MULTIREEL	Any non-blank character used to denote a second tape.
   *		(This is referred to as the secondary logical unit
   *		designator in the fib.)
   *
   *	SERIAL-NO	Serial number of first tape
   *
   *	SEQ-NO	The number to the reel within a given file at
   *		which processing is to begin.
   *
   *	FILE-NAME	An external name given to the file. Used in giving
   *		mounting instructions to the operator.

   *	DENSITY	Tape density for MPC driven tape units.
   *
   *	ACC	FILE PERMISSION
   *		Letters w,r,a,x, or e for the type
   *		of access to be given to the file (write, read,
   *		append or execute. Multiple access codes are
   *		separated by slashs.
   *
   *	MODE	FILE ACCESS
   *		The letter "l" or "r", indicating linked or random, as described above .
   *
   *	PATH	FILE PATHNAME
   *		Full or partial pathname or GCOS file string of the file to be
   *		associated with the filecode.
   *
   *
   *	WRITTEN BY DICK SNYDER DECEMBER 7, 1970
   *	MODIFIED BY T. CASEY DECEMBER 1973, JUNE 1974
   *	MODIFIED BY D. KAYDEN APRIL 1974, JULY 1974, DECEMBER 1974, MARCH 1975
   *	Change: Dave Ward	07/28/81 Allow period in name (By Dick Hemes)
   *      Modified: Ron Barstad 83-05-12  Improve test for path running over cc 72
   *      Modified: Ron Barstad 83-08-02  Added 6250 tape den as per GCOS
   *
   *
   ********************************************************************************************
   ****************************************************************************************** */


gcos_cc_file_cards_: proc (card);


/* 	D E C L A R A T I O N S					 */


%include gcos_ext_stat_;


/* 	External Entries						 */


dcl  gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_open_file_ ext entry (char (*), char (*), ptr, bit (1));
dcl  gcos_open_file_$sysout ext entry (char (*), bit (1));
dcl  gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24));
dcl  gcos_get_cc_field_$asis entry (char (80), char (*), fixed bin(24));
dcl  gcos_error_ ext entry options (variable);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin(35));
dcl  gcos_interpret_file_string_ entry (char (*) varying, char (*), fixed bin(24), char (80));
dcl  ioa_ entry options (variable);
dcl  gcos_write_to_er_ entry options (variable);
dcl  gcos_et_$cc_unimp fixed bin(35) ext;
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_et_$cc_bad_fc fixed bin(35) ext;
dcl  gcos_et_$cc_bad_lud fixed bin(35) ext;



/* 	Work Variables						 */


dcl  card char (80);						/* input card image */
dcl  message char (50);
dcl  dac_sw bit (1);
dcl  present bit (1);
dcl (null_file, type_file, file_file) bit (1) init ("0"b);
dcl  fc char (2);						/* file code */
dcl  lud char (6) init (" ");						/* logical unit designator */
dcl  disp char (1) ;						/* normal disposition */
dcl  adisp char (1) ;						/* abort disposition */
dcl  cfdesc_field char (50);

dcl  field char (6);						/* holder for a field from a card */
dcl  tape_name char (12);
dcl  tape_serial_number char (5);
dcl  prmfl_fc_field char (8);
dcl  temp_tracks bit (2);						/* temporary for fib.tracks */
dcl (i, j, k, digit, cp) fixed bin(24);						/* temps */
dcl  code fixed bin(35);
dcl  result fixed bin(24);						/* holds result code from gcos_get_cc_field_ */
dcl  abs bit (72) aligned;						/* an aligned string for xlation */

dcl  x char (1);						/* temp */
dcl  path char (200) ;						/* holds pathname of permanent file */
dcl  prmfl_path char (168*2) varying ;						/* to hold the path or file string before we know which it is */
dcl  path_type fixed bin(24);						/* 0=dont know; 1=path;2=file string */
dcl  etc_next_sw bit (1) aligned ;						/* if path continued on etc card */
dcl  dirname char (168);
dcl  ename char (32);

dcl  DENS_CHARS (6) char (5) static internal options (constant) 
     init ("den2", "den5", "den8", "den9", "den16", "den62");
dcl  DENS_BITS (6) bit (4) static internal options (constant) 
     init ("0001"b, "0010"b, "0100"b, "0000"b, "1001"b, "1100"b);
dcl  END_OF_CARD fixed bin(24)static internal options (constant) init (2);
dcl  MULTICS_PATHNAME fixed bin(24)static internal options (constant) init (1);
dcl  GCOS_CFDESC fixed bin(24)static internal options (constant) init (2);
dcl 1 PERM (18) aligned static internal options (constant),
    2 NAME char (8) init ("r", "w", "a", "e", "x", "rec", "r/c", "w/c", "q", "t", "t/c", "c", "l", "r/w/c", "r/a", "r/w", "a/r", "w/r"),
    2 READ bit (1) init ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b),
    2 WRITE bit (1) init ("0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b),
    2 SUPPORTED bit (1) init ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b);

dcl (addr, fixed, index, length, null, substr, unspec, verify) builtin;

cc_read:	entry (card);

	call gcos_error_ (gcos_et_$cc_unimp, "^/^a^2x^a", gcos_ext_stat_$card_num, card);

cc_print:	entry (card);

	call Open_File;				/* set up fib */
	fib.print = "1"b;				/* indicate printfile */
	return;

cc_punch:	entry (card);

	call Open_File;				/* set up fib */
	fib.punch = "1"b;				/* indicate punch file */
	fib.write = "1"b;
	return;

cc_file:	entry (card);

	file_file = "1"b;
	call Open_File;				/* set up fib */
	if null_file then return;

	cp = 1;					/* init scan counter */
	call gcos_get_cc_field_ (card, field, result);	/* get access field */
	if result ^= 0 then fib.size = 3840;
	else do;
	     j = 0;				/* clear accumulator */

loop:	     i = fixed (unspec (substr (field, cp, 1)), 17); /* get next col in numeric form */

	     if i >= 48 then if i <= 57 then do;	/* ascii numeral ? */
		     cp = cp+1;			/* advance col indicator */
		     j = j*10+i-48;			/* shift accumulator */
		     go to loop;			/* see if any more digits */
		end;

	     if j ^= 0 then fib.size = 3840*j;		/* set specified no. of links */
	     else do;
		call gcos_write_to_er_ ("Warning:  File size specified is zero.  Assuming 1 link.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
		fib.size = 3840;
	     end;
	     if substr (field, cp) = "r" then		/* random file ? */
		fib.type = "1"b;			/* yes...indicate such */
	     else if substr (field, cp) = "l" then;
	     else call gcos_write_to_er_ (
		"Warning:  Unknown access mode ""^a"" specified.  Assuming ""l"".^/^a^2x^a",
		substr (field, cp), gcos_ext_stat_$card_num, card);
	end;


/*  at this point some test should be made for NEW or OLD in the next field  */


	fib.read, fib.write = "1"b;			/* turn on indicators */
	return;

cc_tape7:	entry (card);

	temp_tracks = "01"b;			/* indicates 7 track */
	goto tape_common;

cc_tape9:	entry (card);

	temp_tracks = "10"b;			/* indicates 9 track */
	goto tape_common;

cc_tape:	entry (card);

/* GCOS default is 7track tape; Multics default is installation dependent,
   and is often 9track, with NO 7track drives installed in the system.


   /*	temp_tracks = "01"b;	*/
tape_common:
	call Open_File;				/* set up fib */
	fib.tape = "1"b;				/* indicate tape */

	fib.tracks = temp_tracks;			/* save tape type requested */

	fib.serial_no = (5)"010000"b;			/* blank(bcd) serial no */
	fib.tape_name = (12)"010000"b;		/* and tape name */
	fib.seq_no = 1;				/* default reel sequence number */

	if index (card, " -noring") = 0 &		/* see if "no ring" option is present */
	index (card, " -nr") = 0 then fib.write = "1"b;	/* default is to use a ring */

/* 	For now, the secondary logical unit designator will be ignored since	 */
/* 	multi-reel files won't be needed for awhile.			 */

	call gcos_get_cc_field_ (card, field, result);	/* skip slud */

	call gcos_get_cc_field_ (card, tape_serial_number, result); /* get serial no. */

	if result = END_OF_CARD then return;		/* done if end of card */
	if result = 0 then do;
	     call gcos_cv_ascii_gebcd_ (addr (tape_serial_number), 5, addr (abs), i); /* convert serial no to bcd */
	     fib.serial_no = substr (abs, 1, 30);	/* fill in fib with returned value */
	end;


/* 	Come here to extract reel sequence number 			 */

	call gcos_get_cc_field_ (card, field, result);	/* get it */
	if result = END_OF_CARD then return;		/* done if end of card */
	if result = 0 then do;			/* if null field, go get tape name */

	     i = index (field, " ")-1;		/* get length of seq_no */
	     if i < 0 then i = length (field);
	     k = 0;				/* init accumulator */

	     do j = 1 to i;				/* loop to convert char string to binary */
		digit = index ("0123456789", substr (field, j, 1)); /* look up digit */
		if digit = 0 then call gcos_error_ (gcos_et_$cc_bad_field,
		     """^a""^/^a^2x^a", field,
		     gcos_ext_stat_$card_num, card);
		k = k*10+digit-1;			/* add to accumulator */
	     end;

	     fib.seq_no = k;			/* store in fib */
	end;


/* 	Come here to extract tape name				 */

	call gcos_get_cc_field_ (card, tape_name, result); /* get name */
	if result = END_OF_CARD then return;		/* done if end of card */
	if result = 0 then do;
	     call gcos_cv_ascii_gebcd_ (addr (tape_name), 12, addr (abs), i); /* convert to bcd */
	     fib.tape_name = abs;			/* move to fib */
	end;

	fib.density = "1111"b;			/* set density default */
	call gcos_get_cc_field_ (card, field, result);	/* skip class field */
	if result = END_OF_CARD then return;

	call gcos_get_cc_field_ (card, field, result);	/* get density field */
	if result ^= 0 then return;			/* done if not there */

	do i = lbound (DENS_CHARS, 1) to hbound (DENS_CHARS, 1);
	     if field = DENS_CHARS (i) then do;
		fib.density = DENS_BITS (i);
		return;				/* that's all */
	     end;
	end;

	call gcos_error_ (gcos_et_$cc_bad_field,
	     "Illegal density specification.^/^a^2x^a""",
	     gcos_ext_stat_$card_num, card);

cc_type:	entry (card);

	type_file = "1"b;
	call Open_File;
	return;

cc_dac:	entry (card);

	dac_sw = "1"b;				/* share code with cc_sysout */
	go to sysout_open;

cc_sysout: entry (card);

	dac_sw = "0"b;

sysout_open: ;
	if ^gcos_ext_stat_$save_data.activ then call gcos_write_to_er_ (
	     "Warning:  The following $ SYSOUT control card has been found outside an activity definition and is being ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

	call gcos_get_cc_field_ (card, field, result);
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "File code missing.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

	fc = substr (field, 1, length (fc));

	if verify (fc, "0123456789.abcdefghijklmnopqrstuvwxyz*") ^= 0 | fc = "00" then
	     call gcos_error_ (gcos_et_$cc_bad_fc, """^a""^/^a^2x^a", fc,
	     gcos_ext_stat_$card_num, card);

	call gcos_open_file_$sysout (field, dac_sw);
	return;

cc_prmfl:	entry (card);

/*  Pick up the filecode and open the file */

	call gcos_get_cc_field_ (card, prmfl_fc_field, result);
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "File code missing.^/^a^2x^a", gcos_ext_stat_$card_num, card);

	fc = substr (prmfl_fc_field, 1, 2);		/* pick up filecode */
	if verify (fc, "0123456789.abcdefghijklmnopqrstuvwxyz*") ^= 0 | fc = "00" then
	     call gcos_error_ (gcos_et_$cc_bad_fc,
	     """^a"" is not a valid file code.^/^a^2x^a", fc,
	     gcos_ext_stat_$card_num, card);

	x = substr (prmfl_fc_field, 3, 1);		/* must be blank or slash */
	if x ^= " " then if x ^= "/" then
		call gcos_error_ (gcos_et_$cc_bad_fc, "^a^2x^a",
		gcos_ext_stat_$card_num, card);

/* If FC/LUD was given, process the LUD */

	if x = "/" then lud = substr (prmfl_fc_field, 4);

	call Open_Prmfl;				/* get a fib and decode lud */

	fib.perm = "1"b;

/* Set access bits from permit field.			 */

	call gcos_get_cc_field_ (card, field, result);
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "Access field missing from $ PRMFL card.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

	do i = lbound (PERM, 1) to hbound (PERM, 1);
	     if PERM (i).NAME = field then do;
		if ^PERM (i).SUPPORTED then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Unsupported access mode.  ""^a""^/^a^2x^a", field,
		     gcos_ext_stat_$card_num, card);
		fib.write = PERM (i).WRITE;
		fib.read = PERM (i).READ;
		goto permissions_done;
	     end;
	end;
	call gcos_error_ (gcos_et_$cc_bad_field,
	     "Unrecognized permission ""^a"".^/^a^2x^a", field,
	     gcos_ext_stat_$card_num, card);


permissions_done:

	call gcos_get_cc_field_ (card, field, result);
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "An access mode is required.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

	if substr (field, 2, 1) ^= " " then call gcos_error_ (gcos_et_$cc_bad_field,
	     """^a"" is not a valid access mode.^/^a^2x^a", field, gcos_ext_stat_$card_num, card);
	if substr (field, 1, 1) = "r" then fib.type = "1"b; /* turn on random bit */
	else if substr (field, 1, 1) = "l" then fib.type = "0"b; /* turn off random bit */
	else if substr (field, 1, 1) = "s" then fib.type = "0"b; /* same as "l" */
	else call gcos_error_ (gcos_et_$cc_bad_field, "Access not ""r"", ""s"", or ""l"".^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

/* Process pathname field of the card. Here we deviate from the    gcos format of:

   catalog1$password1/...catalogn$passwordn/filename$password

   and allow full or partial Multics pathnames to be supplied as an alternative. Continuation
   of the pathname via a $ etc card is possible by following a > or / with a blank. */

	path_type = 0;
	prmfl_path = "";


get_path:	call gcos_get_cc_field_$asis (card, cfdesc_field, result);
	if result ^= 0 then do;
	     if etc_next_sw then call gcos_error_ (gcos_et_$cc_missing_field,
		"A $ ETC card is in error or missing at card number ^a.",
		gcos_ext_stat_$card_num);
	     else call gcos_error_ (gcos_et_$cc_missing_field,
		"^a^2x^a",
		gcos_ext_stat_$card_num, card);
	end;

	i = index (cfdesc_field, " ")-1;		/* find the end */
	if (i < 0) | (index(substr(card,16,73-15)," ")=0) then do;
	     call gcos_write_to_er_ ("Warning:  Check for a pathname or catalog/filename description overflow into column 73.^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     if ^gcos_ext_stat_$save_data.brief then call ioa_ ("Warning:  Check for a pathname or catalog/filename description overflow into column 73.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     i = length (cfdesc_field);
	end;
	x = substr (cfdesc_field, i, 1);		/* look at last character */
	if x = ">" then do;				/* if continued Multics pathname */
	     etc_next_sw = "1"b;			/* remember continuation */
	     if path_type = GCOS_CFDESC then call gcos_error_ (gcos_et_$cc_bad_field,
		"Terminator on this $ ETC card is incompatable with the previous card.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     path_type = MULTICS_PATHNAME;		/* remember its a pathname */
	end;

	else if x = "/" then do;			/* if continued GCOS file string */
	     etc_next_sw = "1"b;			/* remember continuation */
	     if path_type = MULTICS_PATHNAME then call gcos_error_ (gcos_et_$cc_bad_field,
		"Terminator on this $ ETC card is incompatable with the previous card.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     path_type = GCOS_CFDESC;			/* remember its a file string */
	end;
	else etc_next_sw = "0"b;

	if length (prmfl_path) >= 168*2 then call gcos_error_ (gcos_et_$cc_bad_field,
	     "Pathname or Catalog/Filename description is too long.  ""^a""^/^a^2x^a", prmfl_path,
	     gcos_ext_stat_$card_num, card);
	prmfl_path = prmfl_path || substr (cfdesc_field, 1, i); /* save (partial?) pathname */

	if etc_next_sw then do;			/* if continuation was indicated */
	     gcos_ext_stat_$gf = 3;			/* fool gcos_get_cc_cfdesc_field_ into reading a $ ETC card */
	     goto get_path;				/* and go call it */
	end;

	if path_type = 0 then do;			/* if we don't know what kind of path it is
						   we will have to figure it out heuristically */
	     i = index (prmfl_path, "/");		/* a file string must have at least one slash */
	     if i = 0 then path_type = MULTICS_PATHNAME;	/* if it doesn't, it has to be a pathname */
	     else do;				/* otherwise, we are still not sure, since
						   a pathname could contain a slash */
		i = search (prmfl_path, "<>");	/* see if it has a < or > in it */
		if i = 0 then path_type = GCOS_CFDESC;	/* if not, assume a file string */
		else				/* but if it does, Multics is going to treat it as a pathname */
		path_type = MULTICS_PATHNAME;		/* even if the user intended it to be a file string */
	     end;

	end;

	if path_type = GCOS_CFDESC then call gcos_interpret_file_string_ (prmfl_path, path, k, card);
	else path = prmfl_path;


/* Path holds pathname of file at this point 		 */

	call expand_pathname_ (path, dirname, ename, code);
	if code ^= 0 then call gcos_error_ (code, """^a""^/^a^2x^a", path,
	     gcos_ext_stat_$card_num, card);
	if dirname = ">" then fib.pathnm = ">" || ename;
	else fib.pathnm = rtrim (dirname) || ">" || ename;

exit:	return;					/* no more to do */


/*	I N T E R N A L   P R O C E D U R E S			*/


/* 	get file code and lud from control card		*/

Open_File: proc;

	     call gcos_get_cc_field_ (card, field, result); /* get file code from card */
	     if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "File code missing.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);

	     fc = substr (field, 1, length (fc));	/* save file code */
	     if fc = "00" | verify (fc, ".abcdefghijklmnopqrstuvwxyz0123456789*") ^= 0 then
		call gcos_error_ (gcos_et_$cc_bad_fc, """^a""^/^a^2x^a", fc, gcos_ext_stat_$card_num, card);

/* 	Process logical unit designator 				 */

	     lud = "";
	     call gcos_get_cc_field_ (card, field, result); /* get logical unit designator */
	     if result = 0 then do;			/* if no lud supplied, use defaults */
		if field = "null" & file_file then null_file = "1"b;
		else lud = field;
	     end;


/*	Get a fib and process the logical unit designator and disposition 	*/

Open_Prmfl:    entry;

	     if ^gcos_ext_stat_$save_data.activ then do;
		call gcos_write_to_er_ (
		     "Warning:  The following file card has been found outside an activity and is being ignored.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
		goto exit;
	     end;

	     disp, adisp = "";
	     if lud ^= " " then do;			/* check for no lud specified */
		if substr (lud, 6, 1) ^= " " then call gcos_error_ (gcos_et_$cc_bad_lud,
		     """^a""^/^a^2x^a", lud, gcos_ext_stat_$card_num, card);
		if verify (substr (lud, 1, 1), "abcdefghijklmnopqrstuvwxyz0123456789") ^= 0 then
		     call gcos_error_ (gcos_et_$cc_bad_lud,
		     "The first character of a LUD must be alphanumeric.  ""^a""^/^a^2x^a", lud,
		     gcos_ext_stat_$card_num, card);
		cp = verify (substr (lud, 2), "01234567890*")-1; /* separate dispositiin from lud */

		if cp = 0 then call gcos_error_ (gcos_et_$cc_bad_lud,
		     "Device name LUDs are not supported by the Multics GCOS Environment.  ""^a""^/^a^2x^a",
		     lud, gcos_ext_stat_$card_num, card);

		disp = substr (lud, cp+2, 1);
		if cp+3 < length (lud) then
		     adisp = substr (lud, cp+3, 1);
		lud = substr (lud, 1, cp+1);
	     end;

	     if type_file then do;			/* $ TYPE card */
		lud = "ty1";			/* "ty1" is always present for t* */
		disp, adisp = "s";
	     end;

	     call gcos_open_file_ (fc, lud, fibptr, present);

	     if null_file then do;			/* is this $ FILE FC,NULL ? */
		fib.null = "1"b;
		goto exit;			/* bypass setting of type and access */
	     end;

	     fib.disp = decode_disp (disp);		/* decode normal disposition */

	     if adisp ^= " " then			/* abort disposition present ? */
		fib.adisp = decode_disp (adisp);	/* yes - decode it */

	     else fib.adisp = fib.disp;		/* no - make it the same as the normal disposition */

	     if present then go to exit;		/* do not set other attributes for an existing file */
	     return;

decode_disp:   proc (dsp) returns (bit (2));


dcl  dsp char (1);


decode_disp:	if dsp = " " then return ("01"b);	/* blank = release */
		if dsp = "r" then return ("01"b);	/* R = release */
		if dsp = "s" then return ("10"b);	/* S = save */
		if dsp = "c" then return ("11"b);	/* C = continue */
		if dsp = "d" then return ("00"b);	/* D = dismount */
		if dsp = "p" then do;		/* P = purge */
		     fib.purge = "1"b;
		     return ("01"b);
		end;
		call gcos_write_to_er_ (
		     "Warning:  ""^a"" is a bad disposition character.  A disposition of ""r"" is being assumed.", dsp);
		return ("01"b);

	     end decode_disp;


	end Open_File;


     end gcos_cc_file_cards_;




		    gcos_cc_goto_.pl1               09/09/83  1400.3rew 09/09/83  1006.8       69102



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


gcos_cc_goto_: proc (card);

/* This procedure processes the $ GOTO, $ IF, and $ WHEN cards.
   If the Operator is true, or for $ GOTO, always, the Label to be
   transferred to is saved in gcos_ext_stat_$sought_label, and gcos_ext_stat_$save_data.seeking
   is set to "1"b; for $ WHEN, gcos_ext_stat_$save_data.seeking_terminator is also set to "1"b,
   so that gein will not go past the end of an activity looking for the label.

   For $ GOTO and $ IF, a Label of ENDJOB causes an immediate call to
   gcos_cc_endjob_ from this procedure, which exits via a non-local goto,
   rather than returning here.

   For $ IF ABORT, gcos_ext_stat_$save_data.this_act_abort is tested, and if it is "1"b,
   gcos_cc_misc_cards_$cc_break is called to reset the PSW and abort
   switches, before the search for the specified Label is begun.

   WRITTEN BY T. CASEY, DECEMBER 1973
   MODIFIED BY R.H. MORRISON, SEPTEMBER 1974, JULY 14, 1975
   Modified by M. R. Jordan, August 1977

   */


dcl  NL char (1) init ("
");						/* newline character */
dcl  addr builtin;
dcl  bool builtin;
dcl  card char (80);
dcl  field char (66);						/* returned field from get_cc_field_ */
dcl  gcos_cc_endjob_ ext entry;
dcl  gcos_cc_misc_cards_$cc_break ext entry;
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24));
dcl  gcos_write_to_er_ entry options (variable);
dcl  index builtin;
dcl  result fixed bin(24);
dcl  substr builtin;
dcl  var_msg char (j) based (addr (err_msg));						/* variable length overlay */

/*

   Process a $ GOTO control card.

*/



/* Come here from $ IF and $ WHEN as well, to get label field */

get_label: call gcos_get_cc_field_ (card, field, result);

/* see if it's ok */

	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Label field missing.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

/* ENDJOB? */
	if ^gcos_ext_stat_$save_data.seeking_terminator then /* if not $ WHEN card */
	     if field = "endjob" then			/* it could legally be ENDJOB */
		call gcos_cc_endjob_;		/* if it is, end the job */

/* set up to look for the label in the rest of the job deck */

	gcos_ext_stat_$sought_label = substr (field, 1, length (gcos_ext_stat_$sought_label));
	gcos_ext_stat_$save_data.seeking = "1"b;
	call gcos_write_to_er_ ("Note:^-$ card is true; sw=^w; skipping to ""^a"".^/^a^2x^a",
	     save_data.psw, field, gcos_ext_stat_$card_num, card);

	return;

/*

   Process a $ IF control card.

*/


cc_if:	entry (card);


	if operator () then goto get_label;		/* operator is an internal procedure,
						   that returns its value as a function. If the operator is
						   true, it will return "1"b, otherwise "0"b */

	return;					/* it must not have been true */

/*

   Process a $ WHEN control card.

*/


cc_when:	entry (card);


	if ^operator () then return;			/* evaluate operator and return if false */

	gcos_ext_stat_$save_data.seeking_terminator = "1"b;
	goto get_label;

/*

   The following is an internal procedure to evaluate the operator expression.

*/


operator:	proc returns (bit (1));

dcl (term_flag, elem_flag, not_flag, elem_val, psw_val) bit (1);
dcl (plus_indx, star_indx, not_indx) fixed bin(24);
dcl code fixed bin(35);
dcl  term char (52);
dcl  elem char (3);
dcl  ex_or bit (4) init ("0110"b);
dcl  cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
dcl  psw_pos fixed bin(35);
dcl  field char (72-15-1);

	     call gcos_get_cc_field_ (card, field, result);

	     if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Operator field missing.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);

	     if field = "abort" then do;		/* see if activity aborted */

		if gcos_ext_stat_$save_data.this_act_abort then do; /* if it did */

		     call gcos_cc_misc_cards_$cc_break; /* reset psw and abort gcos_ext_stat_$save_data */
		     return ("1"b);			/* tell main procedure that the operator is true */
		end;

		return ("0"b);			/* no abort - operator is false */
	     end;

/* evaluate operator expression */

next_term:
	     plus_indx = index (field, "+");		/* find next infix "+" operator */
	     if plus_indx = 0 then
		do;
		term_flag = "0"b;			/* reset flag to indicate no more terms in field */
		term = substr (field, 1, length (term)); /* field has only one term */
	     end;
	     else do;
		term_flag = "1"b;			/* set flag for more terms */
		term = substr (field, 1, plus_indx-1);	/* extract current field */
		if plus_indx = length (field) then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Illegal expression.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
		field = substr (field, plus_indx+1);	/* remaining terms in field */
	     end;

next_elem:
	     star_indx = index (term, "*");		/* find next infix "*" operator */

	     if star_indx = 0 then do;
		elem_flag = "0"b;			/* reset flag to indicate no more elements in current term */
		elem = substr (term, 1, length (elem)); /* term has only one element */
	     end;
	     else do;
		elem_flag = "1"b;			/* set flag for more elements */
		elem = substr (term, 1, star_indx-1);	/* extract current element */
		if star_indx = length (term) then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Illegal expression.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);
		term = substr (term, star_indx+1);	/* leave remaining elements in term */
	     end;

/* evaluate element */

	     not_indx = index (elem, "/");		/* see if element is complemented */
	     if not_indx = 0 then not_flag = "0"b;	/* reset flag, element not complemented */
	     else if not_indx = 1 then
		do;
		not_flag = "1"b;			/* element is complemented */
		elem = substr (elem, 2);		/* get rid of "/" */
	     end;

	     else call gcos_error_ (gcos_et_$cc_bad_field,
		"Illegal switch word bit specification.  ""^a""^/^a^2x^a",
		elem, gcos_ext_stat_$card_num, card);
	     psw_pos = cv_dec_check_ (elem, code);	/* convert character string element to numeric */
	     if code ^= 0 then
		call gcos_error_ (gcos_et_$cc_bad_field,
		"Illegal switch word bit specification.  ""^a""^/^a^2x^a",
		elem, gcos_ext_stat_$card_num, card);
	     if psw_pos > 35 | psw_pos < 0 then		/* bad */
		call gcos_error_ (gcos_et_$cc_bad_field,
		"Switch word bit specification must be 0 through 35.  ""^a""^/^a^2x^a",
		elem, gcos_ext_stat_$card_num, card);
	     psw_val = substr (save_data.psw, psw_pos+1, 1); /* psw bit value */

	     elem_val = bool (psw_val, not_flag, ex_or);	/* logical value of term so far */

/* decide where to go */
	     if elem_val & ^elem_flag then goto return_1; /* some term is true */
	     if ^elem_val & ^term_flag then goto return_0; /* no term is true */
	     if elem_val & elem_flag then goto next_elem; /* this element is true, test next element */
	     if ^elem_val & term_flag then goto next_term; /* this element not true, test next term */

return_0:	     return ("0"b);				/* return operator is false */

return_1:	     return ("1"b);				/* return operator is true */


	end operator;

%include gcos_ext_stat_;


     end gcos_cc_goto_;




		    gcos_cc_ident_.pl1              09/09/83  1400.3rew 09/09/83  1006.8       28494



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

/* ****************************************************************************************
   ******************************************************************************************
   *
   *
   *
   *	$   I D E N T  C A R D  P R O C E S S O R
   *
   *
   *  This procedure processes $ ident cards. The identification information is
   *  used to build banners for c* and p* (punch and printer files). The format
   *  of an ident card is as described below:
   *
   *
   *
   *  CONTROL CARD:	IDENT
   *
   *
   *  FORMAT:		$     IDENT     Account_no.,Identification
   *
   *
   *  FIELDS:
   *
   *  Account no.:
   *
   *  The account number is an installation dependent field and is ignored currently
   *
   * Columns 16-72 are saved in save_data.ident, for use by other programs.
   * Those columns get converted to BCD and placed in the slave prefix,
   *  by gcos_run_activity_.
   *
   *
   *
   *	WRITTEN BY DICK SNYDER AUGUST 19,1970
   *      MODIFIED BY T.CASEY DECEMBER 1972
   *      MODIFIED BY R.H. MORRISON ON 15 MARCH l974
   *	Modified by M. R. Jordan, August 1977
   *      Modified by Mel Wilson, March 1979 to set output headers from $ident information.
   *
   *
   ******************************************************************************************
   **************************************************************************************** */




gcos_cc_ident_: proc (card);

dcl  addr builtin;
dcl  card char (80);						/* input card image */
dcl  comma_nb fixed bin(24);
dcl  substr builtin;

	gcos_ext_stat_$save_data.save_data.ident = substr (card, 16, 57); /* save ident information */

/** set up dprint/dpunch destination info from $ident, if requested */
	if gcos_ext_stat_$save_data.identflag & ^gcos_ext_stat_$save_data.flgs.ident then do;
	     comma_nb = index (substr (card, 16, 57), ",");
	     if comma_nb ^= 0 then do;
		if index (gcos_ext_stat_$dpo, "-ds") = 0 then
		     gcos_ext_stat_$dpo = rtrim (gcos_ext_stat_$dpo) || " -ds """
		     || substr (card, comma_nb + 16, 9) || """";
		if index (gcos_ext_stat_$dpno, "-ds") = 0 then
		     gcos_ext_stat_$dpno = rtrim (gcos_ext_stat_$dpno) || " -ds """
		     || substr (card, comma_nb + 16, 9) || """";
	     end;
	end;

	gcos_ext_stat_$save_data.flgs.ident = "1"b;	/* indicate that ident processed */

	return;

%include gcos_ext_stat_;


     end gcos_cc_ident_;




		    gcos_cc_incode_.pl1             09/09/83  1400.3rew 09/09/83  1006.8       26406



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


/* **********************************************************************
   ************************************************************************
   *
   *
   *	$  INCODE  CARD  PROCESSING
   *
   *  This procedure processes $ INCODE cards in the following format:
   *
   *	$  INCODE  type
   *
   *  where type is the code type to be translated into bcd. Currently,
   *  this module takes three types, ibmf, ibmc, and ibmel. The
   *  actual implementation of this card is done in gcos_incode_ which will do
   *  the actual translation. All that is done in this module is to set some
   *  translation directing switches in external static.
   *
   *
   *  	WRITTEN BY DICK SNYDER DECEMBER 20,1971
   *      MODIFIED BY T.CASEY DECEMBER 1972
   *	MODIFIED BY D.KAYDEN JANUARY 1975
   *	Modified by M. R. Jordan, August 1977
   *
   ************************************************************************
   ********************************************************************** */




gcos_cc_incode_: proc (card);

dcl  card char (80);
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24));
dcl  result fixed bin(24);
dcl  type char (6);

/*

   Process a $ INCODE control card.

   First get the incode specification (type) from the control card.

*/


	call gcos_get_cc_field_ (card, type, result);	/* get translation type */
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Missing incode specification.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);


/*

   Now process the incode type.  If it is unsupported, say so.
   If it is unrecognized abort the processing of the job.

*/


	if type = "ibmf" then gcos_ext_stat_$incode = 1;
	else if type = "ibmc" then gcos_ext_stat_$incode = 2;
	else if type = "ibmel" then gcos_ext_stat_$incode = 3;
	else if type = "reset" then gcos_ext_stat_$incode = 0;
	else if type = "ge225" | type = "ibmpl" then call gcos_error_ (gcos_et_$cc_bad_field,
	     "An unsupported incode specification has been encountered.  ""^a""^/^a^2x^a", type,
	     gcos_ext_stat_$card_num, card);
	else call gcos_error_ (gcos_et_$cc_bad_field, "Unrecognized incode specification.  ""^a""^/^a^2x^a",
	     type, gcos_ext_stat_$card_num, card);


	return;

%include gcos_ext_stat_;



     end gcos_cc_incode_;




		    gcos_cc_limits_.pl1             09/09/83  1400.3rew 09/09/83  1006.8       61200



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

/* *****************************************************************************************
   *******************************************************************************************
   *
   *
   *	P R O C E S S  $  L I M I T S  C A R D
   *
   *
   *  The $ LIMITS card is used to modify the following standard activity limits:
   *
   *	Time--activity time limit expressed in hundredths of an hour
   *
   *	Storage1--max core required. Given in number of words required or
   *		in the form nk where k = 1024 words and n is a multiple.
   *
   *	Storage2--loader shared storage. Given same way as storage1
   *
   *	Sysout limit--number of sysout print lines allowed.
   *
   *	If this card is encountered before the first activity defining
   *	card, the time and sysout limits will be saved in special
   *	variables, and applied to the whole job, while any other non null
   *	values on the card will be effectively ignored (since the variables
   *	they are stored in will be overwritten with standard values
   *	when the first activity defining card is processed).
   *
   *	WRITTEN BY DICK SNYDER JANUARY 11,1971
   *	MODIFIED BY T. CASEY FEBRUARY 1974
   *	MODIFIED BY D. KAYDEN  JUNE 1974
   *	Modified by M. R. Jordan, August 1977
   *
   *
   ********************************************************************************************
   ****************************************************************************************** */




gcos_cc_limits_: proc (card);

dcl  END_OF_CARD fixed bin(24)static internal options (constant) init (2);
dcl  NULL_FIELD fixed bin(24)static internal options (constant) init (1);
dcl  accum fixed bin(24);						/* temp */
dcl  addr builtin;
dcl  card char (80);						/* input card image */
dcl  cp fixed bin(24);						/* card col position */
dcl  divide builtin;
dcl  fixed builtin;
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24));
dcl  nsw bit (1) aligned init ("0"b);						/* control switch */
dcl  psw bit (1) aligned init ("0"b);
dcl  result fixed bin(24);						/* result from getnum */
dcl  substr builtin;
dcl  sw bit (1) aligned init ("0"b);						/* control switch */
dcl  unspec builtin;



	call getnum;				/* get time limit field */
	if result = 0 then do;			/* null field...try next field */
	     if accum > 999 then accum = 999;		/* max activity = 9.99 hours */
	     accum = 36*accum;			/* convert time limit to secs */
	     if save_data.activity_no = 0 then	/* if activity 1 has not been defined yet */
		save_data.job_time_limit = accum;	/* this is the job time limit */
	     else
	     gcos_ext_stat_$time_limit = accum;		/* else this is the activity limit */
	end;


	sw = "1"b;				/* enable "k option" */
	call getnum;				/* get storage 1 field */
	if result = 0 then				/* null...try next field */
	     gcos_ext_stat_$storage_limit =		/* save storage limit */
	     divide (accum+1023, 1024, 17, 0) * 1024;	/* rounding up to a multiple of 1024 */


	nsw = "1"b;				/* enable negative value for loader space */
	call getnum;				/* get storage 2 field */
	if result = 0 then				/* null...try next field */
	     gcos_ext_stat_$ldrss = accum;		/* save value */


	psw = "1"b;
	nsw = "0"b;				/* disable negative value */
	call getnum;				/* get line limit */
	if result = 0 then do;			/* exit if null field */
	     if save_data.activity_no = 0 then	/* if activity 0 has not been defined yet then */
		save_data.job_sysout_limit = accum; /* this is the job sysout limit */
	     else
	     gcos_ext_stat_$sysout_limit = accum;	/* else this is the activity sysout limit */
	end;


exit:	return;					/* that's it */

getnum:	proc ();


/*  Internal procedure to extract a numeric field from a $ LIMITS card.
   This procedure has implicit inputs...sw and nsw. If sw is a 1, the field
   may legally contain a "k" which will cause the preceeding numeric portion of
   the field to be multiplied by 1024. If nsw = "1"b, negative values are allowed.
   The numeric field is accumulated in "accum". In addition, the result of the field
   extraction is returned in result. If the field was non-null , result
   is set to 0.  If the field was null, result is set to 1.  If the end
   of the card was reached, this procedure will not return.	*/


dcl  field char (12);
dcl  negative bit (1) aligned init ("0"b);						/* to remember a minus sign */
dcl  i fixed bin(24);						/* temp */


	     call gcos_get_cc_field_ (card, field, result);
	     if result = NULL_FIELD then return;	/* null field */
	     if result = END_OF_CARD then go to exit;	/* end of card */


	     cp = 1;				/* init field position */
	     accum = 0;				/* clear accumulator */


	     if psw then				/* if p string allowed in sysout limits ... */
		if substr (field, 1, 1) = "p" then do;
		     psw = "0"b;
		     cp = 2;
		end;


	     if nsw then				/* if negative value allowed */
		if substr (field, 1, 1) = "-" then do;	/* minus sign? */
		     nsw = "0"b;			/* only one allowed in a field */
		     negative = "1"b;		/* remember it */
		     cp = 2;			/* go get next digit */
		end;


next:	     i = fixed (unspec (substr (field, cp, 1)), 17)-48; /* pick up char */
	     if i >= 0 & i <= 9 then do;		/* numeric? */
		accum = accum*10+i;			/* add bcd digit to accumulator */
bump:		cp = cp+1;			/* skip to next digit */
		go to next;			/* go get it */
	     end;


	     if sw then if substr (field, cp, 1) = "k" then do;
		     accum = accum*1024;		/* multiply accum by 1k */
		     cp = cp+1;			/* "k" must be followed by a terminator */
		end;


	     if substr (field, cp, 1) ^= " " then	/* blank terminator */
		call gcos_error_ (gcos_et_$cc_bad_field, "Bad character in numeric field.  ""^a""^/^a^2x^a",
		substr (field, cp, 1), gcos_ext_stat_$card_num, card);


	     if negative then accum = -accum;		/* was there a minus sign? */


	     return;				/* exit */


	end getnum;

%include gcos_ext_stat_;



     end gcos_cc_limits_;




		    gcos_cc_loader_cards_.pl1       09/09/83  1400.3rew 09/09/83  1006.8       21312



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


/* *****************************************************************************************
   ******************************************************************************************
   *
   *
   *	G E L OA D  C O N T R O L  C A R D  P R O C E S S I N G
   *
   *
   *  This procedure writes the various loader control cards on the R* file.
   *  It also sets up R* to receive nondollar cards for $ OBJECT.
   *  cards, for OBJECT.
   *
   *  The cards processed by this procedure are the following:
   *
   *	$  OPTION		$  LIBRARY	$  LOWLOAD
   *	$  USE		$  ENTRY		$  NOLIB
   *	$  EQUATE		$  RELCOM		$  SOURCE
   *	$  NLOAD		$  OBJECT		$  DKEND
   *	$  LINK
   *
   *
   *	WRITTEN BY DICK SNYDER NOVEMBER 16,1970
   *      MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973
   *	MODIFIED BY D. KAYDEN  APRIL 1974
   *
   *******************************************************************************************
   **************************************************************************************** */

gcos_cc_loader_cards_: proc (card, indx, gcos_record);





/* 	D  E  C  L  A  R  A  T  I  O  N  S				 */


%include gcos_ext_stat_;

dcl  gcos_write_$record_ptr ext entry (ptr, char (*), bit (8));

dcl  card char (80);						/* ascii card image */
dcl  indx fixed bin(24);						/* position in cardtable - not used here */
dcl  gcos_record char (*);						/* bcd card image, overlayed by char(*) variable */

dcl  addr builtin;





write:	call gcos_write_$record_ptr (gcos_ext_stat_$rs, gcos_record, (8)"0"b); /* write card on r* */

	return;					/* that's all there is to do */



cc_object: entry (card, indx, gcos_record);

	gcos_ext_stat_$save_data.nondollar = "1"b;			/* tell gein to expect nondollar cards */
	gcos_ext_stat_$nondollar = "";		/* and to put them on geload R* collector file */
	go to write;


     end gcos_cc_loader_cards_;




		    gcos_cc_misc_cards_.pl1         12/11/84  1357.5rew 12/10/84  1036.0       48105



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


gcos_cc_misc_cards_: proc;

/* *  THIS PROCEDURE IS USED TO HANDLE SEVERAL CARDS THAT REQUIRE LITTLE OR NO
   *  PROCESSING IN THIS PASS OF THE SIMULATOR
   *
   *  WRITTEN BY T. CASEY NOVEMBER 1973
   *  MODIFIED BY T. CASEY FEBRUARY 1974
   *  Modified by M. R. Jordan, October 1977
   *  Modified:  Ron Barstad  83-08-03  Added "." and "_" as valid fms characters
   *  Modified:  Ron Barstad  84-02-21  Fixed length of userid if no password 
   *
   */

dcl  FMS_VALID_CHARS char (65) static internal options (constant) init (".-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
dcl  (index, rtrim, verify)  builtin;
dcl  card char (80);						/* ascii card image */
dcl  field char (5);
dcl  gcos_error_ entry options (variable);
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_et_$cc_unimp fixed bin(35) ext;
dcl  gcos_get_cc_field_ entry (char (80), char (*), fixed bin(24));
dcl  gcos_record char (*);						/* bcd card image, overlayed by char (*) variable */
dcl  gcos_write_$record ext entry (char (*), char (*), bit (8));
dcl  gcos_write_to_er_ ext entry options (variable);
dcl  i fixed bin(24);
dcl  indx fixed bin(24);						/* position in card table - not used here */
dcl  ioa_ ext entry options (variable);
dcl  length builtin;
dcl  result fixed bin(24);
dcl  substr builtin;
dcl  userid_field char (25);

/*  These cards get printed on operators console (user's console, for Multics)
   at the time the activity is run */

cc_msg2:
cc_comment:
	entry (card);

	call ioa_ ("^a", substr (card, 8, 72));		/* print the card */
	return;

/* These cards are acted upon in earlier passes, and are ignored in this pass */

cc_msg1:
cc_msg3:
	entry;
						/* do nothing */
	return;

cc_userid: entry (card);


	call gcos_get_cc_field_ (card, userid_field, result);
	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "Userid missing.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);


	i = index (userid_field, "$")-1;
	if i < 0 then i = length (rtrim(userid_field));


	if i > 12 then call gcos_error_ (gcos_et_$cc_bad_field,
	     "Userid longer than 12 characters.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
	if i <= 1 then call gcos_error_ (gcos_et_$cc_bad_field,
	     "Userid missing.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);


	if verify (substr (userid_field, 1, i-1), FMS_VALID_CHARS) ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field,
	     "Illegal charater(s) in userid.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);


	gcos_ext_stat_$userid = substr (userid_field, 1, i);


	return;

/* The $ BREAK card resets the abort flag, and psw bit 5,
   to allow executions to be run after an abort */

cc_break:	entry;


	if gcos_ext_stat_$save_data.prev_act_abort then do;		/* if an abort occurred */

	     gcos_ext_stat_$save_data.prev_act_abort = "0"b;		/* turn off abort flag */
						/* and set PSW bit 5 */
	     if save_data.activity_no		/* if the next activity */
	     < save_data.last_execute_act_no	/* is before the last execution activity */
	     then save_data.psw = save_data.psw | "000001"b; /* then turn on psw bit 5 */
	end;

	return;

/* The etc card might be a continuation of a card that the simulator writes
   on a file without interpreting. If so, we will write it on the same file.
   If not, the etc card is out of place - a nonfatal error */

cc_etc:
	entry (card, indx, gcos_record);


	if gcos_ext_stat_$save_data.write_etc then do;			/* if previous card was written on a file */
	     call gcos_write_$record (gcos_ext_stat_$etc_filecode, gcos_record, (8)"0"b);
	     return;
	end;

/* else fall thru to the out-of-place-card processing, which follows */

/* The following cards have showed up out of context, or we would not be here */
cc_alter:
cc_endcopy:
	entry (card);


	call gcos_write_to_er_ ("Warning:  The following $ card has been encountered out of context.  It will be ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
						/* gcos_error_ does not return */
	if gcos_ext_stat_$save_data.long then				/* print warning if -long was given */
	     call ioa_ ("Warning:  The following $ card has been encountered out of context.  It will be ignored.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);

	return;

cc_need:	entry (card);


	call gcos_get_cc_field_ (card, field, result);

	if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "^a^2x^a", gcos_ext_stat_$card_num, card);

	if field = "any" then return;

	if substr (field, 1, 3) = "sys" then call gcos_error_ (gcos_et_$cc_unimp,
	     "Only $ NEED ANY is allowed.^/^a^2x^a", gcos_ext_stat_$card_num, card);
	else call gcos_error_ (gcos_et_$cc_bad_field, """^a""^/^a^2x^a", field,
	     gcos_ext_stat_$card_num, card);

%include gcos_ext_stat_;


     end gcos_cc_misc_cards_;




		    gcos_cc_param_.pl1              09/09/83  1400.3rew 09/09/83  1006.8       29556



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



/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	PROCESS $ PARAM CONTROL CARD
   *
   *
   *  This module processes the $ PARAM control card.  This control card may
   *  be used to supply replacement parameters in a job stack.  It may also be
   *  used to replace parameter descriptions supplied using the -ag control
   *  argument to the gcos command.
   *
   *
   *	Written by M. R. Jordan,  July 1977
   * Modified:
   *  Ron Barstad  3.1  02/16/83  Fixed illegal $Param ioa, field was missing
   *
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_cc_param_: proc (card);

dcl  i fixed bin(24);
dcl  result fixed bin(24);
dcl  card char (80);
dcl  field char (72-15);
dcl  END_OF_CARD fixed bin(24)static internal options (constant) init (2);
dcl  gcos_get_cc_field_$no_param entry (char (80), char (*), fixed bin(24));
dcl  rtrim builtin;
dcl  hbound builtin;
dcl  gcos_error_ entry options (variable);
dcl  search builtin;
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;

/*

   Initialize a few values and prepare to prcoess all supplied fields.

*/


	result = 0;
	i = 1;


/*

   Now loop through all supplied fields.  Replace the param(i) value
   only when a non-null field is encountered.  This allows selective
   replacement of arguments supplied via -ag.

*/


	do while (result ^= END_OF_CARD);

	     call gcos_get_cc_field_$no_param (card, field, result);

	     if result ^= END_OF_CARD then do;		/* if this is a valid field then ... */

		call Set_Param ();			/* set the value. */

		i = i+1;				/* increment the param index */

	     end;

	end;


	return;

Set_Param: proc ();


/*

   Make sure we don't already have all the parameters we can handle.

*/


	     if i > hbound (save_data.param, 1) then call gcos_error_ (gcos_et_$cc_bad_field,
		"Maximum number of parameters exceeded.  Maximum is ^d.^/^a^2x^a", hbound (save_data.param, 1),
		gcos_ext_stat_$card_num, card);


/*

   Make sure the parameter consists of valid characters only.

   */


	     if search (field, "$/#") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field,
		"Illegal $ PARAM card field.  ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card);


/*

   The parameter value looks good.  Save it if it has not been overridden
   in the command line by the -ag control argument.

*/


	     if save_data.param (i) = "" then
		save_data.param (i) = rtrim (field);


	     return;


	end Set_Param;

%include gcos_ext_stat_;


     end gcos_cc_param_;




		    gcos_cc_set_.pl1                09/09/83  1400.3rew 09/09/83  1006.8       35253



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

/*   ***************************************************************************
   ***************************************************************************
   *                                                                         *
   *                                                                         *
   *                Process $ SET Control Card                               *
   *                                                                         *
   *                                                                         *
   * The $ SET control card is used to set or reset bits in the Program      *
   * Switch Word.                                                            *
   *                                                                         *
   *                                                                         *
   *    Written by R. H. Morrison February 22, 1974                          *
   *    Modified by R.H. Morrison April 4,1974                               *
   *    Modified by M. R. Jordan, August 1977
   *                                                                         *
   *                                                                         *
   ***************************************************************************
   ************************************************************************ */




gcos_cc_set_: proc (card);

dcl  END_OF_CARD fixed bin(24)static internal options (constant) init (2);
dcl  card char (80);
dcl  code fixed bin(35);
dcl  cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35));
dcl  field char (3);						/* returned field has 1,2, or 3 characters */
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24));
dcl  gcos_write_to_er_ entry options (variable);
dcl  nfield fixed bin(24);						/*  converted value of field  */
dcl  result fixed bin(24);						/* returned result code; 0,1,or 2  */
dcl  sr_flag fixed bin(24);						/* set psw bit = 0, reset psw bit = 1 */
dcl  substr builtin;
dcl  swit bit (36);						/*  image of Program Switch Word  */

	swit = save_data.psw;			/*  load image of ProgramSwitch Word  */
	result = 0;


	do while (result ^= END_OF_CARD);


	     call gcos_get_cc_field_ (card, field, result); /* get next field on $ SET card  */


	     if result = 0 then do;			/*  check if first field character is "/" */

		if substr (field, 1, 1) = "/" then do;	/* field specifies reset the bit */
		     sr_flag = 1;			/* set the flag */
		     field = substr (field, 2);	/* get rid of the "/" */
		end;
		else sr_flag = 0;

		nfield = cv_dec_check_ (field, code);
		if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Illegal switch word bit specification.  ""^a""^/^a^2x^a",
		     field, gcos_ext_stat_$card_num, card);

		if nfield > 35 | nfield < 0 then call gcos_error_ (gcos_et_$cc_bad_field,
		     "Switch word bit specification must be 0 through 35.  ""^a""^/^a^2x^a", field,
		     gcos_ext_stat_$card_num, card);

		if nfield = 5 then call gcos_write_to_er_ (
		     "Warning:  Switch word bit 5 should mot be modified using $ SET.^/^a^2x^a",
		     gcos_ext_stat_$card_num, card);

		if sr_flag = 0 then substr (swit, nfield+1, 1) = "1"b; /* set the bit */
		else substr (swit, nfield+1, 1) = "0"b; /* else reset the bit */

	     end;


	end;


	save_data.psw = swit;			/* update psw */


	return;

%include gcos_ext_stat_;



     end gcos_cc_set_;




		    gcos_cc_snumb_.pl1              09/09/83  1400.3rew 09/09/83  1006.8       32049



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


/* *****************************************************************************************
   *******************************************************************************************
   *
   *
   *
   *	$    S N U M B  C A R D  P R O C E S S O R
   *
   *
   *  This routine processes $ snumb cards which have the following format:
   *
   *
   *     CONTROL CARD:	SNUMB
   *
   *
   *     FORMAT:		$     SNUMB     Job_Identifier,Urgency
   *
   *
   *     FIELDS:		Job Identifier:
   *
   *     One to five characters used to identify job. Must not be
   *     blank or 00000.
   *
   *     Urgency:
   *
   *     A number from 1 to 63 which represents the relative
   *     importance of the job.
   *
   *     COMMENTS:	Must be the first card of the job.
   *		Urgency field is currently ignored.
   *
   *
   *
   *
   * WRITTEN BY DICK SNYDER AUGUST 18,1970
   * MODIFIED BY T.CASEY DECEMBER 1972
   * Modified by M. R. Jordan, August 1977
   * Modified by R. Barstad  Nov 1982  Fix format of actid for console messages
   *
   *
   ********************************************************************************************
   ****************************************************************************************** */




gcos_cc_snumb_: proc (card);

dcl  ZEROS char (5) static internal options (constant) init ("00000");
dcl  addr builtin;
dcl  card char (80);						/* card image of snumb card */
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_et_$cc_bad_card fixed bin(35) ext;
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_et_$cc_missing_field fixed bin(35) ext;
dcl  i fixed bin(24);						/* temp */
dcl  search builtin;
dcl  substr builtin;
dcl  verify builtin;

/*

   Make sure this is the only $ SNUMB card.

*/


	if gcos_ext_stat_$save_data.snumb then call gcos_error_ (gcos_et_$cc_bad_card, "Only one $ SNUMB card is allowed per job.^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);
	gcos_ext_stat_$save_data.snumb = "1"b;				/* indicate that snumb processed */


/*

   Save the activity number (initialized to 01) and snumb (from the card).

*/


	i = search (substr (card, 16, 5), " ,")-1;
	if i < 0 then i = 5;


	if i = 0 then call gcos_error_ (gcos_et_$cc_missing_field,
	     "The snumb is missing from the follwing $ SNUMB card:^/^a^2x^a",
	     gcos_ext_stat_$card_num, card);


	if substr (card, 16, i) = substr (ZEROS, 1, i) then /* snumb value cannot be zeros */
	     call gcos_error_ (gcos_et_$cc_bad_field, "Illegal snumb value.  ""^a""^/^a^2x^a",
	     substr (card, 16, i), gcos_ext_stat_$card_num, card);


	if verify (substr (card, 16, i), "0123456789ABCDEFGHIJKMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ^= 0 then
	     call gcos_error_ (gcos_et_$cc_bad_field, "Illegal snumb value.  ""^a""^/^a^2x^a",
	     substr (card, 16, i), gcos_ext_stat_$card_num, card);


	save_data.actid = substr (card, 16, i); /* save activity no and accnt i.d. */
	substr(save_data.actid,6,3) = "-01";

	return;					/* that's all there is to do */

%include gcos_ext_stat_;



     end gcos_cc_snumb_;




		    gcos_cc_update_.pl1             09/09/83  1400.3rew 09/09/83  1006.8       21987



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


/* *****************************************************************************************
   ******************************************************************************************
   *
   *
   *	P R O C E S S  $ U P D A T E  C A R D
   *
   *  The $ UPDATE control card is used when supplying alter input to a compiler
   *  or assembler. The nondollar filecode will be set to A*.
   *  In addition, bit 9 of the psw and gcos_ext_stat_$save_data.nondollar are turned on.
   *
   *
   *	WRITTEN BY DICK SNYDER JANUARY 11,1971
   *     MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973
   *     MODIFIED BY D. KAYDEN APRIL 1974
   *	Modified by M. R. Jordan, August 1977
   *
   *******************************************************************************************
   ***************************************************************************************** */




gcos_cc_update_: proc (card, indx, gcos_record);

dcl  addr builtin;
dcl  card char (80);						/* ascii card image */
dcl  gcos_record char (*);						/* bcd card image overlayed by char(*) variable */
dcl  gcos_write_$record ext entry (char (*), char (*), bit (8));
dcl  gcos_write_to_er_ entry options (variable);
dcl  indx fixed bin(24);						/* position in cardtable - not used here */
dcl  substr builtin;


	if ^gcos_ext_stat_$save_data.activ then do;			/* ignore if not defining an activity */
	     call gcos_write_to_er_ (
		"Warning:  The following $ UPDATE card is outside an activity definition.  It is being ignored.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);
	     return;
	end;

	gcos_ext_stat_$save_data.nondollar = "1"b;			/* tell gein to expect nondollar cards */

	gcos_ext_stat_$nondollar = "a*";		/* and to put them on A* */



	substr (save_data.psw, 10, 1) = "1"b;	/* set update bit in psw */
	call gcos_write_$record ("a*", gcos_record, (8)"0"b); /* put card on A* */
	return;

%include gcos_ext_stat_;


     end gcos_cc_update_;




		    gcos_check_for_mme_.alm         09/09/83  1400.3rew 09/09/83  1006.8       17496



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

"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"  When a gcos activity is set up to be run, the signal pointer in	"
"  the users' stack is set to point to this procedure.  Thus on the	"
"  occurence of a fault this procedure rather than signal_ is invoked."
"  This procedure then checks to see if the fault was caused by a	"
"  gcos mme.  If so, it transfers control to the gcos mme handler.	"
"  If not, it transfers control to signal_.  The condition mechanism	"
"  search for gcos mmes is thus bypassed.			"
"							"
"	Written by Peter M. Haber  8/22/72			"
"	Modified by T. Casey        June 1973
"	Modified by D. Kayden       December 1974
"	Change: Dave Ward 07/30/81 gcos_mme_processor_
"			changed to gcos_process_mme_
"							"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"
	name	gcos_check_for_mme_
	entry	gcos_check_for_mme_
"
"
	include	mc
"
gcos_check_for_mme_:

	eppbp	ap|2,*		pointer to fault name
	lda	bp|0		load fault name
	ldq	bp|1
	cmpaq	gc_mme		compare to "mme1"
	tnz	<gcos_ext_stat_>|[sig_ptr],*
"
	eppbp	ap|4,*		pointer to machine conditions
	eppbp	bp|0,*
	ldx0	bp|mc.scu.ppr.psr_word load psr word
	anx0	scu.ppr.psr_mask,du	isolate psr
	cmpx0	<gcos_ext_stat_>|[gcos_slave_area_seg]  check segment number
	tnz	<gcos_ext_stat_>|[sig_ptr],*
	tra	<gcos_process_mme_>|[gcos_process_mme_]	real gcos mme, transfer to gcos mme handler
"
"
	even
gc_mme:	acc	"mme1"
"
"
"
	end




		    gcos_cleanup_files_.pl1         09/09/83  1400.3rew 09/09/83  1006.8       64224



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_cleanup_files_: proc;

/*

   This procedure is called by gcos_run_activity_ after an activity terminates.
   It examines all the fibs and disposes of them according to the settings of
   of their indicators. The filecode table is also cleared.


   Author: DICK SNYDER SEPTEMBER 10,1970
   Change: T.CASEY DECEMBER 1972, APRIL 1974, JUNE 1974
   Change: D. KAYDEN  APRIL 1974
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	09/12/81 structured.
*/
	er = gcos_ext_stat_$er;

	call ioa_$rs ("^20xfc d type      #reqs^7xip^7xfp^7xis^7xfs^5xi/o stream", msg, k);
	call gcos_write_$ptr (er, nl, "11111100"b);
	call gcos_write_$ptr (er, var_msg, "11111100"b);
	call gcos_write_$ptr (er, nl, "11111100"b);

/* Check for files released by MME GERELS	 */
	do i = 1 to released_fibs.nrf;
	     fibptr = addr (released_fib (i));
	     fc = substr (fib.pathnm, 1, 2);
	     call display ("0"b);
	end;

/* The following loop disposes of fibs according to the settings
   of the various indicators. */
	do i = 1 to hbound (save_data.fibs, 1);
	     fibptr = addr (save_data.fibs (i));	/* get fib address */
	     if ^fib.used then go to next_fib;		/* skip if fib unused */
	     if fibptr = gcos_ext_stat_$prt then go to next_fib; /* skip simulapor files */
	     if fibptr = gcos_ext_stat_$pch then go to next_fib;
	     if fibptr = gcos_ext_stat_$rs then go to next_fib;
	     if fibptr = er then go to next_fib;

	     fc = "00";				/* initialize file code */
	     do j = 1 to hbound (fct, 1);		/* locate a file code for this file */
		if fct.filecode (j) ^= "" then
		     if ^fct.sysout (j) then
			if fct.fibptr (j) = fibptr then do;
			     fc = fct.filecode (j);	/* save the file code */
			     go to hit;
			end;
	     end;

hit:	     ;
	     if fib.console then
		if fc = "t*" then go to close;	/* don't display console t* */
	     if fc = "00" then
		if fib.plud = "435453"b3 then go to close; /* l* library */

	     if gcos_ext_stat_$save_data.this_act_abort then fib.disp = fib.adisp; /* use abort dispositions */

	     call display ("0"b);			/* display file status */

	     do j = 1 to (j-1), (j+1) to hbound (fct, 1); /* look for additional fc's on file */
		if fct.fibptr (j) = fibptr then do;
		     fc = fct.filecode (j);		/* save the file code */
		     call display ("1"b);
		end;
	     end;

	     fib.gein = "0"b;			/* clear in case file gets saved */
	     fib.iocount = 0;			/* reset in case file gets saved */

close:	     ;
	     call gcos_close_file_ (fibptr);		/* let gcos_close_file_ dispose of file appropriately */

next_fib:	     ;
	end;

/* Clear the file code table */
	do i = 1 to hbound (fct, 1);
	     if fct.sysout (i) then do;
		if fct.dac (i) then dev_type = "  DAC";
		else dev_type = "SYOUT";
		fc = translate (fct.filecode (i), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
		call ioa_$rs ("^20x^a  ^a", msg, k, fc, dev_type);
		call gcos_write_$ascii_ptr (er, var_msg, "11111100"b);
	     end;
	     fct.filecode (i) = "";			/* clear file code */
	     fct.sysout (i) = "0"b;			/* clear the sysout flag */
	     fct.fibptr (i) = null ();		/* null() the fib pointer */
	end;

	call gcos_write_$ptr (er, nl, "11111100"b);

/* Write end of activity record on sysout print collector file */
	call gcos_write_$record_ptr (gcos_ext_stat_$prt, addr (end_record) -> char20, (8)"0"b);
	call gcos_write_$force_ptr (gcos_ext_stat_$prt);

	return;
%page;
display:	proc (short);

dcl  short                    bit (1) parm;

	     if short = "0"b then do;
		if fib.tape then dev_type = " TAPE";
		else if fib.print then dev_type = " PRNT";
		else if fib.console then dev_type = " TYPE";
		else if fib.null then dev_type = " NULL";
		else dev_type = " DISK";

		disp = dsp (fixed (fib.disp));

		if fib.gein then gein = "*";
		else if fib.perm then gein = "P";
		else gein = " ";

		if fib.type then rand = "R";
		else rand = " ";

	     end;
	     fc = translate (fc, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");

	     if (dev_type = " DISK") & (short = "0"b) then
		call ioa_$rs ("^20x^a ^a^a ^1a^9d^9d^9d^9d^9d^1a^4x^a", msg, k, fc, disp, dev_type,
		gein, fib.iocount, divide (fib.init_posit, 320, 17, 0), divide (fib.current, 320, 17, 0),
		divide (fib.init_size, 320, 17, 0), divide (fib.size, 320, 17, 0), rand, fib.stream);

	     else
	     call ioa_$rs ("^20x^a ^a^a  ^9d^41x^a", msg, k,
		fc, disp, dev_type, fib.iocount, fib.stream);

	     call gcos_write_$ascii_ptr (er, var_msg, "11111100"b);

	     return;

	end display;
%page;
/*   Variables for gcos_cleanup_files_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  char20                   char(20)based;
dcl  dev_type                 char(5);
dcl  disp                     char(1);
dcl  divide                   builtin;
dcl  dsp                      (0:3) char(1) static int options(constant) init ("D", "R", "S", "C");
dcl  er                       ptr;
dcl  fc                       char(2);
dcl  fixed                    builtin;
dcl  gcos_close_file_         ext entry (ptr);
dcl  gcos_write_$ascii_ptr    ext entry (ptr, char(*), bit(8));
dcl  gcos_write_$force_ptr    ext entry (ptr);
dcl  gcos_write_$ptr          ext entry (ptr, char(*), bit(8));
dcl  gcos_write_$record_ptr   ext entry (ptr, char(*), bit(8));
dcl  gein                     char(1);
dcl  i                        fixed bin(24);
dcl  ioa_$rs                  entry() options(variable);
dcl  ioa_$rsnnl               entry() options(variable);
dcl  j                        fixed bin(24);
dcl  k                        fixed bin(24);
dcl  msg                      char(100);
dcl  null                     builtin;
dcl  rand                     char(1);
dcl  size                     builtin;
dcl  substr                   builtin;
dcl  system_free_area         area based (gcos_ext_stat_$system_free_pointer);
dcl  translate                builtin;
dcl  var_msg                  char(k) based (addr (msg));

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

/* The end_record structure following is written on the sysout print collector
   file at the end of each activity, so that gcos_sysprint will know to stop
   reading the file, and sort and translate the reports for the activity */

dcl 1 end_record int static options(constant) aligned,
      2 rcw bit(36) init ("000004000374"b3)	/* length=4, media code=3 (bcd print), report code= 74 */
,     2 newline_word bit(36) init ("770100000000"b3)	/* the 7701 (bcd newline) prevents gcos_sys_xlate_ from trying to translate the rest of the record from bcd */
,     2 end_message char(12) init ("end activity") /* Ascii characters in BCD record is intential */
;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_fibs;
     end gcos_cleanup_files_;




		    gcos_close_file_.pl1            09/09/83  1400.3rew 09/09/83  1006.8       60417



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_close_file_: proc (fp);

/*
   This procedure is called with a pointer to the file info
   block of the file to be closed. The disposition of the file
   is checked. If is is save, no action is taken. If it is
   continue and the file is a tape, a set file protect command
   is issued and the tape is rewound. If the disposition of the
   file is release or dismount, the file is detached. If the
   file is a scratch file, it is also deleted. If it is a print
   or a punch file, its pathname is paced in the sysout queue.

   Author: DICK SNYDER SEPTEMBER 21, 1970
   Change: T.CASEY DECEMBER 1972, OCTOBER 1973, AUGUST 1974
   Change: D. KAYDEN  APRIL 1974, JULY 1974, MARCH 1975, JUNE 1975
   Change: Dave Ward	09/13/81 structured.
   Change: R. Barstad         11/03/82  IDS2 concurrency control on detach
*/
dcl  fp                       ptr parm;
	fibptr = fp;
	if substr (fib.disp, 1, 1) then do;		/* disp = save */
	     if fib.tape then			/* tape */
		if fib.disp = "11"b then do;		/* with C disposition? */
		     call ios_$order ((fib.stream), "protect", null, status); /* set file to protected */
		     if code ^= 0 then do;		/* fatal error */
			err_msg = "from ios_$order protect ^a";
error_rtrn:		;
			call gcos_error_ (code, err_msg, fib.pathnm);
			return;
		     end;

		     call ios_$order ((fib.stream), "rewind", null, status); /* rewind tape */
		     if code ^= 0 then do;		/* fatal error */
			err_msg = "from ios_$order rewind ^a";
			go to error_rtrn;
		     end;
		     fib.disp = "10"b;		/* set file protect need not be done again */
		end;

	     return;				/* saved file - do not detach */
	end;

	if ^fib.attached then go to wipe;		/* stream never attached */

	if fib.console then go to wipe;		/* no attachment exists for a typewriter console either */

	if fib.null then go to wipe;			/* no attachment exists for a null file */

	if fib.tape then go to detach;

	call expand_path_ (addr (fib.pathnm), 168,	/* break pathname up */
	     addr (pname), addr (ename), code);		/* into entry and directory name */
	if code ^= 0 then go to path_error;		/* fatal error ? */

	if fib.perm then go to detach;		/* permanent disk file */

	if fib.print | fib.punch then do;
	     if fib.current = 0 then
		if fib.buffer = null		/* see if anything was written on the file */
		then go to detach;			/* if not, ignore it */


/* File is ready to be printed or punched. Add pathname of file to sysout */
/* queue. There is room for 10 files. */

	     save_data.sysout_queue (save_data.sqindex) = ename; /* copy entry name to queue */

/* set media code of sysout file */

	     if fib.print then
		save_data.sysout_queue_media (save_data.sqindex) = 3;
	     else save_data.sysout_queue_media (save_data.sqindex) = 1;

	     save_data.sqindex = save_data.sqindex + 1;	/* bump free entry index */

	end;
	else delete = "1"b;				/* file is scratch - remember to delete it */

detach:	;
	call ios_$detach ((fib.stream), "", "", status);	/* detach */
	if code ^= 0 then
	     if code ^= error_table_$ioname_not_found then do; /* fatal error ? */
		err_msg = "from ios_$detach ^a";
		go to error_rtrn;
	     end;

                                                            /* deallocate IDS2 file */
	if fib.perm & fib.type /* random */
	     then if gcos_ids2_concur_$have_xid(pname,ename,code) then do;
		call gcos_ids2_concur_$deallocate(pname,ename,fib.read, fib.write,code);
		if code ^= 0 then do;
		     err_msg = "from gcos_ids2_concur_$deallocate ^a";
		     goto error_rtrn;
		     end;
		end;

	if delete then do;
	     if gcos_ext_stat_$save_data.debug then	/* if user is interactive and wants questions */
		delete_switches = "27"b3 ;		/* noforce,question,nodirs,segs,links,chase */
	     else delete_switches = "07"b3 ;		/* noforce,noquestion,nodirs,segs,links,chase */

	     call delete_$path (pname, ename, delete_switches, "gcos", code);
	     if code ^= 0 then			/* if anything wrong */
		if code ^= error_table_$noentry then do; /* anything but file never having been written on, that is */
		     if ^gcos_ext_stat_$save_data.continue then /* unless -continue argument given, */
			if ^gcos_ext_stat_$save_data.endjob then do; /* or already aborting */
path_error:		     ;
			     err_msg = "attempting to delete ^a"; /* bomb out */
			     go to error_rtrn;
			end;
		     if ^gcos_ext_stat_$save_data.brief then /* if user did not say -brief, print warning */
			call com_err_ (code, "gcos_close_file_", "attempting to delete ^a", fib.pathnm);
		end;
	end;

/* Remove buffer. */

wipe:	;
	fib.used = "0"b;				/* set unused */
	if fib.buffer_indx > 0 then
	     buffer_in_use (fib.buffer_indx) = "0"b;
	fib.buffer_indx = 0;
	fib.buffer = null;				/* set buffer null */

	return;
%page;
/*   Variables for gcos_close_file_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  code                     fixed bin(35) based (addr (status))	/* error rtrn code */;
dcl  com_err_                 ext entry options (variable);
dcl  delete                   bit (1) init ("0"b);
dcl  delete_$path             ext entry (char (*), char (*), bit (6), char (*), fixed bin(35));
dcl  delete_switches          bit (6);
dcl  ename                    char (32)	/* entry name of a file */;
dcl  error_table_$ioname_not_found ext static fixed bin(35)	/* error code for no attach */;
dcl  error_table_$noentry     ext static fixed bin(35)	/* error code for no entry */;
dcl  err_msg                  char (60) var;
dcl  expand_path_             ext entry (pointer, fixed bin(24), pointer, pointer, fixed bin(35));
dcl  gcos_error_              ext entry options (variable);
dcl  gcos_ids2_concur_$deallocate ext entry (char(*), char(*), bit(1), bit(1), fixed bin (35));
dcl  gcos_ids2_concur_$have_xid ext entry (char(*), char(*), fixed bin(35)) returns (bit(1));
dcl  ios_$detach              ext entry (char (*) aligned, char (*), char (*), bit (72) aligned);
dcl  ios_$order               ext entry (char (*) aligned, char (*), ptr, bit (72) aligned);
dcl  null                     builtin;
dcl  pname                    char (168) 	/* path name of a file */;
dcl  status                   bit (72) aligned	/* ios_ status */;
dcl  substr                   builtin;
dcl  endoutput                char (33) int static init ("     ***end of output***
");
%page;
%include gcos_fibs;
%page;
%include gcos_ext_stat_;
     end gcos_close_file_;




		    gcos_control_tables_.alm        09/09/83  1400.3rew 09/09/83  1006.8      153369



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
	name	gcos_control_tables_
"
" This program provides the "gcos_control_tables_" data base
" (Multics object) for the GCOS batch simulator ("gcos"
" command). The data base defines the $ control cards
" recognized by the simulator, the control card options and
" what file cards are provided for activity control cards.
" 
" This data base is referenced using the
" "gcos_control_table_$X" external variables, where "X" is any
" of the following segdefs.
"
	segdef	cardtable
	segdef	activity_table
	segdef	tablelen
	segdef	totallen
	segdef	filecard_count
	segdef	comp_offset
	segdef	exc_offset
	segdef	nonact
	segdef	tabstops
"
"  Author: Dick Snyder	August 25,1970
"  Change: T. Casey		June 1973, Sept 73, Dec 73, Feb 74, Mar 74, Aug 74
"  Change: D. Kayden	April 1974
"  Change: R.H. Morrison	October 1974, July 14, 1975, September 19,1975
"  Change: R.H. Morrison	Jan 30, 1976
"  Change: M. R. Jordan	August 1977 Rewritten.
"  Change: Dave Ward	02/11/81 Reorganized. Documented macro args. IDS2.
"  Change: Ron Barstad        83-08-09 Brought up to 4JS3 functionality

" 	define	arg1
" 	define	arg1,arg2,...,arg8
"  arg1	name of $ card.
"  arg2	(optional) name of library module [default: arg1].
"  arg3	one or more names (parenthesized if >1) default options.
"  arg4	file code of source.
"  arg5	execution time (hundredths of CPU hours).
"  arg6	memory size (in K 1024 word increments).
"  arg7	limit of number print lines (thousands of lines).
"  arg8	name of tabulation table.
	macro	define
	maclist	off
	use	cards
	aci	"&1  ",8
	ine	&K,1
	use	fibs
	vfd	18/0,18/&u
	aci	"&4  ",4
	vfd	36/((&8-tabtable)/10)
	use	vibs
&p:	null
	aci	"&=&2,&[&1&;&2&]  ",8
	vfd	18/&(3&=&x,1&[&i&;+&i&]&),18/&5*36
	vfd	18/&6*1024,18/&7*1000
	vfd	18/optab,18/endtab-optab
	ifend
	maclist	restore
	&end

"	file	arg1,arg2
" arg1	file code.
" arg2	sysout.
"	file	arg1,arg2,arg3
" arg1	file code.
" arg2	file length (in links).
" arg3	lud, access, organization & retention designators.
	macro	file
	maclist	off
	vfd	&=&2,sysout&[12/sysout,6/0&;12/&(3&=&x,1&[&i&;+&i&]&),6/&2&],a18/&1
	maclist	restore
	&end

" 	option	arg1,arg2,arg3
"  arg1	name of the option (on $ option card).
"  arg2	set (on) or reset (off).
"  arg3	BCD name (<=6 characters uppercase).
	macro	option
	maclist	off
	aci	"&1  ",8
	vfd	18/&2,18/&3
	maclist	restore
	&end

" Declarations of local variables.
"
"	file card mnemonics.
"
	bool	generate_lud,4000
	bool	random,0400
	bool	save,2000
	bool	sysout,0200
	bool	write,1000
"
"	options definition mnemonics
"
	equ	set,1
	equ	reset,2
"
	bool	BCD,000002
	bool	CLEAR,020000
	bool	COMDK,004000
	bool	COPY,000010
	bool	DEBUG,000100
	bool	DECK,002000
	bool	DUMP,400000
	bool	EXTEND,000002
	bool	FORM,000010
	bool	FORT,200000
	bool	GESAVE,000004
	bool	LNO,000004
	bool	LSTIN,000200
	bool	LSTOU,001000
	bool	MAP,000040
	bool	NGMAC,000100
	bool	ON1,004000
	bool	ON2,002000
	bool	ON3,001000
	bool	ON4,000400
	bool	ON5,000200
	bool	ON6,000100
	bool	OPTZ,000001
	bool	PURGE,040000
	bool	STAB,000100
	bool	SYMTAB,100000
	bool	UPDATE,000400
	bool	XREF,100000

" Definitions of $ control cards.
"
"	Purpose: Look up table for gcos to determine what card type it has
"	read and if that card terminates an activity def'n
"	and possibly defines a new activity.
"
"	NOTE!!! It is critical that activity definitions preceed non-activity
"	definitions in the section beginning at label "tad". It is also critical
"	that the order of activity definitions remain exactly as the order in
"	"activity_table". Also, there is a table in gcos_cc_activity_cards_
"	that must be in the same order as these two tables.
"
"	Also critical are: filecards at beginning of cardtable;
"	execution activities preceeding compilation activities;
"	and the endjob card at the end of the table.
"
"	Note too that the number and order of the cards defined is critical.
"	If ANY are added or deleted then the indexed gotos in gcos_gein_ must
"	be changed and the declaration changed.
"
"	"OBSOLETE" means only that that the control card is not documented in
"	the control card manual. The card is still knows to GCOS.
"
"	References:
"	Control Cards Reference Manual, DD31-01, July 1980
"	ALC1 gmap source, specifically the macros "CARD", "STDS", and "PATT".
"
	use	cards
	join	/text/cards
cardtable:	null
	use	fibs
	join	/text/fibs
activity_table:	null
	use	vibs
	join	/text/vibs
"
"			numbers are index used by gcos_gein_
	define	print	"  1
	define	punch   	"  2
	define	disk    	"  3  OBSOLETE
	define	disc    	"  4  OBSOLETE
	define	drum    	"  5  OBSOLETE
	define	file    	"  6
	define	mass    	"  7  OBSOLETE
	define	prmfl   	"  8
	define	data    	"  9
	define	tape    	" 10
	define	tape7   	" 11
	define	tape9   	" 12
	define	sysout  	" 13
	define	remote  	" 14
	define	dac     	" 15
	define	type    	" 16
	define	read    	" 17  not supported actually
"
	use	cards
fce:	null
"
"	Cards above this point are file cards, which must be written
"	on R* in an EXECUTE activity.
"
	define	snumb   	" 18
	define	commen  	" 19  comment
	define	incode  	" 20
	define	etc     	" 21
	define	endcop  	" 22  endcopy
	define	update  	" 23
	define	limits  	" 24
	define	msg1    	" 25
	define	msg2    	" 26
	define	msg3    	" 27
	define	userid  	" 28
	define	alter   	" 29
	define	set     	" 30
	define	compil  	" 31  compile
	define	copy    	" 32
	define	delete  	" 33
	define	endedi  	" 34  endedit
	define	endld   	" 35
	define	ffile   	" 36
	define	form    	" 37
	define	futil   	" 38
	define	includ  	" 39  include
	define	input   	" 40
	define	output  	" 41
	define	list    	" 42
	define	modify  	" 43
	define	multi   	" 44
	define	patch   	" 45
	define	qutil   	" 46
	define	seq     	" 47
	define	setsq   	" 48
	define	sysld   	" 49
	define	when    	" 50
	define	abort   	" 51
	define	dump    	" 52
	define	assem	" 53
	define	change	" 54
	define	get	" 55
	define	getrwd	" 56
	define	need	" 57
	define	setsq1	" 58
	define	param	" 59
"
"	Loader cards begin at this point. (This is not required by any program, though.)
"
	define	option  	" 60
	define	librar  	" 61  library
	define	lowloa  	" 62  lowload
	define	use     	" 63
	define	entry   	" 64
	define	nolib   	" 65
	define	equate  	" 66
	define	link    	" 67
	define	relcom  	" 68
	define	source  	" 69
	define	dkend   	" 70
	define	nload   	" 71

"	Cards below this point all terminate activity definitions.
"
"	Those immediately following define execution activities,
"	which do NOT get run after an abort, OR if psw bit 5
"	gets turned off by a preceeding activity.
"
"	WARNING: Changes in the order or number of any of these cards
"	must be also reflected in the wrapup table in gcos_cc_activity_cards_.
"
	use	cards
tad:	null
" 72
	define	execut,geload,,i*,5,17,5,dollar_t
	file	l*,,(generate_lud,random,save)
	file	h*,5,write
	dec	0
" 73
	define	355sim,,,*b,8,25,5,dollar_t
	dec	0
"
"	Those following define activities that
"	do NOT get run after aborts only.
"
" 74
	define	progra,??????,,i*,5,17,5,dollar_t
	dec	0
" 75
	define	conver,,,mc,20,9,1,dollar_t
	dec	0
" 76
	define	filedi,,,f*,4,40,10,dollar_t
	file	*z,5,(random,write)
	file	*1,4,write
	file	*4,1,write
	file	*5,3,write
	file	b*,5,write
	file	g*,4,write
	file	a*,3,write
	file	s*,6,write
	file	c*,sysout
	dec	0
" 77
	define	sysedi,,,s*,5,33,10,dollar_t
	file	l*,,(generate_lud,random,save)
	dec	0
" 78
	define	utilit,,,u*,3,11,10,dollar_t
	dec	0
" 79
	define	utl2,,,*u,3,35,10,dollar_t
	dec	0
" 80  OBSOLETE
	define	convrt,conver,,mc,20,9,1,dollar_t
	dec	0
" 80.1
"	define	lodlib,,LISTIN,i*,5,16,5,dollar_t
"	file	sc,5,(random,write)
"	dec	0
" 80.2
"	define	objlib,,LISTIN,i*,5,50,5,dollar_t
"	file	sc,5,(random,write)
"	dec	0
" 80.3
"	define	srclib,,LISTIN,i*,5,65,5,dollar_t
"	file	sc,5,(random,write)
"	dec	0

"	The following cards define compilation activities,
"	which DO get run after an abort.
"
"	WARNING: If it is necessary to move any activity cards from one section
"	of this table to the other, there are THREE other tables which must
"	be changed, to keep the entries in the same order. They are:
"	1) activity_table, in this procedure (done automagically by file macro)
"	2) the wrapup table in gcos_cc_activity_cards_
"	3) the indexed goto cc(i) in gcos_gein_.pl1
"
	use	cards
comp:	null
" 81
	define	fortra,fortx,(FORT,LSTIN,FORM,LNO,BCD),s*,5,27,12,fortran_t
	file	*1,4,write
	file	b*,3,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 82
	define	pl1,,(FORT,LSTIN),s*,15,90,12,pl1_t
	file	b*,3,(generate_lud,save,write)
	file	*1,3,write
	file	*2,1,write
	file	3*,1,write
	file	g*,4,write
	file	c*,sysout
	file	k*,sysout
	dec	0
" 83
	define	cobol,,(DECK,LSTIN),s*,15,33,20,cobol_t
	file	g*,4,write
	file	*1,4,write
	file	*2,1,write
	file	*3,15,(random,write)
	file	*6,10,(random,write)
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 84
	define	gmap,,(FORT,DECK,LSTOU),g*,4,25,10,gmap_t
	file	*1,4,write
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 85
	define	355map,,(DECK,LSTOU),g*,4,32,10,gmap_t
	file	*1,4,write
	file	b*,2,(generate_lud,save,write)
	file	*b,2,write
	file	c*,sysout
	file	k*,sysout
	dec	0
" 86
	define	algol,,(DECK,LSTIN),s*,8,28,10,pl1_t
	file	*1,4,write
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 87  OBSOLETE
	define	forta,forty,(FORT,LSTIN,DECK,FORM,LNO,BCD),s*,5,25,12,fortran_t
	file	*1,4,write
	file	b*,2,(generate_lud,save,write)
	file	g*,4,write
	file	c*,sysout
	file	k*,sysout
	dec	0
" 88
	define	forty,fortx,(FORT,LSTIN,FORM,LNO,BCD),s*,5,27,12,fortran_t
	file	*1,4,write
	file	b*,3,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 89
	define	jovial,,(DECK,LSTIN),s*,8,29,10,pl1_t
	file	*1,4,write
	file	*2,1,write
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 90  OBSOLETE
	define	asm66,,(DECK,LSTOU),s*,8,75,10,pl1_t
	file	*1,2,write
	file	*2,2,write
	file	*3,5,(random,write)
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 91
	define	cbl74,,LSTIN,s*,15,62,20,cobol_t
	file	g*,8,write
	file	*1,1,write
	file	*2,3,write
	file	*3,5,(random,write)
	file	4*,1,write
	file	5*,8,write
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 92
	define	cbl68,,(DECK,LSTIN),s*,15,33,20,cobol_t	" 92  OBSOLETE
	file	g*,4,write
	file	*1,4,write
	file	*2,1,write
	file	*3,15,(random,write)
	file	*6,10,(random,write)
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 93  OBSOLETE
	define	malt,,LSTOU,s*,8,55,10,pl1_t
	file	*1,2,write
	file	*2,2,write
	file	*3,5,(random,write)
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 94  OBSOLETE
	define	ilang,,LSTIN,s*,16,45,10,pl1_t
	file	*1,5,write
	file	*2,5,write
	file	*3,1,write
	file	*4,1,write
	file	*5,1,write
	file	*6,1,write
	file	*7,2,write
	file	b*,3,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 95
	define	ids,,(DECK,LSTIN),*s,15,33,20,cobol_t
	file	s*,6,write
	file	g*,4,write
	file	*1,4,write
	file	*2,1,write
	file	*3,15,(random,write)
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 96
	define	ids2,,,s*,5,54,10,cobol_t
	file	1*,22,(random,write)
	file	2*,10,(random,write)
	file	3*,10,(random,write)
	file	4*,44,(random,write)
	file	5*,1,(random,write)
	file	6*,10,(random,write)
	file	c*,sysout
	dec	0
" 97  OBSOLETE
	define	4tran,,(DECK,LSTIN),s*,4,32,3,fortran_t
	file	g*,4,write
	file	*1,4,write
	file	*2,1,write
	file	b*,2,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 98  OBSOLETE
	define	g3edit,,,i*,4,44,10,dollar_t
	dec	0
" 99
	define	fort77,,(FORT,LSTIN,LNO,FORM),s*,5,36,12,fortran_t
	file	*1,8,write
	file	b*,6,(generate_lud,save,write)
	file	c*,sysout
	file	k*,sysout
	dec	0
" 100
	define	fortx,,(FORT,LSTIN,LNO,FORM,BCD),s*,5,30,12,fortran_t
	file	b*,3,(generate_lud,save,write)
	file	*1,4,write
	file	c*,sysout
	file	k*,sysout
	dec	0
" 101
	define	cids2,,,s*,5,64,10,cobol_t
	file	1*,22,(random,write)
	file	2*,10,(random,write)
	file	3*,10,(random,write)
	file	4*,10,(random,write)
	file	6*,10,(random,write)
	file	c*,sysout
	dec	0
" 102
	define	rpg2,,(LSTIN,MAP),s*,5,25,5,cobol_t
	file	b*,3,(generate_lud,save,write)
	file	*1,5,write
	file	*2,5,write
	file	3*,5,write
	file	6*,5,write
	file	c*,sysout
	file	k*,sysout
	dec	0

"	Cards below this point still terminate activity definitions
"	but they don't define new activities as do those above starting
"	at label "tad".
"
	use	cards
tad2:	null
	define	ident   	" 103
	define	object  	" 104
	define	break   	" 105
	define	goto    	" 106
	define	if      	" 107
	define	endjob  	" 108
	use	cards
cte:	null			" end of cardtable

"	Purpose: list of unimplemented control cards, so the simulator can
"	distinguish, in its error messages, between unimplemented cards
"	and typing mistakes.
	define	1401si  	" 109  OBSOLETE
	define	167pk   	" 110  OBSOLETE
	define	170pk   	" 111
	define	180pk   	" 112
	define	181pk   	" 113
	define	190pk   	" 114
	define	191pk   	" 115
	define	225sim  	" 116  OBSOLETE
	define	310pk   	" 117
	define	400pk   	" 118
	define	44sim   	" 119  OBSOLETE
	define	450pk   	" 120
	define	94optn  	" 121  OBSOLETE
	define	94prt   	" 122  OBSOLETE
	define	94sim   	" 123  OBSOLETE
	define	94syso  	" 124  OBSOLETE
	define	ascii	" 125
	define	dspk    	" 126  OBSOLETE
	define	enx	" 127
	define	extedi  	" 128  extedit
	define	extend  	" 129
	define	filsys  	" 130
	define	ntape   	" 131
	define	perm    	" 132  OBSOLETE
	define	pptp    	" 133
	define	pptr    	" 134
	define	privit  	" 135  privity
	define	produc  	" 136  OBSOLETE
	define	reladd  	" 137
	define	report  	" 138
	define	reptl   	" 139
	define	reptr   	" 140
	define	s2prog  	" 141
	define	sysnam  	" 142  sysname
	define	tape27  	" 143
	define	tape29  	" 144
	define	filgp	" 145
	define	lodlib	" 146
	define	objlib	" 147
	define	pps	" 148
	define	ppsrpt	" 149
	define	psm	" 150
	define	srclib	" 151
"
	use	cards
tte:	null

" Lengths of tables.
"
"	Purpose: defines number of entries in cardtable
"	(and also the offset in total cardtable at which the unimplemented cards start.)
tablelen:	vfd	36/(cte-cardtable)/2
"
"	Purpose: define number of entries in total cardtable
"		(including the unimplemented cards)
totallen:	vfd	36/(tte-cardtable)/2
"
"	Purpose: holds count of filecards in first section of cardtable,
"	which must be written on R* in an EXECUTE activity.
filecard_count:
	vfd	36/(fce-cardtable)/2
"
"	Purpose: holds offset in cardtable where compilation activities
"	(that DO get run after aborts) begin.
comp_offset:
	vfd	36/(comp-cardtable)/2+1
"
"	Purpose: defines offset in cardtable where activity terminating
"	cards begin.
exc_offset:vfd	36/(tad-cardtable)/2+1
"
"	Purpose: defines offset in cardtable where cards which terminate activities
"	without defining new activities begin.
nonact:	vfd	36/(tad2-cardtable)/2+1

"	Purpose: tabstops for canonicalizing the cards of various types.
tabstops:	dec	6			tabstops.count
"					(number of 10-word tabstop sets which follow)
tabtable:	null
dollar_t:	dec	8,16,32,73,0,0,0,0,0,0	tab(0) dollar cards
data_t:	dec	0,0,0,0,0,0,0,0,0,0		tab(1) data cards
gmap_t:	dec	8,16,32,73,0,0,0,0,0,0	tab(2) gmap cards
fortran_t:dec	7,73,0,0,0,0,0,0,0,0	tab(3) fortran cards
pl1_t:	dec	10,20,30,40,50,60,70,0,0,0	tab(4) pl1 cards
cobol_t:	dec	8,12,73,0,0,0,0,0,0,0	tab(5) cobol cards

" Definition of options.
"
"	Activity card option lookup table. This table contains the name of
"	each legal option for each type of activity defining card. The format
"	of each entry in the table is as follows:
"
"		words 1&2--option name
"		word3 upper--index into xfer vector in gcos_cc_activity_cards_
"		word3 lower--psw bit settings
optab:	null
	option	ascii,reset,BCD
	option	bcd,set,BCD
	option	clear,set,CLEAR
	option	comdk,set,COMDK
	option	copy,set,COPY
	option	debug,set,DEBUG
	option	deck,set,DECK
	option	dump,set,DUMP
	option	form,set,FORM
	option	gesave,set,GESAVE
	option	gmac,reset,NGMAC
	option	lno,set,LNO
	option	lstin,set,LSTIN
	option	lstou,set,LSTOU
	option	map,set,MAP
	option	nclear,reset,CLEAR
	option	ncomdk,reset,COMDK
	option	ncopy,reset,COPY
	option	ndebug,reset,DEBUG
	option	ndeck,reset,DECK
	option	ndump,reset,DUMP
	option	nform,reset,FORM
	option	ngmac,set,NGMAC
	option	nlno,reset,LNO
	option	nlstin,reset,LSTIN
	option	nlstou,reset,LSTOU
	option	nomap,reset,MAP
	option	noptz,reset,OPTZ
	option	npurge,reset,PURGE
	option	nstab,reset,STAB
	option	nsymta,reset,SYMTAB
	option	nxec,set,000040
	option	nxref,reset,XREF
	option	on1,set,ON1
	option	on2,set,ON2
	option	on3,set,ON3
	option	on4,set,ON4
	option	on5,set,ON5
	option	on6,set,ON6
	option	optz,set,OPTZ
	option	purge,set,PURGE
	option	stab,set,STAB
	option	symtab,set,SYMTAB
	option	xref,set,XREF
endtab:	null
"
	end




		    gcos_cv_ascii_gebcd_.alm        09/09/83  1400.3rew 09/09/83  1006.8       42111



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

"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"
"
"	T R A N S L A T E  A S C I I  T O  B C D
"
"
"  This routine takes four parameters. Parameter 1 is a pointer
"  to a string of ASCII characters. Parameter 2 is the length
"  of that string. Parameter 3 is a pointer to the receiving
"  field for the translated BCD output. Parameter 4 is a count 
"  of the number of BCD characters placed in the receiving field.
"  For the main entry, this is always equal to parameter 2.  This
"  return argument is only used so that existing programs that
"  call this entry need not be changed immediately.  When  all routines
"  that call this entry have been changed to ignore this parameter,
"  this entry can be changed to stop returning it. 
"
"  For the gcos_cv_printline_gebcd_ entry, the count returned in parameter
"  4 may not equal the count of ASCII characters input.
"  Certain special ASCII characters are recognized and converted
"  to printer control information. Newline characters are converted
"  to octal 7701 (skip one line). If n contiguous newlines are found,
"  then a control sequence of 77n is produced (skip n lines). If new
"  page characters are encountered, they are converted to 7720 octal  
"  (skip to head of form). 
"
"  For the gcos_cv_ascii_gebcd_check_ entry, parameter 4 is the character
"  number of the first character in the input string that could not be
"  converted to bcd.  If no such charcters are found, parameter 4 is zero.
"
"
"	WRITTEN BY DICK SNYDER AUGUST 12,1970
"	Modified by Dick Snyder 10/31/72 to add $ incode processing
"	MODIFIED BY T. CASEY JUNE 1974 
"	REWRITTEN BY D. KAYDEN DECEMBER 1974
"	MODIFIED BY R.H. MORRISON  5/19/76
"
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
	name	gcos_cv_ascii_gebcd_
	entry	gcos_cv_ascii_gebcd_
	entry	gcos_cv_ascii_gebcd_check_
	entry	gcos_cv_printline_gebcd_

gcos_cv_ascii_gebcd_:
	eppbp	ap|2,*		bp -> input data
	eppbp	bp|0,*
	lda	ap|4,*		a = length
	sta	ap|8,*		store output string 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


gcos_cv_ascii_gebcd_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

gcos_cv_printline_gebcd_:
	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




		    gcos_error_.pl1                 11/05/86  1601.3r w 11/04/86  1042.4       38070



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	G C O S   E R R O R
   *
   *
   *	This procedure is called to report any fatal job error to the user.
   *	The procedure takes a status code as the first argument and an ioa_
   *	control string and arguments follow.
   *
   *
   *	Rewritten by M. R. Jordan,  August 1977
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_error_: procedure (a_code);



dcl  NL char (1) static internal options (constant) init ("
");
dcl  a_code fixed bin(35);
dcl  addr builtin;
dcl  arg_list_ptr ptr;
dcl  callers_sp ptr;
dcl  com_err_ entry options (variable);
dcl  convert_status_code_ entry (fixed bin(35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$stack_frame_ptr entry () returns (ptr);
dcl  db entry ();
dcl  gcos_cc_endjob_ entry ();
dcl  gcos_et_$fatal_error fixed bin(35) ext;
dcl  gcos_write_to_er_ entry options (variable);
dcl  ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1));
dcl  ioa_$ioa_stream entry options (variable);
dcl  long_message char (100) aligned;
dcl  message char (256) varying;
dcl  name char (name_len) based (name_ptr);
dcl  name_len fixed bin(24);
dcl  name_ptr ptr;
dcl  pl1_frame_$name entry (ptr, ptr, fixed bin(24));
dcl  rtn_string char (256);
dcl  rtn_string_len fixed bin(24);
dcl  rtrim builtin;
dcl  short_message char (8) aligned;
dcl  substr builtin;

/*

   If debugging then tell the user who done it ...

*/



	if gcos_ext_stat_$save_data.debug then do;
	     sp = cu_$stack_frame_ptr ();
	     callers_sp = stack_frame.prev_sp;
	     call pl1_frame_$name (callers_sp, name_ptr, name_len);
	     message = NL || "From " || name;
	end;
	else message = "";


/*

   Get the message for the specific error from the error table.

*/


	if a_code ^= 0 then do;
	     call convert_status_code_ (a_code, short_message, long_message);
	     if long_message ^= "" then message = message || NL || rtrim (long_message);
	end;


/*

   Get the ioa_ part of the error message.

*/


	call cu_$arg_list_ptr (arg_list_ptr);
	call ioa_$general_rs (arg_list_ptr, 2, 3, rtn_string, rtn_string_len, "0"b, "1"b);
	if rtn_string_len ^= 0 then
	     if substr (rtn_string, 1, rtn_string_len) ^= "" then
		message = message || NL || substr (rtn_string, 1, rtn_string_len);


/*

   Let the user know that there is a problem.

*/


	call com_err_ (gcos_et_$fatal_error, "gcos_error_", "^a", message);


/*

   Output the message on the execution report and tell the user we're aborting.

*/


	call convert_status_code_ (gcos_et_$fatal_error, short_message, long_message);
	call gcos_write_to_er_ ("gcos_error_:  ^a^a", long_message, message);
	call ioa_$ioa_stream ("error_output", "Aborting GCOS job.");


/*

   If the user is debugging the simulator, then stop for a moment.

*/


	if gcos_ext_stat_$save_data.debug then do;
	     call ioa_$ioa_stream ("error_output", "CALLING DEBUG");
	     call db ();
	end;


/*

   Now try to terminate gracefully ...  If we have started to process the ENDJOB
   card we must have real trouble (we cannot produce the SYSOUT).

*/


	if gcos_ext_stat_$save_data.endjob then do;
	     call com_err_ (0, "gcos_error_", "Unable to produce SYSOUT.");
	     goto gcos_ext_stat_$abort_return;
	end;


	call gcos_cc_endjob_ ();


	return;

%include gcos_ext_stat_;

%include stack_frame;


     end gcos_error_;




		    gcos_et_.alm                    11/05/86  1601.3r w 11/04/86  1038.8       83484



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"	G C O S   E N V I R O N M E N T   E R R O R   T A B L E
"
" Error Table for the GCOS Environment.
"
" Created: M. R. Jordan	08/01/77
" Changed: Dave Ward	05/22/81	multirecord codes.
" Changed: Scott C. Akers	02/22/82	Tape data exceeds buffer size.
"
"
	maclist	off
	include	et_macros

	et	gcos_et_


ec no_reason,GCOS0000,
   (no reason specified)
ec cant_load_ssa,GCOS0001,
   (cannot load ssa module)
ec ssa_mod_cksm_err,GCOS0002,
   (ssa module cheksum error)
ec cant_find_ssa_mod,GCOS0003,
   (cannot find ssa module)
ec dchln_preselected,GCOS0004,
   (dchln preselected)
ec out_of_time,GCOS0005,
   (i8-run time exhausted)
ec bad_mme_in_cc,GCOS0006,
   (i2-improper mme in c.c)
ec geendc_not_in_cc,GCOS0007,
   (i6-geendc but not in cc.)
ec pri_mailbox_err,GCOS0008,
   (primary mailbox error)
ec connect_or_ti_err,GCOS0009,
   (connect or t.i. error)
ec ioc_data_service_err,GCOS0010,
   (ioc data-service error)
ec ioc_mem_addr_flt,GCOS0011,
   (ioc memory address fault)
ec ioc_not_master_mode,GCOS0012,
   (ioc not master mode flt.)
ec mem_parity_in_io,GCOS0013,
   (memory parity during i/o)
ec ioc_not_ctl_proc,GCOS0014,
   (ioc not ctl. proc. fault)
ec ioc_mem_protect,GCOS0015,
   (ioc mem. protect fault)
ec mem_time_out_in_io,GCOS0016,
   (memory time-out in i/o)
ec other_mem_ioc_err,GCOS0017,
   (other ioc-memory error)
ec mem_addr_flt,GCOS0018,
   (f0-memory address fault)
ec bad_mme_addr,GCOS0019,
   (i1-improper mme address)
ec fault_tag_flt,GCOS0020,
   (f1-fault tag fault)
ec command_flt,GCOS0021,
   (f2-command fault)
ec derail_flt,GCOS0022,
   (f3-derail fault)
ec lockup_flt,GCOS0023,
   (f4-lockup fault)
ec mem_parity_flt,GCOS0024,
   (f6-memory parity fault)
ec illegal_procedure,GCOS0025,
   (f7-undefined op. fault)
ec over_or_under_flow,GCOS0026,
   (f9-overflow/underflow)
ec divide_check_flt,GCOS0027,
   (i0-divide check fault)
ec op_not_complete_flt,GCOS0028,
   (f8-op not complete fault)
ec io_oob,GCOS0029,
   (i/o out of memory bounds)
ec fc_not_defined,GCOS0030,
   (i3-file code not defined)
ec no_inos_file_ptr,GCOS0031,
   (i5-no geinos filepointer)
ec access_beyond_file,GCOS0032,
   (i7-access beyond file)
ec bad_status_ret_ptr,GCOS0033,
   (k2-bad status ret. ptr.)
ec invalid_file_ptr,GCOS0034,
   (k3-invalid file pointer)
ec invalid_dcw_ptr,GCOS0035,
   (k4-invalid dcw pointer)
ec bad_cc_ptr,GCOS0036,
   (k5-bad courtesy call ptr)
ec bad_io_cmnd_file,GCOS0037,
   (k6-bad i/o command-file)
ec two_tdcws,GCOS0038,
   (k7-two successive tdcws)
ec invalid_io_for_device,GCOS0039,
   (k1-invalid i/o on device)
ec operator_term_rqst,GCOS0040,
   (x2-operator term request)
ec operator_kill_rqst,GCOS0041,
   (x2-operator kill request)
ec io_lim_call_save,GCOS0042,
   (m4/n4-i/o lim. call/save)
ec io_err_call_save,GCOS0043,
   (m6/n7-i/o err. call/save)
ec no_call_file_pat,GCOS0044,
   (m5-no pat for call file)
ec bad_call_save_device,GCOS0045,
   (m1/n5-bad dev. call/save)
ec non_rndm_call_file,GCOS0046,
   (non-random gecall file)
ec save_file_full,GCOS0047,
   (n8-gesave file is full)
ec call_rstr_cksm,GCOS0048,
   (m6-call/rstr checksum)
ec low_rstr_origin_used,GCOS0049,
   (low gerstr origin used)
ec zero_save_word_cnt,GCOS0050,
   (n4-zero gesave word ct.)
ec call_name_missing,GCOS0051,
   (m2/m3-call name missing)
ec call_out_of_file_span,GCOS0052,
   (n8-call out of file span)
ec bad_gcos_call,GCOS0053,
   (improper gecos call)
ec zero_fc_to_more,GCOS0054,
   (gemore - zero filecode)
ec bad_more_param,GCOS0055,
   (m0-bad gemore parameter)
ec pat_full_from_more,GCOS0056,
   (no room in pat - gemore)
ec not_mass_store_more,GCOS0057,
   (m7-not disc/drum gemore)
ec bad_rout_op_code,GCOS0058,
   (r1-bad gerout op. code)
ec pat_full_from_rout,GCOS0059,
   (r4-gerout pat exhausted)
ec rmt_term_rec_size,GCOS0060,
   (rmt terminal record size)
ec bad_rmt_station_id,GCOS0061,
   (undef remote station id)
ec bad_rout_pgm_id,GCOS0062,
   (invalid gerout prog. id)
ec output_limit_exceeded,GCOS0063,
   (0>-output limit exceeded)
ec syot_rec_size_err,GCOS0064,
   (sysout record size error)
ec syot_seek_err,GCOS0065,
   (sysout seek error)
ec syot_alloc_err,GCOS0066,
   (sysout allocation error)
ec bad_syot_status_ptr,GCOS0067,
   (01-bad syot status ptr.)
ec bad_syot_buffer_ptr,GCOS0068,
   (01-bad syot buffer ptr.)
ec syot_buffer_too_high,GCOS0069,
   (01-syot buffer > limits)
ec irrecoverable_io_err,GCOS0070,
   (ep-irrecoverable i/o err)
ec bad_seek_dcw,GCOS0071,
   (k4-invalid seek dcw i/o)
ec bad_syot_media_code,GCOS0072,
   (bad gesyot media code)
ec cannot_rollback,GCOS0073,
   (n3-rollback not possible)
ec tss_requested_term,GCOS0074,
   (tss requested term)
ec duplicate_file_more,GCOS0075,
   (gemore duplicate file)
ec bad_io_sct_ptr,GCOS0076,
   (invalid i/o sct pointer)
ec impermissible_perm_write,GCOS0077,
   (impermissible perm write)
ec impermissible_perm_read,GCOS0078,
   (impermissible perm read)
ec ids_rec_too_long,GCOS0079,
   (d2-ids record too long)
ec out_of_syot_stor,GCOS0080,
   (sysout storage exhausted)
ec bad_mme_param,GCOS0081,
   (invalid mme parameter)
ec lost_extra_ssa_contents,GCOS0082,
   (lost extra ssa contents)
ec aloc_deleted_job,GCOS0083,
   (j3-aloc deleted job)
ec bad_news_buf_addr,GCOS0084,
   (bad buffer addr - genews)
ec guessing_prmfl_more,GCOS0085,
   (guessing on prmfl gemore)
ec no_userid_prmfl_more,GCOS0086,
   (no userid - prmfl gemore)
ec oper_stop_rqst,GCOS0087,
   (x2-operator stop request)
ec cannot_move_job,GCOS0088,
   (cannot move job in core)
ec enexpected_pcw,GCOS0089,
   (iom chan unexpected pcw)
ec improper_instr,GCOS0090,
   (iom chan improper instr.)
ec iom_chan_bad_dcw,GCOS0091,
   (iom chan improper dcw)
ec iom_cent_lpw_tro,GCOS0092,
   (iom cent lpw tally rnout)
ec iom_cent_two_tdcws,GCOS0093,
   (iom cent two tdcws)
ec iom_cent_bndry_err,GCOS0094,
   (iom cent boundary error)
ec iom_cent_4bar_viol,GCOS0095,
   (iom cent 4-bar violation)
ec iom_cent_idcw_res_mode,GCOS0096,
   (iom cent idcw res mode)
ec iom_cent_char_dis,GCOS0097,
   (iom cent char pos/sz dis)
ec bad_backdoor_fc,GCOS0098,
   (backdoor f.c. unknown)
ec bad_backdoor_file,GCOS0099,
   (invalid file to backdoor)
ec ids_addr_oob,GCOS0100,
   (ids address out of bound)
ec secur_scc_invalid,GCOS0101,
   (secur-scc invalid)
ec file_alloc_err,GCOS0102,
   (file allocation error)
ec scc_invld_for_user,GCOS0103,
   (secur-scc inval for user)
ec scc_invld_for_line,GCOS0104,
   (secur-scc inval for line)
ec duplicate_report,GCOS0105,
   (secur-duplicate report)
ec invalid_dcw_string,GCOS0106,
   (secur-invalid dcw string)
ec invalid_fnc_code,GCOS0107,
   (secur-invalid funct code)
ec no_links_for_swap_file,GCOS0108,
   (no links for swap file)
ec data_access_sys_abrt,GCOS0109,
   (data access system abort)
ec fms_protect_fail,GCOS0110,
   (fms protection failure)
ec bss_mem_bndry_err,GCOS0111,
   (bss main mem boundry err)
ec bss_no_sys_respnse,GCOS0112,
   (bss no system response)
ec bss_connect_halt,GCOS0113,
   (bss connect halt)
ec isp_sys_term,GCOS0114,
   (isp system termination)
ec bad_eis_data,GCOS0115,
   (illegal eis data)
ec io_channel_deactivated,GCOS0116,
   (i/o channel deactivated)
ec user_abort_request,GCOS0117,
   (user abort request)
ec cache_parity_flt,GCOS0118,
   (f5-cache parity fault)
ec bad_rels_rqst,GCOS0119,
   (invalid mme gerels reqst)
ec unimp_mme,unimpmme,
   (The specified MME is not supported by the Multics GCOS Environment.)
ec fatal_error,fatalerr,
   (A fatal error has occured.  The current job is being terminated.)
ec cc_bad_fc,badfc,
   (Illegal file code value specified.)
ec cc_bad_field,badfield,
   (Bad control card field.)
ec cc_field_too_long,toolong,
   (Control card field too long.)
ec cc_missing_fc,missfc,
   (No file code value specified.)
ec cc_bad_lud,badlud,
   (Illegal Logical Unit Designator (LUD) specified.)
ec cc_unimp,unimpcc,
   (The specified $ control card is not supported by the Multics GCOS Environment.)
ec cc_missing_field,misfield,
   (A required control card field is either missing or null.)
ec cc_bad_card,badcard,
   (An error has occured in processing the following $ control card:)
ec too_many_activs,tomnyact,
   (Too many activities have been specified.)
ec no_restart,nrestart,
   (Job restart not specified.)
ec fms_bad_cfdesc,FMS00005,
   (incorrect catalog/file description)
ec fms_perms_denied,FMS00003,
   (permissions denied)
ec non_gcos_fault,badflt,
   (A fault has occured which is impossible on a GCOS system.)
ec no_free_fibs,nofibs,
   (No free fibs - contact support personel.)
ec rel_fibs_exceeded,tmrfib,
   (Exceeded number of released fibs provided for.)
ec record_too_long,toolong,
   (A record whose length is > 319 words has been encountered.)
ec need_multirec,needmr,
   (Multirecord MME GEINOS needed for linked disk file.)
ec bad_multirec,badmr,
   (Multirecord MME GEINOS block count not same as words requested.)
ec request_too_big,bigreq,
   (Requested data exceeds permitted tape buffer size.)
	end




		    gcos_ext_stat_.cds              09/09/83  1400.3rew 09/09/83  1006.8       44271



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

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

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

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

dcl 1 gcos_ext_stat_ aligned,
      2 abort_reason	char (128) varying,
      2 abort_return	label,
      2 activity_card_num	pic "9999",
      2 activity_name	char(8),
      2 activity_start_time	fixed bin(71),
      2 card_num		pic "9999",
      2 dbs		(36)bit(1),
      2 default_nondollar	char(2),
      2 dir_rings		(3) fixed bin(3),
      2 dpno		char(100) varying,
      2 dpo		char(100) varying,
      2 endfc		char(2),
      2 er		ptr,
      2 etc_filecode	char(2),
      2 gcos_slave_area_seg	ptr,
      2 gf		fixed bin(24),
      2 incode		fixed bin(24),
      2 increment_hold	fixed bin(24),
      2 initial_cpu_time	fixed bin(71),
      2 input_segment_path	char(168) varying,
      2 jcl_warnings	fixed bin(24),
      2 job_cpu_time	fixed bin(71),
      2 job_id		char(18) varying,
      2 job_real_time	fixed bin(71),
      2 last_mme		fixed bin(24),
      2 ldrss		fixed bin(24),
      2 max_activities	fixed bin(24),
      2 max_mem		fixed bin(19),
      2 mme_rtrn		label,
      2 nondollar		char(2),
      2 nongcos		char(2),
      2 normal_return	label,
      2 patchfile_ptr	ptr,
      2 pathname_prefix	char(168)var,
      2 pch		ptr,
      2 pdir		char(168) varying,
      2 prt		ptr,
      2 rs		ptr,
      2 saveseg_ptr		ptr,
      2 save_dir		char(168) varying,
      2 seg_rings		(3) fixed bin(3),
      2 sig_ptr		ptr,
      2 skip_umc		bit(1),
      2 snumb		bit (30) aligned,
      2 sought_label	char(8),
      2 statistics		(3*44) fixed bin(24),
      2 stop_code		fixed bin(24),
      2 storage_limit	fixed bin(19),
      2 sysout_limit	fixed bin(35),
      2 sysout_lines	fixed bin(35),
      2 system_free_pointer	ptr,
      2 tape_buffer_size	fixed bin(35),
      2 temp_dir		char(168) varying ,
      2 temp_seg_ptr	ptr,
      2 termination_code	bit (18),
      2 time_limit		fixed bin(71),
      2 userid		char(12),
      2 validation_level	fixed bin(3),

      2 courtesy_call_control aligned like gcos_ext_stat_$courtesy_call_control,

      2 fct		aligned like gcos_ext_stat_$fct,

      2 save_data		aligned like gcos_ext_stat_$save_data,

      2 mc		like gcos_ext_stat_$mc,

      2 gcos_gtss		like gcos_ext_stat_$gcos_gtss;


%page;
%include gcos_ext_stat_;
%page;
%include cds_args;
end;




		    gcos_fault_processor_.pl1       09/09/83  1400.3rew 09/09/83  1006.8      120582



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_fault_processor_: proc;

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

   Author: DICK SNYDER OCTOBER 2, 1970
   Change: T. CASEY SEPTEMBER 1973, FEBRUARY 1974, APRIL 1974
   Change: D. KAYDEN  JUNE 1974, DECEMBER 1974
   Change: T. CASEY AUGUST 1975
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	06/03/81 hashed fault name list.
   Change: Dave Ward	06/03/81 RSW (2) provision.
*/
	cond_info.version = 1;			/* expect version 1 of info structure */
	call find_condition_info_ (null, addr (cond_info), code);
	mcp = cond_info.mcptr;			/* Location of machine conditions at fault time. */
	scup = addr (mc.scu);			/* Corresponding SCU data. */

/* Hash the condition name. */
	unspec (hv) =
	     cn.l					/* Length of condition name, */
	     ||cn.b (1)				/* leftmost character, */
	     ||cn.b (divide (length (condition_name)+1, 2, 17)) /* middle character, */
	     ||cn.b (length (condition_name));		/* rightmost character. */
	i = THL (mod (hv, hbound (THL, 1)+1));		/* Probe the hash start list. */
	if i>0 then				/* Name possibly in hash list. */
	     if condition_name = substr (string (TC), TL (i).fc, TL (i).ln) then do; /* Fault name found. */
		if scu.ppr.psr ^= substr (baseno (gcos_ext_stat_$gcos_slave_area_seg), 4, 15) then
		     goto general_abort;		/* abort if fault occurred outside gcos segment */
		faultv.ic = instruction_counter+1;	/* get IC */
		faultv.ind = string (scu.ir);		/* and I */
		goto fault (i);			/* handle fault if we want */
	     end;
	if condition_name = "simfault_" then goto general_abort;

pass_it_on:
	call continue_to_signal_ (code);		/* let's pass it on */

return_to_gcos_code: ;
	return;
%page;
/* 	Come here on a wide class of faults we won't take specific action on */

/* "page" fault. */
fault (10):
general_abort:

/* to avoid aborting job because of something like a missing segment, or
   bad access (which Multics normally allows users to recover from) we will
   ask the user if he wants to abort or let Multics handle it - but only if -db was given */

	if gcos_ext_stat_$save_data.debug then do;
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (
		addr (query_info)
		, answer
		, "gcos"
		, "fault: ^a occurred while running an activity."
		||"^/Do you wish to invoke the Multics fault handlers ?"
		, cond_info.condition_name
		);
	     if answer = "yes" then goto pass_it_on;
	end;

	abort_code = gcos_et_$non_gcos_fault;		/* abort */
	goto abrt1;
%page;
/* derail					 */

fault (01):

	abort_code = gcos_et_$derail_flt;		/* abort type */
	fault_vector = 12;				/* vector offset */
	goto user_fault;				/* see if user has handler for fault */
%page;
/* fault tag 1				 */

fault (04):

	abort_code = gcos_et_$fault_tag_flt;		/* abort type */
	fault_vector = 4;				/* vector offset */
	goto user_fault;				/* see if user has handler */
%page;
/* Illegal procedure fault (used for RSW recognition). */
fault (05): ;
	if baseno (cond_info.loc_ptr)
	=
	baseno (gcos_ext_stat_$gcos_slave_area_seg) then	/* Fault occured in gcos memory segment. */
	     if cond_info.loc_ptr -> INS.OPCODE = "231"b3 then /* => RSW instruction. */
		if cond_info.loc_ptr -> INS.ADDRESS.r3b = 2 then do; /* Switches selected. */
		     instruction_counter = instruction_counter+1; /* Increment to instruction after RSW. */
		     scu.rfi = "1"b;		/* Refetch instruction. */
		     scu.if = "0"b;			/* Reset fault indicator. */

/* Set the A register to reflect switch info. */
		     mc.regs.a =

/* (A-reg bits) */
/* (0-3) Port address expansion option:		*/ (4)"0"b
/* (4-5) Reserved for future use:		*/ || (2)"0"b
/* (6-12) Processor fault base address switches:	*/ || (7)"0"b
/* (13-16) L66 peripheral connectability:	*/ || (4)"0"b
/* (17) Future use (must be zero):		*/ || (1)"1"b
/* (18) BCD option installed:			*/ || (1)"1"b
/* (19) DPS type processor:			*/ || (1)"0"b
/* (20) 8K cache option installed:		*/ || (1)"0"b
/* (21) Gear shift model processor:		*/ || (1)"0"b
/* (22) Power pach option installed:		*/ || (1)"0"b
/* (23) VMS-CU option installed - 66B' proc:	*/ || (1)"0"b
/* (24) VMS-VU option installed - 66B proc:	*/ || (1)"0"b
/* (25) Type processor (0) CPL, (1) DPSE-NPL:	*/ || (1)"0"b
/* (26) 6025, 6605 or 6610 type processor:	*/ || (1)"0"b
/* (27) 2K cache option installed:		*/ || (1)"0"b
/* (28) Extended memory option installed:	*/ || (1)"0"b
/* (29-30) cabinet (00) 8/70, (01) 8/52, (10) 862, (11) 846:	*/ || (2)"0"b
/* (31) EIS option installed:			*/ || (1)"1"b
/* (32) (1) slow memory access, (0) fast memory:	*/ || (1)"0"b
/* (33) (1) no instruction overlap, (0) overlap:	*/ || (1)"0"b
/* (34-35) Processor number:			*/ ||unspec (mc.cpu_type);
			goto return_to_gcos_code;
		end;
	goto illegal_proc;
%page;
/* MME3 fault. */
fault (02):
	if gcos_ext_stat_$save_data.debug then goto pass_it_on; /* user must say -db in order to use the debugger */

/* MME4 fault. */
fault (03):

/* Illegal modifier. */
fault (06):

/* Linkage error. */
fault (07):

/* Fault tag 3. */
fault (08):

/* Segment fault error. */
fault (09):

/* Gate error. */
fault (11):

/* Illegal opcode. */
fault (21):

illegal_proc: ;
	abort_code = gcos_et_$illegal_procedure;	/* abort type */
	fault_vector = 0;				/* vector offset */
	goto user_fault;				/* see if user has handler */
%page;
/* attempt to read or write out of partition bounds 	 */

/* Store fault. */
fault (12):

/* Out_of_bounds fault. */
fault (20):

	abort_code = gcos_et_$mem_addr_flt;		/* abort type */
	fault_vector = 2;				/* vector offset */
	goto user_fault;				/* see if user has handler */
%page;
/* overflow				 */

fault (16):
	fault_flags = "020000"b3 ;			/* turn on bit 22 of accum. fault status */
	goto common_flow;
%page;
/* fixedoverflow */

fault (15):
	fault_flags = "040000"b3 ;			/* turn on bit 21 of accum. fault status */
	goto common_flow;
%page;
/* underflow */

fault (14):

	fault_flags = "010000"b3 ;			/* turn on bit 23 of accum. fault status */

common_flow:

	abort_code = gcos_et_$over_or_under_flow;	/* abort type */
	fault_vector = 8;				/* vector offset */
	goto user_faultx;				/* see if user has handler */
%page;
/* zero divide 				 */

fault (17):

	abort_code = gcos_et_$divide_check_flt;		/* abort type */
	fault_vector = 6;				/* vector offset */
	fault_flags = "000100"b3 ;			/* turn on bit 29 of accum. fault status */

/* 	Come here with a fault which the gcos user can potentially handle.  */
/* 	"fault_vector" holds the offset from the base of the gcos segment where	 */
/* 	the user's fault vector for the particular fault which occurred is located.	 */
/* 	If the user has no address specifed to which control should go on a fault	 */
/* 	of the type which occurred, "abort_code" holds the type of abort to	  */
/* 	be taken.						  */

/* Put the accumulated fault status into word 25 of prefix */
user_faultx:
	p = addrel (gcos_ext_stat_$gcos_slave_area_seg, 25); /* get pointer to it */
	p -> accum_stat = p -> accum_stat | ((6)"0"b3 || fault_flags); /* or in the gcos_ext_stat_$save_data */

user_fault:

	prefix_vector (fault_vector) = ic_i;		/* copy ic and indicators into fault vector */

	if prefix_vector (fault_vector+1) = (36)"0"b then do; /* if user has no handler, abort the job */

abrt:	     unspec (gcos_ext_stat_$mc) = unspec (mc);	/* save fault data for gcos_mme_bort_ */
abrt1:	     call condition_interpreter_ (null, p, i, 3, mcptr, (condition_name), wcptr, infoptr);
	     call gcos_mme_bort_$system (abort_code);
	     goto return_to_gcos_code;		/* just in case */
	end;

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

/* Useg instruction in gcos code at 2nd word of fault entry. */
	instruction_counter = fault_vector+1;
	scu.rfi = "1"b;				/* Refetch this instruction. */
	scu.if = "0"b;				/* Turn off indicator indicating instruction caused fault. */
	goto return_to_gcos_code;			/* goto return_to_gcos_code to the gcos program */
%page;
/* HANDLERS FOR FAULTS THAT THE USER'S FAULT VECTOR CAN NOT HANDLE */

/* parity */

fault (13):

	abort_code = gcos_et_$mem_parity_flt;
	fault_vector = 6;				/* say where to put IC and I */
	goto ic_and_i;				/* and go do it */
%page;
/* op_not_complete				 */

fault (19):

	abort_code = gcos_et_$op_not_complete_flt;	/* abort */
	fault_vector = 4;				/* say where to put IC and I */
	goto ic_and_i;				/* and go do it */
%page;
/* lockup					 */

fault (18):

	abort_code = gcos_et_$lockup_flt;		/* abort */
	fault_vector = 2;				/* say where to put IC and I */

/* 	Come here to put IC and I in word 10 and one other word (specified by fault_vector) */

ic_and_i:

	prefix_vector (10) = ic_i;			/* put it into word 10 */
	prefix_vector (fault_vector) = ic_i;		/* and also word 2, 4, or 6 */

	goto abrt;				/* and go abort the activity */
%page;
timer_runout: entry (mcp_val, fault_name);

/* 	Come here if fault is a timer runout				 */
dcl  fault_name               char(*)parm	/* fault name from fim */;
dcl  mcp_val                  ptr parm;
	mcp = mcp_val;
	scup = addr (mc.scu);


	abort_code = gcos_et_$out_of_time;		/* abort */

	unspec (gcos_ext_stat_$mc) = unspec (mc);	/* save fault data for gcos_mme_bort_ */

abrt2:	call gcos_mme_bort_$system (abort_code);
	goto return_to_gcos_code;			/* just in case */
%page;
/*   Variables for gcos_fault_processor_:	 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  abort_code               fixed bin(35)	/* abort code for this fault */;
dcl  accum_stat               bit(36) aligned based	/* overlay for accumulated */;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  answer                   char(4) varying;
dcl  baseno                   builtin;
dcl  code                     fixed bin(35);
dcl  command_query_           ext entry options (variable);
dcl  condition_interpreter_   ext entry (ptr, ptr, fixed bin(24), fixed bin(24), ptr, char(*), ptr, ptr);
dcl  continue_to_signal_      ext entry (fixed bin(35));
dcl  divide                   builtin;
dcl  fault_flags              bit(18)	/* gcos_ext_stat_$save_data to set accumulated */;
dcl  fault_vector             fixed bin(24)/* offset from base of gcos segment */;
dcl  find_condition_info_     ext entry (ptr, ptr, fixed bin(35));
dcl  fixed                    builtin;
dcl  gcos_et_$derail_flt      fixed bin(35) ext;
dcl  gcos_et_$divide_check_flt fixed bin(35) ext;
dcl  gcos_et_$fault_tag_flt   fixed bin(35) ext;
dcl  gcos_et_$illegal_procedure fixed bin(35) ext;
dcl  gcos_et_$lockup_flt      fixed bin(35) ext;
dcl  gcos_et_$mem_addr_flt    fixed bin(35) ext;
dcl  gcos_et_$mem_parity_flt  fixed bin(35) ext;
dcl  gcos_et_$non_gcos_fault  fixed bin(35) ext;
dcl  gcos_et_$op_not_complete_flt fixed bin(35) ext;
dcl  gcos_et_$out_of_time     fixed bin(35) ext;
dcl  gcos_et_$over_or_under_flow fixed bin(35) ext;
dcl  gcos_mme_bort_$system    ext entry options (variable);
dcl  hbound                   builtin;
dcl  hv                       fixed bin(35);
dcl  i                        fixed bin(24);
dcl  ic_i                     bit(36) aligned;
dcl  instruction_counter      fixed bin(18)unsigned unal based(addr(scu.ilc));
dcl  length                   builtin;
dcl  mod                      builtin;
dcl  null                     builtin;
dcl  p                        pointer;
dcl  prefix_vector            (0:13) bit(36) aligned based (gcos_ext_stat_$gcos_slave_area_seg);
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  unspec                   builtin;

dcl 1 INS	aligned based
,2 ADDRESS	unal
,  3 fill		bit(15)unal
,  3 r3b		fixed bin(3)unsigned unal
,2 OPCODE		bit(10)unal
,2 I		bit(1)unal
,2 T		bit(1)unal
,2 TAG		bit(6)unal
;


/* Structure overlays varying string "condition name"
   to provide formation of hash value.
*/
dcl 1 cn	aligned based(addr(condition_name))
,2 f bit(27)unal
,2 l bit( 9)unal
,2 b (32)bit(9)unal
;

dcl 1 faultv aligned based (addr (ic_i))	/* overlay for ic_i */,
    2 ic fixed bin(18)unsigned unaligned	/* instruction counter */,
    2 ind bit(18) unaligned			/* indicators */;
%page;
dcl 1 cond_info aligned,
%include cond_info;
%page;
%include gcos_fault_names;
%page;
%include query_info;
%page;
%include gcos_ext_stat_;
     end gcos_fault_processor_;




		    gcos_fms_error_.pl1             09/09/83  1400.3rew 09/09/83  1006.8       27396



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


/* *******************************************************************************************
   *******************************************************************************************
   *
   *
   *	Written by M. R. Jordan, October 1977
   *
   *******************************************************************************************
   ******************************************************************************************* */




gcos_fms_error_: procedure (fms_ecode, buf_ptr, fms_code);

dcl  addr builtin;
dcl  bit36 bit (36) aligned based;
dcl  buf_ptr ptr;
dcl  code fixed bin(35);
dcl  convert_status_code_ entry (fixed bin(35), char (8), char (100));
dcl  cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35));
dcl  fms_buf_ptr ptr;
dcl  fms_code bit (72) aligned;
dcl  fms_ecode fixed bin(35);
dcl  gcos_cv_ascii_gebcd_ entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_mme_bort_$system entry options (variable);
dcl  i fixed bin(24);
dcl  long_message char (100);
dcl  reason_code fixed bin(35);
dcl  rel builtin;
dcl  short_message char (8);
dcl  substr builtin;

dcl 1 fms_buf aligned based (fms_buf_ptr),
    2 pad1 (30) bit (36),
    2 dcw,
      3 data_loc bit (18) unal,
      3 op bit (6) unal,
      3 tally bit (12) unal,
    2 pad2 (3) bit (36),
    2 message bit (30*6) unal;

/*

   Initialize needed data items.

*/


	fms_buf_ptr = buf_ptr;
	fms_return_code_ptr = addr (fms_code);


/*

   Get the messages associated with the specified fms_ecode value.
   If the message is not an FMS error message then abort.  If it is then prepare to
   process the message.

*/


	call convert_status_code_ (fms_ecode, short_message, long_message);
	if substr (short_message, 1, 3) ^= "FMS" then
	     call gcos_mme_bort_$system (fms_ecode, "Bad FMS error code - contact support personnel");
	else do;
	     reason_code = cv_dec_check_ (substr (short_message, 4, 5), code);
	     if code ^= 0 then reason_code = 2047;
	end;


/*

   Now that we have verified the message, put all the data where the user
   can get to it from his GCOS slave job.

*/


	fms_return_code.reason = substr (addr (reason_code) -> bit36, 26, 11);
	fms_buf.dcw.data_loc = rel (addr (fms_buf.message));
	fms_buf.dcw.tally = "0005"b3;
	call gcos_cv_ascii_gebcd_ (addr (long_message), 30, addr (fms_buf.message), i);
	fms_return_code.err_mess_dcw.data_loc = fms_buf.dcw.data_loc;
	fms_return_code.err_mess_dcw.tally = fms_buf.dcw.tally;

	return;

%include gcos_fms_return_code_;


     end gcos_fms_error_;




		    gcos_gein_.pl1                  09/09/83  1400.3rew 09/09/83  1006.8      431649



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_gein_: proc;

/*
   This module receives control from the gcos command procedure. It is the
   "main loop" of the simulator; it controls the running of the entire job.

   It calls gcos_gein_pass1_ which performs (optional) cannonicalization (on an
   ASCII segment), copies $ SELECTed files into the job stream,
   and looks for activity-defining cards in the job.

   The input file must contain a job deck. It may be either an ASCII segment,
   as created by one of the Multics editors, or a gcos standard system format file,
   as created by the gcos daemon from a deck or an IMCV tape.  The appendage ".gcos" is one of
   two ways of identifying the latter type of job deck segment, the other being
   the -gcos (-gc) control argument.

   This procedure also initializes all the external static variables
   in gcos_ext_stat_ which need initialization and it opens a number of gcos files.

   Once initialization is complete, it reads card images from the
   job stream file and passes these on to the appropriate processing routines.

   When all the cards defining an activity have been processed, gcos_run_activity_
   will be called to run the activity. Processing will then continue with the
   cards for subsequent activities. When a $ ENDJOB card is read, its
   processing routine, gcos_cc_endjob_ will clean up all open files, perform
   other end-of-job bookkeeping, and then transfer to the label "normal_termination"
   in this procedure, via a non local goto, thus cleaning up the stack. However,
   if execution of the simulator (not a gcos activity) is aborted because of
   some error, control will be passed to the label "fatalerror" in the command
   procedure, gcos, causing the stack frame for this procedure to be cleaned
   up, and its cleanup handler, gein_cleanup, to be invoked.
*/
%page;
/*
   Author: DICK SNYDER AUGUST 4,1970
   Change: T.CASEY APRIL 1973, OCTOBER 1973, DECEMBER 1973, FEBRUARY 1974, APRIL 1974, AUGUST 1974
   Change: D. KAYDEN  MAY 1974, JULY 1974, FEBRUARY 1975
   Change: R.H. MORRISON MAY 1975
   Change: M. WEAVER JUNE 1975
   Change: M. R. Jordan, August 1977
   Change: A. N. Kepner, March 1978 to allow courtesy call i/o  within cc routines
   Change: Dave Ward, March 1978 to report $ SNUMB not first jcl card.
   Change: Mel Wilson, March, 1979 to remove snumb_then_ident check for gtss
   Change: Dave Ward	08/18/81 cleanup. octal constants.
   Change: Dave Ward	09/09/81 replaced use of alm vector gcos_cc_caller_ with goto cc.
   Change: Dave Ward	09/11/81 changed search_rules from allocated to auto.
   Change: Dave Ward	09/13/81 converted fibs & buffers from allocated space
			         to arrays in a temp segment.
   Change: Dave Ward	09/17/81 removed fctptr. clock_ to clock. unspec init.
   Change: Scott C. Akers	12/21/81	Fix bugs wherein GEIN references the wrong
				directory (syot_dir and save_dir get confused with
				wdir and each other).
   Change: Ron Barstad         11/12/82 Add cleanup handler for attached IDS2 files
   Change: Ron Barstad         12/02/82 Fix bug; $SELECT not writing binary object records to R*
   Change: Ron Barstad  83-08-02  Add 4JS3 to version message and 4js3 cards.
*/
%page;
/* INITIALIZE THE SIMULATOR -
   START BY CLEARING THE FILE INFORMATION BLOCKS,
   AND THEN OPENING THE FILES THAT ARE USED DURING THE WHOLE JOB
*/

start:	;
	unspec (save_data.fibs) = "0"b;

	fct.filecode = "";				/* clear the file code table */
	fct.sysout = "0"b;
	fct.fibptr = null ();

	on condition (cleanup) call gein_cleanup;	/* establish cleanup handler before opening any files */

/* Once per process initialization		 */
	if ^initialized then do;
	     initialized = "1"b;
	     gcos_ext_stat_$gcos_slave_area_seg = null;	/* init ptr to gcos seg once per process */
	     gcos_ext_stat_$max_mem = sys_info$max_seg_size; /* and max memory size */
	end;

	gcos_ext_stat_$save_data.endjob = "1"b;		/* Tell gcos_error_ to not call cc_endjob_ if we */
						/* abort during init.  Instead use gein_cleanup_. */


/* Use the search rules to search for the gcos libraries */
	if gcos_ext_stat_$save_data.userlib then do;	/* if user wants his own libraries */
						/* move "referencing_dir" to end of search rules,
						   to allow user's libraries to be found */
	     call hcs_$get_search_rules (addr (search_rules));

	     do i = 1 to search_rules.number
		     while (search_rules.names (i) ^= "referencing_dir");
	     end;

	     if i < search_rules.number then do;	/* if "referencing_dir" was found */
						/* and it was not last */
		search_rules.names (i) = "";		/* delete it from its present position */
		if search_rules.number = 21 then	/* if rule structure full */
		     do j = i to 20;		/* move the remaining rules up 1 */
		     search_rules.names (j) = search_rules.names (j+1);
		end;
		else search_rules.number = search_rules.number + 1; /* otherwise, save time */

		search_rules.names (search_rules.number) = "referencing_dir"; /* put it last */
	     end;

	     lib_count = 4;				/* allow search for gcos_second_software_ */
	end;
	else lib_count = 3;				/* -userlib not given so do not search for second software */

	do i = 1 to lib_count;

	     if gcos_ext_stat_$save_data.userlib then
		call execute_search_rules_$s_r_ptr (
		lib_names (i)
		, "1"b				/* (input) return target type & bit count. */
		||"1"b				/* (input) return target path. */
		||"1"b				/* (input) return primary name on entry. */
		|| (5)"0"b			/* (NOT USED). */
		, addr (search_rules)
		, fullname
		, ename
		, type
		, bit_count
		, code
		);
	     else
	     call execute_search_rules_ (
		lib_names (i)
		, "1"b				/* (input) return target type & bit count. */
		||"1"b				/* (input) return target path. */
		||"1"b				/* (input) return primary name on entry. */
		|| (5)"0"b			/* (NOT USED). */
		, fullname
		, ename
		, type
		, bit_count
		, code
		);
	     if code ^= 0 then do;
		if code = error_table_$noentry then do;
		     if i = 4 then do;		/* not error if second software not found */
			gcos_ext_stat_$save_data.userlib = "0"b; /* reset so gcos_mme_call_ will not try to use it */
			goto cont_init;
		     end;
		     else
		     if i = 2 then do;
			gcos_ext_stat_$patchfile_ptr = null ();
			goto end_lib_loop;
		     end;

		     if type = 0 then		/* if it was a link */
			err_msg = "target of link to system library ^a in ^a";
		     else
		     err_msg = "system library ^a";
		end;
		else
		err_msg = "while searching for system library ^a in ^a";
lib_err:		;
		call com_err_ (
		     code
		     , "gcos_gein_"
		     , err_msg
		     , lib_names (i)
		     , fullname
		     );
		if code ^= error_table_$no_s_permission then do;
fatal_error:	     ;
		     call gein_cleanup;
		     return;
		end;

	     end;

	     if bit_count = 0 then do;
		code = 0;
		err_msg = "zero bit count for system library ^a";
		goto lib_err;
	     end;


/* make full pathname of library */
	     lib_path = rtrim (fullname) || ">" || ename;
	     if i = 1 then do;			/* save subroutine library pathname */
		call gcos_open_file_ ("", "l*$", fibptr, sw);

		fib.pathnm = lib_path;
		fib.type = "1"b;			/* random file */
		fib.read = "1"b;			/* read only */
		fib.disp = "10"b;			/* disposition = save */
		fib.perm = "1"b;			/* do not delete when detaching */
	     end;
	     else
	     if i = 2 then do;
		gcos_ext_stat_$patchfile_ptr = null ();
		call hcs_$initiate (
		     fullname
		     , (ename)
		     , ""
		     , 0
		     , 0
		     , gcos_ext_stat_$patchfile_ptr
		     , code
		     );
	     end;
	     else do;
		call ios_$attach (
		     lib_streams (i-2)
		     , "file"
		     , lib_path
		     , "r"
		     , status
		     );
		if code ^= 0 then do;
lib_att_err:	     ;
		     err_msg = "trying to attach system library ^a";
		     goto lib_err;
		end;
		call ios_$setsize (lib_streams (i-2), 36, status);
		if code ^= 0 then goto lib_att_err;
	     end;
end_lib_loop:  ;
	end;

cont_init: ;

/* Obtain temporary segment for fibs and buffers. */

	call get_temp_segment_ (
	     "gcos"
	     , gcos_ext_stat_$temp_seg_ptr
	     , code
	     );
	if code ^= 0 then do;
	     call com_err_ (			/* Can not obtain temp segment. */
		code
		, "gcos"
		, "^/Attempting to get temporary segment."
		);
	     goto fatal_error;
	end;

/* INITIALIZE MISCELLANEOUS VARIABLES */
	gcos_ext_stat_$snumb = "4546452520"b3 ;		/* 4546452520 => "NONE" in bcd. */
	save_data.actid = "   NONE ";

	gcos_ext_stat_$normal_return = normal_termination; /* set up normal termination nonlocal goto */
	gcos_ext_stat_$default_nondollar,
	     gcos_ext_stat_$sought_label,
	     gcos_ext_stat_$abort_reason = "";

	unspec (gcos_ext_stat_$statistics) = "0"b;	/* 3*mme number word array being zeroed */

/* Indicate that cc_queue is initially empty. */
	courtesy_call.next_avail = 1;			/* next available empty location */
	courtesy_call.next_out = 1;			/* next entry to remove from queue */

	gcos_ext_stat_$job_real_time = clock ();	/* save job start time */
	call date_time_ (
	     gcos_ext_stat_$job_real_time
	     , execution_msg.date_time
	     );					/* put date and time in execution */
						/* report header message */

	call hcs_$get_usage_values (k, gcos_ext_stat_$job_cpu_time, k); /* get cpu time at start of job */

/* RESTART */

	if ^gcos_ext_stat_$save_data.nosave then do;
	     call hcs_$make_seg (
		(gcos_ext_stat_$save_dir)
		, gcos_ext_stat_$job_id || ".save_data"
		, ""
		, 11
		, gcos_ext_stat_$saveseg_ptr
		, code
		);

	     if gcos_ext_stat_$saveseg_ptr = null then
		call gcos_error_ (
		code
		, "creating ^a>^a.save_data"
		, gcos_ext_stat_$save_dir
		, gcos_ext_stat_$job_id
		);

	     if restart_control.saved then do;		/* job was interrupted */
		call gcos_restart_ (i);		/* do restart */
		goto restart (i);			/* (i) depends on restart options and saved data */

restart (1):	;				/* job restart if activity restart failed */

		call gein_cleanup;
		goto start;			/* start over from scratch */
	     end;
	end;

restart (4): ;					/* job restart if act. restart not attempted */
	save_data.psw = "0"b;			/* clear pgm sw. word */

	save_data.sqindex = 1;			/* init sysout queue index */

	save_data.activity_no = 0;			/* use activity number of zero in job file pathnames */

/* 	"Open" the following files		 */

/*	sysprint collector file */
/*	syspunch collector file */
/* 	execution report		 */
/*	geload r* collector file	*/


	do i = 1 to 4;
	     call gcos_open_file_ ("", "", fibptr, sw);	/* get a fib */
	     fib.disp = "10"b;			/* set disp = save for each file */
	     goto fib_init (i);			/* goto init rtn */
continue:	     ;					/* init rtns return here */
	end;

/*  Write head of form with report code 74 and header message on execution report */
	call gcos_write_$ptr (gcos_ext_stat_$er, FF, "11111100"b); /* write head-of-form */
	call gcos_write_$ptr (
	     gcos_ext_stat_$er
	     , string (execution_msg)
	     , "11111100"b
	     );					/* execution report header */

/* Get information from object or bound segment, and print it on execution
   report and console, to identify the version of the simulator being used */

	gptr = addr (gcos$);			/* get address of object or bound segment */
	call hcs_$status_mins (gptr, type, bit_count, code); /* get its bit count */
	if code ^= 0 then goto skip_version;		/* don't abort job - just skip printing version.
						   user might not have s access on the directory */
	obj_info.version_number = object_info_version_2;
	call object_info_$display (gptr, bit_count, addr (obj_info), code);
	if code ^= 0 then goto skip_version;
	call date_time_ (obj_info.compile_time, vrsn_msg.date_time); /* format time into message */
	call gcos_write_$ptr (
	     gcos_ext_stat_$er
	     , string (vrsn_msg)
	     , "11111100"b
	     );					/* write it on execution report */
	if ^gcos_ext_stat_$save_data.brief then		/* and, if user did not say -brief, */
	     call ioa_$nnl ("GCOS 4JS3 ^a", string (vrsn_msg)); /* on console */

	if gcos_ext_stat_$save_data.debug then do;	/* for benefit of debugger of simulator,
						   print pathname, author, and whether bound or not */
	     call hcs_$fs_get_path_name (
		gptr
		, fullname
		, i
		, ename
		, code
		);
	     if code ^= 0 then goto skip_version;
	     if obj_info.format.bound then seg_type = "bound";
	     else seg_type = "compiled";
	     call ioa_$rs (
		"^a>^a ^a by ^a^/"
		, err_msg
		, j
		, fullname
		, ename
		, seg_type
		, obj_info.userid
		);
	     if gcos_ext_stat_$save_data.long then	/* if user said -long, */
		call ioa_$nnl ("^a", err_msg);	/* print it on the terminal */
	     call gcos_write_$ascii_ptr (
		gcos_ext_stat_$er
		, var_msg
		, "11111100"b
		);				/* and always on ex rpt, in ASCII */

	end;

skip_version: ;
						/* come here on any error getting version information */

	gcos_ext_stat_$save_data.endjob = "0"b;		/* Initialization complete, reset flag */

pass1:	;
	call gcos_gein_pass1_;			/* go put job stream in shape to run job */

	if save_data.last_execute_act_no > 0 then	/* if job contains any EXECUTE cards */
	     save_data.psw = "01"b3 ;			/* turn on psw bit 5 */

	if ^gcos_ext_stat_$save_data.nosave then do;	/* save restart data */
	     call gcos_write_$force_ptr (gcos_ext_stat_$er);
	     call gcos_restart_$save;
	end;


/* Write header record on sysout print collector file. This record identifies
   the file as sysout (to be sorted) rather than print (not to be sorted). It
   also reserves space for the snumb and the offset within the file where the
   execution report begins, to be put in later */

restart (2): ;
	call gcos_write_$record_ptr (
	     gcos_ext_stat_$prt
	     , firstrecord
	     , (8)"0"b
	     );
						/* come here for activity restart of first act. */

restart (3): ;					/* come here for activity restart */
%page;
/* Initialization is now complete. Here begins the main processing loop of GEIN.
   Cards or line images are read here from the job stream file
   and then looked up in a table to obtain a pointer to the appropriate
   processing routine.  Some cards are processed in-line, however. */


/* Come here after each card is processed, to read the next card */

loop:	;
	call gcos_read_card_ (gcos_ptr, gcos_len, card, dollar_sw); /* get card image */
	gcos_ext_stat_$gf = 0;			/* init sw for gcos_get_cc_field_ rtn */

	if ^dollar_sw then goto nondollar;		/* if not a dollar card */

/* WE HAVE A $ CONTROL CARD;
   CHECK FOR VARIOUS SPECIAL CASES BEFORE LOOKING IT UP IN THE TABLE */

	dollar_card_count = dollar_card_count+1;
	card_type = translate (substr (card, 8, 6), LOWER_CASE, UPPER_CASE); /* pick out card type, for faster access */

	if gcos_ext_stat_$save_data.copy then do;	/* copy $ control cards */
	     if card_type ^= "endcop" then goto nondollar; /* go write on file */
	     if gcos_ext_stat_$save_data.endfc then
		if gcos_ext_stat_$endfc ^= translate (substr (card, 16, 2), LOWER_CASE, UPPER_CASE) then goto nondollar;
	     gcos_ext_stat_$save_data.copy
		, gcos_ext_stat_$save_data.nondollar
		, gcos_ext_stat_$save_data.endfc
		= "0"b;				/* turn off sw if endcopy card */
	     gcos_ext_stat_$nondollar = "";		/* no nondollar file is defined now */
	     goto loop;				/* get another card */
	end;

	if ^gcos_ext_stat_$save_data.brief then		/* unless told not to */
	     if nondollar_cards_skipped > 0 then do;	/* warn user of out-of-place nondollar cards
						   that preceeded this one */
		call ioa_ (
		     "^d nondollar cards skipped before:^/^a"
		     , nondollar_cards_skipped
		     , card
		     );
		nondollar_cards_skipped = 0;		/* reset the count */
	     end;
	     else if cc_print_sw then call ioa_ ("^a", card); /* print card if requested, for debugging */

	if substr (card, 1, 7) ^= "$" then		/* possible label card */
	     goto label_card;			/* go see if we are looking for one */

	if card_type ^= "etc   " then
	     gcos_ext_stat_$save_data.write_etc = "0"b;	/* the only way to make sure this switch is not
						   left on too long is to turn it off every time a
						   non-ETC card is read */

	if card_type ^= "incode" then
	     if gcos_ext_stat_$save_data.nondollar then do; /* if we were reading nondollar cards */
		gcos_ext_stat_$save_data.nondollar = "0"b; /* we aren't any more */
		gcos_ext_stat_$nondollar = "";	/* and no nondollar file is defined now */
		gcos_ext_stat_$incode = 0;		/* turn off any incode processing */
	     end;

/* Look up card in table */
	do i = 1 to gcos_control_tables_$tablelen;
	     if card_type = gcos_control_tables_$cardtable (i) then goto found; /* look for card type */
	end;

/* An unknown card is not an error, in real GCOS */

unknown_card: ;
	if gcos_ext_stat_$save_data.long then		/* if told to do so, warn user of bad $ card */
	     call ioa_ (
	     "gcos simulator will ignore the following unknown dollar card:^/^a"
	     , card
	     );
	goto loop;

found:	;					/* come here when card is found in cardtable;
						   "i" is its position in the table, and is used from here on */



/* BEFORE CALLING THE PROCESSOR FOR THIS CARD, CHECK VARIOUS SPECIAL CASES */
	if dollar_card_count = 1 then
	     if card_type ^= "snumb" then goto no_snumb;

/* FIRST, ARE WE SKIPPING THROUGH THE DECK, LOOKING FOR SOMETHING? */


	if gcos_ext_stat_$save_data.seeking then do;	/* if we are seeking a label or terminator */
						/* "seeking" do group */
	     if gcos_ext_stat_$sought_label ^= "" then do; /* if we are seeking a label */
						/* we already know we do not have one */
						/* "seeking label" do group (for GOTO, IF, or WHEN card) */
		if i >= gcos_control_tables_$exc_offset then
		     if i < gcos_control_tables_$nonact then do; /* if this is an activity card, */
						/* we will delete the activity */

delete_activity:		;			/* come here from below to delete activities */
						/* of aborts or compilation errors in previous */
						/* activities */
			gcos_ext_stat_$save_data.this_act_abort = "0"b; /* make sure this switch does not stay on
						   past the end of the aborting activity */

/*  Bump the activity number 	 */

			save_data.activity_no = save_data.activity_no + 1;

/* Write activity deletion messages on console and execution report */

/* format the message */
			call ioa_$rs (
			     "* ^a ACTIVITY -^2d- DELETED"
			     , err_msg
			     , j
			     , card_type
			     , save_data.activity_no
			     );

/* write it on the console, for the benefit of the interactive user */
			if gcos_ext_stat_$save_data.long then /* provided he said -long */
			     call ioa_$nnl ("^a", var_msg);

/* and on the execution report */
			call gcos_write_$ptr (
			     gcos_ext_stat_$er
			     , var_msg
			     , "11111100"b
			     );


			goto loop;		/* go read next card */

		     end;



		if i = gcos_control_tables_$tablelen then /* if ENDJOB card, */
		     goto call_caller;		/* then terminate job normally */

		goto loop;			/* if not from $ WHEN card, or if current card is
						   not a terminator, then keep looking for the label */
	     end;					/* end of "seeking label" do group */

/* So we are just seeking a terminator. We could be skipping an abort subactivity,
   or skipping a deleted execution activity. In either case, a $ ABORT card is not
   an acceptable terminator for the search */

	     if i < gcos_control_tables_$exc_offset then goto loop; /* not a terminator. keep looking for one */

/* it is a terminator - it might be a $ ABORT card, though */
	     if i = gcos_control_tables_$nonact then goto loop; /* if so keep looking */

/* We found a terminator. Turn off the switches that make us look for one */
	     gcos_ext_stat_$save_data.seeking, gcos_ext_stat_$save_data.seeking_terminator = "0"b;

/* And fall thru to process the terminator */
	end;					/* end of "seeking" do group */



/* SECOND, WE WILL ENFORCE RESTRICTIONS ON POSITION OF SNUMB AND IDENT CARDS */

	if gcos_ext_stat_$save_data.flgs.ident then goto activtst; /* snumb and ident already found ? */
	if card_type = "snumb " then goto activtst;	/* snumb? */
	if ^gcos_ext_stat_$save_data.snumb then goto loop; /* no..if none read yet continue */



/* THIRD, ACTIVITY TERMINATING CARDS NEED SOME SPECIAL HANDLING */

activtst:	;
	if i >= gcos_control_tables_$exc_offset then do;	/* if this card is an activity terminator */
	     if gcos_ext_stat_$save_data.activ then do;	/* and an activity was being defined, run it now */

		if ^gcos_ext_stat_$save_data.flgs.ident then
		     goto jobort;			/* require $ident before first activity execution */

		if ^gcos_ext_stat_$save_data.nosave then
		     restart_control.na_restart = restart_control.na_hold; /* copy activity restart option */

		call gcos_run_activity_;

		if ^gcos_ext_stat_$save_data.nosave then do; /* if user requested save */
		     call gcos_write_$force_ptr (gcos_ext_stat_$er);
		     call gcos_write_$force_ptr (gcos_ext_stat_$rs);
		     call gcos_write_$force_ptr (gcos_ext_stat_$pch);
		     call gcos_restart_$save;		/* save state of simulator at activity end */
		end;
						/* so that we could restart from the beginning
						   of the next activity if we had to */
	     end;

/* Control also comes here to continue after running an activity,
   or after skipping a deleted activity. */

/* Here, check for two types of activity deletion, before beginning to
   define the next activity:
   1) run only compilations after an abort (and before a $ BREAK)
   2) if a compiler turns off psw bit 5, delete all execution activities,
   until somebody turns it back on.


   Execution activities are $ EXECUTE and $ 355SIM */
	     if i >= gcos_control_tables_$comp_offset then
		goto dont_delete;			/* never delete a compilation activity */
	     if gcos_ext_stat_$save_data.prev_act_abort then
		goto do_delete;			/* after an abort, delete all non-compilation activities */

	     if i > gcos_control_tables_$exc_offset + 1 then /* if not EXECUTE or 355SIM */
		goto dont_delete;			/* run regardless of PSW bit 5 */

	     if substr (save_data.psw, 6, 1) then	/* if PSW bit 5 is on */
		goto dont_delete;			/* then run EXECUTE OR 355SIM */


do_delete:     ;
	     gcos_ext_stat_$save_data.seeking
		, gcos_ext_stat_$save_data.seeking_terminator
		= "1"b;				/* set save_data to look for next terminator card */

	     goto delete_activity;			/* go print message and increment activity number */

dont_delete:   ;

	end;

	if (gcos_ext_stat_$activity_name = "geload")	/* if we are defining an EXECUTE activity */
	& (i <= gcos_control_tables_$filecard_count) then do; /* and this is a file card */
	     call gcos_write_$record ("r*", gcos_record, (8)"0"b); /* write it on R* */
	     gcos_ext_stat_$save_data.write_etc = "1"b;	/* and remember to write its continuation */
	     gcos_ext_stat_$etc_filecode = "r*";	/* (if any) on R* too */
	end;



/* FINALLY, CALL THE PROCESSOR FOR THIS CARD */


call_caller: ;
	goto cc (i);

cc (001):	;
	call gcos_cc_file_cards_$cc_print (card);	/* print card */
	goto loop;

cc (002):	;
	call gcos_cc_file_cards_$cc_punch (card);	/* punch card */
	goto loop;

cc (004):	;
/* disc card */

cc (005):	;
/* drum card */

cc (006):	;
/* file card */

cc (007):	;
/* mass card */

cc (003):	;
	call gcos_cc_file_cards_$cc_file (card);	/* disk card */
	goto loop;

cc (008):	;
	call gcos_cc_file_cards_$cc_prmfl (card);	/* prmfl card */
	goto loop;

cc (009):	;
	call gcos_cc_data_ (card);			/* data card */
	goto loop;

cc (010):	;
	call gcos_cc_file_cards_$cc_tape (card);	/* tape card */
	goto loop;

cc (011):	;
	call gcos_cc_file_cards_$cc_tape7 (card);	/* tape7 card */
	goto loop;

cc (012):	;
	call gcos_cc_file_cards_$cc_tape9 (card);	/* tape9 card */
	goto loop;

cc (013):	;
/* sysout card */

cc (014):	;
	call gcos_cc_file_cards_$cc_sysout (card);	/* remote card */
	goto loop;

cc (015):	;
	call gcos_cc_file_cards_$cc_dac (card);		/* dac card */
	goto loop;

cc (016):	;
	call gcos_cc_file_cards_$cc_type (card);	/* type card */
	goto loop;

cc (017):	;
	call gcos_cc_file_cards_$cc_read (card);	/* read card */
	goto loop;

cc (018):	;
	call gcos_cc_snumb_ (card);			/* snumb card */
	goto loop;

cc (019):	;
	call gcos_cc_misc_cards_$cc_comment (card);	/* comment card */
	goto loop;

cc (020):	;
	call gcos_cc_incode_ (card);			/* incode card */
	goto loop;

cc (021):	;
	call gcos_cc_misc_cards_$cc_etc (card, i, gcos_record); /* etc card */
	goto loop;

cc (022):	;
	call gcos_cc_misc_cards_$cc_endcopy (card);	/* endcopy card */
	goto loop;

cc (023):	;
	call gcos_cc_update_ (card, i, gcos_record);	/* update card */
	goto loop;

cc (024):	;
	call gcos_cc_limits_ (card);			/* limits card */
	goto loop;

cc (025):	;
	call gcos_cc_misc_cards_$cc_msg1 (card);	/* msg1 card */
	goto loop;

cc (026):	;
	call gcos_cc_misc_cards_$cc_msg2 (card);	/* msg2 card */
	goto loop;

cc (027):	;
	call gcos_cc_misc_cards_$cc_msg3 (card);	/* msg3 card */
	goto loop;

cc (028):	;
	call gcos_cc_misc_cards_$cc_userid (card);	/* userid card */
	goto loop;

cc (029):	;
	call gcos_cc_misc_cards_$cc_alter (card);	/* alter card */
	goto loop;

cc (030):	;
	call gcos_cc_set_ (card);			/* set card */
	goto loop;

cc (032):	;
/* copy card */

cc (033):	;
/* delete card */

cc (034):	;
/* endedit card */

cc (039):	;
/* include card */

cc (042):	;
/* list card */

cc (043):	;
/* modify card */

cc (045):	;
/* patch card */

cc (047):	;
/* seq card */

cc (048):	;
/* setsq card */

cc (053):	;
/* assem card */

cc (055):	;
/* get card */

cc (056):	;
/* getrwd card */

cc (058):	;
/* setsq1 card */

cc (031):	;
	call gcos_cc_directive_cards_$cc_editor (card, i, gcos_record); /* compile card */
	goto loop;

cc (036):	;
	call gcos_cc_directive_cards_$cc_ffile (card, i, gcos_record); /* ffile card */
	goto loop;

cc (040):	;
/* input card */

cc (041):	;
/* output card */

cc (044):	;
/* multi card */

cc (037):	;
	call gcos_cc_directive_cards_$cc_bmc (card, i, gcos_record); /* form card */
	goto loop;

cc (038):	;
/* futil card */
cc (046):	;
	call gcos_cc_directive_cards_$cc_utility (card, i, gcos_record); /* qutil card */
	goto loop;

cc (035):	;
/* endld card */

cc (049):	;
	call gcos_cc_directive_cards_$cc_sysedit (card, i, gcos_record); /* sysld card */
	goto loop;

cc (050):	;
	call gcos_cc_goto_$cc_when (card);		/* when card */
	goto loop;

cc (051):	;
	call gcos_cc_abort_ (card);			/* abort card */
	goto loop;

cc (052):	;
	call gcos_cc_directive_cards_$cc_dump (card, i, gcos_record); /* dump card */
	goto loop;

cc (054):	;
	call gcos_cc_directive_cards_$cc_sced (card, i, gcos_record); /* change card */
	goto loop;

cc (057):	;
	call gcos_cc_misc_cards_$cc_need (card);	/* need card */
	goto loop;

cc (059):	;
	call gcos_cc_param_ (card);			/* param card */
	goto loop;

cc (061):	;
/* library card */

cc (062):	;
/* lowload card */

cc (063):	;
/* use card */

cc (064):	;
/* entry card */

cc (065):	;
/* nolib card */

cc (066):	;
/* equate card */

cc (067):	;
/* link card */

cc (068):	;
/* relcom card */

cc (069):	;
/* source card */

cc (070):	;
/* dkend card */

cc (071):	;
/* nload card */

cc (060):	;
	call gcos_cc_loader_cards_ (card, i, gcos_record); /* option card */
	goto loop;

cc (104):	;    
	call gcos_cc_loader_cards_$cc_object (card, i, gcos_record); /* object card */
	goto loop;

cc (073):	;
/* 355sim card */

cc (074):	;
/* program card */

cc (075):	;
/* conver card */

cc (076):	;
/* filedit card */

cc (077):	;
/* sysedit card */

cc (078):	;
/* utility card */

cc (079):	;
/* utl2 card */

cc (080):	;
/* convrt card */

cc (081):	;
/* fortran card */

cc (082):	;
/* pl1 card */

cc (083):	;
/* cobol card */

cc (084):	;
/* gmap card */

cc (085):	;
/* 355map card */

cc (086):	;
/* algol card */

cc (087):	;
/* forta card */

cc (088):	;
/* forty card */

cc (089):	;
/* jovial card */

cc (090):	;
/* asm66 card */

cc (091):	;
/* cbl74 card */

cc (092):	;
/* cbl68 card */

cc (093):	;
/* malt card */

cc (094):	;
/* ilang card */

cc (095):	;
/* ids card */

cc (096):	;
/* ids2 card */

cc (097):	;
/* 4tran card */

cc (098):	;
/* g3edit card */

cc (099):	;
/* fort77 card */

cc (100):	;
/* fortx card */

cc (101):	;
/* cids2 card */

cc (102):	;
/* rpg2 card */

cc (072):	;
	call gcos_cc_activity_cards_ (card, i, gcos_record); /* execute card */
	goto loop;

cc (103):	;
	call gcos_cc_ident_ (card);			/* ident card */
	goto loop;

cc (105):	;
	call gcos_cc_misc_cards_$cc_break (card);	/* break card */
	goto loop;

cc (106):	;
	call gcos_cc_goto_ (card);			/* goto card */
	goto loop;

cc (107):	;
	call gcos_cc_goto_$cc_if (card);		/* if card */
	goto loop;

cc (108):	;
	call gcos_cc_endjob_ (card);			/* endjob card */
	goto loop;				/* continue processing */

/* Come here to abort job if snumb-ident sequence is not right */

no_snumb:	;
	call gcos_error_ (
	     gcos_et_$cc_bad_card
	     , "$ SNUMB must be first control card.^/^a^2x^a"
	     , gcos_ext_stat_$card_num
	     , card
	     );

jobort:	;
	call gcos_error_ (
	     gcos_et_$cc_bad_card
	     , "$ IDENT must follow $ SNUMB imediately.^/^a^2x^a"
	     , gcos_ext_stat_$card_num
	     , card
	     );


/* Come here when a nondollar card is read */

nondollar: ;
	if gcos_ext_stat_$save_data.seeking then goto loop; /* if we are seeking a label or terminator,
						   we skip over all nondollar cards */

	gcos_ext_stat_$save_data.write_etc = "0"b;	/* the only way to be sure this switch does not get
						   left on too long is to turn it off every time we read
						   a non-etc card */

	if gcos_ext_stat_$save_data.nondollar then goto nondl_write; /* skip if already processing nondollar cards */

/* Enforce restriction on position of snumb and ident cards */
	if ^gcos_ext_stat_$save_data.snumb then goto loop; /* skip cards before snumb */
	if ^gcos_ext_stat_$save_data.flgs.ident then goto jobort; /* abort if cards between snumb and ident */

/* Write the nondollar card on a file (maybe) */

/* we are starting a new nondollar file */
	gcos_ext_stat_$nondollar =			/* whose filecode will be */
	     gcos_ext_stat_$default_nondollar;		/* the default nondollar filecode */
						/* which could be blank if we have already "used it up" */
	gcos_ext_stat_$default_nondollar = "";		/* we have used it up now, if not before */

	if gcos_ext_stat_$nondollar = "" then do;	/* if we had used it up previously */
	     nondollar_cards_skipped = nondollar_cards_skipped + 1; /* skip over the cards */
	     goto loop;
	end;					/* otherwise fall thru and write it on the file */

	gcos_ext_stat_$save_data.nondollar = "1"b;	/* set flag to say processing a data deck */

nondl_write: ;
	if gcos_ext_stat_$nondollar ^= "" then		/*  check for writing to geload r* file */
	     call gcos_write_$record (
	     gcos_ext_stat_$nondollar
	     , gcos_record
	     , (8)"0"b
	     );
	else
	call gcos_write_$record_ptr (
	     gcos_ext_stat_$rs
	     , gcos_record
	     , "0"b
	     );					/* write to r* collector file */
	goto loop;				/* continue */


/* Come here to process possible label cards */

label_card: ;					/* columns 2-7 were not completely blank */

/* get label */
	do j = 3 to 7
		while (substr (card, j, 1) = " ");	/* find beginning of label */
	end;
						/* j now points to its first character */
	k = index (substr (card, j), " ") - 2;		/* get length of label */
	if k < 1 then goto unknown_card;		/* bad label */
	if k > 6 then goto unknown_card;		/* bad label */
	if substr (card, j+k, 1) ^= ":" then		/* if it does not end in colon */
	     if substr (card, j+k, 1) ^= "." then	/* or period */
		goto unknown_card;			/* bad label */

/* good label */
	if ^gcos_ext_stat_$save_data.seeking then goto loop; /* skip it if not looking for anything */
	if gcos_ext_stat_$sought_label = "" then goto loop; /* or if not seeking a label */
	if substr (card, j, k) ^=			/* if the label */
	gcos_ext_stat_$sought_label then		/* is not the one we sought */
	     goto loop;				/* then keep looking for it */

/* we found it */
	gcos_ext_stat_$sought_label = "";		/* so stop looking */
	gcos_ext_stat_$save_data.seeking, gcos_ext_stat_$save_data.seeking_terminator = "0"b;

	goto loop;				/* and go get next card to process */

/* Control comes here from gcos_cc_endjob_ via a nonlocal goto,
   if that procedure was able to complete the termination of the job. */

normal_termination: ;
	call release_temp;
	return;
%page;

/* 	File information block initialization routines	 */


/* 	Fib initialization for syspunch	 */

fib_init (1): ;
	gcos_ext_stat_$pch = fibptr;			/* save sysout punch collector fib pointer */
	fib.stream = "syspunch";			/* file id is "syspunch" */
	fib.punch = "1"b;				/* punch file */
	goto continue;				/* return to processing loop */


/* 	Fib initialization for sysprint	 */

fib_init (2): ;
	gcos_ext_stat_$prt = fibptr;			/* save sysout print collector fib pointer */
	fib.stream = "sysprint";			/* file id is "sysprint" */
	fib.print = "1"b;				/* print file */
	goto continue;				/* return to processing loop */

/* 	Fib initialization for execution report file	 */

fib_init (3): ;
	gcos_ext_stat_$er = fibptr;			/* save execution report fib pointer */
	fib.stream = "exec_rpt";			/* file id is "exec_rpt" */
	fib.print = "1"b;				/* print file */
	goto continue;				/* return to processing loop */

/*	Fib initialization for geload r* collector file 	*/

fib_init (4): ;
	gcos_ext_stat_$rs = fibptr;			/* save fib pointer */
	fib.stream = "rstar";			/* file id is "rstar" */
	goto continue;				/* return to processing loop */
%page;
dollar_print: entry;

/* 	Enter here to set switch to cause control cards to be printed			 */
	cc_print_sw = ^cc_print_sw;			/* flip switch */
	if cc_print_sw then msg_var = "on";
	else msg_var = "off";
	call ioa_ ("control card printing turned ^a", msg_var);
	return;
%page;
gein_cleanup: proc;					/*     CLEANUP HANDLER FOR ENTIRE SIMULATOR EXCEPT PASS1   */
	     do i = 1 to hbound (save_data.fibs, 1);	/* go thru all fibs */
		fibptr = addr (save_data.fibs (i));
		if ^fib.used then goto get_next_fib;	/* if unused, skip to next one */
		if ^fib.attached then goto get_next_fib; /* file not attached, skip to next */
		if fib.console then goto get_next_fib;	/* a console device is never really attached */
		if fib.null then goto get_next_fib;	/* neither is a null file */
		call ios_$detach (fib.stream, "", "", status);
						/* ignore errors */

/* NOTE THAT ALL THE SPECIAL CASE CHECKS FOLLOWING MUST BE REVIEWED, AFTER ANY
   MAJOR CHANGE TO THE SIMULATOR, TO MAKE CERTAIN THEY ARE STILL VALID.  */
		if fib.print then goto keep_it;	/* don't delete print files */
		if fib.punch then goto keep_it;	/* ... or punch files */
		if fib.tape then goto keep_it;	/* nothing to delete here */
		call expand_pathname_ (
		     fib.pathnm
		     , fullname
		     , ename
		     , code
		     );
		if code ^= 0 then goto keep_it;	/* ignore errors, but don't get into trouble doing it */
		if fib.perm then goto keep_it;	/* don't delete perm files */
		call delete_$path (
		     fullname
		     , ename
		     , "07"b3			/* noforce,noquestion,nodirs,segs,links,chase */
		     , "gcos"
		     , code
		     );
						/* ignore errors */
keep_it:		;

/* Clean up any possible IDS2 locked files */
		if fib.perm & fib.type /* rand */
		     then if gcos_ids2_concur_$have_xid(fullname,ename,code)
		         then call gcos_ids2_concur_$deallocate(
		              fullname,ename,fib.read, fib.write,code);
		

/* Make buffer available. */
		if fib.buffer_indx > 0 then do;
		     fib_buffers.buffer_in_use (fib.buffer_indx) = "0"b;
		     fib.buffer_indx = 0;
		     fib.buffer = null ();
		end;
get_next_fib:	;
	     end;					/* fall thru when all fibs examined */
	     call ios_$detach ((lib_streams (1)), "", "", status); /* detach the system libraries */
	     call ios_$detach ((lib_streams (2)), "", "", status);
	     call ios_$detach ("gcos_job_stream_", "", "", status); /* it could be attached if:
						   1) we were still in pass1, or
						   2) it was a msf */
	     call delete_$path (
		string (gcos_ext_stat_$save_dir)
		, gcos_ext_stat_$job_id || ".job_deck"
		, "07"b3
		, "gcos"
		, code
		);
	     call delete_$path (
		string (gcos_ext_stat_$save_dir)
		, gcos_ext_stat_$job_id || ".save_data"
		, "07"b3
		, "gcos"
		, code
		);
	     if gcos_ext_stat_$gcos_slave_area_seg ^= null then
		call hcs_$truncate_seg (
		gcos_ext_stat_$gcos_slave_area_seg
		, 0
		, code
		);
	     if gcos_ext_stat_$temp_seg_ptr ^= null () then do;
		call release_temp;
	     end;
	     return;

	end gein_cleanup;
%page;
release_temp: proc;

	     call release_temp_segment_ (
		"gcos"
		, gcos_ext_stat_$temp_seg_ptr
		, code
		);
	     if code ^= 0 then
		call com_err_ (			/* Could not release temp segment. */
		code
		, "gcos"
		, "^/Releasing temp segment (^p)"
		, gcos_ext_stat_$temp_seg_ptr
		);
	     return;

	end release_temp;
%page;
/*   Variables for gcos_gein_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  baseno                   builtin;
dcl  bit_count                fixed bin(24)	/* length of input segment in bits */;
dcl  card                     char(80)	/* card image returned by gcos_read_card_ */;
dcl  card_type                char(8) aligned	/* card type extracted from dollar card image */;
dcl  cc_print_sw              bit(1) int static init ("0"b);
dcl  char                     builtin;
dcl  cleanup                  condition;
dcl  clock                    builtin;
dcl  code                     fixed bin(35) based (addr (status))	/* return param. for passing error codes */;
dcl  com_err_                 entry() options(variable);
dcl  date_time_               ext entry (fixed bin(71), char(*));
dcl  delete_$path             entry (char(*), char(*), bit(6), char(*), fixed bin(35));
dcl  dollar_card_count        fixed bin(24)init (0)		/* Count of "$" cards. */;
dcl  dollar_sw                bit(1) ;
dcl  ename                    char(32) 	/* holds entry name of input seg */;
dcl  error_table_$noentry     ext fixed bin(35);
dcl  error_table_$no_s_permission ext fixed bin(35);
dcl  err_msg                  char(150)	/* for com_err calls */;
dcl  expand_pathname_         entry (char(*), char(*), char(*), fixed bin(35));
dcl  firstrecord              char(60) based (addr (first_record))	/* overlay for 15-word first_record structure */;
dcl  fullname                 char(168)	/* holds pathname of input seg */;
dcl  gcos$                    ext;
dcl  gcos_cc_abort_           entry options(variable);
dcl  gcos_cc_activity_cards_  entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_data_            entry (char(80));
dcl  gcos_cc_directive_cards_$cc_bmc entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_dump entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_editor entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_ffile entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_sced entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_sysedit entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_directive_cards_$cc_utility entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_endjob_          entry (char(80));
dcl  gcos_cc_file_cards_$cc_dac entry (char(80));
dcl  gcos_cc_file_cards_$cc_file entry (char(80));
dcl  gcos_cc_file_cards_$cc_print entry (char(80));
dcl  gcos_cc_file_cards_$cc_prmfl entry (char(80));
dcl  gcos_cc_file_cards_$cc_punch entry (char(80));
dcl  gcos_cc_file_cards_$cc_read entry (char(80));
dcl  gcos_cc_file_cards_$cc_sysout entry (char(80));
dcl  gcos_cc_file_cards_$cc_tape entry (char(80));
dcl  gcos_cc_file_cards_$cc_tape7 entry (char(80));
dcl  gcos_cc_file_cards_$cc_tape9 entry (char(80));
dcl  gcos_cc_file_cards_$cc_type entry (char(80));
dcl  gcos_cc_goto_            entry (char(80));
dcl  gcos_cc_goto_$cc_if      entry (char(80));
dcl  gcos_cc_goto_$cc_when    entry (char(80));
dcl  gcos_cc_ident_           entry (char(80));
dcl  gcos_cc_incode_          entry (char(80));
dcl  gcos_cc_limits_          entry (char(80));
dcl  gcos_cc_loader_cards_    entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_loader_cards_$cc_object   entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_misc_cards_$cc_alter entry (char(80));
dcl  gcos_cc_misc_cards_$cc_break entry options(variable);
dcl  gcos_cc_misc_cards_$cc_comment entry (char(80));
dcl  gcos_cc_misc_cards_$cc_endcopy entry (char(80));
dcl  gcos_cc_misc_cards_$cc_etc entry (char(80), fixed bin(24), char(*));
dcl  gcos_cc_misc_cards_$cc_msg1 entry options(variable);
dcl  gcos_cc_misc_cards_$cc_msg2 entry (char(80));
dcl  gcos_cc_misc_cards_$cc_msg3 entry options(variable);
dcl  gcos_cc_misc_cards_$cc_need entry (char(80));
dcl  gcos_cc_misc_cards_$cc_userid entry (char(80));
dcl  gcos_cc_param_           entry (char(80));
dcl  gcos_cc_set_             entry (char(80));
dcl  gcos_cc_snumb_           entry (char(80));
dcl  gcos_cc_update_          entry (char(80), fixed bin(24), char(*));
dcl  gcos_error_              ext entry options (variable);
dcl  gcos_et_$cc_bad_card     fixed bin(35) ext;
dcl  gcos_gein_pass1_         ext entry;
dcl  gcos_ids2_concur_$deallocate ext entry (char(*), char(*), bit(1), bit(1), fixed bin(35));
dcl  gcos_ids2_concur_$have_xid ext entry (char(*), char(*), fixed bin(35)) returns (bit(1));
dcl  gcos_len                 fixed bin(24);
dcl  gcos_open_file_          ext entry (char(*), char(*), pointer, bit(1));
dcl  gcos_ptr                 ptr;
dcl  gcos_read_card_          entry (ptr, fixed bin(24), char(80), bit(1));
dcl  gcos_record              char(gcos_len) based (gcos_ptr);
dcl  gcos_restart_            entry (fixed bin(24));
dcl  gcos_restart_$save       ext entry;
dcl  gcos_run_activity_       ext entry;
dcl  gcos_write_$ascii_ptr    ext entry (ptr, char(*), bit(8));
dcl  gcos_write_$force_ptr    ext entry (ptr);
dcl  gcos_write_$ptr          ext entry (ptr, char(*), bit(8));
dcl  gcos_write_$record       ext entry (char(*), char(*), bit(8));
dcl  gcos_write_$record_ptr   ext entry (ptr, char(*), bit(8));
dcl  get_temp_segment_        entry (char(*), ptr, fixed bin(35));
dcl  gptr                     ptr	/* pointer to gcos bound segment, for object_info_ */;
dcl  hbound                   builtin;
dcl  hcs_$fs_get_path_name    entry (ptr, char(*), fixed bin(24), char(*), fixed bin(35));
dcl  hcs_$get_search_rules    ext entry (ptr);
dcl  hcs_$get_usage_values    ext entry (fixed bin(24), fixed bin(71), fixed bin(24));
dcl  hcs_$initiate            entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$make_seg            ext entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
dcl  hcs_$status_mins         ext entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$truncate_seg        ext entry (ptr, fixed bin(24), fixed bin(35));
dcl  i                        fixed bin(24);
dcl  index                    builtin;
dcl  initialized              bit(1) internal static init ("0"b);
dcl  ioa_                     entry() options(variable);
dcl  ioa_$nnl                 entry() options(variable);
dcl  ioa_$rs                  entry() options(variable);
dcl  ios_$attach              ext entry (char(*) aligned, char(*), char(*) aligned, char(*), bit(72) aligned);
dcl  ios_$detach              ext entry (char(*), char(*) aligned, char(*), bit(72) aligned);
dcl  ios_$setsize             ext entry (char(*) aligned, fixed bin(24), bit(72) aligned);
dcl  j                        fixed bin(24);
dcl  k                        fixed bin(24)/* temp */;
dcl  lib_count                fixed bin(24)/* number of libraries in use (2 or 3) */;
dcl  lib_path                 char(168) aligned	/* temporary for library pathnames */;
dcl  lib_streams              (2)char(4)aligned int static options(constant)init("glib", "slib") /* software library streams */;
dcl  LOWER_CASE               char(26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  msg_var                  char(4);
dcl  nondollar_cards_skipped  fixed bin(24)init (0)	/* to count skipped nondollar cards, for debugging */;
dcl  null                     builtin;
dcl  object_info_$display     ext entry (ptr, fixed bin(24), ptr, fixed bin(35));
dcl  release_temp_segment_    entry (char(*), ptr, fixed bin(35));
dcl  rtrim                    builtin;
dcl  seg_type                 char(8) aligned	/* segment type (bound or compiled)  */;
dcl  size                     builtin;
dcl  status                   bit(72) aligned;
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  sw                       bit(1)	/* sw set by open. Not used here */;
dcl  sys_info$max_seg_size    ext fixed bin(24)/* 64K or 256K ? */;
dcl  translate                builtin;
dcl  type                     fixed bin(2);
dcl  UPPER_CASE               char(26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  user_info_$homedir       entry (char(*));
dcl  var_msg                  char(j) based (addr (err_msg))	/* variable length overlay for above */;
dcl  word                     bit(36) aligned based	/* to put bits into a word */;

dcl  execute_search_rules_    entry (
			char(32)
,			bit(8) aligned
,			char(168)
,			char(32)
,			fixed bin(2)
,			fixed bin(24)
,			fixed bin(35)
);

dcl  execute_search_rules_$s_r_ptr entry (
			char(32)
,			bit(8) aligned
,			ptr
,			char(168)
,			char(32)
,			fixed bin(2)
,			fixed bin(24)
,			fixed bin(35)
);

dcl  lib_names                (4)char(32)int static options(constant) init (	/* names of libraries */
     "gcos_library_subroutines_",			/* geload l* file */
     "gcos_system_patchfile_",			/* patch file */
     "gcos_system_software_",				/* glib file */
     "gcos_second_software_");						/* slib file */

dcl 1 execution_msg int static aligned,			/* execution report header msg */
    2 part1 char(54) unaligned initial ("EXECUTION REPORT, MULTICS GCOS ENVIRONMENT SIMULATOR "),
    2 date_time char(24) unaligned,
    2 spacing char(1) unaligned initial ("
");						/* newline */


dcl 1 vrsn_msg int static aligned,
    2 part1 char(11) unaligned init ("Version of "),
    2 date_time char(24) unaligned,
    2 spacing char(2) unaligned init ("

");						/* two newlines */


dcl 1 first_record int static aligned,			/* first record on sysout print collector file */
    2 rcw bit(36) init ("000016000374"b3                       ),
						/* length=14, media code=3 (bcd print), report code=74 */
    2 newline_word bit(36) init ("770100000000"b3                       ),
						/* the 7701 (bcd newline) prevents gcos_sys_xlate_ from
						   trying to translate the stuff that follows */
    2 rec1 char(4) init ("rec1"),			/* to verify that this is the sysout header record */
						/* NOTE: the ASCII characters in a record whose media code
						   says BCD is deliberate - not an error */
    2 er_offset fixed bin(24)aligned init (0),		/* a word in which the offset of the execution report in the
						   sysout file will be written, later, by gcos_cc_endjob_ */
    2 jobs_snumb char(5) init ("NONE "),		/* place for gcos_cc_endjob_ to put snumb */
    2 pad1 char(3),					/* to pad out to a full word */
    2 pad2 (9) fixed bin(24)aligned			/* 9 spare words, making a 14-data-word record */;

dcl 1 search_rules	aligned
,     2 number	fixed bin(24)
,     2 names	(21)char(168)aligned
;

dcl  FF                       char(1) static int options(constant)init("");
%page;
%include gcos_fibs;
%page;
dcl 1 obj_info aligned like object_info;
%include object_info;
%page;
%include gcos_restart_control_;
%page;
%include gcos_control_tables_;
%page;
%include gcos_gtss_dcls;
%page;
%include gcos_ext_stat_;
     end gcos_gein_;




		    gcos_gein_pass1_.pl1            09/09/83  1400.3rew 09/09/83  1006.9      417042



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_gein_pass1_: proc;

/*
   This procedure reads thru the input segment, and any $ SELECTed files,
   performing the following functions:

   1) optional canonicalization of ascii segments (conversion of tabs and
   backspaces to the right number of blanks);

   2) copying of $ SELECTed files into the job stream;

   3) scanning for $ EXECUTE and $ 355SIM cards, for later PSW bit 5 setting.

   It writes the job stream file in standard gcos format. This file contains
   no $ SELECT cards; they are discarded when the $ SELECTed files are
   copied into the job stream.

   For each $ control card, the ascii image, as well as the bcd image, is
   written on the job stream file (with a media code of "0110"b), the
   ascii image preceeding the bcd image.

   The $ control cards are written on the execution report at this time.

   Author: T. CASEY APRIL 1973
   Change: T. CASEY NOVEMBER 1973, FEBRUARY 1974, APRIL 1974, JUNE 1974, AUGUST 1974
   Change: R.H. MORRISON OCTOBER 1974
   Change: D. KAYDEN DECEMBER 1974, MARCH 1975
   Change: R.H. MORRISON SEPTEMBER 19, 1975
   Change: M. R. Jordan, August 1977
   Change: Mel Wilson  March 1979 for gtss media codes.
   Change: Dave Ward	06/21/81 Reorganized. Corrected bug tabulation & alter files.
   Change: Ron Barstad  83-08-02  Start numbering jcl with 1 instead of 2!
                                  Fix card count message to look like GCOS
*/
	write_buffer_ptr = addr (write_buffer);
/*	status_ptr = addr (status); */


	ascii_work_area (*) = (4)"040"b3;
	ascii_ptr = addr (ascii_work_area);
	ascii_card_ptr = addrel (ascii_ptr, 1);
	ascii_len = 20;
	ascii_record.rcw = ascii_rcw;
	substr (ascii_report_card, 85, 1) = ascii_newline;

	write_buffer_ptr = addr (write_buffer);
	output_word_ptr = addrel (write_buffer_ptr, 1);
	remaining_output_words = 319;
	write_buffer_ptr -> bcw.bsn = "000001"b3 ;
	write_buffer_ptr -> bcw.length = (18)"0"b;

	save_data.last_execute_act_no,		/* initialize activity numbers */
	     act_no = 0;
	gcos_ext_stat_$userid = "";

/* stack the main input segment for reading */
	stack_level = 0;
	select_path = gcos_ext_stat_$input_segment_path;
	select_path_len = length (gcos_ext_stat_$input_segment_path);

	if gcos_ext_stat_$save_data.gcos then		/* input is gcos file */
	     ascii_sw, canon_sw = "0"b;
	else do;					/* input is ascii segment */
	     if gcos_ext_stat_$save_data.no_canonicalize
	     then canon_sw = "0"b;
	     else canon_sw = "1"b;
	     ascii_sw = "1"b;
	end;

	on condition (cleanup) call pass1_cleanup;	/* before we start allocating things */

	call stack_selected_file;
						/* inputs to stack_selected_file include: select_path,
						   select_path_len, ascii_sw, canon_sw */

/* attach gcos_job_stream_file for writing */
	js_io_sw = "1"b;				/* in case of io error, print path of job stream file */

	js_path = gcos_ext_stat_$save_dir || ">" || gcos_ext_stat_$job_id || ".job_deck";
	call ios_$attach ("gcos_job_stream_", "file_", js_path, "w", status);
	if code ^= 0 then do;
	     err_msg = "from ios_$attach ^a w";
	     goto file_error;
	end;

	call ios_$setsize ("gcos_job_stream_", 36, status);
	if code ^= 0 then do;
setsize_err:   err_msg = "from ios_$setsize ^a";
	     goto file_error;
	end;

	call ios_$seek ("gcos_job_stream_", "last", "first", 0, status); /* truncate, in case it exists */
	if code ^= 0 then do;
	     err_msg = "from ios_$seek ^a";
	     goto file_error;
	end;

	js_io_sw = "0"b;				/* in case of io error, print pathname of current input file */
%page;
/*     Main loop. Read input as long as any remains. */
	do while (stack_level > 0);			/* (stack level becomes zero at eof on main input seg) */

	     dollar_sw, eof_sw, select_card = "0"b;

	     call read_current_file;
						/* outputs of read_current_file include:
						   gcos_ptr,gcos_len,bcd_card_ptr,
						   ascii_ptr,ascii_len,ascii_card_ptr,
						   dollar_sw,eof_sw, card_type */

	     if eof_sw then				/* if end of file, go back to reading the previous file,
						   if there is one */

		call unstack_current_file;

/*   if eof occurred, fall thru to end of read_loop   */
	     else					/* not eof */
process_card:  do;

		card_count = card_count + 1;		/* count cards */
		if stack_level > 1 then selected_card_count = selected_card_count + 1;

		if dollar_sw then do;		/* if this is a dollar card */

		     if card_type = "endcop" then
			if endfc = "" | substr (ascii_card, 16, 2) = endfc then copy_sw = "0"b;


		     if substr (ascii_card, 8, 8) = "selectd" then goto process_select_card; /* even if copy_sw is on */
		     if copy_sw | card_type = "alter" then do;
			dollar_sw = "0"b;		/* pretend its not a dollar card */
			goto end_process_dollar_card;
		     end;

		     if card_type = "data" then do;	/* check for copy option */
			i = index (substr (ascii_card, 18), ",copy");

/* NOTE: Above code does not provide for ",copy"
   as comment on a data card.
*/
			if i ^= 0 then do;
			     copy_sw = "1"b;
			     i = index (substr (ascii_card, 18), ",endfc");
			     if i ^= 0 then endfc = substr (ascii_card, 16, 2);
			     else endfc = "";
			end;
		     end;

		     if card_type = "select" then do;	/* special handling of select cards */
process_select_card:
			select_card = "1"b;
			call interpret_select_card;
						/* outputs from interpret_select_card include:
						   select_path,select_path_len,ascii_sw,canon_sw */

/* stack the selected file for reading */
			call stack_selected_file;
		     end;
		     else do;			/* Process non-select card. */
			if card_type = "userid" then do; /* special handling of  $ USERID cards */
			     gcos_ext_stat_$save_data.userid = "1"b; /* remember it, so prmfiles will be allowed */
			     in_password = "0"b;

			     if gcos_ptr ^= addr (bcd_work_area) then do; /* can't modify the input file */
				overlay_ptr = addr (bcd_work_area); /* get ptr to our work area */
				overlay_ptr -> bcd_card_overlay = gcos_ptr -> bcd_card_overlay;
						/* copy card into it */
				gcos_ptr = overlay_ptr; /* make it our working copy */
				bcd_card_ptr = addrel (gcos_ptr, 1);
			     end;

			     do i = 16 to 72	/* scan card */
				     while (substr (ascii_card, i, 1) ^= " "); /* to end of operand field */
				if in_password then /* wiping out password */
				     substr (ascii_card, i, 1) = "#";
				else
				if substr (ascii_card, i, 1) = "$" then /* or looking for start of password */
				     in_password = "1"b;
			     end;

			     goto job_stream_write;	/* go write it on job stream and execution report */
			end;

			do i = 1 to gcos_control_tables_$totallen /* look up card in table */
				while (card_type ^= substr (gcos_control_tables_$cardtable (i), 1, 6));
			end;
			if i <= gcos_control_tables_$totallen then /* if not implemented, complain */
			     if i > gcos_control_tables_$tablelen then do;
				unimp_sw = "1"b;	/* remember it */
				if ^gcos_ext_stat_$save_data.brief then do; /* print warning unless told to be quiet */
				     err_msg = "unimplemented control card read from ^a:^/" || ascii_card;
				     call com_err_ (0, "gcos", err_msg, current_file.pathname);
				end;
			     end;

/* see if it is an activity card */
			if i >= gcos_control_tables_$exc_offset then
						/* if it's not before the first activity card in the table */
			     if i < gcos_control_tables_$nonact then do; /* and it's not after the last one */
						/* then it must be an activity card */

				act_no = act_no + 1; /* count activity cards */
						/* and complain if too many   */
				if act_no > gcos_ext_stat_$max_activities then
				     call gcos_error_ (
				     gcos_et_$too_many_activs
				     , "Maximum number of activities allowed is ^d."
				     , gcos_ext_stat_$max_activities
				     );

/* locate info table entry for this activity */
				act_ptr = addr (gcos_control_tables_$activity_table); /* start of table */
				act_ptr = addrel (act_ptr, (i-gcos_control_tables_$exc_offset)*3);

/* pick up nondollar canonicalization index for this activity */
				nondollar_canon_index = act_table_entry.canon_index;

/* if execute card, remember to turn on PSW bit 5 for all preceeding activities */

				if card_type = "execut" | card_type = "355sim" then
				     save_data.last_execute_act_no = act_no;

			     end;

			if card_type = "msg1" then	/* print msg1 card in pass1 */
			     call ioa_ ("^a", substr (ascii_card, 8, 73));

job_stream_write:		call write_job_stream (ascii_ptr, ascii_len+1);
		     end;

print_before_etc:					/* come here to print card before reading $ ETC following */


/* TO KEEP $ SELECT CARDS OFF THE EXECUTION REPORT, MOVE THE ABOVE END STATEMEMNT
   DOWN PAST THE CODE THAT WRITES ON THE EXECUTION REPORT */

/* The following logic puts a $ in column 2 of any dollar cards that were
   in $ SELECTed files. For the case of selected bcd files, we must make a
   copy of the bcd image before inserting the $, since otherwise we would
   be attempting to write into the input file itself, and we probably do
   not have write permission on it. */

		     overlay_ptr = gcos_ptr;		/* point to image to be written on execution report */
		     if stack_level > 1 then do;	/* if card is from a select file */
						/* it needs a double dollar sign */
			if gcos_ptr ^= addr (bcd_work_area) then do; /* bcd file. can't write into it */
			     overlay_ptr = addr (bcd_work_area); /* get pointer to our work area */
			     overlay_ptr -> bcd_card_overlay = gcos_ptr -> bcd_card_overlay; /* move card into it */
			     gcos_ptr = overlay_ptr;	/* make it the working copy */
			     bcd_card_ptr = addrel (gcos_ptr, 1);
			end;

			bcd_card.column (2) = bcd_dollar; /* put $ in column 2 */
			substr (ascii_card, 2, 1) = "$"; /* put it in ASCII copy, also */
		     end;

		     if i >= gcos_control_tables_$exc_offset & i < gcos_control_tables_$nonact then act_flag = "a";
		     else act_flag = " ";
		     gcos_ext_stat_$card_num = mod (card_count, 10000);
		     call ioa_$rs ("^a ^1a^a", rtn_string, rtn_string_len, gcos_ext_stat_$card_num, act_flag, substr (ascii_card_record_overlay, 5));
		     if ^gcos_ext_stat_$save_data.debug then ioa_string = translate (ioa_string, UPPER_CASE, LOWER_CASE);
		     call gcos_write_$ascii_ptr (gcos_ext_stat_$er, ioa_string, "11111100"b);

		     if stack_level > 1 then do;	/* if from a select file */
			bcd_card.column (2) = bcd_blank; /* wipe out the extra dollar sign */
			substr (ascii_card, 2, 1) = " "; /* in both copies */
		     end;


/*	END OF WRITE EXECUTION REPORT CODING. MOVE THAT END STATEMENT HERE */

		     if dbs_dollar then		/* FOR DEBUGGING */
			call ioa_ (ascii_card);

end_process_dollar_card: ;
		end;


/*   for all cards (dollar or not) except $ SELECT cards, write the bcd (or binary) image on the job stream file */

		if ^select_card then
		     call write_job_stream (gcos_ptr, gcos_len + 1);

		if dbs_nondollar then		/*      FOR DEBUGGING     */
		     if ^dollar_sw			/* if this was a nondollar card */
		     then call ioa_ (ascii_card);	/* print it */
						/* NOTE that read_current_file checks the dbs_nondollar, and
						   gives us the ascii image of nondollar cards, if we need them */

		if etc_next_sw then goto etc_label;	/* return to read $ ETC card, if one is expected */
						/* NOTE: for etc after select cards, the select_card
						   switch stays on, and the etc card does not get
						   written on the job stream file */


	     end;
	end;
%page;
/*  fall thru when we hit eof on main input segment */
/* see if job ended in $ ENDJOB card */

	if card_type ^= "endjob" then
	     do;					/* generate endjob card if needed */

	     ascii_card = "$      endjob                *** GENERATED BY GCOS ***";

	     gcos_ptr = addr (bcd_work_area);		/* set up to get bcd image of it */
	     bcd_card_ptr = addrel (gcos_ptr, 1);
	     gcos_len = 14;


	     call get_bcd;				/* entry point in read_current_file,
						   just after reading ascii line */

	     goto process_card;			/* in main loop, just after call to read_current_file */

	end;

/* print card count on execution report */


	call ioa_$rsnnl ("^2xTotal card count this job = ^6d", err_path, i, card_count);
						/* length of returned string must be multiple of 4 */
	err_num = i + 1;				/* err_num = index of first vacant char in string */
						/* it must be the first character in a word */

	if selected_card_count > 0 then do;
	     overlay_ptr = addr (addr (err_path) -> char_addrel (i)); /* get ptr to first vacant character */
						/* ptr may not have a char offset -
						   ioa_$rsnnl wants an aligned string */
	     call ioa_$rsnnl ("  (including ^d from selected files)",
		bcd_card_overlay,			/* convenient based char string, for return arg */
		i, selected_card_count);
	     err_num = err_num + i;			/* err_num = index of first vacant char in extended line */
	end;

	unspec (substr (err_path, err_num, 4)) = (4)"012"b3; /* append 4 newlines */
						/* (skip 3 lines after message) */

	err_num = err_num + 3;			/* now, err_num is the exact length of the message */

	call gcos_write_$ptr (gcos_ext_stat_$er, substr (err_path, 1, err_num), "11111100"b);


	if unimp_sw then
	     if ^gcos_ext_stat_$save_data.continue then do;
		if gcos_ext_stat_$save_data.debug then do;
		     query_info.yes_or_no_sw = "1"b;
		     call command_query_ (addr (query_info), answer, "gcos",
			"unimplemented control cards have been found; do you wish to continue?");
		     if answer = "yes" then goto unimp_continue;
		end;
		call gcos_error_ (0, "unimplemented control cards have been used in this job");
	     end;

unimp_continue: ;

/* detach job stream file, see if it grew to a msf, and "open" it for reading
   in the appropriate way */

/*	WRITE EOF RECORD ON IT FIRST */

	call write_job_stream (addr (eof_rcw), 1);

	js_io_sw = "1"b;				/* in case of io error, print pathname of job stream file */

	call ios_$detach ("gcos_job_stream_", "", "", status);
	if code ^= 0 then do;
detach_err:    err_msg = "from ios_$detach ^a";

/* ALL-PURPOSE ERROR MESSAGE PRINTER */

file_error:    if restartsw then do;
		a_code = code;
		return;
	     end;
	     if js_io_sw then err_path = js_path;
	     else err_path = current_file.pathname;
	     call gcos_error_ (code, err_msg, err_path, err_num); /* job will be aborted, and not return */
	end;

restart_join:
	dirname = gcos_ext_stat_$save_dir;
	ename = gcos_ext_stat_$job_id || ".job_deck";
	call hcs_$status_minf (dirname, ename, chase, type, bit_count, code);

	if code ^= 0 then do;
status_minf_err: err_msg = "from hcs_$status_minf ^a";
	     goto file_error;
	end;

	if type = 2				/* if it grew to a msf */
	|dbs_msf_test then do;			/* or we just want to test the msf logic */
	     call ios_$attach ("gcos_job_stream_", "file_", js_path, "r", status);
	     if code ^= 0 then do;
attach_r_err:	err_msg = "from ios_$attach ^a r";
		goto file_error;
	     end;

	     call ios_$setsize ("gcos_job_stream_", 36, status);
	     if code ^= 0 then goto setsize_err;


	     save_data.job_deck = null;		/* tell rest of gcos it's not a segment */
	end;
	else
	if type = 1 then do;			/* or if it's a segment */
						/* initiate it, for faster reading than if it were a msf */

	     call hcs_$initiate_count (dirname, ename, "", bit_count, 0, save_data.job_deck, code);

	     if save_data.job_deck = null then do;
initiate_err:	err_msg = "from hcs_$initiate_count ^a";
		goto file_error;
	     end;

	     save_data.jd_size = divide (bit_count, 36, 24, 0); /* size in words!!! */


	end;
	else do;					/* bad type code */
type_error:    code = 0;
	     err_num = type;
	     err_msg = "bad type code from hcs_$status_minf for ^a: ^d";
	     goto file_error;
	end;
	call gcos_read_card_$read_init (restartsw);
	return;

job_stream_restart: entry (a_code);

	write_buffer_ptr = addr (write_buffer);
/*	status_ptr = addr (status); */
	restartsw = "1"b;
	a_code = 0;
	js_path = gcos_ext_stat_$save_dir || ">" || gcos_ext_stat_$job_id || ".job_deck";
	go to restart_join;

/*  END OF MAIN PROCEDURE. DEBUGGING ENTRIES AND INTERNAL PROCEDURES FOLLOW     */
%page;
%include gcos_canonicalizer;
%page;
interpret_select_card: proc;

dcl  ca                       char (1) aligned;
dcl  path_type                fixed bin(24) init (0);
dcl  prmfl_path               char (250) varying init ("")	/* file string is 233 chars max - use 250 to be safe */;

pick_up_pathname:					/* come here to scan etc cards, too */
	     etc_next_sw = "0"b;			/* off unless we find that path is not complete on this card */

	     i = index (substr (ascii_card, 16, 57), " "); /* find end of pathname */
	     if i = 0 then
		i = 58;				/* it gets decremented below */
	     if i = 1 then do;
		code = 0;
		err_msg = "no file given on select card from ^a:^/" || ascii_card;
		goto file_error;
	     end;

	     i = i - 1;				/* get rid of trailing blank */

/* check for possible continuation onto etc card */

	     ca = substr (ascii_card, i+15, 1);		/* pick up last nonblank character */

	     if ca = ">" then do;
		etc_next_sw = "1"b;
		path_type = 1;			/* must be Multics pathname */
	     end;

	     else
	     if ca = "/" then do;
		etc_next_sw = "1"b;
		path_type = 2;			/* must be GCOS file string */
	     end;

	     prmfl_path = prmfl_path || substr (ascii_card, 16, i); /* pick up path from this card */

/* if path is continued, finish processing this card, and then go get the etc card */

	     if etc_next_sw then do;
		etc_label = select_etc;		/* remember where to return */
		goto print_before_etc;		/* go print on execution report */
select_etc:					/* return here */
		dollar_sw = "0"b;
		call read_current_file;		/* read etc card */
		if dollar_sw then			/* it better be an etc card ... */
		     if card_type = "etc" then goto pick_up_pathname; /* go get rest of path */

/* error if we fall thru - it was not an etc card */
		code = 0;
		err_msg = "expected etc card missing following:^/$      select  " || prmfl_path;
		goto file_error;
	     end;

/* now we have the whole thing - do we know its type (pathname or file string) */

	     if path_type = 0 then do;		/* we don't, so figure it out */
		j = index (prmfl_path, "/");		/* a file string must have at least one "/" */
		if j = 0 then			/* if it doesn't */
		     path_type = 1;			/* it has to be a Multics pathname */
		else do;				/* it has a "/" - could still be a pathname */
		     j = index (prmfl_path, ">");	/* does it have a ">" */
		     if j = 0 then			/* if it doesn't */
			path_type = 2;		/* assume a GCOS file string */
		     else				/* but if it does, Multics is going to interpret it as a
						   separator, even if someone made up a GCOS file string
						   containing a ">" in one of its catalog names or the file
						   name, so we could not process it as a file string anyway */
		     path_type = 1;
		end;
	     end;

	     if path_type = 2 then
		call gcos_interpret_file_string_ (prmfl_path, select_path, select_path_len, ascii_card);
	     else do;
		select_path = prmfl_path;
		select_path_len = length (prmfl_path);
	     end;

/* note that value of i (length of path field on this card) has been preserved */
/* look for -ascii and -nocan in comments field */

	     i = i + 17;				/* move i to first char of comment field */

	     j = index (substr (ascii_card, i), "-ascii"); /* search whole card image after pathname */
						/* i.e. allow -ascii and -no to run past col 72 */
	     if j ^= 0 then ascii_sw = "1"b;
	     else ascii_sw = "0"b;

	     if ascii_sw then do;
		j = index (substr (ascii_card, i), "-no"); /* too many ways to spell "no canonicalize..." */
		if j = 0 then canon_sw = "1"b;
		else canon_sw = "0"b;
	     end;

	     return;
	end interpret_select_card;
%page;
pass1_cleanup: proc;				/* cleanup handler */

	     do i = stack_level to 1 by -1;
		current_pointer = stacked_pointers (i);
		if i <= hbound (stacked_pointers, 1) then /* avoid freeing nonexistent stuff */
		     if current_pointer ^= null then do;
			if current_file.msf then
			     call ios_$detach (current_file.stream, "", "", status);
						/* ignore errors */
			else
			if current_file.init_ptr ^= null then
			     call hcs_$terminate_noname (current_file.init_ptr, code);

/* be sure the pointer points into free area */
			if baseno (current_pointer) = baseno (gcos_ext_stat_$system_free_pointer) then
			     free current_file in (system_free_area);
		     end;
	     end;
	     call ios_$detach ("gcos_job_stream_", "", "", status);
	end pass1_cleanup;
%page;

read_current_file: proc;

						/* come here to read next line,
						   if this one is null (i.e., just a newline) */
	     if current_file.eof then			/* if no more blocks in file */
		if current_file.eob then do;		/* and no more lines in this block */
		     eof_sw = "1"b;			/* tell caller */
		     return;			/* and return */
		end;

	     if current_file.ascii then do;		/* Read an ascii file. */
		if current_file.msf then do;		/* Read an ascii msf. */

/* Ascii file not blocked. Read 1 line into buffer. Element size is 9 bits (one
   ascii character). Delimiter is ascii newline character). Read up to 1280
   characters only because the buffer holds that many. There must be a newline
   long before that, if it is a legal line */

		     call ios_$read (current_file.stream, buffer_ptr, 0, 1280, chars_read, status);

		     if code ^= 0 then do;
read_err:			err_msg = "from ios_$read ^a";
show_where:		err_msg = err_msg || " (after card ^d of job)";
			err_num = card_count;
			goto file_error;
		     end;

		     current_file.eof = substr (unspec (status), 46, 1); /* pick up eof switch from ios */
		end;
		else do;				/* Read an ascii segment: current file is segment */
						/* simulate ios_$read by moving buffer pointer ahead
						   to next line, and setting chars_read to length of it */

		     buffer_ptr = current_file.read_ptr; /* read_ptr was saved last time thru here */
		     chars_read = index (current_segment, ascii_newline); /* current_segment is based on read_ptr, so
						   it includes only lines we haven't read yet */
		     if chars_read = 0		/* if no newline found */
		     |chars_read >1280		/* or if it was a long way off */
		     then chars_read = 1280;		/* ios_$read would have returned 1280 chars */

		     if chars_read > current_file.remaining_len /* but if there are not 1280 chars left */
		     then chars_read = current_file.remaining_len; /* ios_$read would have returned what was left */

		     current_file.remaining_len = current_file.remaining_len - chars_read;
						/* decrement remaining length */

		     if current_file.remaining_len = 0 then current_file.eof = "1"b;
						/* if none left, give eof on NEXT call */

		     current_file.read_ptr = addr (buffer_ptr -> char_addrel (chars_read+1));
						/* do addrel in terms of characters */
						/* to get pointer to next line, for use in next call */

		end;

		if chars_read = 0 then do;
		     code = 0;
		     err_msg = "zero chars read from ^a";
		     goto show_where;
		end;

		if chars_read = 1280 then
		     if substr (char_buffer, 1280, 1) ^= ascii_newline then do;
			code = 0;
			err_msg = "no newline for 1280 characters in ^a";
			goto show_where;
		     end;

		if current_file.needs_canonicalization then
		     call canonicalizer (buffer_ptr, chars_read, ascii_card_ptr, 80);
		else do;
						/* check for long lines, wipe out newline,
						   copy line to output card buffer */
		     if chars_read <= 81 then chars_read = chars_read - 1; /* wipe out newline */
		     else do;			/* line is too long */
			if gcos_ext_stat_$save_data.truncate then /* if user said -truncate */
			     chars_read = 80;	/* just ignore the extras */
			else do;			/* other wise complain */
			     code = 0;
			     err_num = chars_read;
			     err_msg = "line from ^a is too long (^d characters)^/" || char_buffer;
			     if ^gcos_ext_stat_$save_data.continue then /* this is a nonfatal error */
				goto file_error;
			     if ^gcos_ext_stat_$save_data.brief then /* complain unless told to be quiet */
				call ioa_ (err_msg, current_file.pathname, err_num);
			end;
		     end;
		     ascii_card = char_buffer;	/* this statement SHOULD blank out the tail end of ascii_card */
		end;

/* get bcd image of card */

get_bcd:		entry;				/* place to enter if creating an endjob card */

		call gcos_cv_ascii_gebcd_check_ (ascii_card_ptr, 84, bcd_card_ptr, i);
		if i ^= 0 then do;
		     code = 0;
		     err_num = i;
		     err_msg = "line from ^a contains an illegal character in col. ^d^/" || char_buffer;
		     go to file_error;
		end;

		gcos_record.rcw = bcd_rcw;		/* put standard rcw in front of bcd card */
		if substr (ascii_card, 1, 2) = "$" then do;
		     dollar_sw = "1"b;		/* tell caller about dollar card */
		     card_type = substr (ascii_card, 8, 6); /* and give him its type */
		end;
	     end;

/* IF WE READ AN ASCII FILE, CONTROL SKIPS OVER THE read_gcos_file BLOCK FOLLOWING, AND RETURNS */
	     else do;				/* current file is in gcos format */
		if current_file.eob then do;		/* do we need another block?  */
		     if current_file.msf then do;
			call ios_$read (current_file.stream, buffer_ptr, 0, 320, words_read, status);
			if code ^= 0 then goto read_err;
			current_file.eof = substr (unspec (status), 46, 1); /* pick up eof switch from ios_$read */

			if ^current_file.eof then	/* in the unlikely event that the eof switch is NOT on */
			     if words_read < 320 then do; /* when we get a short block */
				code = 0;		/* complain about it */
				err_num = words_read;
				err_msg = "block from ^a contained only ^d words";
				goto file_error;
			     end;
		     end;
		     else do;			/* current file is a segment */
						/* simulate ios_$read by moving pointer */

			buffer_ptr = current_file.read_ptr;
			words_read = min (320, current_file.remaining_len);

			current_file.remaining_len = current_file.remaining_len - words_read;

			if current_file.remaining_len = 0 then current_file.eof = "1"b;
						/* remember to return eof NEXT get block call */

			current_file.read_ptr = addrel (current_file.read_ptr, words_read);
						/* get pointer to next block, for use in next call */
		     end;

/* now get first record in block */

		     current_file.remaining_block_len = fixed (buffer_ptr -> bcw.length);

		     if current_file.remaining_block_len > 319 /* if block length too long (probably garbage) */
		     | current_file.remaining_block_len < 1 /* or too short (probably all zeros) */
		     then do;			/* then complain */
			code = 0;
			err_num = current_file.remaining_block_len;
			err_msg = "illegal block length in bcw from ^a: ^d words";
			goto file_error;
		     end;

		     gcos_ptr, current_file.record_ptr = addrel (buffer_ptr, 1);
		     current_file.eob = "0"b;		/* don't get another block 'til this one used up */
		end;
		else				/* just get next record in current block */
		gcos_ptr, current_file.record_ptr =
		     addrel (current_file.record_ptr, fixed (current_file.record_ptr -> rcw.length) + 1);
						/* move pointer past LAST record, to THIS one;
						   +1 because rcw.length does not include the rcw itself */

/*   COMMON CODE FOR NEW BLOCK OR JUST NEXT RECORD */
		if gcos_ptr -> rcw.eof = bcd_eof then do; /* if this is an eof record */
		     eof_sw = "1"b;			/* return EOF THIS call */
		     current_file.eob, current_file.eof = "1"b; /* in case anyone looks */
		     return;
		end;
		bcd_card_ptr = addrel (gcos_ptr, 1);	/* get pointer to data words in record */

		gcos_len = fixed (gcos_ptr -> rcw.length); /* get length of THIS record */

		current_file.remaining_block_len = current_file.remaining_block_len - gcos_len -1;
						/* -1 since gcos_len does not include the rcw */

		if current_file.remaining_block_len < 0 then do; /* should never happen. program bug if it does */
		     call gcos_error_ (0, "pass1-get next record: block len < 0");
		end;

		if current_file.remaining_block_len = 0 then current_file.eob = "1"b;
						/* remember to get block NEXT call */

		if gcos_ptr -> rcw.media_code = "0010"b
		| gcos_ptr -> rcw.media_code = "0011"b
		| gcos_ptr -> rcw.media_code = "0111"b
		& gcos_ext_stat_$save_data.gtssflag then do;

		     if bcd_card.column (1) = bcd_dollar then /* is it a dollar card ?   */
			if bcd_card.column (2) = bcd_blank then dollar_sw = "1"b;

		     if gcos_len > 14 then do;
			call ioa_ ("gcos_gein_pass1_ bcd card > 14 words; using first 14");
			gcos_len = 14;
		     end;

		     if dollar_sw			/* if this is a dollar card */
		     |dbs_nondollar then do;		/* or we are tracing nondollar cards */
			ascii_card = "";		/* blank out card; gcos_cv_gebcd_ascii_ does not blank it */
			call gcos_cv_gebcd_ascii_ (bcd_card_ptr, min (80, gcos_len*6), ascii_card_ptr);
		     end;

		     if dollar_sw then		/* return type of dollar card */
			card_type = substr (ascii_card, 8, 6);
		end;

		else
		if gcos_ptr -> rcw.media_code = "0001"b then do; /* if binary card */
		     if dbs_nondollar then ascii_card = "..... binary card .....";
						/* give them something to print in trace */
		end;
		else do;				/* media code not bcd or binary */
		     code = 0;
		     err_num = fixed (gcos_ptr -> rcw.media_code); /* show the code */
		     err_msg = "bad media code in record from ^a: ^d";
		     goto file_error;
		end;
	     end;
	     return;
	end read_current_file;
%page;
stack_selected_file: proc;

	     stack_level = stack_level + 1;		/* increment stack level */

	     if stack_level > hbound (stacked_pointers, 1) then do;
		code = 0;
		err_num = stack_level;
		err_msg = "too many nested $ SELECT cards; ^a contains the ^dth";
		goto file_error;
	     end;

	     allocate current_file
		in (system_free_area)
		set (stacked_pointers (stack_level));
	     current_pointer = stacked_pointers (stack_level);
	     current_file.init_ptr = null;
	     current_file.pathname = select_path;
	     current_file.ascii = ascii_sw;
	     current_file.needs_canonicalization = canon_sw;
	     current_file.eof = "0"b;
	     current_file.eob = "1"b;			/* to get a new block on first call to read */

	     if ascii_sw then do;
		gcos_ptr = addr (bcd_work_area);
		bcd_card_ptr = addrel (gcos_ptr, 1);
		gcos_len = 14;
	     end;
						/* gcos file initialization done below:
						   different for seg and msf */
	     call expand_path_ (addr (select_path), select_path_len, addr (dirname), addr (ename), code);
	     if code ^= 0 then do;
		err_msg = "from expand_path_ ^a";
		goto file_error;
	     end;

	     current_file.pathname = rtrim (dirname)||">"||rtrim (ename);
	     call hcs_$status_minf (dirname, ename, chase, type, bit_count, code);
	     if code ^= 0 then goto status_minf_err;

	     if type = 2				/* if it it is a directory (msf, we hope) */
	     | dbs_msf_test then do;			/* or if we want to test msf logic with a small job */

		if bit_count = 0 then do;		/* zero bit count => directory, not msf */
		     code = 0;
		     err_msg = "attempt to $ SELECT a directory: ^a";
		     goto file_error;
		end;

		current_file.msf = "1"b;
		current_file.stream = "select";
						/* convert stack level to characters, and append to "select" */
		i = stack_level;
		if i > 9 then i = divide (i, 10, 24, 0);
		substr (current_file.stream, 7, 1) = substr ("123456789", i, 1);
		if stack_level > 9 then
		     substr (current_file.stream, 8, 1) = substr ("0123456789", 1+mod (stack_level, 10), 1);
						/* this is better than a call to arith_to_char_ ??? */

		call ios_$attach (current_file.stream, "file_", current_file.pathname, "r", status);

		if code ^= 0 then goto attach_r_err;

		buffer_ptr = addr (current_file.buffer);

		if ^ascii_sw then do;
						/* initializations needed for gcos format msf */
		     call ios_$setsize (current_file.stream, 36, status); /* set element size to 36 (one word)
						   and delimiter to "none" (by changing element size without
						   defining a new delimiter */
		     if code ^= 0 then goto setsize_err;
		end;

/* for an ascii file, the file dim defaults are used:
   -	element size = 9 (one ascii character)
   -	delimiter is ascii newline character. */

	     end;
	     else
	     if type = 1 then do;			/* or if it's a segment */

		current_file.msf = "0"b;
		call hcs_$initiate_count (dirname, ename, "", bit_count, 0, current_file.init_ptr, code);
		if current_file.init_ptr = null then goto initiate_err;

		if bit_count = 0 then do;

		     code = 0;
		     err_msg = "zero length file $ SELECTed: ^a";
		     goto file_error;
		end;

		if ascii_sw then do;		/* initializations needed for ascii segments */
		     current_file.init_len = divide (bit_count, 9, 24, 0); /* length in characters */
		end;
		else do;				/* initializations for gcos format segment */
		     current_file.init_len = divide (bit_count, 36, 24, 0); /* length in words */
		end;

/* for both ascii and gcos segments:     */

		current_file.read_ptr = current_file.init_ptr; /* next block = first block */
		current_file.remaining_len = current_file.init_len;
	     end;
	     else goto type_error;			/* if bad type code from hcs_$status_minf */
	     return;
	end stack_selected_file;
%page;
unstack_current_file: proc;

	     if current_file.msf then do;
		call ios_$detach (current_file.stream, "", "", status);
		if code ^= 0 then goto detach_err;
	     end;
	     else do;
		call hcs_$terminate_noname (current_file.init_ptr, code);
		if code ^= 0 then do;
		     err_msg = "from hcs_$terminate_noname ^a";
		     goto file_error;
		end;
	     end;
	     free current_file in (system_free_area);
	     stacked_pointers (stack_level) = null;	/* the free nulled current_pointer only */
	     stack_level = stack_level -1;

	     if stack_level > 0 then do;		/* if there's a file to resume reading */
						/* then set up for reading it, where we left off */
		current_pointer = stacked_pointers (stack_level); /* get pointer to info for it */

		if current_file.ascii then do;	/* re-do some initializations that were not preserved */
		     gcos_ptr = addr (bcd_work_area);
		     bcd_card_ptr = addrel (gcos_ptr, 1);
		     gcos_len = 14;
		end;
		if current_file.msf then buffer_ptr = addr (current_file.buffer);
	     end;
	     return;
	end unstack_current_file;
%page;
write_job_stream: proc (word_ptr, word_count);

dcl  word_count               fixed bin(24);
dcl  word_ptr                 ptr;
	     if word_count > 319 then do;		/* if record bigger than block, complain */
		code = 0;
		err_num = word_count;		/* tell them how big it is */
		err_msg = "record to be written on ^a is too long: ^d words";
		js_io_sw = "1"b;			/* print job stream file in error message */
		goto file_error;
	     end;

	     if word_count > remaining_output_words then do; /* if no room in block for this record */
write_block:					/* write the block */
		call ios_$write ("gcos_job_stream_", write_buffer_ptr, 0, 320, words_written, status);
		if code ^= 0 then do;		/* if any problem, complain */
		     err_msg = "from ios_$write ^a";
		     js_io_sw = "1"b;
		     goto file_error;
		end;

		if words_written ^= 320 then do;	/* if whole block not written, complain */
		     code = 0;
		     err_num = words_written;
		     err_msg = "wrong number of words written on ^a: ^d";
		     js_io_sw = "1"b;
		     goto file_error;
		end;

/* set block to empty */
		remaining_output_words = 319;
		output_word_ptr = addrel (write_buffer_ptr, 1);
		write_buffer_ptr -> bcw.bsn = bit (fixed (fixed (write_buffer_ptr -> bcw.bsn)+1, 18));
						/* bsn = bsn + 1 */
		write_buffer_ptr -> bcw.length = (18)"0"b; /* length = 0 */

	     end;

	     if last_block then return;		/* if we just wrote out the last block, return */

/* append record to block   */
	     write_buffer_ptr -> bcw.length = bit (fixed (fixed (write_buffer_ptr -> bcw.length) + word_count, 18));
						/* length = length + word_count */
	     output_word_ptr -> words = word_ptr -> words; /* move record to write buffer */
	     output_word_ptr = addrel (output_word_ptr, word_count); /* advance pointer in buffer */
	     remaining_output_words = remaining_output_words - word_count;

	     if word_count = 1 then do;		/* one word record can only be an eof record */
		last_block = "1"b;			/* remember to quit after writing */
		goto write_block;			/* and go write the block out */
	     end;
	     return;

dcl  last_block               bit (1) aligned init ("0"b)	/* used only when writing out final block */;
dcl  words                    (word_count) bit (36) based;
	end write_job_stream;
%page;
/*   Variables for gcos_gein_pass1_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  act_ptr                  ptr;
dcl  ascii_card               char (80) aligned based (ascii_card_ptr)   /* overlay for one line from an ascii file (segment or msf)  */;
dcl  ascii_card_ptr           ptr	/* init(addrel(ascii_ptr,1)) */;
dcl  ascii_card_record_overlay char (84) aligned based (ascii_ptr)	/* char overlay for ascii record, for gcos_write_$record */;
dcl  ascii_len                fixed bin(24);
dcl  ascii_ptr                ptr	/* init(addr(ascii_work_area)) */;
dcl  ascii_report_card        char (85) aligned based (ascii_card_ptr)	/* to write on execution report. char 85 is nl */;
dcl  ascii_work_area          (23) bit (36) aligned;
dcl  a_code                   fixed bin(35)	/* used by restart entry */;
dcl  bcd_card_overlay         char (60) aligned based (overlay_ptr)	/* to send 15 word gcos record to gcos_write */;
dcl  bcd_card_ptr             ptr	/* always = addrel(gcos_ptr,1) */;
dcl  bcd_work_area            (15) bit (36) aligned;
dcl  buffer_ptr               ptr;
dcl  chars_read               fixed bin(21);
dcl  char_addrel              (1280) char (1) based	/* to do addrel in terms of characters */;
dcl  char_buffer              char (chars_read) based (buffer_ptr);
dcl  command_query_           ext entry options (variable);
dcl  com_err_                 ext entry options (variable);
dcl  current_pointer          ptr init (null) /* pointer to info structure for file currently being read, (equal to stacked_pointers(stack_level) */;
dcl  current_segment          char (current_file.remaining_len) based (current_file.read_ptr);
dcl  err_msg                  char (200) varying;
dcl  err_num                  fixed bin(24);
dcl  err_path                 char (200);
dcl  expand_path_             ext entry (ptr, fixed bin(24), ptr, ptr, fixed bin(35));
dcl  gcos_cv_ascii_gebcd_check_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_cv_gebcd_ascii_     ext entry (ptr, fixed bin(24), ptr);
dcl  gcos_error_              ext entry options (variable);
dcl  gcos_et_$cc_bad_field    fixed bin(35) ext;
dcl  gcos_et_$too_many_activs fixed bin(35) ext;
dcl  gcos_interpret_file_string_ entry (char (*) varying, char (*), fixed bin(24), char (80) aligned);
dcl  gcos_len                 fixed bin(24);
dcl  gcos_ptr                 ptr	/* NOT always = addr(bcd_work_area) - just sometimes */;
dcl  gcos_read_card_$read_init ext entry (bit (1) aligned);
dcl  gcos_write_$ascii_ptr    entry (ptr, char (*) aligned, bit (8));
dcl  gcos_write_$ptr          ext entry (ptr, char (*) aligned, bit (8));
dcl  gcos_write_$record_ptr   ext entry (ptr, char (*) aligned, bit (8));
dcl  hcs_$initiate_count      ext entry (char (*), char (*), char (*), fixed bin(24), fixed bin(24), ptr, fixed bin(35));
dcl  hcs_$status_minf         ext entry (char (*), char (*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$terminate_noname    ext entry (ptr, fixed bin(35));
dcl  ioa_                     ext entry options (variable);
dcl  ioa_$rs                  ext entry options (variable);
dcl  ioa_$rsnnl               ext entry options (variable);
dcl  output_word_ptr          ptr;
dcl  overlay_ptr              ptr;
dcl  remaining_output_words   fixed bin(24);
dcl  rtrim                    builtin;
dcl  SP                       char(1)static int options(constant)init(" ");
dcl  stacked_pointers         (11) ptr init ((11)null)	/* pointers to info structure for the open files */;
dcl  stack_level              fixed bin(24)	/* number of input files currently "open"  */;
dcl  system_free_area         area based (gcos_ext_stat_$system_free_pointer)	/* area to allocate things in   */;
dcl  unspec                   builtin;
dcl  words_read               fixed bin(21);
dcl  words_written            fixed bin(21);
dcl  write_buffer             (320) bit (36) aligned;
dcl  write_buffer_ptr         ptr ;

dcl  act_flag                 char (1);
dcl  act_no                   fixed bin(24);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  answer                   char (4) varying;
dcl  ascii_backspace          char (1) int static init ("");
dcl  ascii_rcw                bit (36) aligned int static init ("000024000600"b3);
dcl  baseno                   builtin;
dcl  bcd_blank                bit (6) unaligned int static init ("20"b3);
dcl  bcd_dollar               bit (6) unaligned int static init ("53"b3);
dcl  bcd_eof                  bit (6) unaligned int static init ("17"b3);
dcl  bcd_newline_record       bit (72) aligned int static init ("0000010003747701"b3);
dcl  bcd_newline_record_overlay char (8) aligned based (addr (bcd_newline_record));
dcl  bcd_number_sign          bit (6) unaligned int static init ("13"b3);
dcl  bcd_rcw                  bit (36) aligned int static init ("000016000200"b3);
dcl  bit                      builtin;
dcl  bit_count                fixed bin(24);
dcl  card_count               fixed bin(24)init(0);
dcl  card_type                char (6);
dcl  chase                    fixed bin(1) init (1);
dcl  cleanup                  condition;
dcl  dirname                  char (168);
dcl  divide                   builtin;
dcl  ename                    char (32);
dcl  endfc                    char (2)	/* for endfc option of $ data card */;
dcl  eof_rcw                  bit (36) aligned int static init ("000000170000"b3);
dcl  etc_label                label local	/* place to return to after printing card before etc */;
dcl  fixed                    builtin;
dcl  hbound                   builtin;
dcl  i                        fixed bin(24);
dcl  index                    builtin;
dcl  ioa_string               char (rtn_string_len) aligned based (addr (rtn_string));
dcl  j                        fixed bin(24);
dcl  js_path                  char (168);
dcl  length                   builtin;
dcl  LOWER_CASE               char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  max                      builtin;
dcl  min                      builtin;
dcl  mod                      builtin;
dcl  nondollar_canon_index    fixed bin(24) /* says which tabs to use for nondollar cards, in the current activity */;
dcl  null                     builtin;
dcl  rtn_string               char (256) aligned;
dcl  rtn_string_len           fixed bin(24);
dcl  selected_card_count      fixed bin(24)init(0);
dcl  select_path              char (168);
dcl  select_path_len          fixed bin(24);
dcl  substr                   builtin;
dcl  TAB                      char (1) int static init ("	");
dcl  translate                builtin;
dcl  type                     fixed bin(2);
dcl  UPPER_CASE               char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  VALID_FMS_CHARS          char (38) static internal options (constant) init (".-0123456789abcdefghijklmnopqrstuvwxyz");

dcl  ascii_newline            char (1) int static init ("
");

dcl (						/* switches */
     ascii_sw,					/* on if file to be stacked is ascii */
     canon_sw,					/* on if file being stacked needs canonicalization */
     dollar_sw,					/* on if card read is a dollar card */
     eof_sw,					/* on if attempt to read card got end of file */
     select_card,					/* on if this is a select card */
     unimp_sw,					/* on if any unimplemented card is found in the job */
     copy_sw,					/* on if in a $ DATA ,,COPY deck */
     etc_next_sw,					/* on if next card is expected to be etc */
     js_io_sw,					/* on if doing io on job stream file (selects error message) */
     in_password,					/* on while blanking out password on $ USERID card */
     restartsw					/* on if restart entry called */
     ) bit (1) aligned init ("0"b);

dcl 1 current_file aligned based (current_pointer) /* info structure for open input files
						   new copy allocated each time a $ SELECT card is read,
						   and freed when eof occurs on the $ SELECTed file */

,2 stream		char (8)unal
,2 init_ptr	ptr aligned
,2 init_len	fixed bin(24) aligned
,2 read_ptr	ptr aligned
,2 record_ptr	ptr aligned
,2 remaining_len	fixed bin(35) aligned
,2 remaining_block_len	fixed bin(24) aligned
,2 ascii 		bit (1) aligned
,2 msf 		bit (1) aligned
,2 needs_canonicalization bit (1) aligned
,2 eob 		bit (1) aligned
,2 eof 		bit (1) aligned
,2 pathname	char (200) unal
,2 buffer 	(320) bit 	(36) aligned
;

dcl 1 ascii_record aligned based (ascii_ptr),
    2 rcw bit (36) aligned,
    2 data_words (ascii_len) bit (36) aligned;

dcl 1 bcd_card aligned based (bcd_card_ptr),
    2 column (80) bit (6) unaligned;

dcl 1 gcos_record aligned based (gcos_ptr),
    2 rcw bit 	(36) aligned,
    2 data_words (gcos_len) bit (36) aligned;

dcl 1 bcw aligned based,				/* block control word overlay */
    2 bsn bit (18) unaligned,
    2 length bit (18) unaligned;

dcl 1 rcw aligned based,				/* record control word overlay */
    2 length bit (18) unaligned,
    2 eof bit (6) unaligned,
    2 zeroes bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;

dcl 1 act_table_entry based (act_ptr),
    2 fill1 fixed bin(24),
    2 fill2 char (4),
    2 canon_index fixed bin(24);

dcl 1 tabstops	aligned based (addr (gcos_control_tables_$tabstops)),
    2 count	fixed bin(24) aligned,
    2 tab		(0:tabstops.count-1),
      3 stop	(10) fixed bin(24) aligned;
%page;
%include gcos_control_tables_;
%page;
%include query_info;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dbs_names;
%page;
%include gcos_dcl_ios_;
     end gcos_gein_pass1_;




		    gcos_get_bar_.alm               09/09/83  1400.3rew 09/09/83  1006.9        5310



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" declare gcos_get_bar_ entry(bit(36));
" Return BAR register value (left justified, i.e.,
" bar.base[0-8]||bar.bound[9-17]||garbage[18-35])
" Dave Ward 09/19/80
	name	gcos_get_bar_
	segdef	gcos_get_bar_
	even
gcos_get_bar_:
	sbar	ap|2,*	" b(36)<-bar register.
	short_return
	end




		    gcos_get_cc_field_.pl1          09/09/83  1400.3rew 09/09/83  1006.9       81810



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


/* ******************************************************************************************
   ********************************************************************************************
   *
   *
   *
   *	E X T R A C T  F I E L D  F R O M  G E C O S  C O N T R O L  C A R D
   *
   *
   *
   *  This procedure extracts the next field from a gcos control card. It will
   *  also return a switch called "result". If result is 0 then it means that a field is
   *  being returned in "field". If result is 1, it means that a null field  (two
   *  successive commas) was found. If result is a 2, the end of the card has been read.
   *  Getfield allows $ etc cards to be used to extend the operand field of a card.
   *  If a $ ETC card is read, then 1) if gcos_ext_stat_$save_data.write_etc is "1"b then
   *  the bcd image is written on gcos_ext_stat_$etc_filecode (which might
   *  be "d*" for example), and 2) the ascii image will replace the input
   *  argument, card. This works except when it is not decided to write
   *  the card on a file until after the etc card has been read (e.g., a
   *  stranger option on the second card but not the first. We hope this never happens.
   *
   *  The variable gcos_ext_stat_$gf is used for communication between this
   *  procedure and its callers: a value of 0 (set by the caller) indicates
   *  that a new card has been read, and we should start processing it at
   *  column 16; 1 (set by this procedure) indicates that the same card is being processed
   *  as in the previous call, and we should continue processing at the column where
   *  the field returned then ended; 2 (set by this procedure) indicates
   *  that on the previous call, the field returned was the last one on the card,
   *  and so we should return result=2 on this call; 3 indicates that
   *  we should immediately read a $ ETC card and start processing it in column 16.
   *
   *  gcos_cc_file_cards_ sets gf=3 to force reading of a $ ETC card, when the pathname
   *  on the PRMFL card ends in > or / (continuation, but not indicated by a comma).
   *
   *
   *	WRITTEN BY DICK SNYDER AUGUST 27, 1970
   *      MODIFIED BY T.CASEY DECEMBER 1972, OCTOBER 1973, FEBRUARY 1974
   *	MODIFIED BY D.KAYDEN  FEBRUARY 1975
   *	Modified by M. R. Jordan, August 1977
   *
   *
   ********************************************************************************************
   ****************************************************************************************** */



gcos_get_cc_field_: proc (card, field, result);



/* 	D E C L A R A T I O N S					 */


/* 	Parameters						 */


dcl  card char (80) aligned;						/* input card image */
dcl  field char (*);						/* returned field */
dcl  result fixed bin(24);						/* returned result:     */
						/*  0 = ok		 */
						/*  1 = null field		 */
						/*  2 = end of card 	 */


%include gcos_ext_stat_;


/* 	Work Variables					 */


dcl  gcos_error_ entry options (variable);
dcl  code fixed bin(35);
dcl  cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35));
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  param_num fixed bin(24);
dcl  posn fixed bin(24)internal static;						/* variable to remember scan position */
dcl  i fixed bin(24);						/* temp */
dcl  trans_it bit (1) aligned;
dcl  use_params bit (1) aligned;
dcl  gcos_record char (gcos_len) based (gcos_ptr);						/* bcd image of etc card */
dcl  gcos_len fixed bin(24);
dcl  gcos_ptr ptr;
dcl  dollar_sw bit (1) aligned;

/* 	External Entries				 */

dcl  gcos_et_$cc_field_too_long fixed bin(35) ext;
dcl  gcos_write_$record ext entry (char (*), char (*), bit (8));
dcl  gcos_write_to_er_ entry options (variable);
dcl  gcos_read_card_ ext entry (ptr, fixed bin(24), char (80) aligned, bit (1) aligned);

dcl (addr, length, search, substr, translate) builtin;

dcl  LOWER_CASE char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  UPPER_CASE char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

	trans_it = "1"b;				/* make it lower case */
	use_params = "1"b;				/* and allow params */
	goto continue;


asis:	entry (card, field, result);


	trans_it = "0"b;
	use_params = "0"b;
	goto continue;


no_param:	entry (card, field, result);


	trans_it = "1"b;				/* make sure we get lower case */
	use_params = "0"b;				/* and no parameter expansions */
	goto continue;


no_fold:	entry (card, field, result);


	trans_it = "0"b;
	use_params = "1"b;				/* allow parameter expansions */


continue:

	field = " ";				/* init return field */

	if gcos_ext_stat_$gf = 0 then go to start;	/* flag is 0 when new card read */
	if gcos_ext_stat_$gf = 1 then go to next;	/* middle of card ? */
	if gcos_ext_stat_$gf = 2 then do;		/* if 2 then end of card */
endcard:	     result = 2;				/* indicate end of card */
	     return;				/* exeunt */
	end;

/* gf must be 3, as set by last call, when "," was last character on card */

	go to getetc;				/* go get a $ etc card */



/* 	Come here if starting on a new card */


start:	gcos_ext_stat_$gf = 1;			/* indicate middle of card */
	posn = 16;				/* init position offset */
	go to next1;


/*	Come here if called in middle of card			*/


next:	if posn > 72 then go to getetc;

next1:	i = search (substr (card, posn, 73-posn), " ,")-1; /* scan for a field delimiter */

	if i = 0 then				/* if the first char is a delimiter... */
	     if substr (card, posn, 1) = "," then do;	/* and it is a comma... */
		result = 1;			/* return null field indicator */
		posn = posn+1;			/* bump card position */
		return;
	     end;
	     else					/* it must be a space */
	     if posn = 16 then go to endcard;		/* if no commas before delimiter, this is end of card */
	     else go to getetc;			/* otherwise, get $ etc card */

	if i < 0 then do;				/* if no delimiter found... */
	     i = 73-posn;				/* then field is rest of card */
	     gcos_ext_stat_$gf = 2;			/* and this is the last parameter */
	end;
	else if substr (card, posn+i, 1) = " " then	/* if deleimiter was a blank... */
	     gcos_ext_stat_$gf = 2;			/* this is also the last parameter */

	if i > length (field) then do;		/* field on control card is too long */
	     call gcos_write_to_er_ ("Warning:  Control card field ""^a"" is too long.^/^a^2x^a", substr (card, posn, i), gcos_ext_stat_$card_num, card);
	end;

	call Get_Field ();

	posn = posn + i+1;				/* bump card position past field and delimiter */

	if trans_it then field = translate (field, LOWER_CASE, UPPER_CASE);
	result = 0;
	return;					/* done */


/* 	Come here to read $ etc card */


getetc:	call gcos_read_card_ (gcos_ptr, gcos_len, card, dollar_sw); /* get a new card */


	if ^dollar_sw | substr (card, 1, 10) ^= "$      etc" then do; /* print warning if not $ etc */
	     call gcos_write_to_er_ ("Warning:  There appears to be a missing $ ETC card before:^/^a^2x^a", gcos_ext_stat_$card_num, card);
	     gcos_ext_stat_$gf = 2;
	     goto endcard;
	end;

	if gcos_ext_stat_$save_data.write_etc then			/* if caller wants etc cards written on a file */
	     call gcos_write_$record (gcos_ext_stat_$etc_filecode, gcos_record, (8)"0"b);

	posn = 16;				/* reset position indicator */
	go to next1;				/* continue processing */

Get_Field: procedure ();


	     if substr (card, posn, 1) = "#" & use_params then do;
		if i = 1 then do;
		     call gcos_write_to_er_ (
			"Warning:  A parameter replacement may be in error.^/^a^2x^a",
			gcos_ext_stat_$card_num, card);
		     field = "#";
		end;
		else if substr (card, posn+1, 1) = "#" then field = substr (card, posn+1, i-1);
		else do;
		     param_num = cv_dec_check_ (substr (card, posn+1, i-1), code);
		     if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field,
			"Parameter numbers must be decimal constants.  ""^a""^/^a^2x^a", substr (card, posn, i),
			gcos_ext_stat_$card_num, card);
		     if param_num < lbound (save_data.param, 1) | param_num > hbound (save_data.param, 1) then
			call gcos_error_ (gcos_et_$cc_bad_field,
			"Parameter number values must be from ^d to ^d.^/^a^2x^a",
			lbound (save_data.param, 1), hbound (save_data.param, 1),
			gcos_ext_stat_$card_num, card);
		     if length (save_data.param (param_num)) > length (field) then call gcos_write_to_er_ (
			"Warning:  Control card field ""^a"" is too long.^/^a^2x^a",
			save_data.param (param_num), gcos_ext_stat_$card_num, card);
		     field = save_data.param (param_num);
		end;
	     end;
	     else field = substr (card, posn, i);	/* extract field from card */


	     return;


	end Get_Field;


     end gcos_get_cc_field_;




		    gcos_gtss_update_.pl1           09/09/83  1400.3rew 09/09/83  1006.9       20088



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
*  Written ???
*  Modified: R. Barstad  11/16/82  Fix actid format for console messages
*/
gcos_gtss_update_: proc;
dcl (activity_val, status_val) fixed bin(24)parm;


end_gcos_gtss_update:				/* bail_out point for error_processing */
	return;
%page;
status_update: entry (status_val);

	call setup;

	job_status (snumb_index) = status_val;
	return;



new_activity: entry (activity_val, status_val);

	call setup;

	gtss_snumb_xref_.activity_no (snumb_index) = activity_val;
	job_status (snumb_index) = status_val;

	return;
%page;
setup:	proc;

	     if ^initialized then do;
		call user_info_$homedir (home_path);
		call hcs_$initiate (home_path, "gtss_user_state_.gtss", "gtss_user_state_",
		     0, 1, u_state_ptr, c);
		if u_state_ptr = null () then
		     call ioa_ ("Can't access gtss_user_state_, hcs_$initiate returned ^i.", c);
		initialized = "1"b;
	     end;

	     if u_state_ptr = null () then goto end_gcos_gtss_update;

	     if snumb_index = 0 then do;
		do i = 1 to entry_count while (gtss_snumb_xref_.snumb (i) ^= substr (save_data.actid, 1, 5) | job_status (i) = COMPLETE);
		end;

		if i <= entry_count then
		     snumb_index = i;
		else do;
		     call ioa_ ("Can't find snumb ^5a in gtss tables.", substr (save_data.actid, 1, 5));
		     u_state_ptr = null ();
		     goto end_gcos_gtss_update;
		end;
	     end;


dcl  c                        fixed bin(35);
dcl  i                        fixed bin(24);
dcl  initialized              bit int static init ("0"b);

	end setup;
%page;
/*   Variables for gcos_gtss_update_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl null builtin;
dcl  hcs_$initiate            entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35) );
dcl  ioa_                     entry options (variable);
dcl  user_info_$homedir       entry (char(*));
%page;
%include gcos_gtss_dcls;
%page;
%include gcos_ext_stat_;
     end gcos_gtss_update_;




		    gcos_ids2_concur_.pl1           04/09/85  1702.5r w 04/08/85  1131.7      132624




/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_ids2_concur_: proc;

/*
   IDS 2 concurrency control

   Provides for control of access of multiple processes to the same IDS2
   data bases.

   Whenever an IDS file is created, a lock control seg will be created
   for it. When the simulator is asked by the IDS process to allocate
   an IDS file, the simulator gets the lock control seg and locks other
   processes out temporarily with set_lock_. The control seg is examined
   for a valid combination of Gcos access by current processes that will
   allow the requesting process allocation. If allocation is permitted,
   this is noted in the control seg, the seg is unlocked and the IDS
   file is allocated. If allocation is not permitted, the control seg
   is unlocked and the simulator returns to the IDS process with
   "file busy". When a file is deallocated, the control seg
   is locked and the allocation is removed from the record of current
   allocations in the control seg. When an IDS file is released (deleted)
   the control seg is also deleted.

   In a Gcos environment there are basically two allocation types
   to keep track of.
      - one writer with no other readers
      - many readers with no concurrent writer
   Multiple readers are always ok. There are other esoteric types
   of allocation, but these two are the ones implemented.

   The concurrency control is on a file basis rather than per record
   or per entry. The problem of deadlocks is dealt with by the
   application. If it has more that one data base then it has to
   decide what to do if it can't get one of them.

   There are five entry points to this module. They are:

      gcos_ids2_concur_$create_control  Create an ids2 control segment
      gcos_ids2_concur_$delete_control  Delete ids2 control segment
      gcos_ids2_concur_$allocate        Try allocate ids2 data base
      gcos_ids2_concur_$deallocate      remove allocation lock
      gcos_ids2_concur_$have_xid        returns "1"b if file has ids2 ACL

   The parameters and returned status are discussed in the comments
   for each entry.

   Written:  Ron Barstad  10/18/82
*/
%page;
dcl  ids_dir char (168) parameter;                          /* input */
dcl  ids_entry_name char (32) parameter;                    /* input */
dcl  read_access bit (1) parameter;                         /* input: "1"b if have read access */
dcl  write_access bit (1) parameter;                        /* input: "1"b if have write access */
dcl  busy_status bit (1) parameter;                         /* output: "1"b = busy, "0"b = ok, was allocated */
dcl  code fixed bin (35) parameter;                         /* output */

dcl  acl_ptr ptr;
dcl  addr builtin;
dcl  adj_bit_count fixed bin (35);
dcl  adjust_bit_count_ entry (char(168), char(32), bit(1) aligned,
	fixed bin(35), fixed bin(35));
dcl  bit_count fixed bin (24);
dcl  control_seg_ename char (32);
dcl  CONTROL_SEG_SUFFIX char (12) internal static options (constant)
     initial (".CONCURRENCY");
dcl  delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  divide builtin;
dcl  e_code fixed bin(35); /* local version of code */
dcl  error_table_$invalid_lock_reset fixed bin (35) ext static;
dcl  error_table_$lock_not_locked fixed bin (35) ext static;
dcl  error_table_$lock_wait_time_exceeded fixed bin (35) ext static;
dcl  error_table_$locked_by_this_process fixed bin (35) ext static;
dcl  error_table_$segknown fixed bin (35) ext static;
dcl  have_ids_acl bit (1);
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin,
     fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin,
     fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr,
     fixed bin (35));
dcl  hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35));
dcl  lock_control_ptr pointer;
dcl  max builtin;
dcl  MAX_READERS fixed bin(17) internal static options(constant) init(1000);
dcl  null builtin;
dcl  read_index fixed bin (17);
dcl  rtrim builtin;
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));


dcl 01 segment_acl (1) aligned,
    02 access_name char (32), 
    02 modes bit (36),
    02 xmodes bit (36),
    02 acl_status_code fixed bin (35);


dcl 01 lock_control_seg_acl (1) aligned,
    02 access_name char (32),
    02 modes bit (36),
    02 xmodes bit (36),
    02 acl_status_code fixed bin (35);


dcl 01 lock_control_seg aligned based (lock_control_ptr),
    02 seg_lock bit (36),
    02 write_lock bit (36),
    02 number_of_readers fixed bin (24),
    02 read_lock (MAX_READERS) bit(36);
%page;
/*
   create_control

   Create the ids concurrency control segment. The ids data base file has
   just been created or the control segment was not found.

   parameters:

   ids_entry_name     the name of the ids file - input
   ids_dir            the directory of the ids file - input
   code               the error_table_ status - output

   result:

   If all goes well, the seg, <ids_file_abs_path>.CONCURRENCY will be
   created and initialized. An ACL is added to the IDS2 file to give it
   an extrinsic identification for later recognition.
*/
create_control: entry (ids_dir, ids_entry_name, code);

/* add an acl to ids2 file to give it an extrinsic characteristic */
	segment_acl.access_name = "*.*.I";
	segment_acl.modes = R_ACCESS;
	segment_acl.xmodes = "0"b;
	acl_ptr = addr (segment_acl);
	call hcs_$add_acl_entries (ids_dir, ids_entry_name, acl_ptr, 1, code);
	if code ^= 0 then goto create_exit;

/* create the lock control seg */
	control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX;
	call hcs_$make_seg (ids_dir, control_seg_ename, "",
	     RW_ACCESS_BIN, lock_control_ptr, code);
	if code ^= 0 then goto create_exit;

/* add the acl to allow all to read and write */
	lock_control_seg_acl.access_name = "*.*.*";
	lock_control_seg_acl.modes = RW_ACCESS;
	lock_control_seg_acl.xmodes = "0"b;
	acl_ptr = addr (lock_control_seg_acl);
	call hcs_$add_acl_entries (ids_dir, control_seg_ename, acl_ptr, 1, code);
	if code ^= 0 then goto create_exit;
	
/* intialize control seg */
	lock_control_seg.seg_lock = "0"b;
	lock_control_seg.write_lock = "0"b;
	lock_control_seg.number_of_readers = 0;
	lock_control_seg.read_lock (1) = "0"b;
	call terminate_file_(lock_control_ptr, 4*36,
	     TERM_FILE_BC | TERM_FILE_TERM, code);

create_exit:
	return;
%page;
/*
   delete_control

   Delete the ids concurrency control segment. The ids data base file has
   just been deleted.

   parameters:

   ids_entry_name     the name of the ids file - input
   ids_dir            the directory of the ids file - input
   code               the error_table_ status - output

   result:

   If all goes well, the seg, <ids_file_abs_path>.CONCURRENCY will be
   deleted.
*/
delete_control: entry (ids_dir, ids_entry_name, code);

	control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX;
	call delete_$path (ids_dir, control_seg_ename,
	     "100100"b, "gcos", code);

	return;
%page;
/*
   allocate

   Allocate, or attempt to allocate, the given ids file through the
   control seg.

   parameters:

   ids_entry_name     the name of the ids file - input
   ids_dir            the directory of the ids file - input
   read_access        "1"b if have read access - input
   write_access       "1"b if have write access - input
   busy_status        "0"b if ok, "1"b if busy - output
   code               the error_table_ status - output

   algorithm:

   lock the control seg
   if access_type includes write
      then
         if have any readers
            then busy := true
            else
               try write lock
               if ok
                  then busy := false
                  else busy := true
      else {read access}
         if valid write lock exits
            then busy := true
            else
               set another read lock and increment reader count
               busy := false
   unlock the control seg

   result:

   If the file is available for this allocation type, then status ok
   is returned, otherwise status busy is returned.
*/
allocate:	entry (ids_dir, ids_entry_name, read_access, write_access, busy_status, code);

	control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX;
	call hcs_$initiate_count (ids_dir, control_seg_ename,
	     "", bit_count, 0, lock_control_ptr, code);
	if code ^= 0 
	     then if code ^= error_table_$segknown then goto allocate_exit;

/* try to allocate */

	busy_status = "0"b;			/* assume ok */
	call set_lock_$lock (lock_control_seg.seg_lock, 10, code);
	if code ^= 0 
	     then if code ^= error_table_$invalid_lock_reset
	     then if code ^= error_table_$locked_by_this_process then goto allocate_exit;
	if write_access
	then do;					/* write access */
	     if lock_control_seg.number_of_readers >0 then do;
		call clean_out_dead_locks;
		if lock_control_seg.number_of_readers /* still */ > 0 then goto alloc_busy_exit;
	     end;
	     call set_lock_$lock (lock_control_seg.write_lock, 0, code);
	     if (code = 0 | code = error_table_$invalid_lock_reset
		| code = error_table_$locked_by_this_process) then goto alloc_ok_exit;
	     if code = error_table_$lock_wait_time_exceeded then goto alloc_busy_exit;
	     goto alloc_unlock_exit;
	end;
	else do;					/* read access */
	     if lock_control_seg.write_lock then do;
		call set_lock_$lock(lock_control_seg.write_lock, 0, code); /* maybe it's dead, code is irrelevant now */
		call set_lock_$unlock(lock_control_seg.write_lock, code);
		if code ^= 0 then goto alloc_busy_exit; 
		end;
	     do read_index = 1 to MAX_READERS;
		call set_lock_$lock (lock_control_seg.read_lock (read_index), 0, code);
		if code = 0 then do;
		     lock_control_seg.number_of_readers = lock_control_seg.number_of_readers + 1;
		     call adjust_bit_count_(ids_dir, control_seg_ename, "0"b, adj_bit_count, code);
		     if code = 0 then goto alloc_ok_exit;
		     goto alloc_unlock_exit;
		end;
		if (code = error_table_$invalid_lock_reset
		| code = error_table_$locked_by_this_process) then goto alloc_ok_exit;
	     end;
	end;

alloc_busy_exit:
	busy_status = "1"b; /* busy */
alloc_ok_exit:
	code = 0;
alloc_unlock_exit:
	call set_lock_$unlock (lock_control_seg.seg_lock, e_code);
	if code = 0 then code = e_code; /* report earliest error */
allocate_exit:
	return;
%page;
/*
   deallocate

   deallocate the given ids file through the control seg.

   parameters:

   ids_entry_name     the name of the ids file - input
   ids_dir            the directory of the ids file - input
   read_access        "1"b if have read access - input
   write_access       "1"b if have write access - input
   code               the error_table_ status - output

   algorithm:

   lock control seg
   if access_type includes write access
      then
         unlock write lock
      else
         for read_lock := first_read_lock to end of segment
            unlock read lock
            if ok then exit loop
   unlock control seg
   terminate control seg

   result:

   If the process id is in the control seg, then the lock is unlocked.

*/
deallocate: entry (ids_dir, ids_entry_name, read_access, write_access, code);

	control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX;
	call hcs_$initiate_count (ids_dir, control_seg_ename,
	     "", bit_count, 0, lock_control_ptr, code);
	if code ^= 0
	     then if code ^= error_table_$segknown then goto deallocate_exit;

/* try to deallocate */

	call set_lock_$lock (lock_control_seg.seg_lock, 120, code);
	if code ^= 0 
	     then if code ^= error_table_$invalid_lock_reset
	     then if code ^= error_table_$locked_by_this_process then goto deallocate_exit;
	if write_access
	then do;					/* write access */
	     call set_lock_$unlock (lock_control_seg.write_lock, code);
	     if code ^= 0 
		then if code ^= error_table_$lock_not_locked then goto dealloc_unlock_exit;
	end;
	else 					/* read access */
	     do read_index = 1 to (divide(bit_count,36,17)-3);
	        if (lock_control_seg.read_lock(read_index)) then do;
	           call set_lock_$unlock (lock_control_seg.read_lock (read_index), code);
		 if code = 0 then do;
		     lock_control_seg.number_of_readers = lock_control_seg.number_of_readers - 1;
		     call adjust_bit_count_(ids_dir, control_seg_ename, "0"b, adj_bit_count, code);
		     if code ^= 0 then goto dealloc_unlock_exit;
		     bit_count = max(adj_bit_count, 4*36);
		     call hcs_$set_bc(ids_dir, control_seg_ename, bit_count, code);
		     if code ^= 0 then goto dealloc_unlock_exit;
		     goto dealloc_ok_exit;
	           end;
	        end;
	     end;
dealloc_ok_exit:
	code = 0;
dealloc_unlock_exit:
	call set_lock_$unlock(lock_control_seg.seg_lock, e_code);
	if code = 0 then code = e_code; /* report only earliest error */
          call terminate_file_(lock_control_ptr, bit_count, TERM_FILE_TERM,e_code);
	if code = 0 then code = e_code;
deallocate_exit:
	return;
%page;
/*
   have_xid

   returns "1"b if ids_entry_name has an acl (extrinsic id) identifying
   it as an IDS2 file
*/
have_xid:	entry (ids_dir, ids_entry_name, code) returns (bit (1));

	segment_acl.access_name = "*.*.I";
	segment_acl.modes = R_ACCESS;
	segment_acl.xmodes = "0"b;

	have_ids_acl = "0"b;			/* assume not */
	acl_ptr = addr (segment_acl);
	call hcs_$list_acl (ids_dir, ids_entry_name, null (),
	     null (), acl_ptr, 1, code);
	if code = 0 & segment_acl (1).acl_status_code = 0
	then have_ids_acl = "1"b;
	return (have_ids_acl);
%page;
clean_out_dead_locks:
	proc;
/* clean out all dead read processes in lock control seg */
	     do read_index = 1 to MAX_READERS;
		if (lock_control_seg.read_lock(read_index )) then do;
		     call set_lock_$lock (lock_control_seg.read_lock(read_index), 0, code);
		     if code = error_table_$invalid_lock_reset then do;
			lock_control_seg.number_of_readers = lock_control_seg.number_of_readers -1;
			code = 0;
			end;
		     if code = 0 then call set_lock_$unlock (lock_control_seg.read_lock (read_index), code);
		     end;
		end;
	     code = 0; /* code is irrelevant here */
	     return;
	end;
%page;
%include access_mode_values;
%include terminate_file;
     end gcos_ids2_concur_;




		    gcos_incode_.alm                09/09/83  1400.3rew 09/09/83  1006.9       21816



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

"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"
"	P E R F O R M   I N C O D E   T R A N S L A T I O N
"
"
"  This routine will perform incode translation for a string of bcd
"  characters.  It takes three parameters. Parameter 1 is a pointer to a
"  bcd string. Parameter 2 is the length of that string (number of bcd
"  characters).  Parameter 3 is a pointer to a receiving field for the
"  incoded output.
"
"
"	WRITTEN BY D. KAYDEN JANUARY 1975
"
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
	name	gcos_incode_
	entry	gcos_incode_
gcos_incode_:
	eppbp	ap|2,*		bp->input data
	eppbp	bp|0,*
	lda	ap|4,*		a = char count
	eppbb	ap|6,*		bb->output buffer
	eppbb	bb|0,*
	ldq	<gcos_ext_stat_>|[incode]  q = incode type
	qls	4		multiply by 16
	mvt	(pr,rl),(pr,rl)
	desc6a	bp|0,al
	desc6a	bb|0,al
	arg	ibmf-16,ql
	short_return

ibmf:	oct	000001002003
	oct	004005006007
	oct	010011012075
	oct	057013016017
	oct	020021022023
	oct	024025026027
	oct	030031060033
	oct	055035036037
	oct	040041042043
	oct	044045046047
	oct	050051052053
	oct	054055056057
	oct	060061062063
	oct	064065066067
	oct	070071072073
	oct	035075076077

ibmc:	oct	000001002003
	oct	004005006007
	oct	010011012075
	oct	076013016017
	oct	020021022023
	oct	024025026027
	oct	030031060033
	oct	055035036037
	oct	040041042043
	oct	044045046047
	oct	050051052053
	oct	054055056057
	oct	060061062063
	oct	064065066067
	oct	070071072073
	oct	035075076077

ibmel:	oct	000001002003
	oct	004005006007
	oct	010011015013
	oct	014057075076
	oct	020021022023
	oct	024025026027
	oct	030031032033
	oct	036035060037
	oct	040041042043
	oct	044045046047
	oct	050051052053
	oct	054055056057
	oct	060061062063
	oct	064065066067
	oct	070071020073
	oct	074020016017

	end




		    gcos_interpret_file_string_.pl1 09/09/83  1400.3rew 09/09/83  1006.9       54765



/* *************************************************************
   *                                                           *
   * Copyright, (C) Honeywell Information Systems Inc., 1982   *
   *                                                           *
   * Copyright (c) 1974 by Honeywell Information Systems, Inc. *
   *                                                           *
   ************************************************************* */


/* **************************************************************************
   **************************************************************************
   *
   *
   * This routine receives gcos_cfdesc and returns the corresponding multics_path
   * and path_len.  gcos_cfdesc is the gcos catalog/file description containing
   * slashes and dollar signs.  multics_path is the corresponding Multics absolute pathname.
   * path_len is the length of the returned multics_path.
   *
   *  Written by G. Novak Feb. 21,1974
   *  MODIFIED BY R.H. MORRISON ON APRIL 15, 1974
   *  MODIFIED BY T. CASEY ON MAY 8, 1974
   *  MODIFIED BY R.H. MORRISON ON JULY 18,1975
   * Modified by M. R. Jordan, September 1976
   * Modified:  Ron Barstad  83-08-02  Fixed spelling of "pathname" in ioa_
   *
   *
   **************************************************************************
   *********************************************************************** */




gcos_interpret_file_string_: procedure (gcos_cfdesc, a_multics_path, path_len, card); ;

dcl  LOWER_CASE char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  card char (80);
dcl  cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35));
dcl  gcos_error_ entry options (variable);
dcl  UPPER_CASE char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  a_multics_path char (*);
dcl  addr builtin;
dcl  cat_len fixed bin(24);
dcl  cat_start fixed bin(24);
dcl  cfname char (80) varying;
dcl  code fixed bin(35);
dcl  dollar fixed bin(24);
dcl  err_msg char (150);
dcl  err_msg_len fixed bin(24);
dcl  gcos_cfdesc char (*) varying;
dcl  gcos_et_$cc_bad_field fixed bin(35) ext;
dcl  gcos_write_$ascii_ptr entry (ptr, char (*), bit (8));
dcl  gcos_write_to_er_ entry options (variable);
dcl  i fixed bin(24);
dcl  index builtin;
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  ioa_$rs entry options (variable);
dcl  length builtin;
dcl  message char (34) static internal init ("invalid GCOS catalog/file string") options (constant);
dcl  multics_path char (168) varying;
dcl  param_num fixed bin(24);
dcl  path_len fixed bin(24);
dcl  slash fixed bin(24);
dcl  stop bit (1);
dcl  substr builtin;
dcl  var_err_msg char (err_msg_len) based (addr (err_msg)) ;

/*  Initialize and report the GCOS catalog/file description.  */


	call ioa_$rs ("Comment: GCOS catalog/file string is ^a", err_msg, err_msg_len, gcos_cfdesc) ;
	if gcos_ext_stat_$save_data.long then call ioa_$nnl ("^a", var_err_msg) ;
	call gcos_write_$ascii_ptr (gcos_ext_stat_$er, var_err_msg, "11111100"b) ;


/*  Get the pathname prefix and, if necessary, the UMC name.  */


	multics_path = save_data.pathname_prefix ;
	stop = "0"b ;
	i = 1 ;
	call Get_Name_Component () ;
	if ^save_data.skip_umc then do ;
	     multics_path = multics_path || ">" || cfname ;
	end ;


/*  Process the remaining catalog(s)/file(s).  */


	do while (^stop) ;
	     call Get_Name_Component () ;
	     multics_path = multics_path || ">" || cfname ;
	end ;


/*  Report the absolute Multics pathname developed.  */


	call ioa_$rs ("Comment: Multics pathname is ^a", err_msg, err_msg_len, multics_path) ;
	if gcos_ext_stat_$save_data.long then call ioa_$nnl ("^a", var_err_msg) ;
	call gcos_write_$ascii_ptr (gcos_ext_stat_$er, var_err_msg, "11111100"b) ;


/*  Prepare to return by setting the return values.  */


	a_multics_path = multics_path ;
	path_len = length (multics_path) ;


exit:

	return ;

Get_Name_Component: procedure () ;


	     cat_start = i ;


	     slash = index (substr (gcos_cfdesc, i), "/") ;
	     dollar = index (substr (gcos_cfdesc, i), "$") ;


	     if slash = 0 then do ;
		stop = "1"b ;
		slash = length (gcos_cfdesc)+2-i ;
	     end ;
	     if dollar = 0 then dollar = slash ;


	     if dollar < slash then cat_len = dollar-1 ;
	     else cat_len = slash-1 ;
	     if cat_len = 0 then call gcos_error_ (gcos_et_$cc_bad_field,
		"Catalog/filename element is null.^/^a^2x^a",
		gcos_ext_stat_$card_num, card);


	     i = i+slash ;


	     if substr (gcos_cfdesc, cat_start, 1) = "#" then do;
		if cat_len = 1 then cfname = "#";
		else if substr (gcos_cfdesc, cat_start+1, 1) = "#" then cfname = substr (gcos_cfdesc, cat_start+1, cat_len-1);
		else do;
		     param_num = cv_dec_check_ (substr (gcos_cfdesc, cat_start+1, cat_len-1), code);
		     if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field,
			"Parameter numbers must be decimal constants.  ""^a""^/^a^2x^a", substr (gcos_cfdesc, cat_start, cat_len),
			gcos_ext_stat_$card_num, card);
		     if param_num < lbound (save_data.param, 1) | param_num > hbound (save_data.param, 1) then
			call gcos_error_ (gcos_et_$cc_bad_field,
			"Parameter number values must be from ^d to ^d.^/^a^2x^a",
			lbound (save_data.param, 1), hbound (save_data.param, 1),
			gcos_ext_stat_$card_num, card);
		     cfname = save_data.param (param_num);
		end;
	     end;
	     else cfname = substr (gcos_cfdesc, cat_start, cat_len);


	     if length (cfname) > 12 then call gcos_error_ (gcos_et_$cc_bad_field,
		"Catalog/filename element is longer than 12 characters.  ""^a""^/^a^2x^a",
		cfname, gcos_ext_stat_$card_num, card);
	     cfname = translate (cfname, LOWER_CASE, UPPER_CASE);
	     if verify (cfname, "0123456789abcdefghijklmnopqrstuvwxyz.-") ^= 0 then
		call gcos_error_ (gcos_et_$cc_bad_field,
		"Catalog/filename element contains illegal character.  ""^a""^/^a^2x^a",
		cfname, gcos_ext_stat_$card_num, card);


	     return ;


	end Get_Name_Component ;

%include	gcos_ext_stat_ ;



     end gcos_interpret_file_string_ ;




		    gcos_open_file_.pl1             09/09/83  1400.3rew 09/09/83  1007.1       58248



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_open_file_: proc (filecode, lud, newfib, present);

/*
   This procedure will initialize a fib (file info block) and
   return a pointer to it. If called with a non-null lud
   (logical unit designator), a search is made for an existing
   fib with a matching lud. If a match is found, a pointer to
   that lud is returned and the "present" argument is set on.

   If called with a file code, an entry is made in the file
   code table pointing to the fib. If the file code is already
   entered in the file code table, it is removed.

   The sysout entry to this routine places the requested file
   code in a file code table entry, sets the sysout and dac
   flags, but does not allocate a fib.

   INPUT PARAMETERS:
   =  file_code 2 character file code of file to be opened.
   =  lud       2 or 3 character logical unit designator.

   OUTPUT PARAMETERS:
   =  fibptr    pointer to fib assigned to opened file.
   =  present   set to 1 if file was already open.

   Author: DICK SNYDER AUGUST 7, 1970
   Change: T. CASEY JULY 1973, FEBRUARY 1974
   Change: D. KAYDEN  MAY 1974, MARCH 1975
   Change: M. R. Jordan, October 1977
   Change: Mel Wilson, November 1979 for gtss compatibility
   Change: Dave Ward	09/13/81 structured.
*/
dcl  dac_sw                   bit(1)parm	/* dac/sysout switch */;
dcl  filecode                 char(*)parm	/* file code of file to be opened */;
dcl  lud                      char(*)parm	/* logical unit designator of file */;
dcl  newfib                   ptr parm		/* returns pointer to found fib */;
dcl  present                  bit(1)parm	/* set to 1 if file open already */;

	sysout_call = "0"b;
	if filecode = "" then goto no_fc;
	goto common;

sysout:	entry (filecode, dac_sw);

	sysout_call = "1"b;

common:	;
	do fctno = 1 to hbound (save_data.fibs, 1);	/* search for matching file code */
	     if fct.filecode (fctno) = filecode then go to fc_hit;
	end;

	do fctno = 1 to hbound (save_data.fibs, 1);	/* no match on file codes */
	     if fct.filecode (fctno) = "" then go to set_fc; /* find an unused entry */
	end;

	call gcos_error_ (gcos_et_$no_free_fibs);	/* bad news */

fc_hit:	;
	if fct.sysout (fctno) then go to set_fc;	/* check for sysout file code */
	fibptr = fct.fibptr (fctno);			/* save pointer to fib */
	fct.fibptr (fctno) = null ();			/* detach file code from fib */

	do i = 1 to hbound (save_data.fibs, 1);		/* see if this fib has any file codes left */
	     if fct.filecode (i) ^= "" & ^fct.sysout (i) then
		if fct.fibptr (i) = fibptr then go to set_fc; /* yes - leave file alone */
	end;

	if ^fib.gein & fib.attached then do;		/* if file was saved from a previous activity, */
	     fib.disp = "10"b;			/* then restore its disposition and save it */
	     go to set_fc;
	end;

	if fib.attached then
	     call gcos_close_file_ (fibptr);		/* detach if attached */
	else fib.used = "0"b;

set_fc:	;
	fct.filecode (fctno) = filecode;
	if sysout_call then do;
	     fct.sysout (fctno) = "1"b;		/* set sysout flag */
	     fct.dac (fctno) = dac_sw;		/* set dac flag from parameter */
	     return;				/* done */
	end;

	fct.sysout (fctno) = "0"b;

no_fc:	;
	if lud ^= "" then do;
	     asc_lud = lud;				/* conversion routine requires aligned string */
	     call gcos_cv_ascii_gebcd_ (addr (asc_lud), length (asc_lud), addr (bcd_lud), i);
	end;

	do i = 1 to hbound (save_data.fibs, 1);
	     fibptr = addr (save_data.fibs (i));
	     if bcd_lud ^= "0"b & fib.used then

		if fib.plud = bcd_lud then do;	/* fib with matching lud found */
		     newfib = fibptr;		/* set return pointer to this fib */
		     present = "1"b;		/* indicate not a new file */
		     go to lud_hit;
		end;

	     if ^fib.used & sw then do;		/* find an available fib */
		sw = "0"b;			/* yes. set sw to indicate available fib found */
		newfib = fibptr;			/* set return pointer to this fib */
	     end;					/* continue search */
	end;

	if sw then call gcos_error_ (gcos_et_$no_free_fibs); /* fatal error if no available fib */

	present = "0"b;				/* indicate fib newly opened */
	fibptr = newfib;				/* reset fib pointer to found fib */
	string (fib.indicators) = "0"b;		/* clear fib.indicators */
	fib.disp = "01"b;				/* default disp release */
	fib.used = "1"b;				/* set fib used */
	fib.pathnm = " ";				/* blank pathname */
	fib.unique_file_id = "0"b;			/* multics unique segment id for multi-user control */
	fib.command_index = 0;			/* init for mme_inos_ */
	fib.buffer = null ();			/* set pointer to null */
	fib.size = 0;				/* init file size */
	fib.init_size = 0;
	fib.current = 0;				/* set file in rewound position */
	fib.slud = "0"b;				/* clear log.unit desigs */
	fib.plud = bcd_lud;
	fib.stream = " ";				/* blank attach name */

lud_hit:	;
	if filecode ^= "" then
	     fct.fibptr (fctno) = fibptr;		/* set fib pointer in file code entry */

	if dbs_open_file then do;
	     if lud = "" then
		call ioa_ ("gcos_open_file_ fc=^a, fibnewfib=^p", filecode, newfib);
	     else
	     call ioa_ ("gcos_open_file_ fc=^a, fibnewfib=^p, lud=^a ^[^;not^] present", filecode, newfib, lud, present);
	end;

	return;					/* all done */
%page;
/*   Variables for gcos_open_file_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  asc_lud                  char(3) aligned;
dcl  bcd_lud                  bit(18) aligned init ("0"b);
dcl  fctno                    fixed bin(17);
dcl  gcos_close_file_         ext entry (pointer);
dcl  gcos_cv_ascii_gebcd_     ext entry (ptr, fixed bin(24), ptr, fixed bin);
dcl  gcos_error_              entry options (variable);
dcl  gcos_et_$no_free_fibs    fixed bin(35) ext;
dcl  hbound                   builtin;
dcl  i                        fixed bin(17);
dcl  ioa_                     ext entry options (variable);
dcl  length                   builtin;
dcl  null                     builtin;
dcl  size                     builtin;
dcl  string                   builtin;
dcl  sw                       bit(1) initial ("1"b)	/* switch used in fib search */;
dcl  sysout_call              bit(1);
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dbs_names;
     end gcos_open_file_;




		    gcos_print_call_.pl1            09/09/83  1400.3rew 09/09/83  1007.1       52101



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_print_call_: proc;

/* Print the input arguments (strings) on error_output
   stream with the following considerations:
   strings containing "|" are justified
   and information after the "|" are folded under this
   character, e.g.,
   abc | stuff xxx
   d   | more stuff

   Author: Dave Ward 06/05/81 (from print_calling_sequence_ 02/02/81).
*/
	ll = get_line_length_$stream ("error_output", code);
	call cu_$arg_count (na, code);
	mm = 0;					/* Set initial max m. */

/* Obtain parameter information. */
	do i = 1 to na while (i <= hbound (a, 1));
	     call cu_$arg_ptr (i, p (i), l (i), code);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gcos_print_call_"
		     , "Arg ^i"
		     , i
		     );
		return;
	     end;

/* Measure for | location. */
	     m (i) = index (argi, "|");
	     mm = max (mm, m (i));
	end;

/* Print the strings. */
	do i = 1 to (i-1);
	     if (m (i) = 0) | (mm > (ll-5)) then do;	/* Either no |, or | too far to the right (a Reagen bar). */
		if length (argi) <= ll then		/* Not more than ll characters to print. */
		     call out (argi);
		else				/* More than ll characters to print. */
		call fold (argi);
	     end;
	     else do;				/* String contains |. */
		call out (substr (argi, 1, m (i)-1));
		if m (i)<mm then
		     call out (substr ((100)" ", 1, mm-m (i)));
		call out (" |");
		if l (i)>m (i) then			/* There are characters after the |. */
		     call pr_rest (after_bar);
	     end;
	     call out (NL);
	end;
fail:	;
	return;
%page;
fold:	proc (s);

/* Output ll characters, break on space, fold remainder.
*/
dcl  s                        char(*)parm;
	     if length (s) <= ll then do;
		call out (s);
		return;
	     end;
	     k = search (reverse (substr (s, 1, ll)), " ,");
	     if k>0 then do;
		l = length (rtrim (substr (s, 1, ll-k+1)));
		if l>0 then do;
		     call out (substr (s, 1, l));
		     call out (NL);
		end;
		l = ll - (k-1) + 1;			/* Location 1st character of remainder. */
		if (length (s)-l+1)>ll then
		     call fold (substr (s, l));
		else do;				/* Right justify final piece. */
		     call out (substr ((100)" ", 1, ll- (length (s)-l+1)));
		     call out (substr (s, l));
		end;
		return;
	     end;

/* No blanks in string. */
	     call out (substr (s, 1, ll));
	     call out (NL);
	     call fold (substr (s, ll+1));
	     return;
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
	end fold;
%page;
out:	proc (s);

/* Print string "s". */
dcl  s                        char(*)parm;
	     call iox_$put_chars (
		iox_$error_output
		, addr (s)
		, length (s)
		, code
		);
	     if code ^= 0 then do;
		call com_err_ (
		     code
		     , "gcos_print_call_"
		     , "String ""^a"""
		     , s
		     );
		goto fail;
	     end;
	     return;
	end out;
%page;
pr_rest:	proc (s);

/* Print the string "s" as the rest of the string
   after |.
*/
dcl  s                        char(*)parm;
	     call out (" ");
	     l = ll-mm-2;				/* Print characters available. */
	     pl = length (s);
	     if pl <= l then do;			/* Not more than ll characters to print. */
		call out (s);
		return;
	     end;

/* More than ll characters,
   print up to ll characters on this line
   and fold the remainder.
*/
	     k = search (reverse (substr (s, 1, l)), " ,");
	     if k = 0 then do;			/* No space or comma found. */
		call out (substr (s, 1, l));
		fc = l+1;
		ln = pl-l;
		if ln<1 then return;
	     end;
	     else do;				/* Print up to space. */
		call out (rtrim (substr (s, 1, l-k+1)));
		fc = l-k+2;
		ln = pl-fc+1;
		if ln<1 then return;
	     end;
	     call out (NL);
	     call out (substr ((100)" ", 1, mm-1));
	     call out (" |");
	     call pr_rest (substr (s, fc, ln));
	     return;
dcl  fc                       fixed bin(24);
dcl  k                        fixed bin(24);
dcl  l                        fixed bin(24);
dcl  ln                       fixed bin(24);
dcl  pl                       fixed bin(24);
	end pr_rest;
%page;
/*   Variables for gcos_print_call_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  after_bar                char(l(i)-m(i))unal based(addr(ari(m(i)+1)))	/* i-th argument, characters after |. */;
dcl  argi                     char(l(i))unal based(p(i))	/* i-th argument, character string. */;
dcl  ari                      (l(i))char(1)unal based(p(i))	/* i-th argument, array of characters. */;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr              entry (fixed bin(24), ptr, fixed bin(21), fixed bin(35));
dcl  get_line_length_$stream  entry (char(*), fixed bin(35)) returns(fixed bin);
dcl  hbound                   builtin;
dcl  i                        fixed bin(24);
dcl  index                    builtin;
dcl  iox_$error_output        ptr ext static;
dcl  iox_$put_chars           entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  ll                       fixed bin(24);
dcl  max                      builtin;
dcl  min                      builtin;
dcl  mm                       fixed bin(24);
dcl  na                       fixed bin(17);
dcl  reverse                  builtin;
dcl  search                   builtin;
dcl  substr                   builtin;

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

dcl 1 a	(64)aligned
,     2 p ptr
,     2 l fixed bin(21)
,     2 m fixed bin
;
     end gcos_print_call_;




		    gcos_process_mme_.pl1           09/09/83  1400.3rew 09/09/83  1007.1      165834



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_process_mme_: proc (mcp, fault_name, dummy1, dummy2, continue);

/*

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

   The   faulting   instruction  (MME1)  is  located  in  the  machine
   conditions,  and  is  examined  for  request  type (as given in the
   computed  address by a number from 1 to 44).  The type is looked up
   in  a table and the appropriate MME handler is called with a ptr to
   the  machine  conditions.   When  the  MME  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  MME,  and  then it will return, causing the modified
   machine  conditions  to  be restored and the execution of the slave
   program to be resumed.

*/
%page;
/*

*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* HISTORY *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

   Author: DICK SNYDER	OCT 1,1970
   Change: T. CASEY		FEB 1974,
			AUG 1974
   Change: D. KAYDEN	MAR 1975
   Change: T. CASEY		AUG 1975
   Change: M. R. Jordan	JAN 1977,
			JUL 1977
   Change: A. N. Kepner	MAR 1978	To allow courtesy call I/O  within
				cc routines
   Change: Dave Ward	06/09/81	Reorganized. Debug entries updated.
   Change: Dave Ward	09/09/81	Replaced use of ALM vector
				(gcos_call_mme_processor_) with
				"goto mp."
   Change: Scott C. Akers	11/28/81	Obtain MME number from even instruction
				in all cases.
   Change: Ron Barstad        83-08-04  Added MMEs 41-44 for 4js3

*/
%page;
/*
   This procedure is called as a static handler for the condition MME1
   in  the  current  ring.   After  making sure the MME is in the GCOS
   segment  and  initializing  some  data items we can get down to the
   business at hand - processing the MME.
*/

	debugsw = dbs_stop_mme | dbs_trace_mme | watchsw ;
	scup = addr (mc.scu);
	if substr (baseno (gcos_ext_stat_$gcos_slave_area_seg), 4, 15) ^= scu.ppr.psr then do;
	     if gcos_ext_stat_$sig_ptr ^= null () then
		call cu_$ptr_call (gcos_ext_stat_$sig_ptr, mcp, fault_name, dummy1, dummy2, continue);
	     return;
	end;
	else continue = "0"b;

	unspec (gcos_ext_stat_$mc) = unspec (mc);
%page;
	mme_number = even_instruction.MME_NO;
%page;
/*
   Check  to see if the MME number is within acceptable range.  If not
   abort the user.
*/

	if mme_number < lbound (MME_NAME, 1) | mme_number > hbound (MME_NAME, 1) then
	     call gcos_mme_bort_$system (
	     gcos_et_$bad_mme_addr
	     , "^i is not a valid MME number (^i to ^i)."
	     , mme_number
	     , lbound (MME_NAME, 1)
	     , hbound (MME_NAME, 1)
	     );

/*
   If  we  are within a courtesy call, verify that this MME is a valid
   one for courtesy calls.  If not, report the system detected error.
*/

	if gcos_ext_stat_$save_data.cc then
	     if ^mme_table (mme_number) then
		call gcos_mme_bort_$system (
		gcos_et_$bad_mme_in_cc
		, "MME GE^a is not allowed within a courtesy call."
		, MME_NAME (mme_number)
		);

/*
   Now  that  we  are  fairly certain that this is a valid MME (in the
   right range, anyway), we will initialize the increment and call the
   MME  processor  routine.   If  the  debug  switch  is  on,  tracing
   information will be displayed.

   If  this  is  not a supported MME, the entry gcos_mme_bort_$not_imp
   will be called to report the error to the user.
*/
	increment = 0;
	if debugsw then call debug_1 ();

/*
   Now  call  the appropriate MME processor via the transfer vector in
   gcos_call_mme_processor_.
*/
	goto mp (mme_number);

mp(11):; /** MME GEFILS 11 **/
mp(16):; /** MME GESPEC 16 **/
mp(25):; /** MME GEROLL 25 **/
mp(29):; /** MME GEIDSE 29 **/
mp(30):; /** MME .EMM   30 **/
mp(35):; /** MME GENEWS 35 **/
mp(36):; /** MME GESNUM 36 **/
mp(38):; /** MME GESECR 38 **/
mp(39):; /** MME GEXLIT 39 **/
mp(40):; /** MME xxxxxx 40 **/
mp(41):; /** MME xxxxxx 41 **/
mp(42):; /** MME xxxxxx 42 **/
mp(43):; /** MME GMODES 43 **/
mp(44):; /** MME GMODER 44 **/
	call gcos_mme_bort_$not_imp (mcp, increment, mme_number);
	goto return_from_mp;

mp( 1):; /** MME GEINOS  1 **/
	call gcos_mme_inos_$gcos_mme_inos_ (mcp, increment);
	goto return_from_mp;

mp( 2):; /** MME GEROAD  2 **/
	goto return_from_mp;

mp( 3):; /** MME GEFADD  3 **/
	call gcos_mme_fadd_$gcos_mme_fadd_ (mcp, increment);
	goto return_from_mp;

mp( 4):; /** MME GERELS  4 **/
	call gcos_mme_rels_$gcos_mme_rels_ (mcp, increment);
	goto return_from_mp;

mp( 5):; /** MME GESNAP  5 **/
	call gcos_mme_snap_$gcos_mme_snap_ (mcp, increment);
	goto return_from_mp;

mp( 6):; /** MME GELAPS  6 **/
	call gcos_mme_laps_$gcos_mme_laps_ (mcp, increment);
	goto return_from_mp;

mp( 7):; /** MME GEFINI  7 **/
	call gcos_mme_fini_$gcos_mme_fini_ (mcp, increment);
	goto return_from_mp;

mp( 8):; /** MME GEBORT  8 **/
	call gcos_mme_bort_$gcos_mme_bort_ (mcp, increment);
	goto return_from_mp;

mp( 9):; /** MME GEMORE  9 **/
	call gcos_mme_more_$gcos_mme_more_ (mcp, increment);
	goto return_from_mp;

mp(10):; /** MME GEFCON 10 **/
	call gcos_mme_fcon_$gcos_mme_fcon_ (mcp, increment);
	goto return_from_mp;

mp(12):; /** MME GESETS 12 **/
	call gcos_mme_sets_$gcos_mme_sets_ (mcp, increment);
	goto return_from_mp;

mp(13):; /** MME GERETS 13 **/
	call gcos_mme_rets_$gcos_mme_rets_ (mcp, increment);
	goto return_from_mp;

mp(14):; /** MME GEENDC 14 **/
	call gcos_mme_inos_$mme_endc (mcp, increment);
	goto return_from_mp;

mp(15):; /** MME GERELC 15 **/
	goto return_from_mp;

mp(17):; /** MME GETIME 17 **/
	call gcos_mme_time_$gcos_mme_time_ (mcp, increment);
	goto return_from_mp;

mp(18):; /** MME GECALL 18 **/
	call gcos_mme_call_$gcos_mme_call_ (mcp, increment);
	goto return_from_mp;

mp(19):; /** MME GESAVE 19 **/
	call gcos_mme_save_$gcos_mme_save_ (mcp, increment);
	goto return_from_mp;

mp(20):; /** MME GERSTR 20 **/
	call gcos_mme_call_$mme_rstr (mcp, increment);
	goto return_from_mp;

mp(21):; /** MME GEMREL 21 **/
	call gcos_mme_mrel_$gcos_mme_mrel_ (mcp, increment);
	goto return_from_mp;

mp(22):; /** MME GESYOT 22 **/
	call gcos_mme_syot_$gcos_mme_syot_ (mcp, increment);
	goto return_from_mp;

mp(23):; /** MME GECHEK 23 **/
	call gcos_mme_chek_$gcos_mme_chek_ (mcp, increment);
	goto return_from_mp;

mp(24):; /** MME GEROUT 24 **/
	call gcos_mme_rout_$gcos_mme_rout_ (mcp, increment);
	goto return_from_mp;

mp(26):; /** MME GEUSER 26 **/
	call gcos_mme_user_$gcos_mme_user_ (mcp, increment);
	goto return_from_mp;

mp(27):; /** MME GELOOP 27 **/
	call gcos_mme_loop_$gcos_mme_loop_ (mcp, increment);
	goto return_from_mp;

mp(28):; /** MME GEWAKE 28 **/
	call gcos_mme_wake_$gcos_mme_wake_ (mcp, increment);
	goto return_from_mp;

mp(31):; /** MME GELBAR 31 **/
	call gcos_mme_lbar_$gcos_mme_lbar_ (mcp, increment);
	goto return_from_mp;

mp(32):; /** MME GEFRCE 32 **/
	call gcos_mme_frce_$gcos_mme_frce_ (mcp, increment);
	goto return_from_mp;

mp(33):; /** MME GEFSYE 33 **/
	call gcos_mme_fsye_$gcos_mme_fsye_ (mcp, increment);
	goto return_from_mp;

mp(34):; /** MME GEPRIO 34 **/
	call gcos_mme_prio_$gcos_mme_prio_ (mcp, increment);
	goto return_from_mp;

mp(37):; /** MME GEINFO 37 **/
	call gcos_mme_info_$gcos_mme_info_ (mcp, increment);

return_from_mp: ;
	if debugsw then call debug_2 ();

/*
   Now modify the machine conditions to skip the MME and any arguments
   to  it.   This  is  accomplished  by modifying the IC (scu.ilc) and
   forcing the processor to refetch the instruction pair.
*/
	instruction_counter = instruction_counter + increment +1;
	scu.rfi = "1"b;				/* Refetch faulted instruction. */
	scu.if = "1"b;				/* Turn on indicator that instruction faulted. */

	return;
%page;
mme_trace: entry (arg_string);

/* Set MME trace list, and/or display it. */
dcl  arg_string               char(*)parm;
	mlp = addr (mme_trace_list);			/* Select trace list as the MME list. */
	trace_or_stop = "1"b;			/* Trace entry. */
	goto continue_db;

mme_stop:	entry (arg_string);

/* Set MME stop list, and/or display it. */
	mlp = addr (mme_stop_list);			/* Select stop list as the MME list. */
	trace_or_stop = "0"b;			/* Stop entry. */

continue_db: ;

	on_or_off = "1"b;				/* On by default. */
	do i = 1 by 1;
	     if next_arg (i, ap, al) then do;		/* No more arg_string "arguments". */
		if i = 1 then			/* There were no arguments => set all values on. */
		     mme_list = "1"b;
		dbs_trace_mme = (string (mme_trace_list) ^= "0"b);
		dbs_stop_mme = (string (mme_stop_list) ^= "0"b);
		return;
	     end;

/* Examine the next argument. */
	     if arg = "-all" then do;			/* Set the whole list to current on or off value. */
		mme_list = on_or_off;
		goto get_arg;
	     end;
	     if arg = "-on" then do;			/* Set on or off value to on. */
		on_or_off = "1"b;
		goto get_arg;
	     end;
	     if arg = "-off" then do;			/* Set on of off value to off. */
		on_or_off = "0"b;
		goto get_arg;
	     end;
	     if (arg = "-pr") | (arg = "-print") then do; /* Display the list. */
		if string (mme_list) = "0"b then	/* Whole list is off. */
		     call ioa_ ("MME ^[trace^;stop^] is off for all MME's.", trace_or_stop);
		else
		if (^string (mme_list)) = "0"b then	/* Whole list is on. */
		     call ioa_ ("MME ^[trace^;stop^] is on for all MME's.", trace_or_stop);
		else do;				/* Display specific entries that are on. */
		     call ioa_ ("MME ^[trace^;stop^] is on for:", trace_or_stop);
		     do j = 1 to hbound (mme_list, 1);
			if mme_list (j) then
			     call ioa_ ("(^2i) ^a", j, MME_NAME (j));
		     end;
		end;
		goto get_arg;
	     end;
	     if verify (arg, "0123456789") = 0 then do;	/* => MME number. */
		j = fixed (arg, 17);		/* Obtain MME number as binary. */
		if j < lbound (mme_list, 1) then do;
		     call com_err_ (		/* Debug trace MME number out of range. */
			0
			, "gcos_process_mme_"
			, "^/Arg ^i, ^i, MME number out of range ^i to ^i."
			, i
			, j
			, lbound (mme_list, 1)
			, hbound (mme_list, 1)
			);
		     goto get_arg;
		end;
		goto found_mme_name;
	     end;

/* => arg is a MME name (lookup in name table). */
	     arg_uc = translate (			/* Convert lower to upper case. */
		arg
		, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
		, "abcdefghijklmnopqrstuvwxyz"
		);
	     do j = lbound (MME_NAME, 1) to hbound (MME_NAME, 1);
		if arg_uc = MME_NAME (j) then goto found_mme_name;
	     end;
	     call com_err_ (			/* Debug trace MME number out of range. */
		0
		, "gcos_process_mme_"
		, "^/Arg ^i, ""^a"", unknown MME name (^a^( ^a^))."
		, i
		, arg
		, MME_NAME (*)
		);
	     goto get_arg;

found_mme_name: ;
	     mme_list (j) = on_or_off;

get_arg:	     ;
	end;
%page;
watcher:	entry (address);

dcl  address                  char(*)parm;

	if address = "" then do;
	     watchsw = "0"b;
	     call ioa_ ("watcher off");
	     go to debug_return;
	end;

	watch_address = cv_oct_check_ (address, code);
	if code ^= 0 then do;
	     call ioa_ ("bad address");
	     go to debug_return;
	end;

	watchp = null ();
	watchsw = "1"b;
	watch_contents = 0;

	call ioa_ ("watcher on");


debug_return:


	return;
%page;
%include gcos_next_arg;
%page;
debug_1:	procedure ();


	     mme_statistics.count (mme_number) = mme_statistics.count (mme_number) + 1; /* bump usage count */

	     if dbs_stop_mme then
		if mme_stop_list (mme_number) then
		     goto print_mme;		/* print its name and location,
						   whether or not trace is on for it */
	     if dbs_trace_mme then
		if mme_trace_list (mme_number) then
print_mme:	     call ioa_ ("MME ^2d GE^a at ^6o", mme_number, MME_NAME (mme_number), fixed (scu.ilc, 18));

	     if watchsw then do;
		if watchp = null then watchp = addrel (gcos_ext_stat_$gcos_slave_area_seg, watch_address);
		if watchee ^= watch_contents then do;

		     watch_contents = watchee;
		     call ioa_ ("loc ^o changed to ^w before MME ^a. last MME was ^a",
			watch_address, watch_contents, (mme_number), (gcos_ext_stat_$last_mme));
		end;
	     end;

	     stopped = "0"b;
	     if dbs_stop_mme then
		if mme_stop_list (mme_number) then do;
		     call ioa_ ("CALLING DB");
		     stopped = "1"b;
		     call db;
		end;

	     initial_cpu_time = virtual_cpu_time_ ();


	end debug_1;
%page;
debug_2:	procedure ();


	     mme_statistics.total_time (mme_number) = mme_statistics.total_time (mme_number) +
		virtual_cpu_time_ ()- initial_cpu_time; /* count total time used by a MME */

	     if watchsw then
		if watchee ^= watch_contents then do;
		     watch_contents = watchee;
		     call ioa_ (
			"loc ^6.3b changed to ^w after MME ^a"
			, unspec (watch_address)
			, watch_contents
			, MME_NAME (mme_number)
			);
		end;

	     if stopped then do;
		call ioa_ (
		     "returned from MME ^a processor. CALLING DB"
		     , MME_NAME (mme_number)
		     );
		call db;
	     end;

	     gcos_ext_stat_$last_mme = mme_number;


	end debug_2;
%page;
/*   Variables for gcos_process_mme_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  al                       fixed bin(24);
dcl  ap                       ptr;
dcl  arg                      char(al)unal based(ap);
dcl  arg_uc                   char(100)var;
dcl  baseno                   builtin;
dcl  code                     fixed bin(35);
dcl  com_err_                 entry() options(variable);
dcl  continue                 bit(1) aligned;
dcl  cu_$ptr_call             entry options (variable);
dcl  cv_dec_check_            entry (char(*), fixed bin(35)) returns (fixed bin(35));
dcl  cv_oct_check_            entry (char(*), fixed bin(35)) returns (fixed bin(35));
dcl  db                       entry;
dcl  debugsw                  bit(1);
dcl  dummy1                   ptr;
dcl  dummy2                   ptr;
dcl  fault_name               char(*);
dcl  fixed                    builtin;
dcl  gcos_et_$bad_mme_addr    fixed bin(35) ext;
dcl  gcos_et_$bad_mme_in_cc   fixed bin(35) ext;
dcl  gcos_mme_bort_$gcos_mme_bort_ entry (ptr, fixed bin(24));
dcl  gcos_mme_bort_$not_imp   entry (ptr, fixed bin(24), fixed bin(17));
dcl  gcos_mme_bort_$system    entry options (variable);
dcl  gcos_mme_call_$gcos_mme_call_ entry (ptr, fixed bin(24));
dcl  gcos_mme_call_$mme_rstr  entry (ptr, fixed bin(24));
dcl  gcos_mme_chek_$gcos_mme_chek_ entry (ptr, fixed bin(24));
dcl  gcos_mme_fadd_$gcos_mme_fadd_ entry (ptr, fixed bin(24));
dcl  gcos_mme_fcon_$gcos_mme_fcon_ entry (ptr, fixed bin(24));
dcl  gcos_mme_fini_$gcos_mme_fini_ entry (ptr, fixed bin(24));
dcl  gcos_mme_frce_$gcos_mme_frce_ entry (ptr, fixed bin(24));
dcl  gcos_mme_fsye_$gcos_mme_fsye_ entry (ptr, fixed bin(24));
dcl  gcos_mme_info_$gcos_mme_info_ entry (ptr, fixed bin(24));
dcl  gcos_mme_inos_$gcos_mme_inos_ entry (ptr, fixed bin(24));
dcl  gcos_mme_inos_$mme_endc  entry (ptr, fixed bin(24));
dcl  gcos_mme_laps_$gcos_mme_laps_ entry (ptr, fixed bin(24));
dcl  gcos_mme_lbar_$gcos_mme_lbar_ entry (ptr, fixed bin(24));
dcl  gcos_mme_loop_$gcos_mme_loop_ entry (ptr, fixed bin(24));
dcl  gcos_mme_more_$gcos_mme_more_ entry (ptr, fixed bin(24));
dcl  gcos_mme_mrel_$gcos_mme_mrel_ entry (ptr, fixed bin(24));
dcl  gcos_mme_prio_$gcos_mme_prio_ entry (ptr, fixed bin(24));
dcl  gcos_mme_rels_$gcos_mme_rels_ entry (ptr, fixed bin(24));
dcl  gcos_mme_rets_$gcos_mme_rets_ entry (ptr, fixed bin(24));
dcl  gcos_mme_rout_$gcos_mme_rout_ entry (ptr, fixed bin(24));
dcl  gcos_mme_save_$gcos_mme_save_ entry (ptr, fixed bin(24));
dcl  gcos_mme_sets_$gcos_mme_sets_ entry (ptr, fixed bin(24));
dcl  gcos_mme_snap_$gcos_mme_snap_ entry (ptr, fixed bin(24));
dcl  gcos_mme_syot_$gcos_mme_syot_ entry (ptr, fixed bin(24));
dcl  gcos_mme_time_$gcos_mme_time_ entry (ptr, fixed bin(24));
dcl  gcos_mme_user_$gcos_mme_user_ entry (ptr, fixed bin(24));
dcl  gcos_mme_wake_$gcos_mme_wake_ entry (ptr, fixed bin(24));
dcl  hbound                   builtin;
dcl  i                        fixed bin(24);
dcl  ia                       fixed bin(24);
dcl  increment                fixed bin(24);
dcl  initial_cpu_time         fixed bin(71);
dcl  instruction_counter      fixed bin(18)unsigned unal based(addr(scu.ilc));
dcl  ioa_                     entry options (variable);
dcl  j                        fixed bin(24);
dcl  lbound                   builtin;
dcl  mlp                      ptr;
dcl  mme_list                 (44)bit(1)unal based(mlp);
dcl  mme_number               fixed bin(17)	/* holds mme type */;
dcl  mme_stop_list            (44) bit(1) unal int static init ((44) (1)"0"b);
dcl  mme_trace_list           (44) bit(1) unal int static init ((44) (1)"0"b);
dcl  null                     builtin;
dcl  on_or_off                bit(1);
dcl  on_sw                    bit(1) aligned static init ("0"b);
dcl  previous_instr_ptr	ptr;
dcl  previous_opcode	bit(9);
dcl  state                    char(3);
dcl  stopped                  bit(1) aligned;
dcl  substr                   builtin;
dcl  trace_or_stop            bit(1);
dcl  translate                builtin;
dcl  unspec                   builtin;
dcl  verify                   builtin;
dcl  virtual_cpu_time_        entry () returns (fixed bin(71));
dcl  watchee                  fixed bin(24)based (watchp);
dcl  watchp                   ptr static;
dcl  watchsw                  bit(1) static init ("0"b);
dcl  watch_address            fixed bin(24)static;
dcl  watch_contents           fixed bin(35) static;
dcl  XED			bit(9) internal static options (constant)
			init ("111001111"b);
dcl 1 even_instruction	aligned based(addr(scu.even_inst)) like machine_instruction;
dcl 1 odd_instruction	aligned based(addr(scu.odd_inst)) like machine_instruction;

dcl 1 machine_instruction	aligned based
,2 MME_NO		fixed bin(17)unal
,2 OPCODE		bit(10)unal
,2 II		bit(1)unal	/* Interrupt inhibit. */
,2 A		bit(1)unal	/* Indirect via pointer register flag. */
,2 TAG		bit(6)		/* Instruction address modification. */
;

dcl 1 mme_statistics based (addr (gcos_ext_stat_$statistics)), /* overlay */
    2 total_time (44) fixed bin(71),
    2 count (44) fixed bin(17);
%page;
%include gcos_mme_names;
%page;
%page;
%include gcos_dbs_names;
%include gcos_ext_stat_;

end gcos_process_mme_;




		    gcos_read_card_.pl1             09/09/83  1400.3rew 09/09/83  1007.1       68706



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_read_card_: proc (return_gcos_ptr, return_gcos_len, return_ascii_card, return_dollar_sw);

/*
   *	This procedure is called to read a card from the gcos job stream file.
   *
   *	It returns:
   *		1) a pointer to the (rcw of the) gcos format record (bcd or binary);
   *		2) the length, in ascii characters, (i.e. 4 times length in words)
   *		   of the record, including the rcw. (This is to provide a convenient
   *		   interface with gcos_write_, which is called with a char(*) argument,
   *		   even when writing a gcos record.)
   *
   *
   *	If the card is a $ control card, it returns the ascii image (80
   *	characters, padded with blanks, and NOT ending in a newline), and a "1"b in
   *	dollar_sw; otherwise, it returns "0"b in dollar_sw, and blanks in the ascii image.
   *
   *	If end of file occurs on gcos_job_stream_, it calls gcos_error_ to abort the
   *	job: a $ ENDJOB card should end the deck, and no more calls should be made
   *	after that card is read.
   *
   *	If the job stream file is small enough to be a segment, rather than a msf, it
   *	is initiated, and "read" by moving a pointer through it, instead of
   *	being read by ios_$read, in order to save time.
   *
   *
   Author: T. CASEY     APRIL 1973
   Change: T. CASEY FEBRUARY 1974
   Change: D.KAYDEN  MARCH 1975
   Change: M. R. Jordan, August 1977
   Change: Dave Ward	08/11/81 Reorganized.
*/
dcl  return_gcos_len          fixed bin(24)parm	/* returned length of gcos record  */;
dcl  return_gcos_ptr          ptr parm	/* returned pointer to gcos record */;
	return_dollar_sw = "0"b;			/* turn off "this is dollar card" switch */
	return_ascii_card = "";			/* and blank out the ascii card image */
	save_data.jd_rem_block_len = remaining_block_len;
	save_data.jd_position = block_position;

reread:	;					/* come here to read bcd dollar card,
						   if we just read ascii copy of it */
	if remaining_block_len = 0 then do;		/* if no more records in this block */
/* get next one */

	     block_position = block_position + 320;

	     if msf then do;			/* if this is a msf */
		record_ptr = addr (buffer);
		call ios_$read ("gcos_job_stream_", record_ptr, 0, 320, words_read, status);

		if code ^= 0 then do;
		     err_msg = "from ios_$read ^a";
read_error:	     ;
		     call gcos_error_ (code, err_msg, "gcos_job_stream_", err_num);
		end;
	     end;
	     else do;				/* must be a segment */
		record_ptr = addrel (save_data.job_deck, block_position);
		words_read = min (320, save_data.jd_size - block_position);
	     end;

	     if words_read < 320 then do;

		if words_read = 0 then do;		/* but if there are no more blocks to get */
eof_error:	     ;
		     code = 0;			/* should never happen. complain */
		     err_msg = "end of file on ^a";
		     goto read_error;
		end;

		code = 0;
		err_num = words_read;
		err_msg = "ios_$read ^a returned ^d words";
		goto read_error;
	     end;

/* get first record of block */
	     remaining_block_len = fixed (bcw.length);	/* initialize block length from bcw */

	     if remaining_block_len > 319 then do;
		code = 0;
		err_num = remaining_block_len;
		err_msg = "block from ^a contained ^d words";
		goto read_error;
	     end;

	     record_ptr = addrel (record_ptr, 1);
	end;

/* process record */
	if rcw.eof = bcd_eof then goto eof_error;	/* should never happen */
	record_len = fixed (rcw.length);
	remaining_block_len = remaining_block_len - record_len - 1;

	if remaining_block_len < 0 then do;		/* should never happen */
	     code = 0;
	     err_num = remaining_block_len;
	     err_msg = "^a remaining_block_len negative: ^d";
	     goto read_error;
	end;

	if rcw.media_code = "0110"b then do;		/* if ascii record */

	     if return_dollar_sw then do;		/* should never happen */
		code = 0;
		err_msg = "two consecutive ascii records from ^a";
		goto read_error;
	     end;

	     return_ascii_card = ascii_record.chars;	/* copy ascii card into argument from caller */
	     return_dollar_sw = "1"b;			/* remember that we read a dollar card */
	     record_ptr = addrel (record_ptr, record_len + 1);
	     goto reread;				/* go read the bcd image of this card */
	end;

	return_gcos_ptr = record_ptr;			/* must be a regular gcos record */
	return_gcos_len = (record_len + 1) * 4;

	record_ptr = addrel (record_ptr, record_len + 1);

	if gcos_ext_stat_$card_num = 9999 then gcos_ext_stat_$card_num = 0;
	else gcos_ext_stat_$card_num = gcos_ext_stat_$card_num+1;

	return;					/* normal return */
%page;
read_init: entry (restartsw);

dcl  restartsw                bit (1) aligned parm;

	gcos_ext_stat_$card_num = 0;

	msf = save_data.job_deck = null;

	if ^restartsw then do;
	     save_data.jd_position = -320;
	     save_data.jd_rem_block_len = 0;
	     go to init_done;
	end;

/*	Restart in process - reposition job stream */
	if msf then if save_data.jd_position >= 0 then
		call ios_$seek ("gcos_job_stream_", "read", "first", save_data.jd_position, status);

	if save_data.jd_rem_block_len ^= 0 then do;
	     if msf then do;
		record_ptr = addr (buffer);
		call ios_$read ("gcos_job_stream_", record_ptr, 0, 320, words_read, status);
	     end;
	     else record_ptr = addrel (save_data.job_deck, save_data.jd_position);
	     record_ptr = addrel (record_ptr, 1 + fixed (bcw.length) - save_data.jd_rem_block_len);
	end;

init_done: ;
	block_position = save_data.jd_position;
	remaining_block_len = save_data.jd_rem_block_len;

	return;
%page;
/*   Variables for gcos_read_card_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  bcd_eof                  bit (6) unaligned int static init ("001111"b);
dcl  block_position           fixed bin(24)int static;
dcl  buffer                   (320) bit (36) aligned int static;
dcl  code                     fixed bin(35) aligned based (addr (status));
dcl  err_msg                  char (100) aligned;
dcl  err_num                  fixed bin(24);
dcl  fixed                    builtin;
dcl  gcos_error_              ext entry options (variable);
dcl  ios_$read                ext entry (char (*), ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned);
dcl  ios_$seek                ext entry (char (*), char (*), char (*), fixed bin(24), bit (72) aligned);
dcl  min                      builtin;
dcl  msf                      bit (1) aligned int static	/* on when file is a msf */;
dcl  null                     builtin;
dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr int static;
dcl  remaining_block_len      fixed bin(24)int static;
dcl  return_ascii_card        char (80) parm	/* returned ascii image of dollar card */;
dcl  return_dollar_sw         bit (1) parm	/* switch on if this is a dollar card */;
dcl  status                   bit (72) aligned;
dcl  words_read               fixed bin(24);

dcl 1 ascii_record aligned based (record_ptr),
    2 rcw bit (36) aligned,
    2 chars char (80) unaligned;

dcl 1 bcw aligned based (record_ptr),
    2 bsn bit (18) unaligned,
    2 length bit (18) unaligned;

dcl 1 rcw aligned based (record_ptr),
    2 length bit (18) unaligned,
    2 eof bit (6) unaligned,
    2 zeroes bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;
%page;
%include gcos_ext_stat_;
     end gcos_read_card_;




		    gcos_restart_.pl1               09/09/83  1400.3rew 09/09/83  1007.1       67608



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* ********************************************************************#
   **
   *							*
   *	Save and Restart Procedure				*
   *							*
   *							*
   *  This procedure saves selected data from gcos_ext_stat_ needed	*
   *  to restart a GCOS job from the current actvity when a system	*
   *  interruption occurs.  If an activity restart is specified,	*
   *  this procedure restores the necessary data in gcos_ext_stat_.	*
   *  							*
   *	WRITTEN BY D.A. KAYDEN  JANUARY 1975			*
   *	MODIFIED BY D.A. KAYDEN  JUNE 1975
   *	MODIFIED BY R.H. MORRISON  JULY 14,1975
   *	Modified by M. R. Jordan, October 1977
   *							*
   ******************************************************************** */

gcos_restart_: proc (n);

/*	D E C L A R A T I O N S 	*/

%include gcos_ext_stat_;
%include gcos_restart_control_;


dcl n fixed bin(24)parm;
dcl  ioa_ ext entry options (variable);
dcl size builtin;
dcl  gcos_attach_file_$reattach ext entry (ptr, fixed bin(35));
dcl  gcos_gein_pass1_$job_stream_restart ext entry (fixed bin(35));
dcl  gcos_write_$ptr ext entry (ptr, char (*), bit (8));
dcl  gcos_write_$force_ptr ext entry (ptr);
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_cc_endjob_$restart ext entry;
dcl  gcos_close_file_ ext entry (pointer);
dcl  gcos_et_$no_restart fixed bin(35) ext;

dcl  save_area (size(save_data_entry)) bit (36) aligned based;

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

dcl 1 flags_copy like flags;
dcl  no_job_restart bit (1) aligned;

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


dcl (addr, addrel, null, substr) builtin;



/*	P R O C E D U R E		*/


	fibptr = addr (save_data.fibs);
	no_job_restart = "0"b;			/* initialize flag */

/*  Check for no activity restart */

	if restart_control.na_restart			/* NREST card option */
	| restart_control.cant_do			/* can't do activity restart */
	then
	     if restart_control.nj_restart		/* no job restart - NJREST card option */
	     | save_data.activity_no = 1		/* no job restart special case */
	     then
		do;
		no_job_restart = "1"b;
		if ^gcos_ext_stat_$save_data.brief then call ioa_ ("neither activity nor job is restartable");
		go to restore;
	     end;

	     else do;
		n = 4;
		if ^gcos_ext_stat_$save_data.brief then call ioa_ ("job restarted");
		return;
	     end;


/* Restore gcos_ext_stat_  */
restore:


	unspec (flags_copy) = unspec (gcos_ext_stat_$save_data.flgs); /* save the curren flags. */

	addr (gcos_ext_stat_$save_data) -> save_area = restart_control.restart_data;
						/* copy saved data */

	flags_copy.snumb = gcos_ext_stat_$save_data.snumb; /* change several current gcos_ext_stat_$save_data to saved values */
	flags_copy.ident = gcos_ext_stat_$save_data.flgs.ident;
	flags_copy.prev_act_abort = gcos_ext_stat_$save_data.prev_act_abort;
	flags_copy.endjob = gcos_ext_stat_$save_data.endjob;
	unspec (gcos_ext_stat_$save_data.flgs) = unspec (flags_copy); /* Restore flags. */

	fibptr = addr (save_data.fibs);

	if gcos_ext_stat_$save_data.endjob then go to endjob_restart; /* crashed during endjob processing */
	if no_job_restart then go to job_term;


/*  Activity restart initialization */

	do i = 1 to hbound (save_data.fibs, 1);
	     if ^fib.used then go to next_fib;
	     if fib.tape then go to act_fail;		/* cannot do activity restart presently if tapes */
						/* are saved because we cannot reposition them */
	     if fib.stream = "sysprint" then gcos_ext_stat_$prt = fibptr;
	     else if fib.stream = "syspunch" then gcos_ext_stat_$pch = fibptr;
	     else if fib.stream = "exec_rpt" then gcos_ext_stat_$er = fibptr;
	     else if fib.stream = "rstar" | substr (fib.stream, 4) = "rstar" then
		if ^fib.gein then gcos_ext_stat_$rs = fibptr;

	     fib.buffer = null;
	     if fib.attached then
		do;
		call gcos_attach_file_$reattach (fibptr, code);
		if code ^= 0 then go to act_fail;
	     end;

next_fib:	     fibptr = addrel (fibptr, size (fib));
	end;

	call gcos_gein_pass1_$job_stream_restart (code);
	if code ^= 0 then go to act_fail;

/*  Activity restart */

	call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b);
	call gcos_write_$ptr (gcos_ext_stat_$er,
	     "****** system interruption, job restarted here ******
", "11111100"b);
	call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b);
	call gcos_write_$force_ptr (gcos_ext_stat_$er);

	if save_data.activity_no = 0 then n = 2;	/* restarting at first activity */
	else n = 3;				/* restarting at later activity */

	if ^gcos_ext_stat_$save_data.brief then call ioa_ ("performing activity restart");

	return;

act_fail:
	if ^gcos_ext_stat_$save_data.brief then call ioa_ ("activity restart failed, code = ^o", code);

job_restart:					/* Restart job if card option is JREST; otherwise abort it */

	gcos_ext_stat_$save_data.flgs.snumb, gcos_ext_stat_$save_data.flgs.ident, gcos_ext_stat_$save_data.flgs.prev_act_abort, gcos_ext_stat_$save_data.flgs.endjob = "0"b;
						/* clear gcos_ext_stat_$save_data that may have been set during restart attempt */
	if restart_control.nj_restart			/* test job restart options */
	| save_data.activity_no = 1 then
	     goto job_term;				/* terminate job */
	else do;					/* restart job */
	     n = 1;
	     if ^gcos_ext_stat_$save_data.brief then call ioa_ ("job restarted");

/* Files that we were able to attach must be detached again - this is done by gcos_gein_ calling gein_cleanup */

	     return;

	end;

job_term:						/* reattach sysout files and terminate job */

	do i = 1 to hbound (save_data.fibs, 1);
	     if ^fib.used then go to nextfib;
	     if fib.stream = "sysprint" then gcos_ext_stat_$prt = fibptr;
	     else if fib.stream = "syspunch" then gcos_ext_stat_$pch = fibptr;
	     else if fib.stream = "exec_rpt" then gcos_ext_stat_$er = fibptr;
	     else do;
		fib.disp = "01"b;
		call gcos_close_file_ (fibptr);
		go to nextfib;
	     end;

	     fib.buffer = null;
	     if fib.attached
	     then
		do;
		call gcos_attach_file_$reattach (fibptr, code);
		if code ^= 0 then gcos_ext_stat_$save_data.endjob = "1"b;
	     end;

nextfib:	     fibptr = addrel (fibptr, size (fib));

	end;

	call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b);
	call gcos_write_$ptr (gcos_ext_stat_$er,
	     "****** system interruption, job terminated here ******
", "11111100"b);
	call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b);
	call gcos_write_$force_ptr (gcos_ext_stat_$er);

	call gcos_error_ (gcos_et_$no_restart);


endjob_restart:
	do i = 1 to hbound (save_data.fibs, 1);		/* we must null the buffer pointers */

	     fib.buffer = null;

	     fibptr = addrel (fibptr, size (fib));
	end;

	if ^gcos_ext_stat_$save_data.brief then
	     call ioa_ ("restarting end of job processing");

	call gcos_cc_endjob_$restart;			/* does not return here */


/*		Entry to save the necessary portions of gcos_ext_stat_		*/



save:	entry;

	restart_control.cant_do = "1"b;		/* don't try to restart an incomplete save */

	restart_control.restart_data = addr (gcos_ext_stat_$save_data) -> save_area;

	restart_control.saved = "1"b;			/* set flag */

	restart_control.na_restart = "0"b;		/* default card option is REST */

	restart_control.cant_do = "0"b;		/* save completed */

	return;

     end gcos_restart_;




		    gcos_restore_regs_.alm          09/09/83  1400.3rew 09/09/83  1007.1        5337



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" declare gcos_restore_regs_ entry(ptr);
" Restore registers from 6 word located by ptr.
" Dave Ward 09/22/80
	name	gcos_restore_regs_
	segdef	gcos_restore_regs_
	even
gcos_restore_regs_:
	eppbp	ap|2,* " bp->reg save area.
	lreg	bp|0,* " registers<-reg save area.
	short_return
	end




		    gcos_run_activity_.pl1          08/04/87  1725.9r   08/04/87  1541.4      236745



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


/* ****************************************************************************************
   ******************************************************************************************
   *
   *
   *
   *	R U N   A   G C O S   A C T I V I T Y
   *
   *
   *  This procedure is called by gcos_gein_ whenever an activity terminating card is read
   *  while an activity is being defined. This procedure will setup to run the activity
   *  specified in gcos_ext_stat_$activity_name. It will receive control when this activity
   *  is completed. At such time, it will clean up, record some accounting information
   *  and return.
   *
   *
   *	WRITTEN BY DICK SNYDER SEPTEMBER 10,1970
   *	MODIFIED BY T. CASEY JUNE 1973, OCTOBER 1973, JANUARY 1974, FEBRUARY 1974, MAY 1974, AUGUST 1974
   *	MODIFIED BY D. KAYDEN MARCH 1974, APRIL 1974, JUNE 1974, DECEMBER 1974
   *	MODIFIED BY R.H. MORRISON  75/06/15
   *	Modified by M. R. Jordan, August 1977
   *      Modified  Ron Barstad  83-11-16  Fix actid format and console msgs
   *      Modified  Ron Barstad  83-04-28  Fix precision of time limit divide
   *                                       change "ACT. TERM." to "NORM TERM"
   *
   ******************************************************************************************
   **************************************************************************************** */
%page;
gcos_run_activity_: proc;

	if pre_setup_stop_sw then do;
	     call ioa_ ("run_activity_ entered; calling db:");
	     call db;
	end;

	gcos_ext_stat_$save_data.activ = "0"b;		/* clear activity being defined sw */

	if gcos_ext_stat_$save_data.gtssflag then
	     call gcos_gtss_update_$new_activity (save_data.activity_no, WAIT_PERIPH);


/* 	This loop scans the fibs and does the following things   	 */
/* 	where indicated:						 */
/* 		write eof and rewind gein files			 */
/*		attach unattached files				 */
/*		save initial file size and position			 */


	do i = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (i) = "" then go to bump;
	     if fct.sysout (i) then go to bump;

	     fibptr = fct.fibptr (i);

	     if fib.gein then do;			/* eof and rewind? */

		if fib.buffer = null then go to bump;	/* bump if no writes done */

		call gcos_write_$bcd_ptr (fibptr, "", (8)"0"b); /* write eof */

		fib.last = fib.current;

		call ios_$seek (fib.stream, "read", "first", 0, status); /* reset read ptr */

		fib.read = "1"b;			/* gein files can only be read */

		fib.current = 0;

		fib.disp = "01"b;			/* set disposition to release */
	     end;


	     if ^fib.attached then call gcos_attach_file_ (fibptr); /* attach file */

	     fib.init_posit = fib.current;		/* save file position */
	     fib.init_size = fib.size;		/* save file size */
bump:
	end;

%page;

/* Set up the gcos segment. If it does not exist yet, it will be */
/* created by the file system in the working directory or in the */
/* process directory depending on the control arg. "-nosave". A pointer */
/* to the segment will be kept in internal static so that the seg */
/* need be created only once per process. Once the segment has been  */
/* created or located, it is truncated and then its max length */
/* is set to the storage limit for the activity. Thus if the gcos */
/* program attempts to write above its allotted memory, a fault */
/* will occur and the program can be aborted just like in "real" gcos. */

	if gcos_ext_stat_$activity_name = "geload" then do; /* activity = "geload" ? */

	     if gcos_ext_stat_$ldrss ^= 0 then do;	/* yes...loader shared stg = 0 ? */

/* If loader shared storage > max for loader, decrease it to this max (22000 octal ) */

/* NOTE that a constant loader size of 9K is built into the code, here */

		if gcos_ext_stat_$ldrss > 9*1024 then gcos_ext_stat_$ldrss = 9*1024; /* 9K */

/* Round ldrss down to a multiple of 1K */

		i = divide (gcos_ext_stat_$ldrss, 1024, 17, 0);
		gcos_ext_stat_$ldrss = i*1024;
	     end;

/* If ldrss is negative, the above will round its absolute value down to a multiple of 1K.
   Then, the subtraction below will add its absolute value to the storage limit,
   which is what is desired when negative loader shared storage is specified */

	     gcos_ext_stat_$storage_limit = gcos_ext_stat_$storage_limit+9*1024-gcos_ext_stat_$ldrss;
						/* compute final storage limit */
	end;

/*  Check for storage limit too high */

	if gcos_ext_stat_$storage_limit >gcos_ext_stat_$max_mem then /* wants too much core */
	     call gcos_error_ (0, "slave core limit > max Multics segment size");

	gseg = gcos_ext_stat_$gcos_slave_area_seg;

	if gseg = null then do;
	     call hcs_$make_seg ("", "gcos_slave_area_seg", "", 11, gseg, code); /* create gcos segment */
						/* in process directory */
	     if gseg = null then call gcos_error_ (code, "attempting to create slave segment");
	     gcos_ext_stat_$gcos_slave_area_seg = gseg;	/* save ptr in ext static */

/* Set rewa access on gcos_slave_area_seg */

/* NOTE: eliminate append access ONLY after all existing Multics systems
   have been upgraded to the version that does not use it */

	     acla.userid = get_group_id_$tag_star ();	/* fill in user id in acl model */
	     call cu_$level_get (i);			/* get validation level */
	     rb1 = substr (unspec (i), 31, 6);		/* put in ring bracket 1 */
	     rb2, rb3 = substr (unspec (i), 31, 6);	/* brackets 2 & 3 = val level */
	     acla.mode = "01110"b;			/* mode = rew */

	     call hcs_$acl_add (string (gcos_ext_stat_$pdir), "gcos_slave_area_seg", addr (acla), 1, code); /* set acl */
	     if code ^= 0 then call gcos_error_ (code, "setting access to slave segment");

	end;
	call hcs_$truncate_seg (gseg, 0, code);		/* truncate */

/* Set the actual max length limit on the segment */
	call hcs_$set_max_length (string (gcos_ext_stat_$pdir), "gcos_slave_area_seg", gcos_ext_stat_$storage_limit, code);
	if code ^= 0 then call gcos_error_ (code, "setting max length on slave segment");

/* Set up bypass of condition handlers */

	on any_other call gcos_fault_processor_;

	call sct_manager_$get (mme1_sct_index, gcos_ext_stat_$sig_ptr, code);
						/* check */
	call sct_manager_$set (mme1_sct_index, addr (gcos_process_mme_), code);
						/* check */

/* The stack frame for this procedure stays around during the running of the
   activity. If it gets cleaned up, we must reset to the normal condition
   handlers and turn off the timer */

	on cleanup begin;
	     call timer_manager_$reset_cpu_call (gcos_fault_processor_$timer_runout); /* abort any timeout */
	     if gcos_ext_stat_$sig_ptr ^= null		/* pointer was diddled */
	     then do;
		call sct_manager_$set (mme1_sct_index, gcos_ext_stat_$sig_ptr, code);
						/* check */
		gcos_ext_stat_$sig_ptr = null;	/* reinitialize */
	     end;
	     if gcos_ext_stat_$save_data.rout then call gcos_mme_rout_$rout_cleanup; /* MME GEROUT simulater wants to clean up too */

	     released_fibs.nrf = 0;			/* Empty released fibs array. */

	end;

	on program_interrupt			/* to simulate the GCOS equivalent of "QUIT" to stop */
	     call gcos_mme_rout_$rout_interrupt;	/* unwanted typing from the slave program, we use the */
						/* Multics "pi" command (user hits QUIT, then types "pi") */


/* CLEAR THE SLAVE PREFIX, THEN START INITIALIZING IT */

	zero = "0"b;				/* zero out slave prefix */

subact1:						/* come here to start running an abort subactivity */
	slave_prefix.mme = "000000000000010010000000001000000000"b; /* set up MME GECALL in slave prefix */


/* Translate program name to bcd and put in prefix */

	call gcos_cv_ascii_gebcd_ (addr (gcos_ext_stat_$activity_name), 6, addr (slave_prefix.prog), i);

	if gcos_ext_stat_$save_data.abort_subact then goto subact2; /* skip lots of initialization, if running subactivity */

/* 	Convert activity number and job number to one word with the following format:	 */
/* 		bits 0-5  activity number in binary		 */
/* 		bits 6-35 job number in BCD		 */
/* 	Save also in ext static for use by MME GESYOT			 */

/* convert snumb to BCD */

	call gcos_cv_ascii_gebcd_ (addr (substr (save_data.actid, 1, 5)), 5, addr (slave_prefix.activid), i);

/* now get the activity number and concatenate the BCD snumb onto the end of it */

	i = save_data.activity_no;

	save_data.short_actid, slave_prefix.activid =
	     substr (unspec (i), 31, 6) || substr (slave_prefix.activid, 1, 30);

/* 	Compute relative load limits and put in 37 octal of slave prefix */
/* 	Has the following format. Bits 0-17 hold lowest allowable address */
/* 	of activity relative to GELOAD origin. Bits 18-35 hold highest allowable */
/* 	address to be loaded by GELOAD.				 */


/* Lower limit = size of GELOAD - loader shared storage */

	i = 9*1024-gcos_ext_stat_$ldrss;

/* Upper limit = storage limit -1 */

	j = gcos_ext_stat_$storage_limit-1;
	slave_prefix.load_limits = substr (unspec (i), 19, 18)||substr (unspec (j), 19, 18);

/* Put ident card info in slave prefix */

	call gcos_cv_ascii_gebcd_ (addr (gcos_ext_stat_$save_data.save_data.ident), length (gcos_ext_stat_$save_data.save_data.ident), addr (slave_prefix.ident), i);

	if gcos_ext_stat_$save_data.taskflag then spa_taskflag = (36) "1"b; /* set gtss drl task flag in spa */

/* 	Set up label variable in external static so that when the GCOS */
/* 	program terminates, the handler can return to this procedure */
/* 	and revert the stack properly.				 */

	gcos_ext_stat_$mme_rtrn = end_activity;

	if gcos_ext_stat_$save_data.gtssflag then
	     call gcos_gtss_update_$status_update (EXECUTING);

/*  Put activity start message out to operator     */

	call hcs_$get_usage_values (k, cputime_start, k); /* get cpu time at activity start */
	realtime_start = clock_ ();			/* get activity start time */
	gcos_ext_stat_$activity_start_time = realtime_start;
	call date_time_ (realtime_start, holdtime);	/* get date and time */
	if save_data.activity_no = 1 & ^gcos_ext_stat_$save_data.brief then
	     call ioa_ (" *SRT  ^a  @^a  ^6a  (^3d)", save_data.actid, 
	     substr (holdtime, 11, 6), gcos_ext_stat_$activity_name,
	     divide(gcos_ext_stat_$time_limit,36,35));

	pta.accno, rta.accno = substr (save_data.actid, 7, 2);

	term_msg = "activity";

/* Format the begin message for the execution report */

subact2:	call ioa_$rs ("* ACTY-^2d  $CARD #^4a  ^6a   ^a   SW=^w", bannerstring, j,
	     save_data.activity_no,
	     gcos_ext_stat_$activity_card_num, gcos_ext_stat_$activity_name,
	     substr (holdtime, 1, 8), save_data.psw);

	call gcos_write_$ptr (gcos_ext_stat_$er, var_msg, "11111100"b); /* write it on the execution report */

	if gcos_ext_stat_$save_data.long then
	     call ioa_$nnl (var_msg);			/* also write it on the console for the interactive user */

/* 	Set up timeout = current number of cpu seconds process has */
/* 	been running + time limit. Control goes to fault$timer_runout */
/* 	if timeout occurs.					 */

	call timer_manager_$cpu_call (gcos_ext_stat_$time_limit, "11"b, gcos_fault_processor_$timer_runout);

	if ^gcos_ext_stat_$save_data.abort_subact then	/* except when continuing, with a subactivity */
	     gcos_ext_stat_$initial_cpu_time = virtual_cpu_time_ ();

	if pre_activity_stop_sw then do;
	     call ioa_ ("ready to run activity; calling db:");
	     call db;
	end;

/*	Ready to transfer to gcos segment. Call a program to set BAR and do	*/
/*	a TSS to enter BAR mode. Pass as args the limit part of the BAR	*/
/*	(number of 512 word blocks), and a pointer to 26 in the gcos segment	*/
/*	which is the location of the MME GECALL to get the activity going.	*/

	call gcos_set_slave_ (divide (gcos_ext_stat_$storage_limit, 512, 18, 0), addrel (gseg, 26), (gcos_ext_stat_$save_data.no_bar));

/* Control will return to the top of the next page, via a nonlocal goto,
   when the slave program gives up control, which it will do for any of the following reasons:

   1) MME GEFINI from the slave program,
   2) MME GEBORT from the slave program,
   3) fault in slave program, of a type which causes an abort,
   4) error in one of the mme simulators, of a type which causes an abort.
   */
%page;

/* Control comes here via a nonlocal goto, when the activity terminates */

end_activity:

	if post_activity_stop_sw then do;
	     call ioa_ ("activity completed; calling db:");
	     call db;
	end;

	call timer_manager_$reset_cpu_call (gcos_fault_processor_$timer_runout); /* turn off timeout */

	call hcs_$get_usage_values (k, cputime_finish, k); /* get cpu time used */

/* compute cpu time used in slave program */

	cputime_used = cputime_finish - cputime_start;

/* CONVERT MICROSECONDS USED TO SECONDS USED - VERIFY THIS THOUGH,
   hcs_$get_usage_values is not in the MPM any longer, so we can not be
   sure the value it returns IS microseconds ... */

	cputime_used = divide (cputime_used, 1000000, 71, 0);

	if gcos_ext_stat_$abort_reason ^= "" then do;	/* was there an abort in the slave pgm */
						/* NOTE: if activity aborted but wrapup did not,
						   abort_reason will be blank when wrapup terminates,
						   and this do group will be skipped after the wrapup */

	     term_msg = term_msg || " aborted ";

	     if ^gcos_ext_stat_$save_data.wrapup	/* if not wrapup */
	     then if ^gcos_ext_stat_$save_data.abort_subact /* and not subactivity */
		then initial_abort_reason = gcos_ext_stat_$abort_reason; /* save the abort reason for the ABT message */
	     call gcos_write_to_er_ ("^a", gcos_ext_stat_$abort_reason);


	     gcos_ext_stat_$abort_reason = "";		/* clear it, so we can tell if wrapup aborts */

	     if gcos_ext_stat_$save_data.gtssflag then
		call gcos_gtss_update_$status_update (TERMINATING);

/* Check type of dump desired, set switches, then call dump program */

	     if substr (save_data.psw, 1, 1) then
		dump_info = (36)"0"b;		/* dump it all */
	     else
	     dump_info = (29)"0"b || "1"b || (6)"0"b;	/* only regs and prefix */

	     call gcos_mme_snp1_$bord (gcos_ext_stat_$mc.scu (4), dump_info);

	     if gcos_ext_stat_$save_data.wrapup then goto no_wrapup; /* if abort from within wrapup, don't wrapup again */

	     if slave_prefix.wrapup = "0"b then goto no_wrapup; /* if no wrapup address given */

	     if fixed (slave_prefix.wrapup) > gcos_ext_stat_$storage_limit then do; /* if wrapup address out of bounds */

		call ioa_ ("wrapup address out of bounds");
		call gcos_write_$ptr (gcos_ext_stat_$er, "wrapup address out of bounds", "11111100"b);
		goto no_wrapup;
	     end;

/* print psw, etc. before entering wrapup */
	     call print_term_msg;			/* internal procedure */

	     term_msg = "wrapup";			/* prepare for next message */

/* add 30 seconds to the remainder of the time limit, for the wrapup routine */

	     gcos_ext_stat_$time_limit = gcos_ext_stat_$time_limit - cputime_used + 30;

/* set timer for wrapup */

	     call timer_manager_$cpu_call (gcos_ext_stat_$time_limit, "11"b, gcos_fault_processor_$timer_runout);

	     gcos_ext_stat_$save_data.wrapup = "1"b;	/* remember that we are wrapping up after an abort */
	     substr (save_data.psw, 1, 1) = "0"b;	/* and don't dump if wrapup aborts */

/* Call program to set bar and then transfer via TSS to wrapup address in gcos pgm */

	     call gcos_set_slave_ (divide (gcos_ext_stat_$storage_limit, 512, 18, 0),
		addrel (gseg, slave_prefix.wrapup), (gcos_ext_stat_$save_data.no_bar));

/* control returns to "end_activity" above, via a nonlocal goto, when the wrapup terminates */

	end;

	term_msg = term_msg || " terminated ";		/* no abort - normal termination */



/* come here if wrapup not to be executed, for any reason (including no abort) */

no_wrapup:

/* clean up the slave environment that we established earlier */

	call sct_manager_$set (mme1_sct_index, gcos_ext_stat_$sig_ptr, code);
						/* check */
	gcos_ext_stat_$sig_ptr = null;

	revert program_interrupt;

	if gcos_ext_stat_$save_data.rout then call gcos_mme_rout_$rout_cleanup;

	gcos_ext_stat_$save_data.wrapup = "0"b;		/* turn off wrapup flag in case it was oh */

	call print_term_msg;			/* go print message */

/* if an abort subactivity is to be run, we do not want to clean up everything right now, though */

	if gcos_ext_stat_$save_data.this_act_abort then	/* if this activity aborted */
	     if gcos_ext_stat_$save_data.abort_card then do; /* and it contained a $ ABORT card */

/* NOTE that we are using our own flag and ignoring psw bit 12 here. This means that:
   1) the activity can not turn off bit 12 to prevent the subactivity from running;
   2) the activity can not turn on bit 12 to force it to run;
   it depends only on whether a $ ABORT card was present */


		if gcos_ext_stat_$activity_name ^= "geload" /* only after a $ EXECUTE activity */
		then goto no_subact;		/* is $ ABORT allowed */

		gcos_ext_stat_$save_data.abort_subact = "1"b; /* remember that we are running an abort subactivity */

/* add 30 seconds to remainder of time limit, for the subactivity */

		gcos_ext_stat_$time_limit = gcos_ext_stat_$time_limit - cputime_used + 30;

		gcos_ext_stat_$activity_name = "utility";

		term_msg = "subactivity";
		call date_time_ (clock_ (), holdtime);

		goto subact1;			/* go back to the activity-initializing part of this procedure,
						   and set up to run the subactivity */

	     end;


no_subact:

/* terminate the activity and clean up completely */

	call gcos_cleanup_files_;			/* dispose of files according to settings of fib.indicators */

/* Write real time used on execution report */

	realtime_finish = clock_ ();			/* get current time */

	call gcos_time_convert_ (realtime_finish-realtime_start, rta.time); /* get real time used */

	call gcos_write_$ptr (gcos_ext_stat_$er, string (rta), "11111100"b); /* put out real time used msg */

/* Write cpu time used on execution report */

	call gcos_time_convert_ (cputime_finish-cputime_start, pta.time); /* get cpu time used */

	call gcos_write_$ptr (gcos_ext_stat_$er, string (pta), "11111100"b); /* put msg on execution report */

/* Write activity completion message (either FIN or ABT) on console */

	if ^gcos_ext_stat_$save_data.brief then do;
	     call date_time_ (realtime_finish, holdtime); /* format date and time of activity completion */
	     if gcos_ext_stat_$save_data.this_act_abort then /* put abort message on console */

		call ioa_ (" *ABT  ^a  @^a  ^a", save_data.actid, substr (holdtime, 11, 6), initial_abort_reason);

/*	     else
	     call ioa_ (" *FIN  ^a  @^a", save_data.actid, substr (holdtime, 11, 6));  
*/	end;

post_cleanup:

	if post_cleanup_stop_sw then do;
	     call ioa_ ("post-activity cleanup completed; calling db:");
	     call db;
	end;

	return;


/*  INTERNAL PROCEDURE TO PRINT MESSAGES OF THE FORM:
   *
   *  ACTIVITY
   *               TERMINATED
   *  WRAPUP                    AT nnnnnn I=nnnnnn SW=nnnnnnnnnnnn
   *               ABORTED
   *  SUBACTIVITY
   *
   */

print_term_msg: proc;

dcl (xilc, xir) fixed bin(35);

/* get pointer to scu data */

	     scup = addr (gcos_ext_stat_$mc.scu);

/* get location counter and indicators into separate full words, to keep ioa_ happy */

	     xilc = fixed (scu.ilc);

	     xir = fixed (substr (string (scu.ir), 1, 12));

/* format the message */

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

   CHANGE TO USE NEW IOA CODES TO GET RID OF FORMAT PROBLEMS */

	     if term_msg = "activity terminated "
		then term_msg = "normal termination ";  /* what it should be */
	     call ioa_$rs ("  * ^22a at ^6w I=^4w SW=^w", bannerstring, j,
		term_msg, xilc, xir, save_data.psw);

	     call gcos_write_$ptr (gcos_ext_stat_$er, var_msg, "11111100"b); /* write it on execution report */

	     if gcos_ext_stat_$save_data.long then
		call ioa_$nnl (var_msg);		/* also write it on console, for interactive user */

	     return;

	end print_term_msg;


/*      D  E  B  U  G  G  I  N  G     E  N  T  R  I  E  S     */

pre_setup_stop: presetup: entry;
	switch_name = "pre_setup_stop";
	pre_setup_stop_sw = ^pre_setup_stop_sw;
	if pre_setup_stop_sw then
print_on:
	     switch_state = "on";
	else
print_off:
	switch_state = "off";

print_switch:
	call ioa_ ("^a turned ^a", switch_name, switch_state);
	return;

pre_activity_stop: preact: entry;
	switch_name = "pre_activity_stop";
	pre_activity_stop_sw = ^pre_activity_stop_sw;
	if pre_activity_stop_sw then goto print_on;
	else goto print_off;

post_activity_stop: postact: entry;
	switch_name = "post_activity_stop";
	post_activity_stop_sw = ^post_activity_stop_sw;
	if post_activity_stop_sw then goto print_on;
	else goto print_off;

post_cleanup_stop: postclean: entry;
	switch_name = "post_cleanup_stop";
	post_cleanup_stop_sw = ^post_cleanup_stop_sw;
	if post_cleanup_stop_sw then goto print_on;
	else goto print_off;
%page;
/* 	D E C L A R A T I O N S					 */


/* External Static */

dcl  error_table_$namedup ext static fixed bin(35);						/* system error code */
dcl  error_table_$segknown ext static fixed bin(35);						/* system error code */

/* 	External Entries				 */


dcl  gcos_attach_file_ ext entry (ptr);
dcl  gcos_process_mme_ ext entry;						/* called at fault time instead of signal_ */
dcl  gcos_cleanup_files_ ext entry;
dcl  gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_mme_snp1_$bord entry (bit (36), bit (36));
dcl  gcos_error_ ext entry options (variable);
dcl  gcos_fault_processor_ ext entry;
dcl  gcos_fault_processor_$timer_runout ext entry;
dcl  virtual_cpu_time_ entry () returns (fixed bin(71) aligned);
dcl  gcos_mme_rout_$rout_cleanup ext entry;
dcl  gcos_mme_rout_$rout_interrupt ext entry;
dcl  gcos_set_slave_ ext entry (fixed bin(18), ptr, bit (1) aligned);
dcl  gcos_time_convert_ ext entry (fixed bin(52), char (19));
dcl  gcos_write_$bcd_ptr ext entry (ptr, char (*), bit (8));
dcl  gcos_write_$ptr ext entry (ptr, char (*), bit (8));
dcl  gcos_write_to_er_ entry options (variable);

dcl  clock_ ext entry returns (fixed bin(71));
dcl  cu_$level_get ext entry (fixed bin(24));
dcl  date_time_ ext entry (fixed bin(71), char (*));
dcl  db ext entry options (variable);
dcl  get_group_id_$tag_star ext entry returns (char (32));
dcl  hcs_$acl_add ext entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$get_usage_values ext entry (fixed bin(24), fixed bin(71), fixed bin(24));
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin(5), ptr, fixed bin(35));
dcl  hcs_$set_max_length ext entry (char (*), char (*), fixed bin(19), fixed bin(35));
dcl  hcs_$truncate_seg ext entry (pointer, fixed bin(24), fixed bin(35));
dcl  ios_$seek ext entry (char (*), char (*), char (*), fixed bin(35), bit (72));
dcl  sct_manager_$get entry (fixed bin, ptr, fixed bin(35));
dcl  sct_manager_$set entry (fixed bin, ptr, fixed bin(35));
dcl  timer_manager_$cpu_call ext entry (fixed bin(71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call ext entry (entry);
dcl (ioa_, ioa_$rs, ioa_$nnl) ext entry options (variable);




/* 	Work Variables					 */


dcl  system_free_area area based (gcos_ext_stat_$system_free_pointer);
dcl  dump_info bit (36);
dcl  status bit (72);						/* holds return status from ios_ */
dcl  bannerstring char (120);						/* area to build banner in */
dcl  var_msg char (j) based (addr (bannerstring));						/* variable length overlay for above */
dcl  term_msg char (24) varying;						/* holds "activity terminated", "wrapup aborted", etc. */
dcl  initial_abort_reason char (128) varying;						/* holds initial abort reason, for ABT message */

dcl (j, i) fixed bin(24);						/* temps */

dcl (realtime_start, realtime_finish) fixed bin(71);						/* holds time of start,end of activity */
dcl (cputime_start, cputime_finish, cputime_used) fixed bin(71);						/* hold cpu time usage figures */
dcl  k fixed bin(24);
dcl  holdtime char (24);						/* holds date and time */
dcl  code fixed bin(35);						/* code returned from calls to hardcore */
dcl  gseg pointer;						/* temp ptr to gcos seg */

dcl  zero bit (2304) based (gseg);						/* used to zero slave prefix */
dcl 1 slave_prefix based (gseg),			/* slave prefix model */
    2 fault_vector (14) fixed bin(24),
    2 fill1 (9) fixed bin(24),
    2 goodies,
      3 wrapup bit (18) unaligned,			/* address of abort wrapup routine */


      3 fill2 bit (18) unaligned,
    2 fill3 (2) fixed bin(24),
    2 mme bit (36),					/* place where MME GECALL is to go */
    2 prog bit (36),				/* prog to be loaded for this activity */
    2 fill4 (2) fixed bin(24),
    2 activid bit (36),				/* activity number and job number */
    2 load_limits bit (36),				/* upper and lower load limits */
    2 fill5 (22) fixed bin(24),
    2 ident bit (360)				/* ident information from ident card (60 BCD characters) */;
dcl 1 slave_prefix_alt_1 based (gseg),
    2 fill (0:62) bit (36),
    2 spa_taskflag bit (36);


dcl 1 acla,					/* acl model for file system */
    2 userid char (32),
    2 pack,
      3 mode bit (5),				/* access  */
      3 reterr bit (13),
      3 (rb1, rb2, rb3) bit (6);

dcl 1 rta int static,
    2 msg char (21) init ("real time activity  #"),
    2 accno char (2),
    2 blanks char (4) init ("    "),
    2 time char (19),
    2 nl char (2) init ("

");

dcl 1 pta int static,
    2 msg char (26) init ("processor time activity  #"),
    2 accno char (2),
    2 blanks char (4) init ("    "),
    2 time char (19),
    2 nl char (4) init ("



");



/* FOR DEBUGGING */

dcl (
     pre_setup_stop_sw
     , pre_activity_stop_sw
     , post_activity_stop_sw
     , post_cleanup_stop_sw
     ) bit (1) aligned int static init ("0"b);

dcl  switch_name char (32) aligned;
dcl  switch_state char (4) aligned;

dcl (addr, addrel, divide, fixed, null, string, substr, unspec) builtin;

dcl (any_other, cleanup, program_interrupt) condition;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_gtss_dcls;
%page;
%include static_handlers;
%page;
%include gcos_fibs;
end gcos_run_activity_;




		    gcos_set_slave_.alm             11/05/86  1601.3r w 11/04/86  1038.8       19845



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" Provide for setting the BAR register and transfering
" into GCOS user code.
"
"	WRITTEN BY DICK SNYDER, JANUARY 31, 1973 for the 6180
"	MODIFIED BY T. CASEY, MAY 1974  TO ADD no_bar ENTRY
"	MODIFIED BY D. KAYDEN DECEMBER 1974, JUNE 1975
"	Modified by M. R. Jordan, August 1977
"
	name	gcos_set_slave_
	temp	temp
"
	entry	gcos_set_slave_
"
" dcl gcos_set_slave_ entry(new_bar,code,bar_mode);
" dcl gcos_set_slave_ entry(fixed bin(18),ptr,bit(1)aligned);
"
" Set the BAR register to the "new_bar" value.
" The right 18 bits are used (9 for bar base and 9 for bar bound).
" If "bar_mode" is "0"b execute in bar mode.
" Transfer to the code specified by pointer "code".
" Note that the pointer "code" word offset (addrel offset) is
" in relation to the bar base setting (i.e., bar-base*512+offset)
" is the offset into the Multics segment located by pointer code.
" "bar_mode" = "1"b implies do a TRA rather than TSS machine
" operation, i.e., don't run in bar mode. This nullifies any bar
" base setting.
"
gcos_set_slave_:
	push
	sprisp	sb|stack_header.bar_mode_sp save sp so signaller can reset
"				 it in case gcos uses adr6
	lda	ap|2,*		get the BAR setting
	als	18		position it
	sta	temp
	lbar	temp		set the BAR
	eppbp	ap|4,*		get the ptr
	eppbp	bp|0,*		..

	stz	sp|stack_frame.entry_ptr  make stack traces look nice
	stz	sp|stack_frame.entry_ptr+1
	szn	ap|6,*		test no bar switch
	tmi	bp|0		bit on means do tra instead of tss
	tss	bp|0		transfer to the gcos program and set BAR mode
"
	entry	load_bar
"
" dcl gcos_set_slave_$load_bar entry(new_bar);
" dcl gcos_set_slave_$load_bar entry(fixed bin(18));
"
" Perform just the BAR register setting, "new_bar" treated the
" same as for the gcos_set_slave_ entry.
"
load_bar:
	push
	lda	ap|2,*		get the BAR setting
	als	18		position it
	sta	temp
	lbar	temp		set the BAR
	return		that's it
"
	include	stack_header
"
	include	stack_frame
	end




		    gcos_sysout_writer_.pl1         09/09/83  1400.3rew 09/09/83  1007.1       95328



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_sysout_writer_: proc;

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

/* PROCEDURE TO SEND SYSOUT FILES TO PRINTER OR CARD PUNCH

   Calls gcos_sysprint and gcos_syspunch commands to translate files from BCD
   to Multics-usable format (Multics ASCII for printer, RAW mode for punch).

   Calls dprint and dpunch commands (if necessary) to place converted files on
   daemon output queues.

   We use cu_$cp to call these commands. This has two side effects:
   
   1) ABBREV  may  be used to supply default arguments to these commands
   (e.g.  -he -ds), and
   
   2)  the  search  rule  "referencing  directory" will not find gcos_sysprint
   or gcos_syspunch, even if they are  in  the  same  directory  as  the  gcos
   simulator.

*/
%page;
/*

   WRITTEN BY T. CASEY	MAR 73
   MODIFIED BY T. CASEY	APR 74
			AUG 74
   MODIFIED BY D. KAYDEN	MAR 75
			JUN 75
   MODIFIED BY R.H. MORRISON  JUL 75
   MODIFIED BY S.C. AKERS	DEC 81	Fix "-syot_dir" ctl_arg so gsp and gspn
				look in the right place for input, and
				put the output in the working_dir.

*/
%page;
	call initialize_routine;

	do   i = save_data.sqindex-1 to 1 by -1;	/* sqindex points to first FREE spot in queue */
	     converted = "0"b;
	     call build_io_pathnames;			/* Build the pathnames for input and output files. */

	     medium = save_data.sysout_queue_media (i);	/* pick up media code */

	     if   medium = 1			/* punch file */
	     then call process_punch;
	     else if   medium = 3
		then call process_print;		/* print file */

		else do;				/* must be bad media code */
		     call com_err_ (0, "gcos",
				"Bad sysout media code; file not processed:^/^a",
				in_pathname);

		     goto next_file;
		     end;

	     if ^gcos_ext_stat_$save_data.nosave	/* if save/restart is active */
	     then do;
		save_data.sqindex = i;		/* set sysout queue index so that this entry is not */
						/* processed again */
		saved_sqindex = i;			/* and also saved value of sqindex */
		end;

	     if   delete
	     then call delete_original;

	     if   gcos_ext_stat_$save_data.gtssflag
	     then if   not_queued
		then call gcos_gtss_update_$status_update (OUTPUT_WAITING);
		else call gcos_gtss_update_$status_update (OUTPUT_COMPLETE);

	     if   ^gcos_ext_stat_$save_data.brief	/* unless told otherwise,       */
	      &   not_queued			/* print names of files not queued for daemon output */
	     then do;
		if ^printed_heading			/* print heading once PER CALL */
		then do;
		     call ioa_ ("^/GCOS sysout files NOT queued for daemon output:");
		     printed_heading = "1"b;
		     end;
		if   ^converted			/* Which name to ship to user. */
		then call ioa_ (in_pathname);
		else call ioa_ (out_pathname);
		end;
next_file:     ;
	     end;

	return;
%page;
build_io_pathnames: proc;				/* Build the input and output pathnames. */

	in_pathname = save_data.syot_dir
		  ||">"
		  ||rtrim (save_data.sysout_queue (i));

	l = length (in_pathname);			/* remember pathname length */

	out_pathname = rtrim (output_dir)
		   ||">"
		   ||rtrim (save_data.sysout_queue (i));

	return;

end build_io_pathnames;
%page;
command_error_handler: proc; 				/* Does  the dirty work when command_error
						   occurs in the syspunch,  sysprint,  dpunch,
						   or dprint routines.  */
	
	on condition (command_error);			/* Can't handle it here. */
	command_error_switch = "1"b;			/* turn on a static switch */
	call continue_to_signal_ (code);		/* and then go print normal message on terminal */
	if code ^= 0				/* can't figure why, but better say something */
	then call com_err_ (code, "gcos_sysout_writer_:", 
			     "Error while attempting to ""continue_to_signal_ command_error"" ");
	revert command_error;

	return;

end command_error_handler;
%page;
delete_original: proc;
	delete = "0"b;				/* turn off delete switch */
	call delete_$path   (syotdir,			/* directory portion of pathname */
			(save_data.sysout_queue (i)),	/* entry portion of pathname */
			"000100"b,		/* noforce,noquestion,nodirectories,segments,nolinks,nochase */
			"gcos",			/* name of caller */
			code);			/* error code */
	if code ^= 0
	then call com_err_ (code, "gcos", "while attempting to delete ^a",
			substr (in_pathname, 1, l));	/* pathname, less .raw or .list suffix */

	return;

end delete_original;
%page;
initialize_routine: proc;				/* Performs initialization chores. */


	delete, not_queued, printed_heading = "0"b;	/* Turn off the flags. */

	syotdir = save_data.syot_dir;			/* Save for "delete" call */
	output_dir = get_wdir_ ();			/* Where to put the Multics
						   printer and punch files. */

	saved_sqindex_offset = fixed (rel (addr (save_data.sqindex)))
			   - fixed (rel (addr (gcos_ext_stat_$save_data)));
	saved_sqindex_ptr = addrel (addr (restart_control.restart_data),
			        saved_sqindex_offset);

	return;

end initialize_routine;
%page;
process_print: proc;				/* Process a print file. */

	not_queued = "1"b;				/* switch turned off only if dprint called later */
	if gcos_ext_stat_$save_data.list		/* If we need to translate from bcd */
	then do;					/* then call translation command */
	     out_pathname = out_pathname || ".list";

	     varline = "gcos_sysprint " || in_pathname || " " || out_pathname;

	     if   gcos_ext_stat_$save_data.lower_case
	     then varline = varline || " -lower_case";
	     line = varline;
	     len = length (varline);
	     command_error_switch = "0"b;
	     on condition (command_error)
	     call command_error_handler;
	     call cu_$cp (addr (line), len, code);
	     revert command_error;
	     if   code ^= 0
	      |   command_error_switch
	     then do;				/* if any problem */
		call com_err_ (code, "gcos_sysout_writer_",
			     "Error in sysout conversion; original not deleted:^/^a",
			     in_pathname);

		goto next_file;
		end;

	     delete = "1"b;				/* remember to delete original */
	     converted = "1"b;
	     if   gcos_ext_stat_$save_data.dprint	/* If we're to print it */
	     then do;				/* then call dprint command */
		varline = "dprint " || gcos_ext_stat_$dpo || " " || out_pathname;
		line = varline;
		len = length (varline);

		command_error_switch = "0"b;
		on condition (command_error)
		call command_error_handler;
		call cu_$cp (addr (line), len, code);
		revert command_error;
		if   code ^= 0
		 |   command_error_switch		/* if any problem */
		then do;
		     call com_err_ (code, "gcos_sysout_writer_",
				"^/Error in sysout call; listing file not dprinted or deleted:^/^a",
				out_pathname);
		     goto next_file;
		     end;

		not_queued = "0"b;			/* file on dprint queue so turn off switch */
		end;
	     end;

	return;

end process_print;
%page;
process_punch: proc;

	not_queued = "1"b;				/* switch turned off only if dpunch called later */

	if gcos_ext_stat_$save_data.raw		/* If we're to translate from BCD */
	then do;					/* then call translation command */
	     out_pathname = out_pathname || ".raw";	/* syspunch so names its output file */
	     varline = "gcos_syspunch " || in_pathname;
	     line = varline;
	     len = length (varline);

	     command_error_switch = "0"b;
	     on condition (command_error)
	     call command_error_handler;
	     call cu_$cp (addr (line), len, code);
	     revert command_error;

	     if code ^= 0
	      | command_error_switch
	     then do;				/* if any problem, print message and go on to next file */
		call com_err_ (code, "gcos_sysout_writer_",
			     "Error in sysout conversion; original not deleted:^/^a",
			     in_pathname);
		goto next_file;
		end;

	     delete = "1"b;				/* remember to delete the original */
	     converted = "1"b;

	     if gcos_ext_stat_$save_data.dpunch		/* if to be dpunched */
	     then do;
		varline = "dpunch " || gcos_ext_stat_$dpno || " " || out_pathname;
		line = varline;
		len = length (varline);

		command_error_switch = "0"b;
		on condition (command_error)
		call command_error_handler;
		call cu_$cp (addr (line), len, code);
		revert command_error;
		if code ^= 0 | command_error_switch
		then do;				/* if problem in dpunch */
		     call com_err_ (code, "gcos_sysout_writer_",
				"Error in sysout dpunch call; output file will not dpunched or deleted:^/^a",
				out_pathname);
		     goto next_file;
		     end;

		not_queued = "0"b;			/* file on dpunch queue, so turn off switch */
		end;

	     end;

	return;

end process_punch;
%page;
/*	External Entries	*/

dcl  ioa_ ext entry options (variable);
dcl  size builtin;
dcl  com_err_ ext entry options (variable);
dcl  continue_to_signal_ ext entry (fixed bin(35));
dcl  cu_$cp ext entry (ptr, fixed bin(24), fixed bin(35));
dcl  delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin(35));
dcl  get_wdir_ entry() returns(char(168));
dcl  gcos_restart_$save ext entry;

/*	Work Variables 	*/

dcl  code			fixed bin(35);
dcl  command_error		condition;
dcl  command_error_switch	bit (1) aligned int static;
dcl  converted		bit (1);
dcl  delete		bit (1);			/* switch on if bcd file to be deleted */
dcl  in_pathname		char (168) varying;
dcl  len			fixed bin(24);
dcl  line			char (500);		/* fixed length version for cu_$cp parameter */
dcl  not_queued		bit (1);			/* switch on if "not queued" message needed for this file */
dcl  out_pathname		char (168) varying;
dcl  output_dir		char (168);
dcl  printed_heading	bit (1);			/* switch on if "not queued" heading already printed */
dcl  saved_sqindex		fixed bin (24)
			based (saved_sqindex_ptr);	/* sqindex value in save_data */
dcl  saved_sqindex_offset	fixed bin(24);
dcl  saved_sqindex_ptr	ptr;
dcl  syotdir		char (168);
dcl  varline		char (500) varying;		/* place to construct command line for cu_$cp calls */
dcl (addr, addrel, rel, index, length, substr) builtin;
dcl (i, j, l, medium) fixed bin(24);
%page;
%include gcos_ext_stat_;
%page;
%include gcos_gtss_dcls;
%page;
%include gcos_restart_control_;

end gcos_sysout_writer_;




		    gcos_time_convert_.pl1          09/09/83  1400.3rew 09/09/83  1007.1       19476



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


/* ****************************************************************************************
   ******************************************************************************************
   *
   *
   *
   *	T I M E  C O N V E R S I O N   P R O C E D U R E
   *
   *
   *  This procedure takes as an input argument a fixed bin(52) representation of
   *  time in microseconds. It converts this value to a character string of length
   *  nineteen which contains the time in minutes, seconds, and tenths
   *
   *
   *	WRITTEN BY DICK SNYDER SEPTEMBER 25,1970
   *      MODIFIED BY T.CASEY DECEMBER 1972
   *
   *
   *******************************************************************************************
   ***************************************************************************************** */
/*  */
gcos_time_convert_: proc (timeused, returntime);


dcl  returntime char (19);						/* time returned */
dcl (timeused, timework) fixed bin(52);						/* time interval */
dcl  digits (0: 9) char (1) internal static
     init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");						/* ascii 0-9 */
dcl (i, n) fixed bin(24);
dcl  v (14) fixed bin(24)int static init ((10)10, 6, 10, 0, 10);						/* divide values */

dcl (divide, mod, substr) builtin;

	returntime = "     mins   .  secs";		/* init return string */
	timework = divide (timeused, 100000, 52, 0);	/* convert to tenths of secs */

	do i = 14, 12 by -1 to 11, 4 by -1 to 1;	/* divide loop */
	     substr (returntime, i, 1) = digits (mod (timework, v (i))); /* grab digit */
	     timework = divide (timework, v (i), 17, 0);	/* reduce time */
	end;
	return;
     end gcos_time_convert_;




		    gcos_verify_access_.pl1         09/09/83  1400.3rew 09/09/83  1007.1       22167



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


/* *******************************************************************************************
   *******************************************************************************************
   *
   *
   *	Written by M. R. Jordan, October 1977
   *
   *******************************************************************************************
   ******************************************************************************************* */




gcos_verify_access_: proc (dirname, ename, fms_perms, buf_ptr, fms_code);

dcl  buf_ptr ptr;
dcl  code fixed bin(35);
dcl  dirname char (*);
dcl  ename char (*);
dcl  error_table_$no_s_permission fixed bin(35) ext;
dcl  fms_code bit (72) aligned;
dcl  fms_perms bit (6);
dcl  gcos_et_$fms_bad_cfdesc fixed bin(35) ext;
dcl  gcos_et_$fms_perms_denied fixed bin(35) ext;
dcl  gcos_et_$unimp_mme fixed bin(35) ext;
dcl  gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned);
dcl  gcos_mme_bort_$system entry options (variable);
dcl  hcs_$status_ entry (char (*), char (*), fixed bin(1), ptr, ptr, fixed bin(35));

	call hcs_$status_ (dirname, ename, 1, addr (status_info_branch), null (), code);
	if code ^= 0 & code ^= error_table_$no_s_permission then do;
	     call gcos_fms_error_ (gcos_et_$fms_bad_cfdesc, buf_ptr, fms_code);
	     return;
	end;


	goto Access (fixed (substr (fms_perms, 1, 2), 2));


Access (0):					/* none - error */

	call gcos_mme_bort_$system (gcos_et_$unimp_mme,
	     "Request for access other than read, write or read/write are not supported.");


Access (1):					/* write */
Access (3):					/* read/write */

	if (status_info_branch.mode & "01010"b) ^= "01010"b then
	     call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code);
	return;


Access (2):					/* read */

	if ^substr (status_info_branch.mode, 2, 1) then call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code);
	return;

%include status_info_branch;


     end gcos_verify_access_;




		    gcos_verify_tss_access_.pl1     09/09/83  1400.3rew 09/09/83  1007.2      143046



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

gcos_verify_tss_access_: proc (dname, ename, permissions, buf_ptr, forced_acl_flag, fms_code);

/* 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.instance), a bit is returned 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
   Changed: Mel Wilson	01/08/80 to handle multi_segment files
   and to lessen interference between an interactive user and an absentee run
   Changed: Sandy Bartlet     01/26/80 to allow SysDaemon and SysSfwr
   unlimited file access
   Changed: Sandy Bartlet	02/21/80 to fix SysDaemon/SysSfwr unlimited
   access and to fix so msf will be able to get forced acl
   Changed: Dave Ward	07/30/81 provided gtss_filat_error_status_ as internal for 9.0.

*/

dcl (dname, ename) char (*) parm;
dcl  permissions bit (6) parm;
dcl  buf_ptr ptr parm;
dcl  forced_acl_flag bit parm;
dcl  fms_code bit (72) aligned parm;
dcl 1 fms_overlay aligned based (addr (fms_code)),
    2 gcos_status bit (12) unal,
    2 pad bit (60) unal;

	forced_acl_flag = "0"b;
	call user_info_ (person, umc, acct);
	UMC = translate (umc, "QWERTYUIOPASDFGHJKLZXCVBNM", "qwertyuiopasdfghjklzxcvbnm");

	call msf_manager_$open (dname, ename, fcbptr, code);
	if code ^= 0 then do;
	     gcos_status = gtss_filact_error_status_ (code);
	     return;
	end;

	call hcs_$get_author (dname, ename, 1b, originator, code);
	if code ^= 0 then do;
	     gcos_status = gtss_filact_error_status_ (code);
	     goto bailout;
	end;

	originator = before (after (originator, "."), ".");
	if originator = umc | umc = "SysDaemon" | umc = "SysSfwr" then do;
	     a = empty ();
	     call msf_manager_$acl_list (fcbptr, addr (a), sa_ptr, null (), sa_count, code);
	     if code ^= 0 then do;
		if code = error_table_$incorrect_access then do;
		     sa_count = 0;
		end;
		else do;
		     gcos_status = gtss_filact_error_status_ (code);
		     goto bailout;
		end;
	     end;
	     found_sp = "1"b;			/* give the originator any permissions wanted */
	     sa_sp = "111"b;
	     goto check_request (bin (permissions));
	end;


	if ^gcos_ext_stat_$skip_umc then		/* "-drm smc" in gtss terms */
	     prefix_level = count ((gcos_ext_stat_$pathname_prefix), ">");
	else prefix_level = 2;			/* "-drm umc" */

	temp_dir = "";				/* trim the leading ">" */
	temp_name = after (rtrim (dname), ">");
	do i = 1 to prefix_level;			/* get the pathname prior to the umc into temp_dir */
	     temp_dir = temp_dir || ">" || before (temp_name, ">");
	     temp_name = after (temp_name, ">");
	end;

	do i = 1 to hbound (cat, 1) - 1
		while (index (temp_name, ">") ^= 0);	/* Find levels betwixt umc and files */
	     cat_dir (i) = temp_dir;
	     cat_name (i) = before (temp_name, ">");
	     temp_dir = temp_dir || ">" || before (temp_name, ">");
	     temp_name = after (temp_name, ">");
	end;

	cat_dir (i) = temp_dir;
	cat_name (i) = temp_name;
	cat_num = i;
	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), addr (a), da_ptr, null (), da_count, code);
	     if code ^= 0 then do;
		if code = error_table_$incorrect_access then
		     da_count = 0;
		else do;
		     gcos_status = gtss_filact_error_status_ (code);
		     goto bailout;
		end;
	     end;

	     found_sp, found_gp = "0"b;
	     cat.gp (i), cat.sp (i) = "NONE";
	     do j = 1 to da_count while (^found_gp | ^found_sp);
		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;
	     end;
	end;

/* Accumulate permissions through each catalog */

	have_sp = "0"b;
	working_perm = "0"b;
	do i = 1 to cat_num;
	     if ^have_sp then do;			/* no specific perms encountered yet */
		if cat.sp (i) ^= "NONE" then do;	/* just encountered first specific permissions */
		     working_perm = bit (cat.sp (i));	/* replace (override) accumulated g.p. */
		     have_sp = "1"b;		/* switch to spec. perm. */
		end;
		else if cat.gp (i) ^= "NONE" then
		     working_perm = working_perm | bit (cat.gp (i)); /* accumulate g.p. */
	     end;

	     else do;				/* have previously switched to specific permissions */
		if cat.sp (i) ^= "NONE" then
		     working_perm = bit (cat.sp (i));	/* new s.p. override old */
	     end;
	end;

	found_sp, found_gp, sa_sp, sa_gp = "0"b;
	a = empty ();				/* Look at segment acl */
	call msf_manager_$acl_list (fcbptr, addr (a), sa_ptr, null (), sa_count, code);
	if code ^= 0 then do;
	     if code = error_table_$incorrect_access then
		sa_count = 0;
	     else do;
		gcos_status = gtss_filact_error_status_ (code);
		goto bailout;
	     end;
	end;
	do i = 1 to sa_count while (^found_gp | ^found_sp);
	     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;
	end;

	goto check_request (bin (permissions));		/* convert gcos to multics access */


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. */
	goto bailout;


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:

/* Check requested permissions vs accumulated permissions */
	if found_sp then do;			/* honour specific perms on file */
	     if (^mu_need | sa_sp) ^= "111"b then
		goto permission_denied;
	end;
	else if have_sp then do;			/* honour specific perms on containing catalog */
	     if (^gc_need | working_perm) ^= (10)"1"b then
		goto permission_denied;
	end;
	else if ((^mu_need | sa_gp) ^= "111"b)
	& ((^gc_need | working_perm) ^= (10)"1"b) then
	     goto permission_denied;			/* no general permissions */

/* HAVE accumulated enough permissions thru catalogs. */
	do i = 1 to sa_count;			/* check for relevant acl on file */
	     call match_star_name_ (get_group_id_ (), sa_name (i), code);
	     if code = 0 then
		goto found_acl_match;
	end;
	goto force_access;				/* no matching acl - go force what we want */

found_acl_match:
	if (^mu_need | substr (sa_modes (i), 1, 3)) ^= "111"b then
	     goto force_access;

permission_granted:
	gcos_status = "4000"b3;			/* Successful. */
bailout:
	call msf_manager_$close (fcbptr);
	return;


permission_denied:
	call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code); /* Permissions denied. */
	goto bailout;


force_access:
	force_name, force_dir_name = get_group_id_ ();
	force_modes = mu_need;
	force_dir_modes = "111"b;
	call hcs_$add_dir_acl_entries (dname, ename, addr (force_dir_acl), 1, code);
	if code ^= 0 then
	     if code ^= error_table_$nondirseg then do;
		gcos_status = gtss_filact_error_status_ (code);
		goto bailout;
	     end;
	call msf_manager_$acl_add (fcbptr, addr (force_acl), 1, code);
	if code ^= 0 then do;
	     gcos_status = gtss_filact_error_status_ (code);
	     goto bailout;
	end;
	forced_acl_flag = "1"b;
	goto permission_granted;

check_forced_access: entry (dname, ename, forced_acl_flag);

/* Remove forced acl, if set. */

	if forced_acl_flag then do;
	     dl_name, force_dir_name = get_group_id_ ();
	     force_dir_modes = "111"b;
	     call hcs_$add_dir_acl_entries (dname, ename, addr (force_dir_acl), 1, code);
	     call msf_manager_$open (dname, ename, fcbptr, code);
	     if code ^= 0 then
		return;
	     call msf_manager_$acl_delete (fcbptr, addr (dl_array), 1, code);
	     call msf_manager_$close (fcbptr);
	     call hcs_$delete_dir_acl_entries (dname, ename, addr (dl_array), 1, code);
	end;
	return;

count:	proc (in_string, target) returns (fixed bin);
dcl (in_string, target) char (*) parm;

	     j = 1;
	     k = 0;
	     do while (index (substr (in_string, j), target) ^= 0);
		j = j + index (substr (in_string, j), target) + length (target) - 1;
		k = k + 1;
	     end;

	     return (k);


dcl (j, k) fixed bin(24);

dcl (after, index, length, substr) builtin;
	end count;
%page;
/* FOLLOWING PROCEDURE IS FROM gtss MODULES.
   INCLUDED AS AN INTERNAL PROCEDURE TO RESOLVE
   EXTERNAL REFERENCES FOR RELEASE 9.0. IN THE
   FUTURE THIS SHOULD BE MADE AVAILABLE TO BOTH
   SIMULATORS (dbw 07/30/81).
*/
gtss_filact_error_status_: proc (code) returns (bit (12));

dcl  code fixed bin (35);

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

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

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

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

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

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

	end gtss_filact_error_status_;

dcl  a area (1000) ;
dcl  acct char (32);
dcl 1 cat (10),
    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(24);
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  fcbptr ptr init (null ());
dcl 1 force_acl,
    2 force_name char (32),
    2 force_modes bit (36),
    2 mbz bit (36) init ("0"b),
    2 force_code fixed bin(35);
dcl 1 force_dir_acl,
    2 force_dir_name char (32),
    2 force_dir_modes bit (36),
    2 force_dir_code fixed bin(35);
dcl (found_gp, found_sp) bit (1);
dcl  gc_need bit (10);
dcl  gp_result bit (10);
dcl  have_sp bit;
dcl (i, j) fixed bin(24);
dcl  mu_need bit (3);
dcl  originator char (32);
dcl  person char (22);
dcl  prefix_level fixed bin(24);
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(24);
dcl  sa_gp bit (3);
dcl  sa_ptr ptr;
dcl  sa_sp bit (3);
dcl  sp_result bit (10);
dcl  temp_dir char (168) varying;
dcl  temp_name char (168) varying;
dcl (umc, UMC) char (9);
dcl  working_perm bit (10);


dcl  gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned);
dcl  gcos_mme_bort_$system entry options (variable);

dcl (
     gcos_et_$fms_bad_cfdesc,
     gcos_et_$fms_perms_denied,
     gcos_et_$unimp_mme
     ) fixed bin(35) ext;


%include gcos_ext_stat_;



dcl
    (error_table_$incorrect_access,
     error_table_$nondirseg
     ) fixed bin(35) ext;

dcl  get_group_id_ entry returns (char (32));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$get_author entry (char (*), char (*), fixed bin(1), char (*), fixed bin(35));
dcl  hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$list_dir_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin(24), fixed bin(35));
dcl  match_star_name_ entry (char (*), char (*), fixed bin(35));
dcl  msf_manager_$acl_add entry (ptr, ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$acl_delete entry (ptr, ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin(35));
dcl  user_info_ entry (char (*), char (*), char (*));


dcl (after, before, bin, bit, empty, index, null, rtrim, substr, translate) builtin;
     end gcos_verify_tss_access_;




		    gcos_write_.pl1                 09/09/83  1400.3rew 09/09/83  1007.2      187056



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_write_: proc (filecode, record, reportcode);

/*
   *  This  procedure  is  called  to write a record on a gcos file.
   *
   *  The main entry point expects an ASCII string, which will be converted to BCD,
   *  and put into a GCOS standard system format record. Certain  special  ascii
   *  characters are recognized and are converted to printer control information.
   *  Newline characters are converted to  octal  7701  (skip  one  line).  If  n
   *  contiguous  newlines  are  encountered,  then  a control sequence of 77n is
   *  produced (skip n lines). Page characters (octal 014) are converted  to  7720
   *  (skip  to  head of form).   Note that gcos_write_ does not actually do this
   *  conversion, but instead, it is done by a subroutine  (gcos_cv_printline_gebcd_).
   *
   *  A search of the filecode table is made to match the filecode to an existing  fib.  If
   *  no  match  is  found,  a file is opened and a fib is built. This is done by
   *  gcos_open_file_, and gcos_attach_file_. This is only done for those
   *  entry points that use the filecode to specify the file.
   *
   *  Since records are written in GCOS standard format, multiple records are
   *  packed  into  320  word  blocks.  These blocks are written to the specified
   *  files using ios_.
   *
   *  If  the  length  of
   *  the record to be written is 0, an end of file record will be written.  This
   *  is a record with length 0 and the end of file code (170000)  in  the  lower
   *  half  of the record header word (the upper half containing the length).
   *  The buffer is then written out.
   *
   *
   *  ADDITIONAL ENTRY POINTS:
   *
   *  $ptr	-same as main entry, except that the file is specified by a
   *		 fib pointer.
   *
   *  $force	-forces a partially-filled buffer for the specified filecode
   *		 to be written out to the file. An empty buffer is not written out.
   *
   *  $force_ptr	-same as $force, except that the file is specified by a
   *   		 fib pointer.
   *
   *  $bcd	-writes a BCD string onto the given stream, in a GCOS record.
   *
   *  $bcd_ptr	-same as $bcd above, except that the file is specified by
   *		 a fib pointer.
   *
   *  $ascii_ptr	-writes a GCOS record, containing the ASCII characters from the
   *		 input string. Turns on bit 27 (counting from zero) of the rcw,
   *		 if bits 28 and 29 are not both zero, and bit 26 if they are zero,
   *		 thus allowing media codes 5, 6, 7, and 8 to be specified.
   *		 Pads last word with ASCII pad characters (octal 177).
   *		 The file is specified by a pointer to the fib.
   *
   *
   *  The above entries all construct a rcw and place it before the data in the record.
   *
   *
   *
   *  The following entries assume the record already starts with a rcw (or bcw, for $block).
   *
   *  $record	-writes gcos record, complete with rcw, without changing
   *		 anything in it. reportcode is ignored, but must be supplied
   *		 in the call (and should be (8)"0"b).
   *		 record should be char(*), with * being 4 times
   *		 the word length of the record, including the rcw.
   *
   *		 Since the contents of the record and the rcw are not
   *		 examined or changed, but merely copied into the output buffer,
   *		 this entry can be used to write more than one record per call,
   *		 by overlaying the records with a char(*) argument of the
   *		 correct length. This is done by gcos_mme_syot_.
   *
   *
   *  $record_ptr	-same as $record, except that the file is specified
   *		 by a fib pointer.
   *
   *  $print_bcd_card -writes gcos record, supplied as above, but modifies it as follows:
   *		 it assumes it is a bcd card (14 data words in record) and it
   *		 puts octal 7701 (bcd newline) into last word, in "columns" 81-82.
   *		 It puts reportcode into the rcw that it is passed. reportcode
   *		 should begin with "11"b (media code for bcd printlines).
   *		 BCD ! (77) and ? (17) are escaped by preceeding them with 7777.
   *		 All modifications are made to the copy in the write buffer,
   *		 so the copy passed by the caller is preserved.
   *
   *  $print_bcd_ptr -same as $print_bcd_card except that file is specified
   *		 by a pointer to the fib.
   *
   *  $block	-writes a full block (up to 320 words). If there are any records in
   *		 the buffer for the given filecode, that buffer is written out first. The
   *		 length and serial number are put into the bcw, in the caller's copy of the
   *		 block. The block must be passed as a char(*) variable, with * being exactly
   *		 4 times the word length of the block, including the bcw.
   *
   *  $block_ptr	-same as $block, except that the file is specified
   *		 by a fib pointer.
   *
   *	INPUT PARAMETERS:
   *	either:	filecode--filecode of file to be written on.
   *	or:	fib_ptr--pointer to fib of file to be written on
   *		record--record to be written.
   *		reportcode--8 bits used as: media code (2 bits) and report code (6 bits).
   *			(thus the 4 bit ascii media codes are not presently supported -
   *			EXCEPT for the $ascii_ptr, $record and $record_ptr entries.)
   *
   */
%page;
/*
   Author: DICK SNYDER AUGUST 10,1970
   Change: T. CASEY JUNE 1973, NOVEMBER 1973, FEBRUARY 1974, APRIL 1974,  AUGUST 1974
   Change: D. KAYDEN  APRIL 1974, JULY 1974, DECEMBER 1974
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	08/14/81 reorganized. Arrayed form of fibs.
*/
%page;
dcl  fib_ptr                  ptr parm;
dcl  filecode                 char(*) parm	/* file code of file to be written */;
dcl  record                   char(*) parm	/* record to be written */;
dcl  reportcode               bit(8) parm	/* record type and report code */;

/* Come here from all entry points that take filecode (except $force)
   to look up the fib by filecode, and open the file if the fib is not found */

main: ;


/* 	Look for fib to match file code 			 */

	if look_up_filecode () then return;		/* internal procedure */

/* Come here from all entries that take a fib pointer (except $force_ptr),
   to provide a buffer if necessary, and write a record on the file, but bypassing
   the the opening of the file if the fib is not found; when a fib pointer is
   specified, the file must be open.		*/

setbuf: ;
	call setup;

	if length (record) = 0 then do;

/*
   Come here if length of record to be written is 0. Write a
   filemark record (000000170000 octal) in the block if the
   device is disk or drum. If tape, write an eof followed by
   a trailer and another eof.
*/
	     if ^fib.tape then do;			/* if not a tape */
		buf (fib.rec_len) = "000000170000"b3;	/* put eof mark */
						/* in record header (bits 18-23). */
						/* Rest of header = 0's  */
		fib.rec_len = fib.rec_len + 1;	/* and increment length of record */
	     end;

	     call write_fib_block;			/* go write the block */

	     if fib.tape then do;			/* writing on tape? */

		call ios_$order ((fib.stream), "eof", null, status); /* write eof */
		if code ^= 0 then			/* all errors fatal */
wr_err:		     ;
		call gcos_error_ (code, "^a^/stream=^a", fib.pathnm, fib.stream);

		trailer.blk_count = block.num -1;	/* put no blocks written in trailer */
		call ios_$write ((fib.stream), addr (trailer), 0, 14, i, status); /* write eof trailer */
		if code ^= 0 then goto wr_err;	/* all errors fatal */

		call ios_$order ((fib.stream), "eof", null, status); /* write another eof */
		if code ^= 0 then goto wr_err;	/* all errors fatal */
	     end;

	     return;
	end;

	lenrec = divide (length (record)+3, 4, 17, 0);


/* 	set up for translation of ASCII data to BCD. Subroutine gcos_cv_printline_gebcd_ */
/* 	will translate the message and move it to the buffer. It will also */
/* 	transform newlines and newpages into proper BCD escape codes  */

	inp = addr (record);			/* get address of input record */

	if ^acisw then				/* if we don't want an ASCII record */
	     if ^bcdsw then do;			/* and we don't have a BCD record */

/* if any of the above, copy the input record directly into the buffer,
   omitting the ASCII to BCD translation */


/* Since we are here, none of the above was true, so translate to BCD */

		call gcos_cv_printline_gebcd_ (inp, length (record), addr (temp_buf), i);
		lenrec = divide (i+5, 6, 17, 0);
		inp = addr (temp_buf);		/* get pointer to the BCD string */
	     end;

print_join: ;

	if lenrec >= 319 then do;			/* test for long record */
	     code = gcos_et_$record_too_long;
	     goto wr_err;
	end;

	if fib.rec_len + lenrec >= 319 then call write_fib_block; /* write current block if new rec won't fit */

	rcwp, outp = addr (buf (fib.rec_len));		/* addr of slot in buffer for this record */

	if ^gcossw then outp = addrel (outp, 1);	/* leave room for rcw, unless its there already */

	outstring = instring;			/* copy record into buffer */

	if gcossw then do;				/* if we have a gcos record, with rcw already in it */

	     lenrec = lenrec - 1;			/* don't count the rcw in the length */

/* INCODE PROCESSING:

   All BCD card images (which may have been originally created by reading cards punched
   in other than GEBCD card codes) are written onto files by calls to gcos_write_$record.

   That entry turns on gcossw. Therefore, if gcossw is on
   and the media code is "10" (BCD card) and gcos_ext_stat_$incode is nonzero,
   we want to go through the record we just put into the buffer, looking for any of the
   six characters that can be different, and translate them into the proper GEBCD codes. */

	     if gcos_ext_stat_$incode ^= 0 then		/* If incode translation is in effect */
		if rcw.media_code = "0010"b then	/* and we have a BCD card */
		     call gcos_incode_ (addrel (inp, 1), lenrec * 6, addrel (outp, 1));

	end;

	else do;

/* Create record header (rcw) consisting of length and record type and reportcode */

	     rcwp -> word = "0"b;			/* clear out the rcw */
	     rcw.length = lenrec;			/* fill in record length */

	     substr (rcwp -> word, 29, 8) = reportcode;	/* fill in media and report codes */

	     if acisw then do;			/* if $ascii entry, fix up several parts of the record */

		if rcw.media_code = "0"b then		/* if we want ascii media code 8 */
		     substr (rcw.media_code, 1, 1) = "1"b; /* make it 8 ("1000"b) */
		else substr (rcw.media_code, 2, 1) = "1"b; /* else make it 5, 6, or 7 ("01xx"b) */

		acipad = mod (length (record), 4);	/* see if they partially fill the last word */

		if acipad > 0 then			/* if last word is only partially filled */
		     substr (outp -> acistring, length (record)+1, 4-acipad) = substr (pads, 1, 4-acipad);
						/* fill rest of it with pad (177) chars */
	     end;
	end;

	fib.rec_len = fib.rec_len+lenrec+1;		/* compute new length of block */
	return;
%page;
print_bcd_card: entry (filecode, record, reportcode);

/* print bcd card image. 7701 is appended to card, and rcw is modified using reportcode argument */

	goto print_common;
%page;
print_bcd_ptr: entry (fib_ptr, record, reportcode);

/* print bcd card image, but with fib pointer argument */

	fibptr = fib_ptr;
print_common: ;
	call setup;

/* EDITP PROCESSING

   The following code searches the record just written for the BCD characters
   ! (77) and ? (17), which have special meaning for printed output. In order
   to be taken literally and just printed, they must be preceeded by the BCD
   escape sequence, which is two !'s (7777). Since this procedure is called to
   write all sorts of records on gcos files, some of which will later be printed,
   and some of which will be read by gcos slave programs, and the escapes are
   only proper in print files, this code is only entered when the $print_bcd_card
   entry was used.

   */

	inp = addrel (addr (record), 1);
	outp = addr (temp_buf);
	j = 0;
	do i = 1 to 80;

	     if bcd.char = "17"b3 |			/* 17 = "?" */
	     bcd.char = "77"b3 then do;		/* 77 = "!" */
		bcd2.chars = "7777"b3 ;		/* 7777 = "!!" */
		outp = addr (bcd2.next);
		j = j + 2;
	     end;
	     outp -> bcd.char = bcd.char;
	     inp = addr (bcd.next);
	     outp = addr (outp -> bcd.next);
	     j = j + 1;
	end;
	bcd2.chars = "7701"b3 ;			/* 7701 = "!1" (bcd newline) */

	inp = addr (temp_buf);
	lenrec = divide (j+7, 6, 17, 0);
	goto print_join;
%page;
record_ptr: entry (fib_ptr, record, reportcode);

/* write gcos record (as for $record entry) but with fib pointer arg */

	gcossw = "1"b;				/* full gcos record, rcw included */
						/* fall thru to turn on bcdsw */

/* 	Enter here to write a string which is already in bcd and which	 */
/* 	already has newlines and newpages translated to their bcd equivalents */


bcd_ptr:	entry (fib_ptr, record, reportcode);

	bcdsw = "1"b;				/* indicate that input is in BCD */
%page;
ptr:	entry (fib_ptr, record, reportcode);

/* do the same as the primary entry, given a fib pointer */

/* Come here from $ascii_ptr entry */
ptr_common: ;
	fibptr = fib_ptr;

	goto setbuf;
%page;
ascii_ptr: entry (fib_ptr, record, reportcode);

/* write a record containing the ascii input string, untranslated */

	acisw = "1"b;				/* remember we entered here */

	goto ptr_common;				/* go set fib pointer */
%page;
record:	entry (filecode, record, reportcode);

/* write gcos record with no alteration at all. rcw is included in length of char(*) argument */

	gcossw = "1"b;				/* we have a full gcos record, rcw included */
%page;
bcd:	entry (filecode, record, reportcode);

/* write block of bcd words, and build rcw, but look up fib by filecode */

	bcdsw = "1"b;				/* input is bcd characters */

	goto main;				/* go look up filecoe and join main body of program */
%page;
block:	entry (filecode, record);

/* write complete 320 word block */

	if look_up_filecode () then return;

writing_block: ;
	call setup;
	if fib.rec_len > 0 then			/* if there is anything in the buffer */
	     call write_fib_block;			/* go write it out first */

	blockptr = addr (record);
	blockptr -> block.num = block.num;		/* copy current bsn into bcw of block to be written */

/* Compute word length of block and put it where write_block expects to find it. */

	fib.rec_len = blockptr -> block.length;

	call write_block;				/* go write the block */

	return;					/* that's all */
%page;
block_ptr: entry (fib_ptr, record);

/* write complete 320 word block, but with fib pointer arg
*/

	fibptr = fib_ptr;
	goto writing_block;


/* 	Enter here to force out buffer for file specified in filecode.	 */
/* 	Do not force if buffer is null or rec_len = 0 which		 */
/* 	indicates that buffer was just written out.		 */

force:	entry (filecode);

	if look_up_filecode () then return;


	goto force_common;
%page;
force_ptr: entry (fib_ptr);

/* 	Enter here to force out buffer for file associated with the	 */
/* fib pointed to by fibptr. */

	fibptr = fib_ptr;

force_common: ;
	if fib.buffer ^= null then			/* and there is a buffer */
	     if fib.rec_len ^= 0 then			/* and it is not empty */
		call write_fib_block;		/* write it out */

	return;
%page;
look_up_filecode: proc () returns (bit (1));

/* look up a fib by filecode
   Return "1"b if file not to be written.
*/

	     do i = 1 to hbound (save_data.fibs, 1);
		if fct.filecode (i) = filecode then do;
		     if fct.sysout (i) then return ("1"b);
		     fibptr = fct.fibptr (i);		/* get pointer to fib */
		     if ^fib.gein then return ("1"b);	/* protect user files from simulator */
		     return ("0"b);
		end;
	     end;

/* 	No fib found. Create one and a file to match 	 */
	     call gcos_open_file_ (filecode, "", fibptr, sw); /* initialize a fib for the specified filecode */
	     fib.gein = "1"b;			/* file for slave use - a gein file */
	     return ("0"b);
	end look_up_filecode;
%page;
setup:	proc;

/* allocate a working buffer if necessary */
	     if fib.buffer = null then do;		/* buffer provided yet? */
		k = index (string (fib_buffers.buffer_in_use), "0"b);
		if k = 0 then do;
		     call gcos_error_ (		/* No buffers available. */
			0
			, "Exceeded ^i file buffers provided."
			, hbound (fib_buffers.buffer_in_use, 1)
			);
		     return;
		end;
		fib_buffers.buffer_in_use (k) = "1"b;	/* Mark buffer in use. */
		fib.buffer_indx = k;
		fib.buffer = addr (fib_buffers.buffer (k));

		fib.rec_len = 0;			/* block length */
		block.num = divide (fib.current, 320, 17, 0) + 1; /* set block serial number */
		if ^fib.attached then call gcos_attach_file_ (fibptr);

	     end;
	     return;
	end setup;
%page;
write_fib_block: proc;

/* write a block onto the file */
	     blockptr = fib.buffer;			/* pointer to the block to be written */
	     blockptr -> block.length = fib.rec_len;	/* put length into bcw */

write_block:   entry;

/* entry with blockptr already set. */

	     if fib.tape then write_count = fib.rec_len + 1; /* write only used words in block on tape */
	     else write_count = 320;			/* write max words per block to disk */
	     fib.rec_len = 0;			/* reset block length */

	     call ios_$write ((fib.stream), blockptr, 0, write_count, i, status); /* write record */

	     if code ^= 0 then goto wr_err;		/* fatal write error */

/* 	Bump serial number in buffer header (bits 1-17) by one	 */

	     block.num = block.num + 1;

	     fib.current = fib.current + write_count;	/* bump curr rec no */
	     if fib.current > fib.size then		/* grow file size if necessary */
		fib.size = fib.size + 3840;		/* grow file one link */

	     return;				/* return from internal procedure */

	end write_fib_block;
%page;
/*   Variables for gcos_write_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  acipad                   fixed bin(24)	/* number of pad chars needed to finish ascii rec */;
dcl  acistring                char(1044480) based;
dcl  acisw                    bit(1)init("0"b)	/* => $ascii entry. */;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  bcdsw                    bit(1)init("0"b)	/* => $bcd entry. */;
dcl  blockptr                 ptr;
dcl  divide                   builtin;
dcl  gcossw                   bit(1)init("0"b)	/* => $record entry. */;
dcl  gcos_attach_file_        ext entry (pointer);
dcl  gcos_cv_printline_gebcd_ ext entry (ptr, fixed bin(21), ptr, fixed bin(21));
dcl  gcos_error_              ext entry options (variable);
dcl  gcos_et_$record_too_long fixed bin(35) ext;
dcl  gcos_incode_             ext entry (ptr, fixed bin(24), ptr);
dcl  gcos_open_file_          ext entry (char(*), char(*), pointer, bit(1));
dcl  i                        fixed bin(21);
dcl  index                    builtin;
dcl  inp                      ptr;
dcl  instring                 (lenrec) fixed bin(24)based (inp)	/* input string */;
dcl  j                        fixed bin(24);
dcl  k                        fixed bin;
dcl  length                   builtin;
dcl  lenrec                   fixed bin(17)	/* length in words of record  */;
dcl  mod                      builtin;
dcl  null                     builtin;
dcl  outp                     ptr;
dcl  outstring                (lenrec) fixed bin(24)based (outp)	/* output string */;
dcl  pads                     char(4) int static init("")	/* four ASCII pad (177) chars */;
dcl  putp                     ptr;
dcl  rcwp                     ptr;
dcl  substr                   builtin;
dcl  sw                       bit(1)	/* switch used in open call */;
dcl  temp_buf                 (350) fixed bin(24);
dcl  word                     bit(36) aligned based;
dcl  write_count              fixed bin(21)	/* no of words to write */;	;

dcl 1 block	aligned based (fib.buffer),		/* overlay for buffer */
      2 num	fixed bin(18)unsigned unaligned,	/* block number */
      2 length	fixed bin(18)unsigned unaligned,	/* block length */
      2 buf	(0:318) bit(36)			/* remainder of block */
;

dcl 1 trailer	int static			/* model of eof trailer */
,     2 eoftrailer	bit(36) init( "202546262020"b3 )	/* bEOFbb */
,     2 blk_count	fixed bin(24) init(0)		/* block count for file */
,     2 junk	(12)bit(36) init((12)(1)"0"b)		/* remainder of label record. */
;

dcl 1 rcw		aligned based (rcwp),
      2 length	fixed bin(18)unsigned unaligned,			/* record length */
      2 eof	bit(6) unaligned,
      2 zeros	bit(2) unaligned,
      2 media_code	bit(4) unaligned,
      2 report_code	bit(6) unaligned;

dcl 1 bcd		unaligned based (inp),
      2 char	bit(6) unaligned,
      2 next	bit(6) unaligned;

dcl 1 bcd2	unaligned based (outp),
      2 chars	bit(12) unaligned,
      2 next	bit(6) unaligned;
%page;
%include gcos_fibs;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dcl_ios_;
     end gcos_write_;




		    gcos_write_to_er_.pl1           09/09/83  1400.3rew 09/09/83  1007.3       24651



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	G C O S   W R I T E   T O   E R
   *
   *
   *	This procedure is called to write messages on the execution report
   *	of the executing GCOS job.  Its arguments are the same as ioa_.
   *	Multiple line messages are handled and case is preserved.
   *
   *
   *	Written by M. R. Jordan,  August 1977
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_write_to_er_: procedure ();



dcl  NL char (1) static int options (constant) init ("
");
dcl  arg_list_ptr ptr;
dcl  cu_$arg_count entry (fixed bin(24));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  gcos_write_$ascii_ptr entry (ptr, char (*), bit (8));
dcl  index builtin;
dcl  ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1));
dcl  len fixed bin(24);
dcl  nargs fixed bin(24);
dcl  rtn_string char (257);
dcl  rtn_string_len fixed bin(24);
dcl  start fixed bin(24);
dcl  substr builtin;

/*

   If called with no arguments, return imediately.

*/


	call cu_$arg_count (nargs);
	if nargs <= 0 then return;


/*

   Get ready and call ioa_ to format the message.

*/


	call cu_$arg_list_ptr (arg_list_ptr);
	call ioa_$general_rs (arg_list_ptr, 1, 2, rtn_string, rtn_string_len, "0"b, "1"b);


/*

   If the returned string does not contain any useful information, then just quit.

*/


	if rtn_string_len = 0 then return;
	if substr (rtn_string, 1, rtn_string_len) = "" then return;


/*

   Now write the message to the execution report one line at a time.

*/


	start = 1;
	do while (rtn_string_len > 0);
	     len = index (substr (rtn_string, start, rtn_string_len), NL);
	     if len = 0 then len = rtn_string_len;
	     call gcos_write_$ascii_ptr (gcos_ext_stat_$er, substr (rtn_string, start, len), "11111100"b);
	     start = start+len;
	     rtn_string_len = rtn_string_len-len;
	end;


	return;

%include gcos_ext_stat_;


     end gcos_write_to_er_;


*/
                                          -----------------------------------------------------------


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

*/
