



		    gcos_mme_bort_.pl1              09/09/83  1404.1rew 09/09/83  1007.3      109548



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


/* 
   ********************************************************************************
   ********************************************************************************
   *
   *
   *	M M E   G E B O R T
   *
   *  MME GEBORT is used to abort the execution of the current slave activity
   *  by the user.	The abort code passed in the Q register is used in messages
   *  displayed on the execution report and at the users terminal.
   *
   *  This module also processes requests from the GES system to abort the
   *  slave activity.  These requests are handled by .mbrt1,3 in real GCOS.
   *  This entry (gcos_mme_bort_$system) is called passing some system defined
   *  error code (from gcos_et_).  The short message associated with this error
   *  code is the GCOS system abort number which is to be placed in the
   *  slave prefix.
   *
   *  After the processing of the appropriate abort request, gcos_mme_bort_ will
   *  fill in the proper words in the slave prefix and return to gcos_run_activity_
   *  by way of a non-local goto through gcos_ext_stat_$mme_rtrn.
   *
   *	CALLING SEQUENCE:
   *
   *	MME	GEBORT
   *
   *	C(Q) 24-35	BCD abort code
   *
   *
   *	WRITTEN BY DICK SNYDER, 1971.
   *	MODIFIED BY T. CASEY - DECEMBER 1973, MARCH 1974, AUGUST 1974.
   *	Modified by M. R. Jordan, January 1977, August 1977
   *	Modified by S. C. Akers, December 1981. Change \014 to %page;
   *					Fix bug to stuff abort reason
   *					and address of faulting instruction
   *					in Word 13 (octal) of slave prefix.
   *
   ********************************************************************************
   ********************************************************************************
*/
%page;
gcos_mme_bort_: procedure (mcp, increment);
/* 


   The data item gcos_ext_stat_$termination_code is of special importance in that it tells the user
   what type of abort (system or user) and exactly which abort he got.  This information
   is typicaly used in a wrapup routine to make decisions.	The data item
   is declared as a bit(18).	The following assignments are made within it:

   0-3	MBZ
   4-5	=1 system abort; =2 user abort
   6-17	system abort number or user abort code (BCD)

*/
%page;
/* 

   This entry will be called as a result of a MME GEBORT in a slave activity.
   After extracting the abort code from the Q register, a message will be
   printed at the users terminal and wrapup will be looked into.

*/

	substr (abort_code, 1, 1) = xlate (fixed (substr (mc.regs.q, 25, 6), 7));
	substr (abort_code, 2, 1) = xlate (fixed (substr (mc.regs.q, 31, 6), 6));

/* 

   Set the termination code to reflect the specified abort code and the
   fact that this is a GEBORT rather than a fault.

*/

	substr (gcos_ext_stat_$termination_code, 1, 6) = "000010"b;
	substr (gcos_ext_stat_$termination_code, 7, 12) = substr (mc.regs.q, 25, 12);

/* 

   Now print a message at the users terminal and continue.

*/

	gcos_ext_stat_$abort_reason = "Users " || abort_code || " MME GEBORT.";
	call ioa_$ioa_stream ("error_output", "^a", gcos_ext_stat_$abort_reason);
	goto continue_termination;
%page;
/* 

   The following entry provides for system termination of the slave
   activity due to a system detected error.  This entry expects a
   code  from the gcos_et_ (or any valid error table code) as its first
   argument.  The remaining arguments are passed to ioa_ for printing.

*/
%page;
system:	entry (abort_ecode);

	ecode = abort_ecode;

system_error: ;

/* 

   Prepare the termination code value from the information given
   in the gcos error table (gcos_et_).

*/


	call get_abort_info ();
	substr (gcos_ext_stat_$termination_code, 1, 6) = "000001"b;
	substr (gcos_ext_stat_$termination_code, 7, 12) = substr (addr (abort_number) -> bit36, 25, 12);

/* 

   Now prepare the message for the user to tell him what went wrong.
   The message consists of the long message from the gcos_et_ and an
   additional message formatted from the remaining arguments passed to
   gcos_mme_bort_$system.

*/

	call ioa_$ioa_stream ("error_output", "^a", long_message);
	call cu_$arg_count (nargs);
	if nargs > 1 then do;
	     call cu_$arg_list_ptr (arg_list_ptr);
	     call ioa_$general_rs (arg_list_ptr, 2, 3, rtn_string, rtn_string_len, "0"b, "0"b);
	     if rtn_string_len > 0 then
		if substr (rtn_string, 1, rtn_string_len) ^= "" then
		     call ioa_$ioa_stream ("error_output", "^a", substr (rtn_string, 1, rtn_string_len));
	end;


/* 

   Now pass the abort message on to gcos_run_activity_ by continuing.

*/


	gcos_ext_stat_$abort_reason = rtrim (long_message);
	goto continue_termination;
%page;
abort_number: entry (abort_ecode, return_code);


	ecode = abort_ecode;
	call get_abort_info ();
	return_code = abort_number;

	return;
%page;
continue_termination:;

/* 

   Set up pointers needed later.

*/

	scup = addr (gcos_ext_stat_$mc.scu);


/* 

   Initialize the proper locations in the slave prefix.  Some of the
   values to be set are offset by 1 if the most recent termination
   occured during wrapup.

*/


	slave_prefix_ptr = gcos_ext_stat_$gcos_slave_area_seg;
	slave_prefix.word_30 = (36)"0"b;
	slave_prefix.words_60_thru_65 = (216)"0"b;
	if gcos_ext_stat_$save_data.wrapup then slave_prefix_ptr = addrel (slave_prefix_ptr, 1);
	slave_prefix.termination_info = gcos_ext_stat_$termination_code;
	slave_prefix.ic_and_i = addr (scu.ilc) -> bit36;
	slave_prefix.ic_value = scu.ilc;

/* 

   Now if the user has specified the -debug control argument, do it.

*/


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


/* 

   Prepare to return to gcos_run_activity by setting the activity abort
   flag and the "run only compilations till next $ BREAK" flag.  Bit 5
   of the program switch word gets reset and the abort code is passed
   back to gcos_run_activity.

*/


	gcos_ext_stat_$save_data.this_act_abort = "1"b;
	gcos_ext_stat_$save_data.prev_act_abort = "1"b;
	substr (save_data.psw, 6, 1) = "0"b;
	goto gcos_ext_stat_$mme_rtrn;
%page;
/* 

   This entry is called to inform the user of a bad MME number in his
   program.  This is an i1 system abort.

*/


not_imp:	entry (mcp, increment, mme_number);


	if mme_number = 0 then
	     call gcos_mme_bort_$system (gcos_et_$unimp_mme, "0 is not a valid MME number.");
	else
	call gcos_mme_bort_$system (gcos_et_$unimp_mme, "GE^a", MME_NAME (mme_number));
%page;
/* 

   This entry process run-time "system" detected fatal errors.
   The calling sequence is essentially options(variable), but the first
   argument must be a char(2) for the abort code.  Other arguments that
   follow are passed to ioa_ to be printed.

*/


simulator: entry (code);

	abort_code = code;
	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 */
	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 goto continue_termination;	/* 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 = fixed (i-2, 18);
	     do j = divide (ii+4, 2, 18, 0) to ii+2;	/* 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 */
	gcos_ext_stat_$termination_code = "000001000000000000"b;
	gcos_ext_stat_$abort_reason = abort_code;
	goto continue_termination;


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);
dcl  code char (*);
dcl  cu_$gen_call ext entry (entry, pointer);
dcl  cu_$stack_frame_ptr ext entry (pointer);
dcl  divide builtin;
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  i fixed bin(24);
dcl  ii fixed bin(24);
dcl  j fixed bin(24);
dcl  name char (j) aligned based (z);
dcl  offset fixed bin(24);
dcl  p pointer;
dcl  pl1_frame_$name ext entry (ptr, ptr, fixed bin(24));
dcl  rel builtin;
dcl  unspec builtin;
dcl  z pointer;
%page;
get_abort_info: procedure ();


/* 

   This internal procedure obtains the short_message, long_message, and abort_number
   given the ecode value passed to  the gcos_mme_bort_ entry point that has been called.

   To begin with, using the convert_status_code_ subroutine get the message for this
   code value.

*/

	     call convert_status_code_ (ecode, short_message, long_message);

/* 

   Prepare the abort number from the ecode value.

*/

	     if substr (short_message, 1, 4) = "GCOS" then do ;
		abort_number = cv_dec_check_ (substr (short_message, 5, 4), ecode);
		if ecode ^= 0 then abort_number = 0;
	     end;
	     else abort_number = 0;

	     return;

end get_abort_info;
%page;
dcl  abort_code char (2);				/* the ASCII abort code  */
dcl  abort_ecode fixed bin(35);			/* error code value for system aborts  */
dcl  abort_number fixed bin(24);			/* GCOS system abort number  */
dcl  null builtin;
dcl  addr builtin;
dcl  addrel builtin;
dcl  arg_list_ptr ptr;				/* ptr to the system entry points arg list  */
dcl  bit36 bit (36) based;				/* a based word for bit manipulation  */
dcl  convert_status_code_ entry (fixed bin(35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_count entry (fixed bin(24));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35));
dcl  db ext entry;
dcl  ecode fixed bin(35);				/* local error code value  */
dcl  fixed builtin;
dcl  gcos_et_$unimp_mme fixed bin(35) ext;
dcl  gcos_mme_bort_$system entry options (variable);
dcl  increment fixed bin(24);				/* number of arg words to this MME  */
dcl  ioa_ ext entry options (variable);
dcl  ioa_$ioa_stream entry options (variable);
dcl  ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1));
dcl  long_message char (100) aligned;			/* long message for ecode  */
dcl  mme_number fixed bin(24);			/* the MME number for non-implemented MMEs  */
dcl  nargs fixed bin(24);
dcl  return_code fixed bin(24);			/* returned abort number for return_abort_number entry  */
dcl  rtn_string char (256);				/* output string for ioa_$general_rs  */
dcl  rtn_string_len fixed bin(24);			/* output string length from ioa_$general_rs  */
dcl  rtrim builtin;
dcl  short_message char (8) aligned;			/* short message for ecode  */
dcl 1 slave_prefix aligned based (slave_prefix_ptr),
    2 filler_1 (11) bit (36),
    2 ic_value bit (18) unal,
    2 termination_info bit (18) unal,
    2 filler_2 (6) bit (36),
    2 ic_and_i bit (36),
    2 filler_3 (5) bit (36),
    2 word_30 bit (36),
    2 filler_4 (23) bit (36),
    2 words_60_thru_65 bit (216);
dcl  slave_prefix_ptr ptr;				/* ptr to slave jobs prefix  */
dcl  substr builtin;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_mme_names;
%page;
%include gcos_xlate_bcd_ascii_;
%page;
%include query_info;

end gcos_mme_bort_;




		    gcos_mme_call_.pl1              09/09/83  1404.1rew 09/09/83  1007.3      221130



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

/*
   *  MME GECALL is used to load programs into memory. The programs may be either relocatable
   *  or absolute. Note, if dynamic library ** present, it is searched first.
   *
   *  MME GERSTR restores data saved by MME GESAVE. The data is read from the file
   *  whose filecode is in the q reqister. The calling sequence is the same as that
   *  shown for MME GECALL.
   *
   *	CALLING SEQUENCE:
   *
   *	MME	GECALL
   *	BCI	1,XXXXXX		BCD PROGRAM NAME
   *	ZERO	L(FIRST WORD),L(ERR RTRN)	PLACE TO BEGIN LOADING
   *	ZERO	L(TRANSFER),0	PLACE TO XFER CONTROL TO
   *				(IF 0, GO TO PLACE SPECIFIED
   *				IN THE PROGRAM'S DIRECTORY)
   *
   *	RETURNS:
   *
   *	C(A) 0-17			LOADING ORIGIN
   *	C(A) 18-35		NUMBER OF WORDS LOADED
   *	C(Q) 0-17			TRANSFER ADDRESS IN PGM DIR.
   *
   *	On error returns the C(Q) 18-35 contains the error code.
   *
   *	_c_o_d_e	_r_e_a_s_o_n
   *
   *	30	i3-file code not defined
   *	42	m4/n4-i/o lim. call/save
   *	43	m6/n7-i/o err. call/save
   *	46	non-random gecall file
   *	48	m6-call/rstr checksum
   *	51	m2/m3-call name missing
   *
   Author: DICK SNYDER OCTOBER 26, 1970
   Change: T. CASEY OCTOBER 1973, FEBRUARY 1974, AUGUST 1974
   Change: D. KAYDEN  APRIL 1974, JULY 1974, APRIL 1975
   Change: M. R. Jordan, September 1977
   Change: Dave Ward	05/29/81 made FB precision adequate.
*/
	scup = addr (mc.scu);			/* init pointer to scu data */
	i = instruction_counter+1;			/* get parameter loc'n */
	callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* build ptr to parameters */

/*  see if the dynamic library ** exists. if it does, search  */
/*  it first before the regular library.    */
	do i = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (i) = "**" then
		if ^fct.sysout (i) then do;
		     dylibsw = "1"b;		/* remember that we are searching dynamic lib */
fc_join:		     ;
		     fibptr = fct.fibptr (i);		/* come here from mme_rstr entry point */
		     fib.iocount = fib.iocount + 1;
		     if ^fib.type then do;
			if gecall.error_return_loc ^= (18)"0"b then
			     call Error (gcos_et_$non_rndm_call_file);
			else
			call gcos_mme_bort_$system (gcos_et_$non_rndm_call_file);
		     end;
		     load_at = fib.stream;		/* get stream to load from */
		     goto search_lib;
		end;
	end;


srch_gs:	;					/* come here after searching ** file, if one was there */
	dylibsw = "0"b;				/* searching regular lib now */
	load_at = "glib";				/* search standard system library */

search_lib:
	if first_lib then do;			/* initialize if not done previously */
	     first_lib = "0"b;
	     statp = addr (st);			/* init pointer to ios status */
	     scup = addr (mc.scu);			/* init pointer to scu data */
	     i = instruction_counter+1;		/* get parameter loc'n */
	     callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* build ptr to parameters */
	     if dbs_mme_call then do;			/* print gecall name if trace is on */
		call gcos_cv_gebcd_ascii_ (
		     addr (gecall.prog_name)
		     , 6
		     , addr (ascii_gecall_name)
		     );				/* translate call name to ascii */
		call ioa_ ("mme gecall ^a", ascii_gecall_name);
	     end;
	end;
	seek_save, k = 0;				/* init file offsets */
%page;
/*  Read catalog record and search for program to be loaded   */
/* **************N   O   T   E*********************************************************
   *
   *	The catalog for the simulator library, gcos_system_software_, is not
   *	the same as the catalog for a random system loadable file produced by
   *	SYSEDIT, and commonly used as a dynamic library (** file).
   *	This routine presently handles both types.  Note that it would be
   *	inefficient for the simulator to utilize a sector oriented catalog
   *	for its primary software library.  In fact, after GCOS is booted, it
   *	does not use the catalogs contained in its primary software libraries.
   *	It uses one linear directory that it has built from the disjoint disk
   *	catalogs of its primary libraries.  The catalog formats of the GCOS
   *	and the GCOS simulator primary libraries should be of no concern
   *	to users of either system.
   *
   *	See the GCOS PLM (AN77) for a detailed description of the differences
   *	in format between a random system loadable file (a dynamic library), the
   *	simulator library, and a tape system loadable file (from which the
   *	simulator library is produced).
   *
   **************N   O   T   E******************************************************* */
	prefp = addr (buffer);			/* init buffer pointer */

	call ios_$seek (load_at, "read", "first", 0, st); /* seek to start of file */
	if status.code ^= 0 then do;			/* error ? */
	     message = "from ios_$seek to start of file";

io_abort:	     ;
	     if status.code ^= 0 then
		call check_fs_errcode_ (status.code, "xxxxxxxx", longerror); /* get error message */
	     call gcos_cv_gebcd_ascii_ (addr (gecall.prog_name), 6, addr (ascii_gecall_name)); /* get call name in ascii */
	     if gecall.error_return_loc ^= (18)"0"b then
		call Error (gcos_et_$io_err_call_save);
	     else call gcos_mme_bort_$system (gcos_et_$io_err_call_save,
		"on ^a; looking for ^a^/^a^/^a", load_at, ascii_gecall_name, longerror, message);
	end;


read:	;
	call ios_$read (load_at, prefp, 0, 1000, j, st);	/* read catalog */
	if status.code ^= 0 then do;
	     message = "from ios_$read first catalog block";
	     goto io_abort;				/* error ? */
	end;

	if gcatblk.avail_ptr ^= 1 then go to sim_cat;	/* determine catalog type */
	gcatsw = "1"b;				/* GCOS standard catalog type */

gcat_loop: ;
	do i = 1 to 15;				/* search entries on this block */
	     if gcatblk.element (i) = gecall.prog_name then do;
		seek_save = gcatblk.address (i)*64;
		go to readp;
	     end;
	end;
						/* not found - is there another block ? */
	if gcatblk.next_cat = 0 then go to next_lib;	/* if not, search next library */
	call ios_$seek (load_at, "read", "first", gcatblk.next_cat*64, st);
	if status.code ^= 0 then do;
	     message = "from ios_$seek to next random catalog block";
	     goto io_abort;
	end;

	call ios_$read (load_at, prefp, 0, 64, j, st);	/* read in next catalog block */
	if status.code ^= 0 then do;
	     message = "from ios_$read random catalog block";
	     goto io_abort;
	end;
	go to gcat_loop;				/* now go scan it */

sim_cat:	;
	gcatsw = "0"b;

	do i = 1 to catblk.no_ent;			/* loop for no. of entries in cat */
	     if catblk.element (i) = gecall.prog_name then do; /* hit ? */
		seek_save = catblk.address (i);
		go to readp;
	     end;
	end;

next_lib:	;
	if rstr_switch then goto not_found;		/* search only one file for mme gerstr */
	if dylibsw then go to srch_gs;		/* no hit on dynamic lib, try regular */

	if ^seclibsw then do;			/* but only if we have not searched it yet */
	     seclibsw = "1"b;			/* remember that we have */
	     if gcos_ext_stat_$save_data.userlib then do; /* -userlib arg enables use of this feature */
		load_at = "slib";			/* search  secondary library */
		go to search_lib;
	     end;
	end;

not_found: ;
	call gcos_cv_gebcd_ascii_ (addr (gecall.prog_name), 6, addr (ascii_gecall_name)); /* convert call name to ascii */

	if gecall.error_return_loc ^= (18)"0"b then
	     call Error (gcos_et_$call_name_missing);
	else call gcos_mme_bort_$system (gcos_et_$call_name_missing,
	     """^a""", ascii_gecall_name);
%page;
/*  Come here when entry found. Seek to and read preface record   */
readp:	;
	call ios_$seek (load_at, "read", "first", seek_save, st); /* seek */
	if status.code ^= 0 then do;
	     message = "from ios_$seek to preface record";
	     goto io_abort;				/* abort if error */
	end;

	call ios_$read (load_at, prefp, 0, 64, j, st);	/* read preface rcrd */
	if status.code ^= 0 then do;
	     message = "from ios_$read preface record";
	     goto io_abort;				/* abort if error */
	end;

/*  compute no of dcws in preface     */
	first_loc = gcos_ext_stat_$storage_limit;
	last_loc = -1;
	do ndcw = 1 to 58 while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b);
	     dcwp = addr (preface.dcws (ndcw));
	     first_loc = min (first_loc, fixed (dcw_model.data_addr, 18));
	     last_loc = max (last_loc, fixed (dcw_model.data_addr, 18)+fixed (dcw_model.count, 12)-1);
	end;
	dcwp = addr (preface.dcws (ndcw));
	first_loc = min (first_loc, fixed (dcw_model.data_addr, 18));
	last_loc = max (last_loc, fixed (dcw_model.data_addr, 18)+fixed (dcw_model.count, 12)-1);
	pgm_text_length = last_loc-first_loc+1;
	reloc_len = fixed (preface.reloc_words);	/* save no. of relocation words */
	load_origin = fixed (preface.origin);		/* save origin */
	pgm_length = fixed (preface.data_words);	/* save pgm length */

	if gcatsw then do;
	     reloc_len = reloc_len*64;		/* for a GCOS catalog, convert blocks to words */
	     pgm_length = pgm_length*64;
	     seek_save = seek_save + 64;		/* and program starts in next block */
	end;
	else seek_save = seek_save+6+ndcw;		/* for a simulator catalog, program immediately follows */

	transfer_addr = fixed (preface.entry);		/* save entry point */
	load_increment = 0;				/* init load increment */

	if gecall.origin ^= (18)"0"b then do;		/* did slave specify an origin ? */
	     if load_origin > 131072 then		/* relocatable overlay ? */
		load_increment = fixed (gecall.origin);
	     else load_increment = fixed (gecall.origin)-load_origin; /* set up new load increment */
	     load_origin = fixed (gecall.origin);	/* use user specified origin */
	     transfer_addr = transfer_addr+load_increment; /* new transfer address */
	end;

/* In the following test, load_origin + pgm_text_length > storage_limit is the same as
   load_origin + pgm_text_length -1 >= storage_limit. A storage_limit of nnnK means that the program
   can legitimately address 0 to nnnK-1. */

	if load_origin + pgm_text_length > gcos_ext_stat_$storage_limit then do; /* will pgm_text fit ? */
	     if gecall.error_return_loc ^= (18)"0"b then
		call Error (gcos_et_$io_lim_call_save);
	     else call gcos_mme_bort_$system (gcos_et_$io_lim_call_save);
	end;

	mc.regs.q = substr (unspec (transfer_addr), 19, 18)||substr (mc.regs.q, 19, 18);

/*  Use user specified transfer address if present    */
	if gecall.xfer_addr ^= (18)"0"b then transfer_addr = fixed (gecall.xfer_addr);

	call ios_$seek (load_at, "read", "first", seek_save, st); /* seek to read data record */
	if status.code ^= 0 | status.eof then do;
	     if status.code = 0 then
		longerror = "end of file";
	     message = "from ios_$seek to first dat block";
	     goto io_abort;
	end;
%page;
	first_loc = first_loc-1024+load_increment;

/*  Loop to read data records into gcos segment    */
	xfer_total = 0;				/* clear xfer total */
	do i = 1 to ndcw;				/* loop to process dcws */

	     dcwp = addr (preface.dcws (i));		/* get pointer to a dcw */
	     j = fixed (dcw_model.count);		/* grab xfer count */
	     if j = 0 then j = 4096;			/* count of 0 = 4096 */
	     xfer_total = xfer_total + j;		/* total up words to xfer */

	end;

	call ios_$read (load_at, gcos_ext_stat_$gcos_slave_area_seg, (first_loc), xfer_total, k, st); /* read data record */
	if status.code ^= 0 | xfer_total ^= k then do;
	     if status.code = 0 then
		longerror = "data words read ^= total of dcw counts";
	     message = "from ios_$read data blocks";
	     goto io_abort;				/* error ? */
	end;

/*  Calculate checksum and compare with that in preface block */
	if preface.data_check ^= 0 then do;		/* don't do if checksum = 0 */

	     ptr = addrel (gcos_ext_stat_$gcos_slave_area_seg, first_loc); /* get ptr to first loc loaded */
	     accum = 0;				/* clear accumulator */

	     do i = 1 to xfer_total;
		accum = accum + fixed (checker (i));	/* add a word */
		if accum > 68719476735 then do;	/* carry into second word ? */
		     accum = accum - 68719476736 + 1;	/* add carry to low end of no. */
		end;
	     end;

	     if substr (unspec (accum), 37, 36) ^= unspec (preface.data_check) then do; /* error */
		if gecall.error_return_loc ^= (18)"0"b then
		     call Error (gcos_et_$call_rstr_cksm);
		else call gcos_mme_bort_$system (gcos_et_$call_rstr_cksm);
	     end;
	end;
%page;
/*  If this is an absolute program, go turn control back to the user */
	if reloc_len = 0 then go to start_pgm;
	if load_increment = 0 then go to start_pgm;	/* no relocation to do */

/*  Must change load increment before relocating program. The load increment */
/*  is usually off by 102 octal in the preface record. Actually, the  */
/*  preface record is off by 400102 but the extra 400000 is really just a */
/*  flag to indicate that the program is relocatable.    */

/* The 102 octal consists of the slave area prefix, which is 100 octal words
   long, followed by two words immediately after it, reserved by the loader for
   communication between overlay modules.  Thus it represents the difference
   between giving the load increment relative to the beginning of the program and
   giving it relative to the beginning of the slave area.
*/
	if fixed (preface.origin) > 131072 then
	     load_increment = load_increment+131072-fixed (preface.origin); /* fix load increment */

	if gcatsw then do;				/* for a GCOS catalog, move to beginning of next block */
	     call ios_$seek (load_at, "read", "first", seek_save+pgm_length, st);
	     if status.code ^= 0 then do;
		message = "from ios_$seek to first random relocation block";
		goto io_abort;
	     end;
	end;

rd_rel:	;
	call ios_$read (load_at, prefp, 0, 1000, j, st);	/* read reloc record */
	if status.code ^= 0 then do;
	     message = "from ios_$read relocation block";
	     goto io_abort;
	end;

	size = min (reloc_len, 1000);			/* can only relocate 18000 words per read */
	reloc_len = reloc_len-1000;
	size = min (size*36, pgm_text_length*2);
	do i = 1 to size;
	     if reloc_bits (i) then do;		/* reloc bit on? */
		fb18 = fixed (gcos_reloc.half_wd (i));	/* pull the half word */
		fb18 = fb18 + load_increment;		/* increment it */
		gcos_reloc.half_wd (i) = bit (fb18);	/* put it back */
	     end;
	end;

	if reloc_len > 0 then go to rd_rel;		/* more relocation bits ? */
%page;
/*  Come here when relocation finished    */
start_pgm: ;					/* return load origin and pgm length in A */
	call Apply_Patches ();
	mc.regs.a = substr (unspec (load_origin), 19, 18)||substr (unspec (pgm_text_length), 19, 18);

/*  Set "increment" to force xfer to location specified in transfer address */
/*  when control is returned to the user.     */
	increment = transfer_addr - instruction_counter - 1; /* compute offset from current instruction */

exit_gecall:

	return;					/* go start program */
%page;
mme_rstr:	entry (mcp, increment);

	rstr_switch = "1"b;				/* remember we entered here */
	scup = addr (mc.scu);			/* init pointer to scu data */
	callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, instruction_counter+1); /* build ptr to parameters */

	call gcos_cv_gebcd_ascii_ (addr (mc.regs.q), 6, addr (fc)); /* get file code in ascii */
	do i = 1 to hbound (save_data.fibs, 1);		/* look for file code */
	     if fct.filecode (i) = substr (fc, 5, 2) then if ^fct.sysout (i) then do;
		     goto fc_join;
		end;
	end;

/*	if gecall.error_return_loc ^= (18)"0"b then
   call Error (gcos_et_$fc_not_defined);
   else call gcos_mme_bort_$system (gcos_et_$fc_not_defined, """^a""", substr (fc, 5, 2));
*/
	call gcos_mme_bort_$system (gcos_et_$fc_not_defined, """^a""", substr (fc, 5, 2));
%page;
Apply_Patches: proc ();


	     if gcos_ext_stat_$patchfile_ptr = null () then return;


	     module_name = gecall.prog_name;
	     call Get_Module_Name_Index ();


	     if module_name_index ^= 0 then do;
		patch_ptr = ptr (gcos_ext_stat_$patchfile_ptr, patch_file.module (module_name_index).first_patch_offset);
		number_of_patches = patch_file.module (module_name_index).number_of_patches;
		do i = 1 to number_of_patches;
		     if patch (i).location > gcos_ext_stat_$storage_limit then do;
		     end;
		     word_ptr = ptr (gcos_ext_stat_$gcos_slave_area_seg, patch (i).location);
		     if dbs_mme_call then
			call ioa_ (
			"before ^w; after ^w^[^-NO CHANGE^]"
			, word
			, patch (i).content
			, (word = patch (i).content)
			);
		     word = patch (i).content;
		end;
	     end;
	     else if dbs_mme_call then call ioa_ ("no patches");


	     return;

Get_Module_Name_Index: proc ();


dcl  divide                   builtin;
dcl  floor                    builtin;
dcl  l                        fixed bin(24);
dcl  u                        fixed bin(24);


		l = 1;
		u = patch_file.number_of_names;


		do while (u >= l);

		     module_name_index = floor (divide ((l+u), 2, 17));

		     if module_name < patch_file.module (module_name_index).name then u = module_name_index-1;
		     else if module_name > patch_file.module (module_name_index).name then l = module_name_index+1;
		     else return;

		end;


		module_name_index = 0;


		return;


	     end Get_Module_Name_Index;

dcl  i                        fixed bin(24);
dcl  module_name              bit (36);
dcl  module_name_index        fixed bin(24);
dcl  null                     builtin;
dcl  number_of_patches        fixed bin(24);
dcl  patch_ptr                ptr;
dcl  ptr                      builtin;
dcl  word                     fixed bin(35) based (word_ptr);
dcl  word_ptr                 ptr;

dcl 1 patch (number_of_patches) aligned based (patch_ptr),
    2 location fixed bin(17),
    2 content fixed bin(35);

dcl 1 patch_file aligned based (gcos_ext_stat_$patchfile_ptr),
    2 version fixed bin(24),
    2 number_of_names fixed bin(24),
    2 module (130560),
      3 name bit (36),
      3 first_patch_offset bit (18) unal,
      3 number_of_patches fixed bin(17) unal;
	end Apply_Patches;
%page;
Error:	proc (code);

	     call gcos_mme_bort_$abort_number (code, abort_number);
	     mc.regs.q = unspec (abort_number);
	     return_loc = fixed (gecall.error_return_loc, 18, 0);
	     gecall.error_return_loc = (18)"0"b;
	     increment = return_loc-instruction_counter-1;
	     goto exit_gecall;

dcl  abort_number             fixed bin(35);
dcl  code                     fixed bin(35);
dcl  return_loc               fixed bin(18);
	end Error;
%page;
/*   Variables for gcos_mme_call_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  accum                    fixed bin(71)	/* checksum accumulator */;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  ascii_gecall_name        char (6)	/* for printing in trace or error messages */;
dcl  bit                      builtin;
dcl  buffer                   bit (36000)	/* preface and relocation blk buffer */;
dcl  callp                    pointer;
dcl  checker                  (pgm_length) bit (36) aligned based (ptr)	/* overlay for computing chksum */;
dcl  check_fs_errcode_        ext entry (fixed bin(24), char (8), char (100));
dcl  dcwp                     pointer;
dcl  dylibsw                  bit (1) aligned init ("0"b)	/* on if searching dynamic library (**) */;
dcl  fb18                     fixed bin(18)	/* need full 18 bits for address arithmetic */;
dcl  fc                       char (6);
dcl  first_lib                bit (1) aligned init ("1"b)	/* on until initialzation done */;
dcl  first_loc                fixed bin(18);
dcl  fixed                    builtin;
dcl  gcatsw                   bit (1)	/*  0=simulator catalog, 1=gcos format catalog */;
dcl  gcos_cv_gebcd_ascii_     ext entry (pointer, fixed bin(24), pointer);
dcl  gcos_et_$call_name_missing fixed bin(35) ext;
dcl  gcos_et_$call_rstr_cksm  fixed bin(35) ext;
dcl  gcos_et_$fc_not_defined  fixed bin(35) ext;
dcl  gcos_et_$io_err_call_save fixed bin(35) ext;
dcl  gcos_et_$io_lim_call_save fixed bin(35) ext;
dcl  gcos_et_$non_rndm_call_file fixed bin(35) ext;
dcl  gcos_mme_bort_$abort_number entry (fixed bin(35), fixed bin(35));
dcl  gcos_mme_bort_$system    entry options (variable);
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24)	/* number of parameter words to skip */;
dcl  instruction_counter      fixed bin(18)unsigned unal based(addr(scu.ilc));
dcl  ioa_                     ext entry options (variable);
dcl  ios_$read                ext entry (char (*) aligned, pointer, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned);
dcl  ios_$seek                ext entry (char (*) aligned, char (*), char (*), fixed bin(24), bit (72) aligned);
dcl  j                        fixed bin(24);
dcl  k                        fixed bin(24);
dcl  last_loc                 fixed bin(18);
dcl  load_at                  char (8) aligned	/* holds attach name of file to load from */;
dcl  load_increment           fixed bin(24);
dcl  load_origin              fixed bin(24);
dcl  longerror                char (100);
dcl  max                      builtin;
dcl  message                  char (60);
dcl  min                      builtin;
dcl  ndcw                     fixed bin(24);
dcl  pgm_length               fixed bin(24);
dcl  pgm_text_length          fixed bin(18);
dcl  prefp                    pointer;
dcl  ptr                      pointer;
dcl  reloc_bits               (36000) bit(1)unaligned based (prefp)	/* overlay for relocation record */;
dcl  reloc_len                fixed bin(24);
dcl  rstr_switch              bit (1) aligned init ("0"b)	/* on if entered at mme_rstr */;
dcl  seclibsw                 bit (1) aligned init ("0"b)	/* on if searching secondary library */;
dcl  seek_save                fixed bin(24)	/* holds seek offset */;
dcl  size                     fixed bin(24)	/* size of pgm overlay arrays */;
dcl  st                       bit (72) aligned 	/* ios status */;
dcl  state                    char (4);
dcl  statp                    pointer;
dcl  substr                   builtin;
dcl  transfer_addr            fixed bin(24);
dcl  unspec                   builtin;
dcl  xfer_total               fixed bin(24)	/* used to hold total no. words to xfer */;

dcl 1 status aligned based (statp),			/* overlay for ios_ status */
    2 code fixed bin(24),				/* standard error code */
    2 fill bit (9) unaligned,
    2 eof bit (1) unaligned		/* eof bit */
;


dcl 1 gecall aligned based (callp),			/* overlay for gecall parameters */
    2 prog_name bit (36) unaligned,			/* bcd pgm name */
    2 origin bit (18) unaligned,			/* place to begin loading */
    2 error_return_loc bit (18) unaligned,
    2 xfer_addr bit (18) unaligned		/* transfer address */
;


dcl 1 preface aligned based (prefp),			/* model of preface record - 64 words max */
    2 data_check fixed bin(24),				/* checksum of following data words */
    2 rel_check fixed bin(24),				/* checksum of following reloc. words */
    2 rel_abs fixed bin(24),				/* 0=absolute|^0=relocatable */
    2 name bit (36) unaligned,			/* name of pgm */
    2 entry bit (18) unaligned,			/* entry address */
    2 origin bit (18) unaligned,			/* origin */
    2 reloc_words bit (18) unaligned,			/* no. of relocation words */
    2 data_words bit (18) unaligned,			/* no. of data words */
    2 dcws (ndcw) bit (36) unaligned			/* dcw(s) - max of 58 - to load following data records */
;


dcl 1 dcw_model aligned based (dcwp),			/* model of dcw */
    2 data_addr bit (18) unaligned,
    2 zero bit (3) unaligned,
    2 action bit (3) unaligned,
    2 count bit (12) unaligned		/* number of words to xfer */
;


dcl 1 gcos_reloc aligned based (ptr),			/* overlay for each half word  */
    2 half_wd (131072) bit (18) unaligned;						/* of the loaded program */


dcl 1 catblk aligned based (prefp),			/* catalog image */
    2 nxt fixed bin(24),				/* pointer to next cat blk */
    2 no_ent fixed bin(24),				/* no. of entries in this cat blk */
    2 elblock (499),				/* room for 499 entries */
      3 element bit (36) unaligned,			/* prog name */
      3 address fixed bin(24)				/* offset in file of preface rcrd */
;


dcl 1 gcatblk	aligned based (prefp),	/* catalog image for gcos format catalog */
    2 avail_ptr	fixed bin(18)unsigned unaligned,
    2 next_cat	fixed bin(18)unsigned unaligned,
    2 pad		bit (36),
    2 elblock 	(15),
      3 element	bit (36),
      3 length	fixed bin(18)unsigned unaligned,
      3 address	fixed bin(18)unsigned unaligned,
      3 pad	bit (72);
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dbs_names;
     end gcos_mme_call_;




		    gcos_mme_chek_.pl1              09/09/83  1404.1rew 09/09/83  1007.3       21960



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	M M E  G E C H E K
   *
   *
   *	MME GECHEK initiates a checkpoint dump and sets up bookkeeping to enable
   *	the program requesting the MME GECHEK to be later rolled back (via MME GEROLL)
   *	to the last checkpoint taken.
   *
   *
   *	CALLING SEQUENCE
   *
   *	MME	GECHEK
   *	return
   *
   *
   *	C(word 14) 0-17	location of rollback special processing routine
   *
   *
   *	For programs using File and Record Control:
   *
   *	C(Q) 0-17		checkpoint FCB location
   *	C(Q) 18-35	MBZ
   *
   *
   *	or for programs not using File and Record Control:
   *
   *	C(Q) 0-5		MBZ
   *	C(Q) 6-17		file code of the checkpoint file
   *	C(Q) 18		MBZ
   *	C(Q) 19		=1
   *	C(Q) 20-35	MBZ
   *
   *
   *	on return from the MME:
   *
   *	C(Q) 0-17		location+1 of the last MME GECHEK
   *	C(Q) 18-35	error code (always zero)
   *
   *
   *  Modified by M. R. Jordan,  April 1977
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_mme_chek_: proc (mcp, increment);

dcl  addr builtin;
dcl  bit36 bit (36) aligned based;
dcl  fixed builtin;
dcl  increment fixed bin(18);
dcl  return_loc fixed bin(18);
dcl  substr builtin;

/*

   This MME is not supported.  Simply return to the slave job as if we
   had taken the checkpoint.

*/


/*

   Initialize the increment and scu data pointer.  Then set up the Q
   register to look like we just did the GECHEK and return.

*/


	increment = 1;
	scup = addr (mc.scu);
	return_loc = fixed (scu.ilc, 18)+1;
	mc.q = substr (addr (return_loc) -> bit36, 19, 18) || (18)"0"b;

	return;

%include mc;


     end gcos_mme_chek_;




		    gcos_mme_fadd_.pl1              09/09/83  1404.1rew 09/09/83  1007.3       30528



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

/*
   MME GEFADD is used to obtain physical addresses for use in operator messages.
   Since physical addresses are meaningless in this environment, a random bit
   pattern is returned in the A and Q registers.

   This mme is also used to find out if a file exists, so it is important
   to return nonzero values when the file does exist.

   Author: DICK SNYDER FEBRUARY 21,1972
   Change: T. CASEY NOVEMBER 1973
   Change: D. KAYDEN  APRIL 1974, DECEMBER 1974
   Change: R.H. MORRISON	JAN. 29, 1976
   Change: Dave Ward	09/02/81 density history 2 bits (not 3). Tape density 6250. Revised source.
*/
dcl  increment                fixed bin(24)parm;
dcl  mcpp                     ptr parm;
	mcp = mcpp;
	increment = 0;

	substr (fc, 1, 1) = xlate (q_ovl.fc_bcd1);	/* put ascii equivalent in fc */
	substr (fc, 2, 1) = xlate (q_ovl.fc_bcd2);
	if fc = "  " then go to not_found;

	do i = 1 to hbound (save_data.fibs, 1);		/* see if file named fc exists */
	     if fct.filecode (i) = fc then go to found;
	end;

not_found: ;
	mc.regs.a,
	     mc.regs.q = "0"b;			/* not found, return zeroes */
	return;


found:	;
	if fct.sysout (i) then go to not_found;

	fibptr = fct.fibptr (i);
	mc.regs.a = "0"b;
	substr (mc.regs.a, 7, 3) = fib.disp;		/* put in disposition code */
	if fib.print then substr (mc.regs.a, 1, 6) = "25"b3 ; /* device code = 25 (prt300 */
	else
	if fib.tape then do;

	     if fib.tracks = "01"b then substr (mc.regs.a, 1, 6) = "13"b3 ; /* dev. code = 13 (mth500 - 7 trk) */
	     else
	     substr (mc.regs.a, 1, 6) = "14"b3 ;	/* dev. code = 14 (mth500 - 9 trk) */

	     substr (mc.regs.a, 10, 19) = "0100000000001000010"b; /* set density capability (200, 556, 800,
						   1600 or 6250) and high and low defaults (800 & 556) */
	     substr (mc.regs.a, 29, 4) = fib.density;	/* set density from $ tape card */
	     substr (mc.regs.a, 33, 2) = fib.dens_hist;
	end;
	else do;
	     substr (mc.regs.a, 1, 6) = "61"b3 ;	/* device code = 61 (dsu191) */
	     substr (mc.regs.a, 19, 1) = "1"b;		/* size given in llinks */
	     substr (mc.regs.a, 20, 1) = fib.type;	/* random file indicator */
	     substr (mc.regs.a, 21, 1) = fib.perm;	/* permanent file indicator */
	     i = divide (fib.size, 320, 24, 0);		/* get size in llinks */
	     if i <= 16383 then
		a_ovl.llinks = i;
	end;
	mc.regs.q = "000116160000"b3 ;
	return;
%page;
/*   Variables for gcos_mme_fadd_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  divide                   builtin;
dcl  fc                       char(2)aligned;
dcl  i                        fixed bin(24);
dcl  substr                   builtin;
dcl  unspec                   builtin;

dcl 1 q_ovl	aligned based(addr(mc.regs.q))
,     2 fill	bit(24)unal
,     2 fc_bcd1	fixed bin(6)unsigned unal
,     2 fc_bcd2	fixed bin(6)unsigned unal
;

dcl 1 a_ovl	aligned based(addr(mc.regs.a))
,     2 fill	bit(22)unal
,     2 llinks	fixed bin(14)unsigned unal
;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_xlate_bcd_ascii_;
     end gcos_mme_fadd_;




		    gcos_mme_fcon_.pl1              09/09/83  1404.1rew 09/09/83  1007.3       51651



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

/*
   *  MME GEFCON is used by GEFRC to obtain information about a particular file. This
   *  information is placed in the file control block or file control blocks if
   *  several are linked together. The address of the first file control block is found
   *  in the caller's Q register.
   *
   *
   Author: DICK SNYDER OCTOBER 26, 1970
   Change: D. KAYDEN  APRIL 1974, JULY 1974, AUGUST 1974, JANUARY 1975
   Change: R.H.MORRISON  MARCH 2, 1976
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	09/14/81 arrayed fib usage.
*/
dcl  increment                fixed bin(24)parm	/* no. of param words to skip */;
dcl  mcpp                     ptr parm;
	mcp = mcpp;
	increment = 0;				/* => no arguments to MME. */
	j = fixed (substr (mc.regs.q, 1, 18));		/* get fcb offset */

loop:	;
	if j >= gcos_ext_stat_$storage_limit then return; /* out of bounds ? */
	if j < 8 then return;

	fcbp = addrel (gcos_ext_stat_$gcos_slave_area_seg, j-8); /* get ptr to -8 in fcb */
	i = fixed (substr (fcb.filecode, 1, 6));	/* pick up first letter of bcd filecode */
	substr (fc, 1, 1) = xlate (i);		/* put ascii equiv. in fc */
	i = fixed (substr (fcb.filecode, 7, 6));	/* get second bcd letter */
	substr (fc, 2, 1) = xlate (i);		/* put ascii equivalent in */


	do i = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (i) = fc then do;
		fibptr = fct (i).fibptr;
		if substr (mc.regs.q, 19, 2) ^= "00"b then do; /* alternate function requested */
		     if ^fib.tape then return;

		     if substr (mc.regs.q, 19, 1) then	/* set serial number in fib */
			fib.serial_no = substr (fcb.file_size, 1, 30);
		     else fib.density = substr (mc.regs.q, 33, 4); /* set new tape density in fib */

		     return;
		end;

		fcb.file_present = "1"b;		/* indicate file present */
		string (fcb.group) = "0"b;		/* clear */
		if fct.sysout (i) then goto sysout;

		fibptr = fct.fibptr (i);		/* get pointer to fib */
		fcb.dev_add = fib.plud;		/* copy log. unit info */

		if fib.tape then goto tape;		/* tape ? */
		if fib.console then goto console;
		if fib.print then goto printer;
		if fib.reader then goto reader;

		fcb.dev_type = "0110"b;		/* device is 64 word sector disk */
		fcb.random = fib.type;		/* copy random indicator */

		llinks = divide (fib.size, 320, 23, 0);
		if llinks > 16383 then fcb.file_size = unspec (llinks) | "400000000000"b3;
		else do;
		     b = mod (llinks-1, 12)+1;
		     c = b+divide (llinks+11, 12, 23, 0)-1;
		     fcb.file_size = unspec (bc);
		end;

		goto next_fcb;			/* get next fcb */


tape:		;
		fcb.dev_type = "0010"b;
		if fib.tracks = "01"b then fcb.random = "0"b; /* 7 track tape */
		else fcb.random = "1"b;		/* 9 track tape or default */
		fcb.file_size = fib.serial_no;	/* plug in serial no */
		fcb.reel_seq_no = substr (unspec (fib.seq_no), 10, 9); /* plug in sequence no */

		if fib.disp = "11"b | fib.disp = "00"b then fcb.int_cntrl = "1"b; /* set special bit */
		goto next_fcb;			/* get next fcb */

console:		;
		fcb.dev_type = "1101"b;
		goto next_fcb;

printer:		;
		fcb.dev_type = "1010"b;
		goto next_fcb;

reader:		;
		fcb.dev_type = "1000"b;
		goto next_fcb;

sysout:		;
		if fct.dac (i) then goto dac;
		fcb.sysout = "1"b;
		goto next_fcb;

dac:		;
		fcb.dev_type = "0111"b;
		goto next_fcb;
	     end;
	end;

next_fcb:	;
	j = fixed (fcb.fcbptr);			/* get next fcb address */
	if j = 0 then return;			/* no more ? */
	if j = fixed (substr (mc.regs.q, 1, 18)) then return; /* end of loop ? */
	goto loop;				/* no...process more */
%page;
/*   Variables for gcos_mme_fcon_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  divide                   builtin;
dcl  fc                       char(2)	/* holder for file code */;
dcl  fcbp                     ptr	/* pointer to fcb */;
dcl  fixed                    builtin;
dcl  i                        fixed bin(24);
dcl  j                        fixed bin(24);
dcl  llinks                   fixed bin(23);
dcl  mod                      builtin;
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  temp                     bit(12) aligned	/* holder for bcd filecode */;
dcl  unspec                   builtin;

dcl 1 bc aligned,
    2 b fixed bin(17)unaligned,
    2 c fixed bin(17)unaligned;


dcl 1 fcb aligned based (fcbp),			/* fcb model */

/* 	-8		 */

    2 fill1 bit(27) unaligned,
    2 reel_seq_no bit(9) unaligned,			/* tape reel sequence no */

/* 	-7		 */
    2 file_size bit(36) unaligned,			/* for disk - file size */
						/* for tape - file serial number */

/* 	-6		 */

    2 fill2 bit(36) unaligned,

/* 	-5		 */

    2 fill3 bit(18) unaligned,
    2 file_present bit(1) unaligned,
    2 fill4 bit(10) unaligned,
    2 int_cntrl bit(1) unaligned,			/* bit used if tape */
    2 fill5 bit(6) unaligned,

/* 	-4		 */

    2 pat bit(18) unaligned,
    2 zero1 bit(6) unaligned,
    2 filecode bit(12) unaligned,

/* 	-3		 */

    2 fill6 bit(36),

/* 	-2		 */

    2 fill7 bit(36),

/* 	-1		 */

    2 fcbptr bit(18) unaligned,
    2 dev_add bit(18) unaligned,

/* 	0		 */

    2 fill8 bit(24) unaligned,
    2 group unaligned,
      3 random bit(1) unaligned,
      3 sysout bit(1) unaligned,
      3 dev_type bit(4) unaligned,
      3 zero2 bit(6) unaligned;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_xlate_bcd_ascii_;
     end gcos_mme_fcon_;




		    gcos_mme_fini_.pl1              09/09/83  1404.1rew 09/09/83  1007.3       14967



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


/* *****************************************************************************************
   *******************************************************************************************
   *
   *
   *	M M E  G E F I N I
   *
   *
   *  MME GEFINI is the standard method of bringing an activity to a successful completion.
   *  Control goes back to gcos_run_activity by transferring to an external static label
   *  variable which is set to point to the cleanup procedures in gcos_run_activity.
   *
   *
   *	WRITTEN BY DICK SNYDER OCTOBER 15,1970
   *	MODIFIED BY D. KAYDEN  APRIL 1974
   *
   *
   *******************************************************************************************
   ****************************************************************************************** */

gcos_mme_fini_: proc (faultp, increment);





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


%include gcos_ext_stat_;



/* 	Work Variables						 */


dcl  faultp pointer;						/* unused input parameter */
dcl  increment fixed bin(24);						/* ditto */



/* 	P R O C E D U R E					 */


	go to gcos_ext_stat_$mme_rtrn;		/* return to gein */
     end gcos_mme_fini_;




		    gcos_mme_frce_.pl1              09/09/83  1404.1rew 09/09/83  1007.4       87084



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	M M E  G E F R C E
   *
   *
   *	MME GEFRCE is used to produce ISP abort messages or perform
   *	UFAS label processing.
   *
   *
   *	CALLING SEQUENCE
   *
   *	MME	GEFRCE
   *	ZERO	Function,Abort_message_number
   *	ZERO	Parameter_list_ptr,Number_of_ptrs_in_list
   *	return
   *
   *	For function < 0 ISP abort processing is invoked.  Function ^= -1 is in error.
   *
   *
   *	For Function >= 0 unimplemented label processing is called.  This always
   *	results in an abort of the slave job.
   *
   *
   *	Written by M. R. Jordan,  August 1977
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_mme_frce_: procedure (mcp, increment);

dcl  BAD_FUNCTION_CODE char (48) static internal options (constant) init ("invalid function code specified for 'mme gefrce'");
dcl  BAD_MESSAGE_NUMBER char (31) static internal options (constant) init ("undefined error message number ");
dcl  BAD_PARAM_LOC char (38) static internal options (constant) init ("invalid 'mme gefrce' parameter address");
dcl  addr builtin;
dcl  addrel builtin;
dcl  fb35 fixed bin(35) aligned based;
dcl  divide builtin;
dcl  fixed builtin;
dcl  function fixed bin(24);
dcl  gcos_cv_gebcd_ascii_ entry (ptr, fixed bin(24), ptr);
dcl  gcos_et_$bad_mme_param fixed bin(35) ext;
dcl  gcos_et_$isp_sys_term fixed bin(35) ext;
dcl  gcos_et_$unimp_mme fixed bin(35) ext;
dcl  gcos_mme_bort_$system entry options (variable);
dcl  gseg_ptr ptr;
dcl  hbound builtin;
dcl  i fixed bin(24);
dcl  increment fixed bin(18);
dcl  ioa_$rsnnl entry options (variable);
dcl  last_loc fixed bin(18);
dcl  lbound builtin;
dcl  length builtin;
dcl  message char (128) varying;
dcl  message_num fixed bin(24);
dcl  min builtin;
dcl  mme_arg_ptr ptr;
dcl  param (3) character (48) varying;
dcl  param_len fixed bin(24);
dcl  param_list_len fixed bin(24);
dcl  param_list_loc fixed bin(18);
dcl  param_list_ptr ptr;
dcl  param_loc fixed bin(18);
dcl  param_pic picture "999999";
dcl  param_ptr ptr;
dcl  storage_limit fixed bin(18);
dcl  substr builtin;
dcl  temp_param char (48);

/*

   The following declaration is the argument list to the MME for ISP abort processing.

*/


dcl 1 mme_args aligned based (mme_arg_ptr),
    2 function fixed bin(17) unal,
    2 message_num fixed bin(17) unal,
    2 param_list_loc bit (18) unal,
    2 param_list_len fixed bin(17) unal;


/*

   The following is the parameter list used in ISP abort processing.

*/


dcl 1 param_list (param_list_len) aligned based (param_list_ptr),
    2 param_loc bit (18) unal,
    2 param_len fixed bin(17) unal;


/*

   The following are message texts and number of parameters expected.

*/


dcl 1 MESSAGE (0:33) aligned static internal options (constant),
    2 TEXT char (48) init (
     "^a",
     "file code '^a' is already open",
     "not enough memory to open data file '^a'",
     "file code '^a' requested but not present",
     "file code '^a' is not random",
     "key outside of record area for data file '^a'",
     "file '^a' record size ^6o > 1024 words",
     "file '^a' record size ^6o+3 >page size ^6o",
     "descriptor card file '^a' content error",
     "data file '^a' key size = 0",
     "index file '^a' and data file '^a' do not match",
     "protection error on file code '^a'",
     "data file '^a' is not open",
     "file code '^a' is not a data file",
     "data file '^a' was not opened by 'nopen'",
     "index file '^a' is too small",
     "journalization requested - journal file missing",
     "unrecoverable i/o error on file code '^a'",
     "page ^6o out of range of data file '^a'",
     "unable to locate required key in index file '^a'",
     "data file '^a' was not opened by 'iopen'",
     "not enough memory to run journal restore",
     "contents of journal tape file 't1' are not valid",
     "descriptor card file '.x' content error",
     "more than 20 data file codes specified",
     "unrecoverable read error on journal tape 't1'",
     "invalid file code for additional data file",
     "file code 'in' or 'ot' must be present for xutil",
     "file '^a' is not a valid isp index file",
     "no records have been stored in file '^a'",
     "file '^a' is not a valid isp data file",
     ".qpbg buffer is too small",
     "file '^a' page size discrepancy between isp/fms",
     "xckptp not taken before xrolbp executed"),
    2 NUM_PARAMS fixed bin(24)init ((6)1, 2, 3, (10)1, 2, (2)1, (7)0, (3)1, 0, (2)1);

/*

   Do some initialization and make sure the first argument word to the MME is accessable.

*/


	gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg;
	storage_limit = gcos_ext_stat_$storage_limit;
	scup = addr (mc.scu);

	if fixed (scu.ilc, 18)+1 >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEFRCE parameter word is outside slave limits.");


/*

   Determine the function requested and attempt to process it.

*/


	mme_arg_ptr = addrel (gseg_ptr, fixed (scu.ilc, 18)+1);
	function = mme_args.function;


	if function >= 0 then call UFAS_Label_Processing ();
	else call ISP_Abort_Processing ();


	return;

UFAS_Label_Processing: procedure ();


	     increment = 1;
	     call gcos_mme_bort_$system (gcos_et_$unimp_mme, "MME GEFRCE does not support UFAS calls.");


	     return;


	end UFAS_Label_Processing;

/*

   This internal procedure controls the simulation of the ISP abort processing
   subfunction of MME GEFRCE.  Assumtions are as follows:  (1) function < 0;
   (2) mme_arg_ptr is valid.

*/


ISP_Abort_Processing: procedure ();


/*

   Initialize the number of parameters and make sure they're accessable.

*/


	     increment = 2;
	     if fixed (scu.ilc, 18)+2 >= storage_limit then
		call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEFRCE parameter word is outside slave limits.");


/*

   Make sure the function is -1.  If its not, use the precanned message to say so.

*/


	     if function = -1 then do ;


/*

   Get the necessary items from the parameter list.

*/


		message_num = mme_args.message_num;
		param_list_loc = fixed (mme_args.param_list_loc, 18);
		param_list_len = mme_args.param_list_len;


/*

   Initialize the parameters.

*/


		do i = 1 to hbound (param, 1);
		     param (i) = "";
		end;


/*

   Make sure the parameter list is entirely accessable.

*/


		if param_list_len+param_list_loc > storage_limit then message = BAD_PARAM_LOC;


/*

   If the message number is bad, say so.  Otherwise, get the proper message.

*/


		else if message_num > hbound (MESSAGE, 1) | message_num < lbound (MESSAGE, 1) then do;
		     param_pic = message_num;
		     message = BAD_MESSAGE_NUMBER || param_pic;
		end;
		else call Get_Message ();


	     end;
	     else message = BAD_FUNCTION_CODE;


/*

   ... at last ... abort the user.

*/


	     call gcos_mme_bort_$system (gcos_et_$isp_sys_term, "^a^/", message);


	     return;


	end ISP_Abort_Processing;

/*


   This internal procedure gets the 'message' text.  Editing of parameters is also
   performed.  Assumtions are as follows:  (1) param(*) = "";  (2) message_num is valid;
   (3) param_list_loc+param_list_len-1 is a valid location.

*/


Get_Message: procedure ();


/*

   If parameters exist, process them.

*/


	     if param_list_len ^= 0 then do;


/*

   After obtaining a pointer to the parameter list, process those needed and present.

*/


		param_list_ptr = addrel (gseg_ptr, param_list_loc);
		do i = 1 to min (MESSAGE (message_num).NUM_PARAMS, param_list_len);


		     param_loc = fixed (param_list (i).param_loc, 18);
		     param_len = param_list (i).param_len;


/*

   If the length is negative we use only one word.  Otherwise, calculate how many we will need.

*/


		     if param_len <= 0 then last_loc = param_loc;
		     else do;
			param_len = min (param_len, 48);
			last_loc = param_loc+divide (param_len+5, 6, 18, 0)-1;
		     end;


/*

   If the last word needed is not accessable complain.

*/


		     if last_loc >= storage_limit then do;
			message = BAD_PARAM_LOC;
			return;
		     end;
		     param_ptr = addrel (gseg_ptr, param_loc);


/*

   If param_len < 0, use the rightmost -param_len digits from the integer at location aram_loc.

*/


		     if param_len < 0 then do;
			param_len = min (-param_len, 6);
			param_pic = param_ptr -> fb35;
			param (i) = substr (param_pic, length (param_pic)+1-param_len, param_len);
		     end;


/*

   Otherwise, use the first param_len characters (GBCD).

*/


		     else if param_len > 0 then do;
			call gcos_cv_gebcd_ascii_ (param_ptr, param_len, addr (temp_param));
			param (i) = substr (temp_param, 1, param_len);
		     end;


		end;


	     end;


/*

   Now format the text for the message.

*/


	     call ioa_$rsnnl (MESSAGE (message_num).TEXT, message, 0, param);


	     return;


	end Get_Message;

%include gcos_ext_stat_;


     end gcos_mme_frce_;




		    gcos_mme_fsye_.pl1              09/09/83  1404.1rew 09/09/83  1007.4       87876



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


/* ****************************************************************************************
   ******************************************************************************************
   *
   *
   *
   *		M  M  E       G  E  F  S  Y  E
   *
   *
   *	This procedure processes the file system mme, mme gefsye.
   *	Currently, creating, deleting, and purging a file, and
   *	creating a catalog are the only calls accepted.
   *
   *
   *	WRITTEN:	D. Kayden		MAR 75
   *	CHANGED:	S.C. Akers	NOV 81	Use gcos_build_pathname_
   *					to expand pathnames instead
   *					of doing it internally.
   *      Changed:  R. Barstad          Nov 1982  delete IDS2 concurrency
   *                                              lock control seg if exists
   *
   *
   ******************************************************************************************
   **************************************************************************************** */
%page;
gcos_mme_fsye_: proc (mcp, increment);
%page;
/*	P R O C E D U R E			*/

	increment = 2;
	scup = addr (mcp -> mc.scu);
	gseg = gcos_ext_stat_$gcos_slave_area_seg;
	ap1 = addrel (gseg, fixed (scu.ilc)+1);
	ap2 = addrel (gseg, fixed (arglst1.al2));
	rap = addrel (gseg, fixed (arglst2.ra));
	return.code = "1"b;

	fnc = fixed (arglst1.fn);

	if fnc > 22 then go to err2;
	if fnc_map (fnc) = 0 then go to err2;		/* illegal or unimplemented function */


/*	Get the pathname of catalog/file description */

	nameptr = addr (name);
	CSEQ_ptr = addrel (gseg, fixed (scu.ilc,18));
	call gcos_build_pathname_ (nameptr, addrel (gseg, BUFFER),
			       dirname, entryname, status);
	dirlen = length (rtrim (dirname));
	if dirlen = 0 then go to err1;		/* operations in UMC not allowed */
	pname = rtrim (dirname)
	      ||">"
	      ||entryname;

	go to fnc_proc (fnc_map (fnc));		/* process specific function */

fnc_proc (1):					/* create catalog request */
	dirsw = 1;
	mode = 01011b;				/* access = sma */
	bitcount = 0;
	go to create_entry;


fnc_proc (2):					/* create file request */
	op = addrel (gseg, fixed (arglst2.opt));	/* get pointer to options area */
	if opt.nonstruct | opt.userinfo then go to err4;	/* illegal file characteristics */
	if opt.spec_perms ^= (36) "1"b then go to err4;	/* specific permissions not handled */

	bitcount = fixed (opt.initial_size) * 36 * 320;

	if ^opt.llsize then bitcount = bitcount * 12;

	dirsw = 0;
	mode = 01010b;				/* access = rw */

create_entry: call modefn;				/* get mode and access name */

	call hcs_$append_branchx (dirname, entryname, mode, ring_br, access_name, dirsw, 0, bitcount, code);
	if code ^= 0 then go to err3;

	if fnc = 2 then go to exit;			/* done if create catalog */

	if opt.ids & opt.attrib_present then do;

	     entryname = substr (pname, dirlen+2) || ".ids_attributes";

	     call hcs_$make_seg (dirname, entryname, "", 01010b, attribptr, code);
	     if attribptr = null then go to err3;

	     attributes = opt.attrib;

	end;

	go to exit;



fnc_proc (3):					/* delete or purge file request */
	call delete_$path (dirname, entryname, "000100"b, "gcos_mme_fsye_", code);
	if code ^= 0 then go to err5;

	call gcos_ids2_concur_$delete_control(dirname,entryname,code); /* just try to delete, if can't --code bad-- don't care */

	entryname = substr (pname, dirlen+2) || ".ids_attributes";

	call delete_$path (dirname, entryname, "000100"b, "gcos_mme_fsye_", code);

exit:	return;


modefn:	proc;

	     access_name = get_group_id_$tag_star ();

	     ring_br = fixed (cu_$level_get (), 6);

	     return;
	end modefn;



/*	Error returns */

err1:	return.code = "100000111101"b;
	msg = "operations on the UMC not allowed";
	go to err_common;

err2:	return.code = "100000111101"b;		/* 4075 = illegal gefsye function */
	msg = "illegal or unimplemented function";
	go to err_common;

err3:	return.code = "100000111111"b;		/* 4077 = cannot create entry */
	go to get_msg;

err4:	return.code = "100000111110"b;		/* 4076 = illegal file characteristics */
	msg = "unimplemented file options";
	go to err_common;

err5:	return.code = "100001000100"b;		/* 4104 = unable to delete entry */

get_msg:	call convert_status_code_ (code, "xxxxxxxx", msg1);
	msg = msg1;				/* move char (100) to char (102) */

err_common: return.messaddr = arglst1.buf;

	call gcos_cv_ascii_gebcd_ (addr (msg), length (msg), addrel (gseg, fixed (arglst1.buf)), i);
	return.messlen = divide (length (msg), 6, 17, 0);
	return;
%page;

/*	External Entries	*/


dcl  convert_status_code_ ext entry (fixed bin(35), char (8), char (100));
dcl  cu_$level_get ext entry returns (fixed bin(24));
dcl  cv_oct_ entry (char (*), fixed bin(35));
dcl  date_time_$fstime ext entry (fixed bin(35), char (13));
dcl  delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin(35));
dcl  expand_path_ entry (ptr, fixed bin(24), ptr, ptr, fixed bin(35));
dcl  gcos_build_pathname_ ext entry (ptr, ptr, char(*), char (*), bit (72) aligned);
dcl  gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin(24), ptr);
dcl  gcos_ids2_concur_$delete_control ext entry (char(*),char(*),fixed bin(35));
dcl  get_group_id_$tag_star ext entry returns (char (32) aligned);
dcl  get_default_wdir_ ext entry returns (char (168));
dcl  hcs_$append_branchx ext entry (char (*), char (*), fixed bin(5), (3) fixed bin(6),
     char (*), fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35));
dcl  hcs_$chname_file ext entry (char (*), char (*), char (*), char (*), fixed bin(35));
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin(24), fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin(5), ptr, fixed bin(35));


/* 	Work Variables */


dcl  access_name char (32);
dcl  bitcount fixed bin(24);
dcl  bitmode bit (5) aligned;
dcl  code fixed bin(35);
dcl  CSEQ_ptr ptr;
dcl  date char (13);
dcl  dirname char (168);
dcl  dirsw fixed bin(1);
dcl  ecount fixed;
dcl  entryname char (32);
dcl  increment fixed bin;				/* number of argument words to skip over */
dcl  msg char (102);
dcl  msg1 char (100);
dcl  mode fixed bin(5);
dcl  name char (32);
dcl  pname char (168) varying;
dcl  ring_br (3) fixed bin(6);
dcl  status bit (72) aligned;
dcl (dirlen, fnc, i, j, k) fixed bin(24);

dcl  word bit (36) aligned based;

dcl (ap1, ap2, attribptr, cdp, gseg, nameptr, nnp, op, pp, rap, radp, sp) ptr;



/*	Structures and overlays */

dcl 1 arglst1 aligned based (ap1),			/* structure for the arg list following the mme */
    2 ccal bit (18) unal,				/* 0 or courtesy call address */
    2 al2 bit (18) unal,				/* location of arg list 2 */
    2 fn bit (18) unal,				/* function code */
    2 buf bit (18) unal;						/* working buffer address */

dcl 1 arglst2 aligned based (ap2),			/* structure for the main argument list */
    2 ra bit (18) unal,				/* address of the return area */
    2 pad1 bit (18) unal,
    2 catdesc bit (18) unal,				/* address of the cataog description */
    2 perms bit (18) unal,				/* address of the permissions word */
    2 opt bit (18) unal,				/* address of the options area */
    2 newname bit (18) unal;						/* address of the newname for modify functions */

dcl 1 opt aligned based (op),				/* the options area */
    2 contig bit (1) unal,				/* file must be contiguous */
    2 rand bit (1) unal,				/* define file as random */
    2 tss bit (1) unal,				/* file is tss-created */
    2 ids bit (1) unal,				/* file is IDS */
    2 llsize bit (1) unal,				/* file sizes specified in llinks */
    2 nonstruct bit (1) unal,				/* file on tape or nonstructured disk pack */
    2 pad bit (1) unal,
    2 attrib_present bit (1) unal,			/* attributes present */
    2 userinfo bit (1) unal,				/* user specified information present */
    2 pad1 bit (4) unal,
    2 protect bit (1) unal,				/* protection options specified */
    2 pad2 bit (22) unal,

    2 initial_size bit (18) unal,			/* initial file size */
    2 max_size bit (18) unal,				/* maximum file size (zero if unlimited) */
    2 spec_perms bit (36) unal,			/* specific permissions */
    2 attrib bit (180) unal;						/* attributes for IDS files */

dcl  attributes bit (180) aligned based (attribptr);

	/* MME GEFSYE Calling Sequence */

dcl 1 CALL_SEQ			aligned   based (CSEQ_ptr),
    2 CC		bit (18)		unaligned,
    2 ARGLIST	bit (18)		unaligned,
    2 FUNCTION	bit (18)		unaligned,
    2 BUFFER	fixed bin (18)	unaligned unsigned;

dcl 1 return aligned based (rap),			/* return area for error indicators */
    2 code bit (12) unal,				/* error code or zero */
    2 pad bit (24) unal,
    2 messaddr bit (18) unal,				/* address of error message */
    2 messlen fixed bin(17) unal;						/* length of error message (in words) */

dcl  fnc_map (22) fixed bin(24)aligned int static init (	/* map gefsye function codes to processors */
     0,						/* 1 = unimplemented */
     1,						/* 2 = ccreat */
     2,						/* 3 = fcreat */
    (5) 0,					/* 4 to 8 = unimplemented */
     3,						/* 9 = freles */
    (12) 0,					/* 10 to 21 = unimplemented */
     3);						/* 22 = fpurge */

dcl (addr, addrel, bit, divide, fixed, index, length, null, substr, unspec) builtin;
%page;
%include gcos_ext_stat_;
end gcos_mme_fsye_;




		    gcos_mme_info_.pl1              12/11/84  1358.2rew 12/10/84  1036.5      105174



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

/*
   *  MME GEINFO allows a slave program to access specific information outside the
   *  program's normal Base Address Register (BAR) limits.  Either or both of the
   *  following functions may be requested:
   *
   *
   *     1.	Information from the upper slave service area (SSA) of the user
   *		program can be copied to a buffer provided by the user.
   *		***NOTE:  this function is _n_o_t supported***
   *
   *     2.	A List Pointer Word (LPW) can be supplied to allow one or more single
   *		units of information to be placed in the slave program's core memory.
   *
   *
   *	CALLING SEQUENCE
   *
   *	MME	GEINFO
   *	ZERO	Buffer_end,Number_of_words
   *	ZERO	LPW,Size_of_list
   *
   *
   *	WHERE:
   *
   *	Buffer_end	address+1 of the end of a buffer storage area
   *	Number_of_words	size of the storage area
   *	LPW		Address of first word of list of directives to be processed
   *	Size_of_list	Number of words of list directives
   *
   *
   *  The format of the list of directives is as follows:
   *
   *
   *	ZERO	Address,Option
   *	ZERO	Address,Option
   *	 .	   .      .
   *	 .           .      .
   *	ZERO	Address,Option
   *
   *
   *  Address is the location at which the requested data word is to be stored.
   *  Option is the option number (See code below for values).
   *
   *
   Author: ?
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	07/28/81 Reorganized. 4S1 notice. Removed arg list restriction (By Dick Hemes)
   Change: Ron Barstad        83-09-29 Changed software release "4S1" to "4S3".
                                        Added options 16 and 17 for 4js3.
   Change: Ron Barstad        84-02-21 Allow move from SSA if only 2 words since
                                        is BCD userid 
*/
dcl  increment                fixed bin(24)parm;
dcl  mcpp                     ptr parm;
	mcp = mcpp;

/*
   Get set up for the MME processing.
*/
	increment = 2;
	scup = addr (mc.scu);
	storage_limit = gcos_ext_stat_$storage_limit;
	gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg;


/*
   Verify that the entire MME argument list is in addressable memory.
*/

	mme_arg_list_loc = fixed (scu.ilc, 18)+1;
	if mme_arg_list_loc+2 >= storage_limit then
	     call gcos_mme_bort_$system (		/* Bad mme address. */
	     gcos_et_$bad_mme_addr
	     , "MME GEINFO argument list is not entirely in slave limits."
	     );
	mme_arg_list_ptr = addrel (gseg_ptr, mme_arg_list_loc);

/*
   Is the user asking for any SSA words to be copied?  If so we must complain
   at this point since we cannot satisfy such a request.
*/
	if mme_arg_list.number_of_words ^= (18)"0"b       /* User has given an SSA Copy request */
	then if					/* See if we can bypass because it's redundant */
	     mme_arg_list.buffer_end ^= mme_arg_list.lpw | /* If SSA copy word just dup's the option word, we can */
	     mme_arg_list.number_of_words ^= mme_arg_list.lpw_size then /* If any of these checks fail, we can't bypass */
	          if fixed(mme_arg_list.number_of_words, 18) ^= 2 then /* there is ONE exception */
	     do;
		call gcos_mme_bort_$system (		/* Unimplemented MME. */
		gcos_et_$unimp_mme
		, "MME GEINFO cannot copy SSA words to user buffer."
		);
	     end;
	          else do;
/*
  Move the 2 word BCD userid (.SUID) to user buffer
*/
		     data_word_loc = fixed (mme_arg_list.buffer_end, 18);
		     if data_word_loc > storage_limit then
			call gcos_mme_bort_$system (		/* Bad mme address. */
			gcos_et_$bad_mme_addr
			, "MME GEINFO buffer end is not within slave limits."
			);
		     data_word_ptr = addrel (gseg_ptr, data_word_loc-2);
		     call gcos_cv_ascii_gebcd_ (addr(gcos_ext_stat_$userid),12,
			                      data_word_ptr, i);
		     return;
		end;

/*
   Now that we seem to have a valid request for a list of directives to
   be processed, let's see if the list is any good.
*/
	arg_list_loc = fixed (mme_arg_list.lpw, 18);
	size_of_list = fixed (mme_arg_list.lpw_size, 18);
	if arg_list_loc+size_of_list > storage_limit then
	     call gcos_mme_bort_$system (		/* Bad mme address. */
	     gcos_et_$bad_mme_addr
	     , "MME GEINFO directive list is not entirely within slave limits."
	     );
	if size_of_list = 0 then return;
	arg_list_ptr = addrel (gseg_ptr, arg_list_loc);


/*
   Now process the entire list of directives.
*/
	do arg_list_index = 1 to size_of_list;


/*
   Verify the validity of the data word location specified by the user in the directive list.
   This address must be within the slave limits or we must inform the user that he has sinned.
*/

	     data_word_loc = fixed (arg_list.address (arg_list_index), 18);
	     if data_word_loc >= storage_limit then
		call gcos_mme_bort_$system (		/* Bad mme address. */
		gcos_et_$bad_mme_addr
		, "MME GEINFO directive word data location is outside slave limits."
		);
	     data_word_ptr = addrel (gseg_ptr, data_word_loc);


/*
   Now extract the option number specified, verify it and prepare to process it.
*/
	     option_number = fixed (arg_list.option (arg_list_index), 18);
	     if option_number > hbound (opt, 1) then
		call gcos_mme_bort_$system (		/* Bad mme address (option number). */
		gcos_et_$bad_mme_addr
		, "MME GEINFO directive word option number is bad."
		);
	     goto opt (option_number);
%page;
/*
   Processor time remaining (copy of .SALT)
*/
opt (1):
	     fixed_data_word =
		Convert_Time (gcos_ext_stat_$time_limit-virtual_cpu_time_ ()+gcos_ext_stat_$initial_cpu_time);
	     goto option_loop;

/*
   SYSOUT lines remaining (calculated from .SSYOT 0-17 - .SSYOT 18-35)
*/
opt (2):
	     fixed_data_word = gcos_ext_stat_$sysout_limit-gcos_ext_stat_$sysout_lines;
	     goto option_loop;

/*
   Channel time remaining (copy of .SACHT)
*/
opt (3):
	     fixed_data_word = 0;
	     go to option_loop;

/*
   Processor time used (copy of .SPRT)
*/
opt (4):
	     fixed_data_word = Convert_Time (virtual_cpu_time_ ()-gcos_ext_stat_$initial_cpu_time);
	     goto option_loop;

/*
   SYSOUT lines used (from .SSYOT 18-35)
*/
opt (5):
	     fixed_data_word = gcos_ext_stat_$sysout_lines;
	     goto option_loop;

/*
   Channel time used (copy of .STCHT)
*/
opt (6):
	     fixed_data_word = 0;
	     goto option_loop;

/*
   Time-of-day start of activity (copy of .START)
*/
opt (7):
	     fixed_data_word = Convert_Time (gcos_ext_stat_$activity_start_time);
	     goto option_loop;

/*
   Program state word (copy of .STATE)
*/
opt (8):
	     data_word = "400000000000"b3;
	     goto option_loop;

/*
   Job urgency (from .SURG 18-23 aligned to bits 30-35)
*/
opt (9):
	     fixed_data_word = 10;
	     go to option_loop;

/*
   Configuration data (copy of .CRFIG)

   This word says: Series 60 or 6000;  IOM;  IOM #0 configured;  CPU #0 configured;
   CPU #0 has EIS;  and Datanet 355/6600 on system.
*/
opt (10):
	     data_word = "100010001000100000001000000000000001"b;
	     goto option_loop;

/*
   BCD time in hours-minutes-seconds (formatted as hhmmss)
*/
opt (11):
	     call date_time_ (clock (), date_string);
	     date_string = substr (date_string, 1, 2) || substr (date_string, 4, 2) || substr (date_string, 7, 2);
	     call gcos_cv_ascii_gebcd_ (addr (date_string), 6, addr (data_word), i);
	     goto option_loop;

/*
   Program number from SNUMB
*/
opt (12):
	     if substr (data_word, 1, 30) = gcos_ext_stat_$snumb then substr (data_word, 31, 6) = "12"b3;
	     else substr (data_word, 31, 6) = "00"b3;
	     goto option_loop;

/*
   Software release number (copy of .CRSR)
*/
opt (13):
	     data_word = "046203202020"b3;		/* "4S3" in BCD */
	     goto option_loop;

/*
   System default number of lines per printed page (copy of .CRPSZ)
*/
opt (14):
	     upper_half_data_word = 55;
	     goto option_loop;

/*
   Julian date (copy of .CRJCD)
*/
opt (15):
	     fixed_data_word = Julian_Date ();
	     goto option_loop;

/*
   Shared system number (.CRSSN)
*/
opt (16):	     
	     fixed_data_word = 0;
	     goto option_loop;

/*
   Startup option word (copy of .CROPT)

   This word says: ASCII printer available, FORTX, 800 & 1600 bpi,
   800 bpi low-den and 1600 high-den.
*/
opt (17):	     
	     data_word = "010100000000000000100000001001000100"b;
option_loop:   ;
	end;

/*
   Now that we have finished with the list of directives, return to the caller.
*/
	return;
%page;
Convert_Time: proc (multime) returns (fixed bin (35));


dcl  multime                  fixed bin(71)parm;
	     gcostime = divide (multime, 1000, 29)*64;
	     return (gcostime);

dcl  gcostime                 fixed bin(35);
	end Convert_Time;
%page;
Julian_Date: proc () returns (fixed bin (24));



	     call date_time_ (clock (), date_string);
	     call convert_date_to_binary_ (date_string||" midnight", midnight, code);
	     substr (date_string, 1, 5) = "01/01";
	     call convert_date_to_binary_ (date_string||" midnight", start_year, code);
	     call convert_date_to_binary_$relative ("1day", tomorrow, midnight, code);
	     daysworth = tomorrow-midnight;
	     julian_date = divide ((midnight-start_year), daysworth, 34)+1;
	     return (julian_date);

dcl  code                     fixed bin(35);
dcl  convert_date_to_binary_  entry (char (*), fixed bin(71), fixed bin(35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin(71), fixed bin(71), fixed bin(35));
dcl  daysworth                fixed bin(71);
dcl  julian_date              fixed bin(24);
dcl  midnight                 fixed bin(71);
dcl  start_year               fixed bin(71);
dcl  tomorrow                 fixed bin(71);
	end Julian_Date;
%page;
/*   Variables for gcos_mme_info_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  arg_list_index           fixed bin(24);
dcl  arg_list_loc             fixed bin(24);
dcl  arg_list_ptr             ptr;
dcl  clock                    builtin;
dcl  data_word                bit (36) aligned based (data_word_ptr);
dcl  data_word_loc            fixed bin(24);
dcl  data_word_ptr            ptr;
dcl  date_string              char (8);
dcl  date_time_               entry (fixed bin(71), char (*));
dcl  divide                   builtin;
dcl  fixed                    builtin;
dcl  fixed_data_word          fixed bin(35) aligned based (data_word_ptr);
dcl  gcos_cv_ascii_gebcd_     entry (ptr, fixed bin(24), ptr, fixed bin(24));
dcl  gcos_et_$bad_mme_addr    fixed bin(35) ext;
dcl  gcos_et_$unimp_mme       fixed bin(35) ext;
dcl  gcos_mme_bort_$system    entry options (variable);
dcl  gseg_ptr                 ptr;
dcl  hbound                   builtin;
dcl  i                        fixed bin(24);
dcl  mme_arg_list_loc         fixed bin(24);
dcl  mme_arg_list_ptr         ptr;
dcl  option_number            fixed bin(24);
dcl  size_of_list             fixed bin(24);
dcl  storage_limit            fixed bin(18);
dcl  substr                   builtin;
dcl  upper_half_data_word     fixed bin(17) unal based (data_word_ptr);
dcl  virtual_cpu_time_        entry () returns (fixed bin(71));

dcl 1 arg_list (size_of_list) aligned based (arg_list_ptr),
    2 address bit (18) unal,
    2 option bit (18) unal;


dcl 1 mme_arg_list aligned based (mme_arg_list_ptr),
    2 buffer_end bit (18) unal,
    2 number_of_words bit (18) unal,
    2 lpw bit (18) unal,
    2 lpw_size bit (18) unal;
%page;
%include gcos_ext_stat_;
     end gcos_mme_info_;




		    gcos_mme_inos_.pl1              09/09/83  1404.1rew 09/09/83  1007.6      539451



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

/*
   *  This procedure processes the I/O MME, GEINOS. The GEINOS calling sequence(s) are:
   *  Also contains code to process the GEENDC MME.
   *
   *			MME GEINOS
   *			OPERATION WORD
   *			IDENTIFICATION WORD
   *			RETURN WORD
   *
   *			or.....
   *
   *			MME GEINOS
   *			OPERATION WORD 1
   *			IDENTIFICATION WORD 1
   *			OPERATION WORD 2
   *			IDENTIFICATION WORD 2
   *			RETURN WORD
   *
   *			where:
   *
   *		OPERATION WORD FORMAT =
   *
   *			BITS	USE
   *			0-5	Device Command [cc] (See values below)
   *			6-17	Zeros
   *			18-22	IOC Command [ii]
   *			23	Zero
   *			24-29	Control
   *			30-35	Count [nn]
   *
   *		Operation word (GMAP oct implementation):
   *			8	16
   *			oct	cc0000ii00nn
   *
   *		IDENTIFICATION WORD FORMAT =
   *
   *			BITS	USE
   *			00-17	File Control Block Pointer
   *			18-35	Dcw List Pointer
   *
   *		RETURN WORD FORMAT =
   *
   *			BITS	USE
   *			0-17	Status Return Pointer
   *			18-35	Courtesy Call Address
   *
   *		DCW FORMAT
   *
   *			BITS	USE
   *			0-17	Data Address
   *			18-20	Zero
   *			   21	Character tally flag.
   *			22-23	Action Code (See values below)
   *			24-35	Count (value of zero indicates count of 4096)
   *
   *		DCW ACTION CODES
   *
   *			CODE	MEANING
   *			00	(IOTD) Transfer and Disconnect (this is last DCW in list)
   *			01	(IOTP) Transfer and Continue (with next DCW in list)
   *			10	(TDCW) Skip to New DCW List (whose address is in Data Address)
   *			11	(IONTP) Skip Data Transfer (skip words and continue with next DCW in list)
   *
   *		OPERATION WORD DEVICE COMMANDS [cc]
   *
   *			CODE	MEANING
   *
   *			00	Request Status
   *
   *			03	Read Typewriter
   *			04	Read Tape Decimal
   *			05	Read Tape Binary
   *
   *			13	Write (then Read) Typewriter
   *			14	Write Tape Decimal
   *				(and Write Filemark Decimal, when IOC command = "00100"b)
   *			15	Write Tape Binary
   *				(and Write Filemark, when IOC command = "00100"b)
   *
   *			25	Read
   *
   *			30	Write Printer Edited
   *			31	Write
   *
   *			34	Seek
   *
   *			40	Reset Status
   *
   *			41	Set 6250 Density
   *			42	Set 800 Density
   *			43	Set 556 Density
   *			44	Forward Space Record
   *			45	Forward Space to Filemark
   *			46	Backspace Record
   *			47	Backspace to Filemark
   *
   *			54	Erase
   *			55	Write EOF
   *
   *			60	Set High Density
   *			61	Set Low Density
   *			64	Set 200 Density
   *			65	Set 1600 Density
   *
   *			70	Rewind
   *			72	Rewind and Unload
   *
   *
*/
%page;
/*
   Author: DICK SNYDER OCTOBER 7, 1970
   Change: T. CASEY, OCTOBER 1973, DECEMBER 1973, AUGUST 1974
   Change: D. KAYDEN, MARCH 1974, APRIL 1974, JULY 1974, DECEMBER 1974, MARCH 1975
   Change: R.H. MORRISON  FEB 2, 1976
   Change: M. R. Jordan, September 1976
   Change: A. N. Kepner, March 1978 to allow courtesy call i/o  within cc routines
   Change: Dave Ward	05/20/81 multirecord read/write disk, various bugs.
   Change: Dave Ward	09/02/81 Removed use of cmd_word variable.
   Change: Dave Ward	09/02/81 provided tape density 6250.
   Change: Dave Ward	09/16/81 removed use of init (except for constant).
   Change: Scott C. Akers	12/23/81 Fix bugs which arise when dealing with
			         discontiguous DCWs and stuff.

   Change: Ron Barstad        01/27/83 Rewrite tape status checking. The
                                       old version was checking tally residues
                                        and IOM Central statuses, mistaking
                                       them for handler status.

   Change: Ron Barstad  83-07-01  Fix bug in writting multi-records to a non-randon file
   Change: Ron Barstad  83-08-03  Fix courtesy call queue to work like GCOS
*/
%page;
dcl  increment                fixed bin (24)parm;		/* number of words MME processor
						   must skip over */
dcl  mcpp                     ptr parm			/* pointer to machine conditions. */;
	mcp = mcpp;
	increment = 3;				/* init parameter skip number */
	gseg = gcos_ext_stat_$gcos_slave_area_seg;	/* pointer to slave program */
	storlimit = gcos_ext_stat_$storage_limit;	/* slave core boundary */
	trace_or_stopsw = dbs_mme_inos_trace | dbs_mme_inos_stop;

	scup = addr (mc.scu);			/* get ptr to scu data */
	i = instruction_counter + 2;			/* get offset of first id word */
	idptr = addrel (gseg, i);			/* build pointer to id word */

	if id_word.filep >= storlimit then		/* file control block ptr */
	     call gcos_mme_bort_$system (
	     gcos_et_$invalid_file_ptr
	     , "File code pointer in GEINOS sequence is outside slave limits."
	     );

	workp = addrel (gseg, id_word.filep);		/* get pointer to fcb */
	substr (fc, 1, 1) = xlate (fixed (substr (file_code_word.fcode, 1, 6))); /* translate file code */
	substr (fc, 2, 1) = xlate (fixed (substr (file_code_word.fcode, 7, 6))); /* to ascii */

	if fc = "  " 				/* a blank file code is illegal */
	then call gcos_mme_bort_$system (gcos_et_$fc_not_defined,
				   "Blank file code is illegal.");

	call init_routine;				/* Initialize variables. */

/* Now we see if we have a legal file code. The variable "j" gets set. */

	if fc = "*t" | fc = "t/" | fc = "/t"		/* See if it's the operator's console. */
	then fc = "t*";

	if ^match_fc ()				/* If we didn't find a match,
						   we bail out. */

	then call gcos_mme_bort_$system (gcos_et_$fc_not_defined,
				        """^a""", fc);

	if fct.sysout (j) then			/* abort if sysout file */
	     call gcos_mme_bort_$system (
	     gcos_et_$fc_not_defined
	     , "File code ""^a"" is assigned to SYSOUT."
	     , fc
	     );

	fibptr = fct.fibptr (j);			/* copy pointer to fib */

	call process_request;			/* Go do the dirty work. */
%page;
com_proc (01): ;

/* disk or drum seek */
	seeksw = "1"b;				/* Indicate seek has been performed. */
	if fib.type = random_file then do;		/* (no seek necessary for sequential file) */
	     if dcw_offset >= storlimit then		/* dcw addr OOB? */
		call gcos_mme_bort_$system (
		gcos_et_$invalid_dcw_ptr
		, "DCW is outside slave limits."
		);

	     dcwptr = addrel (gseg, dcw_offset);	/* get address of dcw */
	     if dcw.data_addr >= storlimit		/* data address OOB? */
	     | dcw.count ^= 1 then			/* count not 1 ? */
		call gcos_mme_bort_$system (
		gcos_et_$bad_seek_dcw
		, "DCW address field is outside slave limits or DCW word count is not 1."
		);

	     i = addrel (gseg, dcw.data_addr) -> seek_address; /* grab seek address */
	     fib.current = i*64;			/* multiply by block size */
	     if trace_or_stopsw then call ioa_ ("seek ^w", i);
	end;

bump:	;

	increment = increment + 2;			/* prepare for following command */
	idptr = addrel (idptr, 2);			/* get ptr to new id word */
	call process_request;			/* Do the next command. */
%page;
com_proc (02): ;

/* read disk continuous */

	if fib.read = "0"b then do;			/* Reads are not allowed on this file. */
	     if fib.null then do;			/* If this a null file */
		substr (slave_status, 3, 4) = "1111"b;	/* return eof status. */
		goto return_stat;
	     end;
	     call gcos_mme_bort_$system (
		gcos_et_$impermissible_perm_read
		, "No read permission on file ""^a""."
		, fc
		);
	end;

	if fib.order = write_file then do;		/* If last i/o request was a write, then */
	     fib.order = read_file;			/* we must bring ios_'s seek pointers together */
	     goto seek;
	end;

	if fib.type = random_file then do;		/* Seek only if file is random. */
seek:	     ;
	     if seeksw = "0"b then			/* read or write must be preceded by a seek */
		call gcos_mme_bort_$system (
		gcos_et_$bad_io_cmnd_file
		, "Disk ^[read^;write^] without a seek on file ""^a""."
		, fib.order = read_file
		, fc
		);
	     call do_seek;
	end;
	if fib.type ^= random_file then		/* Linked file. */
	call check_multirecord_request (mr);
	goto loop;

com_proc (03): ;

/* write disk continuous */

	if fib.write = "0"b then do;			/* write not allowed ? */
	     if fib.null then goto return_stat;		/* is this a null file ? */
	     call gcos_mme_bort_$system (
		gcos_et_$impermissible_perm_write
		, "No write access to file ""^a""."
		, fc
		);
	end;

	if fib.order = read_file then do;		/* if last i/o request was a read, then */
	     fib.order = write_file;			/* we must bring ios_'s seek pointers together */
	     goto seek;
	end;
	if fib.type = random_file then goto seek;
	call check_multirecord_request (mr);

/* transfer to loop. */
%page;
/* Read and write processing. */

loop:	;

/* Call a subroutine which examines the dcw list and returns the
   number of contiguous words to transmit (count), the address to
   transmit from/to (where), and an indicator saying whether
   there are more dcws to be processed (continue).
*/
	call get_dcw;

	if fib.type = linked_file then do;		/* Linked file on disk. */
	     if fib.order = read_file then		/* sequential file read */
		if fib.current >= fib.last then do;	/* check for end of valid data */
		     substr (slave_status, 3, 4) = "1111"b; /* set eof status */
		     wc_residue = count;
		     da_residue = where;
		     goto return_stat;
		end;

	     if mr = "0"b then			/* Not a multirecord request. */
		if (count + total_count) > 320 then do; /* About to exceed 1 block. */
		     wc_residue = count + total_count - 320;
		     continue = "0"b;
		     count = max (0, 320 - total_count); /* Adjust count to finish to 1 block. */
		end;
	end;

	fib.current = fib.current + count;		/* Calculate next position in the file. */

	if fib.current > fib.size then goto disk_eof;	/* will i/o go over eof ? */

/* If get_dcw returns a where value of -1, this means that a skip
   DCW (IONTP) has been encountered. In this case, the proper
   pointer will be advanced by the value in count, an the next
   DCW is obtained.
*/

	if where = -1 then do;			/* => Skip DCW (IONTP). */
	     if fib.type = linked_file then
		if fib.order = write_file then do;	/* Fill block with zeroes. */
		     if count < 1 then nelemt = 0;
		     else
		     call ios_$write (
			fib.stream
			, addr (z320)
			, 0			/* offset to 1st word of z320. */
			, count			/* Number words to write. */
			, nelemt			/* (output) number of words written. */
			, status
			);
		     goto complete;
		end;
	     if count > 0 then
		call do_seek;
	end;
	else do;					/* Data movement DCW (IOTP or IOTD). */

issue:	     ;

	     if fib.order = write_file then
		call ios_$write (
		fib.stream
		, gseg
		, where
		, count
		, nelemt
		, status
		);
	     else
	     call ios_$read (
		fib.stream
		, gseg
		, where
		, count
		, nelemt
		, status
		);

complete:	     ;

	     total_count = total_count + nelemt;	/* Update count total. */
	     if fib.tape then goto tape_stat;
	     if code ^= 0 then do;
fail_loop:	;
		call gcos_mme_bort_$system (
		     code
		     , "Fatal ^[read^;write^] error on ^[random^;linked^]  file ""^a""."
		     , fib.order = read_file
		     , fib.type = random_file
		     , fc
		     );
	     end;
	     if fib.order = write_file then fib.last = max (fib.last, fib.current); /* update last pointer */
	     da_residue = where + count;
	end;
	if continue then goto loop;

/* Complete the i/o operation. */
	if fib.type = linked_file then		/* Final positioning. */
	     if mr = "0"b then			/* Not multirecord request. */
		if total_count < 320 then do;
		     fib.current = fib.current + (320 - total_count);
		     if fib.order = write_file then do; /* Fill block with zeroes. */
			call ios_$write (
			     fib.stream
			     , addr (z320)
			     , 0			/* 1st word of z320. */
			     , 320-total_count	/* Number words to write. */
			     , nelemt		/* (output) number of words written. */
			     , status
			     );
			if code ^= 0 then goto fail_loop;
			if fib.order = write_file then fib.last = max (fib.last, fib.current); /* update last pointer */
		     end;
		     else				/* => linked file read. Position to block. */
		     call do_seek;
		end;
	goto return_stat;
%page;
com_proc (04): ;

/* rewind disk/drum */

	if fib.print then goto return_stat;		/* temporary fix until sysout is working */
	if fib.null then goto return_stat;		/* is this a null file ? */

	fib.current = 0;				/* reset position */

	goto disk_posit;
%page;
com_proc (05): ;

/* backspace disk/drum */

	bksp_sw = "1"b;				/* remember backspace */


bksp_share: ;

	if fib.type = random_file then		/* abort if random */
	     call gcos_mme_bort_$system (
	     gcos_et_$bad_io_cmnd_file
	     , "Attempt to backspace/forward space random file ""^a""."
	     , fc
	     );
	if fib.null then goto return_stat;		/* is this a null file ? */

	j = op_word.count;
	if j = 0 then j = 64;			/* zero count means 64 */
	j = 320*j;
	if bksp_sw then j = -j;

	fib.current = fib.current + j;
	if fib.current < 0 then fib.current = 0;	/* allow for backspace too far */
	if fib.current > fib.size then do;		/* check for end of file */


disk_eof:	     ;

	     if fib.type = random_file then		/* end of file on a random file */
		call gcos_mme_bort_$system (
		gcos_et_$access_beyond_file
		, "Positioning to ^i on random file ""^a"" exceeds size ^i."
		, fib.current
		, fc
		, fib.size
		);
	     substr (slave_status, 3, 4) = "1111"b;	/* Is this the proper status ? */

	     rec_ct_residue = divide (fib.current - fib.size, 320, 17, 0);
	     substr (slave_status, 31, 6) = substr (unspec (rec_ct_residue), 31, 6);

	     fib.current = fib.size;

	end;


disk_posit: ;

	call do_seek;

	goto return_stat;				/* process status */
%page;
com_proc (06): ;

/* forward space disc/drum */

	bksp_sw = "0"b;				/* remember forward space */

	goto bksp_share;				/* now go share backspace code */
%page;
com_proc (07): ;

/* reset status for disk/drum */

	goto return_stat;
%page;
com_proc (08): ;

/* request status for disk/drum */

	goto return_stat;
%page;
com_proc (09): ;					/* read tape binary */

	error_retry = "0"b;
	total_read = 0;				/* Haven't read anything first time through. */
	fib.order = read_file;			/* indicate read to be done */
	if   fib.mode ^= "00"b
	then do;
	     fib.mode = "00"b;
	     order = "binary";
	     call ios_$order (fib.stream, order, null, status);
	     end;

	more_dcws = "1"b;
	do   while (more_dcws);
	     call next_dcw_ptr (output_ptr, transfer_count, more_dcws);
	     call ios_$read (fib.stream, output_ptr, 0, transfer_count, nelemt, status);

	     total_read = total_read + nelemt;
	     da_residue = dcw.data_addr + nelemt;
	     wc_residue = transfer_count - nelemt;

	     end;
	goto tape_status;
%page;
com_proc (10): ;					/* write tape binary */

	fib.order = write_file;			/* indicate write to be done */

	if fib.mode = "00"b then goto mode_set;		/* mode already binary? */
	fib.mode = "00"b;				/* set mode to binary */
	order = "binary";				/* set up to change mode */

mode_order: ;
	call ios_$order (fib.stream, order, null, status); /* change tape mode */

mode_set:	;
	call get_dcw;				/* get dcw */
	error_retry = "0"b;				/* not doing error recovery */
	if where >= 0 then
	     if continue = "0"b then goto issue;	/* avoid  overhead of extra buffering if possible */

	sc_ga = "1"b;				/* remember for possible error recovery */
	if fib.buffer = null then
	     fib.buffer = addr (tapebuffer);

	if fib.order = read_file then do;

sc_read:	     ;
	     call ios_$read (fib.stream, fib.buffer, 0, 1632, nelemt, status);
	     call adjust_buffer (fib.buffer);

	     call scatter_input (fib.buffer);		/* send any data to slave, even if tape error */
	end;
	else do;					/* Write tape. */
	     posit = 0;				/* init fib.buffer position */

ga_loop:	     ;
	     if where >= 0				/* skip dcw ? */
	     then do;
		ibuffptr = addrel (fib.buffer, posit);	/* pointer to intermediate fib.buffer */
		sbuffptr = addrel (gseg, where);	/* pointer to slave fib.buffer */
		internal_buffer = slave_buffer;	/* move data */
		posit = posit + count;		/* adjust intermediate fib.buffer position */
		end;
	     if continue				/* more to do ? */
	     then do;
		call get_dcw;
		goto ga_loop;
		end;

	     da_residue = where + count;		/* data address residue */
	     wc_residue = 0;			/* word count residue */

	     call ios_$write (fib.stream, fib.buffer, 0, posit, nelemt, status); /* write gathered output */
	end;
	goto tape_status;				/* done - now process status */

%page;
com_proc (11): ;

/* read tape nine */

	fib.order = read_file;			/* indicate read to be done */


asa9_common: ;

	if fib.mode = "10"b then goto mode_set;		/* already in asa9 mode? */

	fib.mode = "10"b;				/* set mode to decimal */
	order = "nine";				/* prepare to make order call */

	goto mode_order;
%page;
com_proc (12): ;

/* write tape nine */

	fib.order = write_file;			/* indicate write to be done */

	goto asa9_common;
%page;
com_proc (13): ;

/* rewind */

	order = "rewind";
	goto order_call;
%page;
com_proc (14): ;

/* write eof */

	order = "eof";
	goto order_call;
%page;
com_proc (15): ;

/* forward space file */

	order = "forward_file";
	goto order_call;
%page;
com_proc (16): ;

/* backspace file */

	order = "backspace_file";
	goto order_call;
%page;
com_proc (17): ;

/* forward space record */

	order = "forward_record";
	goto order_loop;
%page;
com_proc (18): ;

/* backspace record */

	order = "back";


order_loop: ;

	i = op_word.count;				/* pick up skip count */
	if i = 0 then i = 64;			/* count of 0 means 64 */

	do j = 1 to i;				/* loop to skip */
	     call ios_$order (fib.stream, order, null, status); /* issue a skip order */
	     if code ^= 0 then do;			/* stop if any problems */
		rec_ct_residue = i-j;		/* compute count of no of skips left */
		goto tape_status;
	     end;
	end;

	goto tape_status;				/* process status */
%page;
com_proc (19): ;

/* write file mark binary */

	goto com_proc (14);
%page;
com_proc (20): ;

/* write file mark decimal */

	goto com_proc (14);
%page;
com_proc (21): ;

/* erase */

	order = "erase";
	goto order_call;
%page;
com_proc (22): ;

/* rewind and unload */

	order = "unload";
	goto order_call;
%page;
com_proc (23): ;

/* set high density */

	order = "high";
	density_history = "01"b ;
	goto tape_high_low;
%page;
com_proc (24): ;

/* set low density */

	order = "low";
	density_history = "00"b ;


tape_high_low: ;

	if fib.density = "0000"b then goto set_density;	/* means "as is" */
	if fib.density = "1111"b then do;		/* use system default densities */
	     if order = "high" then order = default_high;
	     else order = default_low;
	     goto set_density;
	end;

	if fib.density = "0010"b then goto com_proc (26);
	if fib.density = "0100"b then goto com_proc (27);
	if fib.density = "1001"b then goto com_proc (28);
	if fib.density = "1100"b then goto com_proc (41);
%page;
com_proc (25): ;

/* set 200 density */

	order = "d200";
	density_history = "10"b ;
	goto set_density;
%page;
com_proc (26): ;

/* set 556 density */

	order = "d556";
	density_history = "00"b ;
	goto set_density;
%page;
com_proc (27): ;

/* set 800 density */

	order = "d800";
	density_history = "01"b ;
	goto set_density;
%page;
com_proc (28): ;

/* set 1600 density */

	order = "d1600";
	density_history = "11"b ;

set_density: ;

	call ios_$order (fib.stream, order, null, status);
	if code = 0 then fib.dens_hist = density_history; /* change history bits only if order was successful */
	goto tape_status;
%page;
com_proc (41): ;

/* set 6250 density */

	order = "d6250";
	density_history = "00"b ;
	goto set_density;
%page;
com_proc (29): ;

/* reset status */

	order = "reset_status";
	override = 1;


order_call: ;

	call ios_$order (fib.stream, order, null, status);

	goto tape_status;
%page;
com_proc (30): ;

/* request status */

	call ios_$order (fib.stream, "request_status", addr (slave_status), status);
	override = 1;

	goto tape_status;
%page;
com_proc (31): ;

/* read tape bcd */

	fib.order = read_file;			/* indicate read to be done */


bcd_common: ;

	if fib.mode = "01"b then goto mode_set;		/* already in bcd mode? */

	fib.mode = "01"b;				/* set mode to bcd */
	order = "bcd";				/* prepare to make order call */

	goto mode_order;
%page;
com_proc (32): ;

/* write tape bcd */

	fib.order = write_file;			/* indicate write to be done */

	goto bcd_common;
%page;
com_proc (33): ;

/* write printer edited */

	n = 1;


write_prt: ;

	do i = 1 to n;


get_prt_dcw:   ;

	     call get_dcw;
	     if where < 0 then goto get_prt_dcw;	/* skip dcw ? */
	     if count > 27 then do;
		if count = 4096 then goto print_skip;
		count = 27;
	     end;
	     j = count*4;				/* compute length of char */
						/* string overlay		 */
	     call gcos_write_$bcd_ptr (fibptr, addrel (gseg, where) -> record,
		"11111100"b);			/* put on file */


print_skip:    ;

	     if continue then goto get_prt_dcw;

	end;

	goto return_stat;				/* return good status */
%page;
com_proc (34): ;

/* write printer edited continuous */

	n = op_word.count;				/* get record count */
	if n = 0 then n = 64;
	goto write_prt;
%page;
com_proc (35): ;

/* reset status */

	goto return_stat;
%page;
com_proc (36): ;

/* request status */

	goto return_stat;
%page;
com_proc (37): ;

/* write console */

	ascii_index = 0;				/* init line index for possible multi-dcw list */


type_loop: ;					/* come here for all dcws after the first */

	call get_dcw;				/* analyze dcw */

	if where = -1 then goto type_loop;		/* if this dcw said skip data, do it */

	workp = addrel (gseg, where);			/*  get pointer to string to write */

	do i = 1 to count*6;

	     if bcd_string (i) = "77"b3 then do;	/* escape */
		i = i+1;
		if bcd_string (i) = "77"b3 then do;	/* escape */
		     i = i+1;
		     if bcd_string (i) = "77"b3 then char = "!";
		     else
		     if bcd_string (i) = "17"b3 then char = "?";
		     else
		     if bcd_string (i) = "20"b3 then do;
			substr (ascii_string, ascii_index, 3) = "/b";
			ascii_index = ascii_index + 3;
			goto skip_fill;
		     end;
		     else do;
			substr (slave_status, 3, 10) = "0011010000"b; /* incorrect format */
			goto type_it;		/*  send the good part */
		     end;
		     goto end_loop;
		end;

		j = fixed (bcd_string (i));		/* get carriage control char */
		if j < 32 then unspec (char) = "012"b3; /* put newline in string */
		else unspec (char) = "011"b3;		/* put tab in string */
		goto end_loop;
	     end;

	     if bcd_string (i) = "17"b3 then goto skip_fill; /* if not fill char */
	     char = xlate (fixed (bcd_string (i)));	/* put ascii equivalent in string */


end_loop:	     ;

	     ascii_index = ascii_index+1;		/* increment ascii output string index */
	     substr (ascii_string, ascii_index, 1) = char; /* stuff char into string */


skip_fill:     ;

	     if ascii_index > 129 then goto type_it;	/* check for too much output */

	end;

	if continue then goto type_loop;		/* if more dcws, go process them */


type_it:	;

	if ascii_index > 0 then			/* type line and test for write-then-read */
	     call ios_$write_ptr (addr (ascii_string), 0, ascii_index); /* print output */

	if op_word.count = 2 then goto bump;		/* test for write then read */
	goto return_stat;				/* go return status */
%page;
com_proc (38): ;

/* read console */

	call get_dcw;				/* analyze dcw */

	call ios_$read_ptr (addr (ascii_string), 132, i); /* read a line from tty */
	i = i - 1;				/* strip off NL */
	if i > 0 then				/* check for null response */
	     call gcos_cv_ascii_gebcd_ (addr (ascii_string), i, addr (mybuf), i); /* convert to bcd */
						/* don't attempt to convert null string */
	nelemt = divide (i+5, 6, 17, 0);		/* compute word and character residues */
	cc_residue = mod (i, 6);
	call scatter_input (addr (mybuf));
	goto return_stat;
%page;
com_proc (39): ;

/* reset status */

	goto return_stat;
%page;
com_proc (40): ;

/* request status */

	goto return_stat;
%page;
tape_stat: ;

	if fib.order = read_file then call adjust_buffer (addrel (gseg, where)); /* adjust fib.buffer on input */

	wc_residue = count - nelemt;
	da_residue = where + nelemt;


tape_status:	;



	if   ^substr (unspec (status), 1, 1)		/* Are we expected to interpret
						/* a Multics error code? */
	then do;
	     if   code = 0
	     then go to return_stat;			/* everything ok */
	     else call gcos_mme_bort_$system (code, "fc=""^a""", fc);
	     end;

	substr (slave_status, 1, 12) =   "10"b
				 ||substr (unspec (status), 27, 10);  /* copy major/minor status */
	substr (slave_status, 31, 6) = substr (unspec (rec_ct_residue), 31, 6); /* copy any residue from skip op */

	if trace_or_stopsw then call ioa_ ("status:^-^w", slave_status);

	major_status = substr (unspec (status), 27, 4);	/* Get major and minor status */
	minor_status = substr (unspec (status), 31, 6);
	
	if   major_status = "0000"b			/* Device Ready */
	   | major_status = "0100"b			/* EOF */
	then goto return_stat;

	if   major_status = "1001"b			/* Device busy */
	   & minor_status = "000000"b			/* Command Accepted */
	then goto return_stat;
	

	if ^error_retry then			/* if not already attempting error recovery, */
	     fib.error_retry = fib.error_retry + 1;	/* then count tape errors */

	call make_stat_ptr;				/* we need pointer to status words */
	if override = 0 then
	     if substr (sw1, 1, 33) = (33)"1"b then	/* error recovery override requested */
		override = - (addr (sw1) -> fb35);	/* remember type */

	if   override = 1				/* normal status override */
	   | override = 5				/* override all except mpc statuses */
	then  go to return_tape_stat;

	if   major_status = "0001"b			/* Device Busy */
	   | major_status = "0010"b			/* Device Attention */
	then goto epabort;

	if   major_status = "0101"b			/* Command Reject */
	then do;
	     if   (minor_status & "001000"b) = "001000"b	/* Tape on Load Point */
	     then goto return_tape_stat;
	     else goto epabort;			/* Other cmd rejects are illegal */
	     end;

	if   major_status ^= "0011"b
	then go to epabort;				/* If not Data Alert, abort */

	if   (minor_status & "000011"b) = "000011"b	/* Bit During Erase */
	then goto epabort;

	if   override = 3
	then goto return_tape_stat;			/* override case 2 */

	if   (minor_status & "000010"b) = "000010"b	/* Blank Tape on Read */
	   | (minor_status & "100000"b) = "100000"b	/* End of Tape */

	then goto return_tape_stat;

	if   (minor_status & "000001"b) = "000001"b	/* Transfer Timing Alert */
	   | (minor_status & "000100"b) = "000100"b	/* Transmission Parity Alert */

	then goto epabort;

/* 	We must have a parity error of some type */


	if override = 2 then go to return_tape_stat;	/* override parity errors */

	if ^error_retry then retry_count = 11;
	error_retry = "1"b;				/* set switch to indicate we are processing error */
	retry_count = retry_count-1;			/* decrement retry attempt count */
	if retry_count = 0 then go to epabort;		/* abort if we still have */
						/* parity error after 10 retries */

	slave_status = "400000000000"b3;		/* reinitialize status for retry */

	if override ^= 4 then			/* check for bypass noise check */
	     if fib.order = read_file then
		if nelemt < 4 then
		     if nelemt > 0 then		/* noise record */
			if sc_ga then goto sc_read;
			else goto issue;

	call ios_$order (fib.stream, "back", null, status); /* backspace tape */

	if fib.order = write_file then
	     if retry_count ^= 10 then		/* on a write, retry same spot once */
		call ios_$order (fib.stream, "erase", null, status); /* then erase bad spot on tape */

	if sc_ga = "0"b then goto issue;
	else
	if fib.order = write_file
	then do;					/* write gathered output */
	     call ios_$write (fib.stream, fib.buffer, 0, posit, nelemt, status);
	     goto tape_status;			/* done - now process status */
	     end;

	else goto sc_read;


epabort:	;

	call gcos_mme_bort_$system (
	     gcos_et_$irrecoverable_io_err
	     , "Fatal tape I/O error on file ""^a"".  Status = ^w."
	     , fc
	     , slave_status
	     );
%page;
return_stat: ;

	call make_stat_ptr;


return_tape_stat: ;

	sw1 = slave_status;				/* move status into slave */
	sw2 = "0"b;

	substr (sw2, 1, 18) = substr (unspec (da_residue), 19, 18); /* and data address residues */
	if cc_residue ^= 0 then			/* check for character residue */
	     substr (sw2, 19, 3) = substr (unspec (cc_residue), 34, 3); /* we have some */
	substr (sw2, 22, 1) = (fib.order = read_file);	/* Last order was a read. */
	substr (sw2, 23, 2) = type_dcw;		/* Type of last DCW. */
	substr (sw2, 25, 12) = substr (unspec (wc_residue), 25, 12); /* return word count */
	if trace_or_stopsw then call ioa_ ("status ^w ^w", sw1, sw2);

	fib.iocount = fib.iocount + 1;		/* count I/O requests completed */

	if return_word.courtesy_call = 0 then return;	/* done if no courtesy call */

	if gcos_ext_stat_$save_data.cc then do;		/* Already in courtesy call */

/* Check courtesy call queue for overflow */
	     new_next_avail =
		mod (courtesy_call.next_avail, hbound (courtesy_call.queue, 1))+1;
	     if courtesy_call.next_out = new_next_avail then
		call gcos_mme_bort_$system (
		gcos_et_$bad_mme_in_cc
		, "Maximum of ^i simultaneous outstanding courtesy calls has been exceeded."
		, hbound (courtesy_call.queue, 1)-1
		);

/* Add cc address to queue */
	     courtesy_call.queue (courtesy_call.next_avail) =
		return_word.courtesy_call;
	     courtesy_call.next_avail = new_next_avail;
	end;
	else do;					/* Not in courtesy call yet. */
	     gcos_ext_stat_$save_data.cc = "1"b;	/* indicate that courtesy call in progress */


/* Save machine conditions and increment value for return to the caller of	 */
/* MME GEINOS when the MME GEENDC is executed. Put courtesy call address		 */
/* in increment to cause control to go to courtesy call routine.		 */

	     gcos_ext_stat_$increment_hold = increment;	/* save increment */
	     courtesy_call.hold = courtesy_call_conditions.save_space; /* save MME GEINOS conditions */
	     i = return_word.courtesy_call;		/* get courtesy call address */
	     j = instruction_counter;			/* get loc of MME GEINOS */
	     increment = i-j-1;			/* compute increment value to cause control to go to cc rtn */
	end;

	return;					/* go */
%page;
mme_endc:	entry (mcpp, increment);

/* MME GEENDC. Processing consists of restoring
   The machine conditions that existed at the time of the MME GEINOS
*/

	if gcos_ext_stat_$save_data.cc = "0"b then
	     call gcos_mme_bort_$system (
	     gcos_et_$geendc_not_in_cc
	     , "A MME GEENDC has been executed outside of a courtesy call."
	     );

	mcp = mcpp;

	if courtesy_call.next_out = courtesy_call.next_avail then do; /* cc queue empty */
	     gcos_ext_stat_$save_data.cc = "0"b;	/* unset courtesy call in progress flag */

	     increment = gcos_ext_stat_$increment_hold;	/* set old increment */

/* Restoration of slave program registers at time of courtesy call  */
	     mc_save_ptr = addr (courtesy_call.hold);
	     mcp -> mc_save_data.pr_regs = mc_save_data.pr_regs;
	     mcp -> mc_save_data.s_regs = mc_save_data.s_regs;
	     mcp -> mc_save_data.ici_regs = mc_save_data.ici_regs;
	     mcp -> mc_save_data.pl_regs = mc_save_data.pl_regs;
	end;
	else do;					/* cc routine still waiting. */

/* remove cc address from queue */
	     scup = addr (mc.scu);			/* get ptr to scu data */
	     increment =				/* Set increment to return to courtesy code return. */
		courtesy_call.queue (courtesy_call.next_out)
		- instruction_counter
		-1
		;
	     courtesy_call.next_out =
		mod (courtesy_call.next_out, hbound (courtesy_call.queue, 1))+1;

	end;

	return;
%page;
inos_trace_filecode: entry (arg_string);

/* Set file code values to trace. */
dcl  arg_string               char(*)parm;

	do k = 1 by 1;
	     if next_arg (k, argp, arglen) then return;
	     dbs_filecode = "1"b;
	     if (arg = "-pr") | (arg = "-print") then do; /* Display which files being traced. */
		if trace_index < 1 then call ioa_ ("No files being traced.");
		else
		do i = 1 to trace_index;
		     call ioa_ ("^3i. ^a", i, trace_array (i));
		end;
	     end;
	     else do;
		if trace_index >= hbound (trace_array, 1) then
		     call ioa_ ("ONLY ^i ALLOWED, ^a not entered.", hbound (trace_array, 1), arg);
		else do;
		     trace_index = trace_index + 1;	/* set table size */
		     trace_array (trace_index) =	/* Record file code (lower case) to trace. */
			translate (
			arg
			, "abcdefghijklmnopqrstuvwxyz"
			, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
			);
		end;
	     end;
	end;
	return;
%page;
adjust_buffer: proc (bp);

/* for a fib.buffer just read from tape,
   determine if Multics has given us
   one word too much
*/
dcl  bp                       ptr parm;

	     if nelemt >= 4 then
		if bcw.blk_size = (nelemt - 2) then
		     if addrel (bp, nelemt - 1) -> word = "0"b then
			nelemt = nelemt - 1;
	     return;

dcl  word                     aligned bit(36) based;

dcl 1 bcw		aligned based (bp),
      2 bsn	fixed bin (18)unsigned unal,
      2 blk_size	fixed bin (18)unsigned unal;
	end adjust_buffer;
%page;
check_multirecord_request: proc (m);

/* Set "m" to "1"b if the MME GEINOS operation word
   specifies a multirecord request, and verify that the sum of the
   DCW list count of words to move and/or skip is consistent with
   the operation word block count.
   Set "m" to "0"b if the operation is not multirecord.
*/
dcl  m                        bit(1)parm;
	     if op_word.ioc_com ^= multirecord_com then do;
		m = "0"b;
		return;
	     end;

	     t = 0;				/* Total of DCW's words. */
	     d = dcw_offset;
get_ptr:	     ;

	     if d >= storlimit then			/* dcw ptr legal ? */
		call gcos_mme_bort_$system (
		gcos_et_$invalid_dcw_ptr
		, "DCW (at ^6.3b oct) is outside slave limits (^6.3b)."
		, addr (d) -> r18
		, addr (storlimit) -> r18
		);

	     dcwptr = addrel (gseg, d);		/* get ptr to dcw list */

	     if dcw.action = TDCW then do;		/* Transfer DCW. */
		d = dcw.data_addr;			/* get new address */
		goto get_ptr;			/* continue */
	     end;

	     if dcw.count = 0 then t = t+4096;
	     else t = t+dcw.count;
	     d = d + 1;				/* bump to next dcw */
	     if dcw.action ^= IOTD then goto get_ptr;	/* iontp or iotp - check next dcw */

	     nb = op_word.count;
	     if nb = 0 then nb = 64;			/* (gcos convention). */
	     if t ^= (320*nb) then
		call gcos_mme_bort_$system (
		gcos_et_$bad_multirec
		, "Multirecord ^[read^;write^] on file ""^a""."
		||"^/Requesting ^i blocks (^i words) but ^i specified in"
		||" MME GEINOS command (at memory ^6.3b)."
		, fib.order = read_file
		, fc
		, nb
		, count
		, op_word.count
		, scu.ilc
		);

	     m = "1"b;
	     return;

dcl  d                        fixed bin (24);
dcl  nb                       fixed bin (24);
dcl  t                        fixed bin (24);
	end check_multirecord_request;
%page;
debug_proc: proc ();

/* Display filecode debugging. */
	     if trace_index = 0 then goto trace;

	     do i = 1 to trace_index;
		if trace_array (i) = fc then goto trace;
	     end;
	     return;

trace:	     ;
	     if dbs_mme_inos_trace then do;
		call ioa_ (
		     "^a order ^w ^a (at ^6.3b)"
		     , fc
		     , op_word
		     , type_op (op_word.dev_com)
		     , rel (opptr)
		     );
	     end;

	     if dbs_mme_inos_stop then do;
		call ioa_ ("CALLING db:");
		call db;
	     end;
	     return;

	end debug_proc;
%page;
do_seek:	proc;					/* position file at fib.current */

	     if fib.current > fib.last then do;
		call ios_$seek (fib.stream, "last", "first", fib.current, status);
		if code ^= 0 then
		     call gcos_mme_bort_$system (
		     code
		     , "I/O error seek extending file ""^a"" to position ^i."
		     , fc
		     , fib.current
		     );
	     end;

	     if fib.order = write_file then seek_pointer = "write"; /* seek the write pointer */
	     else seek_pointer = "read";		/* seek the read pointer */

	     call ios_$seek (fib.stream, seek_pointer, "first", fib.current, status); /* do seek */
	     if code ^= 0 then
		call gcos_mme_bort_$system (
		code
		, "I/O error seeking to ^i on file ""^a""."
		, fib.current
		, fc
		);

	     return;
	end do_seek;
%page;
get_cmd_tbl_entry: proc;
	if fib.tape				/* tape? */
	then do;
	     fib.command_count = index.printer - index.tape;   /* get command table length */
	     fib.command_index = index.tape;		/* get command table address */
	     end;

	else if fib.print				/* printer? */
	     then do;
		fib.command_count = index.typewriter - index.printer;  /* get command table length */
		fib.command_index = index.printer;	/* get command table address */
		end;

	     else if fib.console			/* typewriter? */
		then do;
		     fib.command_count = index.next - index.typewriter;	/* get command table length */
		     fib.command_index = index.typewriter;   /* get command table address */
		     end;

/* If none of the above, the device type is disk (or punch simulated as a disk). */
		else do;
		     fib.command_count = index.tape - index.disk; /* get command table length */
		     fib.command_index = index.disk;	/* get command table address */
		     end;

	return;

end get_cmd_tbl_entry;
%page;
get_dcw: proc;

/* Return "count" with total number of contiguous words specified
   by DCW's, "where" to the memory location, and "continue" to
   "1"b if there are more DCW's to be processed. The format of
   the DCW, and the meanings of the action codes, are described
   in the comments at the beginning of the external procedure,
   gcos_mme_inos_.
*/
	     count = 0;
	     successive_tdcws = 0;

get_ptr:	     ;
	     if dcw_offset >= storlimit then		/* dcw ptr legal ? */
		call gcos_mme_bort_$system (
		gcos_et_$invalid_dcw_ptr
		, "DCW (at ^6.3b oct) is outside slave limits (^6.3b)."
		, addr (dcw_offset) -> r18
		, addr (storlimit) -> r18
		);

	     dcwptr = addrel (gseg, dcw_offset);		/* get ptr to dcw list */
	     if trace_or_stopsw then
		call ioa_ (
		"dcw (^[IOTD^;IOTP^;TDCW^;IONTP^]) ^w"
		, fixed (dcw.action, 2)+1
		, dcw
		);

	     if dcw.action = TDCW then do;		/* Transfer DCW. */
		successive_tdcws = successive_tdcws+1;
		if successive_tdcws>1 then
		     call gcos_mme_bort_$system (	/* 2 successive TDCW's. */
		     gcos_et_$two_tdcws
		     , "File ""^a"""
		     , fc
		     );
		dcw_offset = dcw.data_addr;		/* get new address */
		goto get_ptr;			/* continue */
	     end;
	     successive_tdcws = 0;			/* Reset count. */

	     if dcw.action = IONTP then do;		/* Skip and continue. */
		continue = "1"b;			/* indicate more to do */
		if count ^= 0 then return;		/* Exit perform previous DCW's, return to "get_dcw" for skip. */
		if dcw.count = 0 then count = 4096;	/* grab skip count */
		else count = dcw.count;		/* (count of 0 = 4096) */
		type_dcw = IONTP;
		dcw_offset = dcw_offset + 1;		/* bump over dcw */
		where = -1;			/* indicate medium skip to caller */
		return;				/* Exit to process skip. */
	     end;

/* => IOTD or IOTP form of DCW. */
	     if dcw.count = 0 then holdcount = 4096;	/* count of 0 = 4096 */
	     else holdcount = dcw.count;

	     if count = 0 then			/* first dcw processed this call ? */
		where = dcw.data_addr;		/* yes...get transfer start location */
	     else
	     if (where + count) ^= dcw.data_addr then do; /* new dcw contiguous ? */
		continue = "1"b;			/* indicate more dcws to process */
		return;				/* exit */
	     end;
	     count = count + holdcount;		/* bump total transfer count */
	     dcw_offset = dcw_offset + 1;			/* bump to next dcw */
	     type_dcw = IOTP;
	     if dcw.action = IOTP then goto get_ptr;	/* iotp - check next dcw */
	     type_dcw = IOTD;
	     continue = "0"b;			/* iotd dcw */
	     return;

dcl  holdcount                fixed bin (24);
dcl  successive_tdcws         fixed bin (24);
	end get_dcw;
%page;
init_routine: proc;

	seeksw,
	sc_ga,
	mr,
	type_dcw = "0"b;

	unspec (status) = "0"b;

	slave_status = "400000000000"b3;

	cc_residue,
	da_residue,
	nelemt,
	override,
	total_count,
	wc_residue = 0;

	argp,
	dcwptr,
	ibuffptr,
	mc_save_ptr,
	opptr,
	sbuffptr,
	sptr,
	swptr = null ();
	i = 0;

	return;

end init_routine;
%page;
make_stat_ptr: proc;				/* obtain pointer to status
						   words and check return_word
						   address fields */
	if return_word.status_return >= storlimit then /* legal status return */
	     call gcos_mme_bort_$system (
	     gcos_et_$bad_status_ret_ptr
	     , "Status return address in I/O sequence is outside slave limits."
	     );

	if return_word.courtesy_call >= storlimit then /* legal courtesy call */
	     call gcos_mme_bort_$system (
	     gcos_et_$bad_cc_ptr
	     , "Courtesy call address in I/O sequence is outside slave limits."
	     );

	if return_word.status_return = 0		/* program doesn't want status */
	then do;
	     swptr = addr (scratch_status);		/* so fake a return area */
	     scratch_status = "0"b;
	     end;
	else swptr = addrel (gseg, return_word.status_return); /* get address of status words */
	return;

end make_stat_ptr;
%page;
match_fc: proc () returns (bit (1));			/* Find a file code in the FC table. */

	do   j = 1 to hbound (save_data.fibs, 1);	/* Search file code table for match */
	     if fct.filecode (j) = fc			/* Set MATCH flag if match. */
	     then return ("1"b);
	     end;

	return ("0"b);

end match_fc;
%page;
next_dcw_ptr: proc (data_ptr, how_many, continuation);

/*

   Check  the  DCW  list and return the buffer pointer, transfer count,
   and a flag indicating whether this was the last DCW in the list.

   If the DCW is a transfer DCW (TDCW), then we go to the next list and
   start looking there, returning only when we find an I/O DCW.

   We  also  check  the  buffer  pointer for legality.  If it is out of
   range, we don't return to the caller, but instead bail  out  through
   the MME GEBORT escape-hatch.  Ditto for 2 successive TDCWs.

*/

dcl  data_ptr	pointer		parm;
dcl  how_many	fixed bin (21)	parm;
dcl  continuation	bit (1)		parm;

	successive_tdcws = 0;

	if   dcw_offset >= storlimit
	then call gcos_mme_bort_$system (gcos_et_$invalid_dcw_ptr,
				   "DCW (at ^6.3b oct) is outside slave limits (^6.3b).",
				   addr (dcw_offset) -> r18,
				   addr (storlimit) -> r18);

	dcwptr = addrel (gseg, dcw_offset);
	if   trace_or_stopsw
	then call ioa_ ("dcw (^[IOTD^;IOTP^;TDCW^;IONTP^]) ^w",
		      fixed (dcw.action, 2) + 1,
		      dcw);
	
	if   dcw.action = TDCW
	then do;
	     dcw_offset = dcw.data_addr;
	     dcwptr = addrel (gseg, dcw_offset);
	     if   dcw.action = TDCW
	     then call gcos_mme_bort_$system (gcos_et_$two_tdcws,
				        "While accessing file code ""^a""",
				        fc);
	     end;

	if   dcw.data_addr = 0			/* Gotta provide an address SOMEHOW! */
	   | dcw.action = IONTP
	then data_ptr = addr (tapebuffer);		/* If nothing else, round-file it. */
	else data_ptr = addrel (gseg, data_addr);

	if   dcw.count = 0
	then how_many = 4096;			/* Can't just do nuthin'. */
	else how_many = dcw.count;

	if how_many > gcos_ext_stat_$tape_buffer_size
	then call gcos_mme_bort_$system (gcos_et_$request_too_big,
				   "gcos_mme_inos_",
				   "^/Request was ^i, buffer size is ^i words (decimal).",
				   how_many,
				   gcos_ext_stat_$tape_buffer_size);

	continuation = (dcw.action ^= IOTD);		/* Gotta tell him there's more. */

	dcw_offset = dcw_offset + 1;			/* Bump over this one. */

	return;

end next_dcw_ptr;
%page;
process_request: proc;				/* Process the GEINOS command. */

	opptr = addrel (idptr, -1);			/* build pointer to operation word */
	sptr = addrel (idptr, 1);			/* build pointer to return word */
	dcw_offset = id_word.dcwp;			/* get dcw list pointer */
	if trace_or_stopsw then call debug_proc ();

	if fib.command_index = 0			/* Get pointer to proper command table entry. */
	then call get_cmd_tbl_entry;

/* Look up command in the command table specified in fib.command.
   Table length is specified by fib.command_count. */

	do i = fib.command_index to fib.command_index + fib.command_count;
	     if   substr (io (i).command, 1, 6) = op_word.dev_com	/* are device and */
	        & substr (io (i).command, 19, 5) = op_word.ioc_com	/* IOC command valid? */
	     then goto com_proc (io (i).process);	/* go to processing rtn */
	end;					/* no...continue */

	call gcos_mme_bort_$system (gcos_et_$bad_io_cmnd_file,
			        "This MME GEINOS command is not supported:"
			        ||"^/file code=""^a"", command=^w (^a), memory offset=^6.3b",
			        fc,
			        unspec (op_word),
			        type_op (op_word.dev_com),
			        scu.ilc);

end process_request;
%page;
scatter_input: proc (bp);

/* move data from fib.buffer pointed to by bp
   to (possibly) multiple buffers in
   slave program, according to dcw list
*/
dcl  bp                       ptr parm;

	     posit, wc_residue = 0;
sc_loop:	     ;
	     if nelemt < count then do;
		wc_residue = wc_residue + count - nelemt;
		if nelemt = 0 then goto sc_res;
		count = nelemt;
	     end;
	     if where = -1 then goto sc_skip;		/* no-transfer and proceed */
	     ibuffptr = addrel (bp, posit);		/* move from our fib.buffer */
	     sbuffptr = addrel (gseg, where);		/* into slave fib.buffer */
	     slave_buffer = internal_buffer;
sc_skip:	     ;
	     nelemt = nelemt - count;
	     posit = posit + count;
	     da_residue = where + count;
sc_res:	     ;
	     if continue = "0"b then return;
	     call get_dcw;
	     goto sc_loop;

	end scatter_input;
%page;
type_op:	proc (op)returns (char (*));

/* Return string specifying type of mme inos operation word. */
dcl  op                       bit(6)unal parm;
	     do i = 1 to hbound (device_cmd, 1);
		if op = device_cmd (i) then return (rtrim (name_cmd (i)));
	     end;
	     return ("UNKNOWN DEVICE COMMAND");

dcl  i                        fixed bin (24);
dcl 1 operation_word_values	(27)static int options(constant)
,2 device_cmd		bit(6)init(
	"00"b3 /* Request Status */
,	"03"b3 /* Read Typewriter */
,	"04"b3 /* Read Tape Decimal */
,	"05"b3 /* Read Tape Binary */
,	"13"b3 /* Write (then Read) Typewriter */
,	"14"b3 /* Write Tape Decimal */
,	"15"b3 /* Write Tape Binary */
,	"25"b3 /* Read */
,	"30"b3 /* Write Printer Edited */
,	"31"b3 /* Write */
,	"34"b3 /* Seek */
,	"40"b3 /* Reset Status */
,	"41"b3 /* Set 6250 Density */
,	"42"b3 /* Set 800 Density */
,	"43"b3 /* Set 556 Density */
,	"44"b3 /* Forward Space Record */
,	"45"b3 /* Forward Space to Filemark */
,	"46"b3 /* Backspace Record */
,	"47"b3 /* Backspace to Filemark */
,	"54"b3 /* Erase */
,	"55"b3 /* Write EOF */
,	"60"b3 /* Set High Density */
,	"61"b3 /* Set Low Density */
,	"64"b3 /* Set 200 Density */
,	"65"b3 /* Set 1600 Density */
,	"70"b3 /* Rewind */
,	"72"b3 /* Rewind and Unload */
			)
,2 name_cmd		char(28)init(
	/* 00"b3*/ "Request Status"
,	/* 03"b3*/ "Read Typewriter"
,	/* 04"b3*/ "Read Tape Decimal"
,	/* 05"b3*/ "Read Tape Binary"
,	/* 13"b3*/ "Write (then Read) Typewriter"
,	/* 14"b3*/ "Write Tape Decimal"
,	/* 15"b3*/ "Write Tape Binary"
,	/* 25"b3*/ "Read"
,	/* 30"b3*/ "Write Printer Edited"
,	/* 31"b3*/ "Write"
,	/* 34"b3*/ "Seek"
,	/* 40"b3*/ "Reset Status"
,	/* 41"b3*/ "Set 6250 Density"
,	/* 42"b3*/ "Set 800 Density"
,	/* 43"b3*/ "Set 556 Density"
,	/* 44"b3*/ "Forward Space Record"
,	/* 45"b3*/ "Forward Space to Filemark"
,	/* 46"b3*/ "Backspace Record"
,	/* 47"b3*/ "Backspace to Filemark"
,	/* 54"b3*/ "Erase"
,	/* 55"b3*/ "Write EOF"
,	/* 60"b3*/ "Set High Density"
,	/* 61"b3*/ "Set Low Density"
,	/* 64"b3*/ "Set 200 Density"
,	/* 65"b3*/ "Set 1600 Density"
,	/* 70"b3*/ "Rewind"
,	/* 72"b3*/ "Rewind and Unload"
	);
	end type_op;
%page;
%include gcos_next_arg;
%page;
/*   Variables for gcos_mme_inos_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  arg                      char(arglen) based (argp);
dcl  arglen                   fixed bin (24);
dcl  argp                     ptr;
dcl  ascii_index              fixed bin (21);
dcl  ascii_string             char(132);
dcl  bcd_string               (count*6) bit(6) unal based (workp);
dcl  bksp_sw                  bit(1);
dcl  cc_residue               fixed bin (24);
dcl  char                     char aligned;
dcl  continue                 bit(1)	/* parameter from get_dcw */;
dcl  count                    fixed bin (21);
dcl  da_residue               fixed bin (24);
dcl  db                       ext entry;
dcl  dcwptr                   ptr;
dcl  dcw_offset		fixed bin (24)		/* slave offset of current dcw */;
dcl  default_high             char(5) int static options (constant) init ("d1600")	/* system default high density */;
dcl  default_low              char(4) int static options (constant) init ("d556")	/* system default low density */;
dcl  density_history          bit(2) aligned;
dcl  divide                   builtin;
dcl  error_retry              bit(1) aligned		/* 1 = processing parity error */;
dcl  fb35                     fixed bin (35) based;
dcl  fc                       char(2)	/* file code from file control block */;
dcl  fixed                    builtin;
dcl  gcos_cv_ascii_gebcd_     ext entry (ptr, fixed bin (21), ptr, fixed bin (21));
dcl  gcos_et_$access_beyond_file fixed bin (35) ext;
dcl  gcos_et_$bad_cc_ptr      fixed bin (35) ext;
dcl  gcos_et_$bad_io_cmnd_file fixed bin (35) ext;
dcl  gcos_et_$bad_mme_in_cc   fixed bin (35) ext;
dcl  gcos_et_$bad_multirec    fixed bin (35) ext static;
dcl  gcos_et_$bad_seek_dcw    fixed bin (35) ext;
dcl  gcos_et_$bad_status_ret_ptr fixed bin (35) ext;
dcl  gcos_et_$fc_not_defined  fixed bin (35) ext;
dcl  gcos_et_$geendc_not_in_cc fixed bin (35) ext;
dcl  gcos_et_$impermissible_perm_read fixed bin (35) ext;
dcl  gcos_et_$impermissible_perm_write fixed bin (35) ext;
dcl  gcos_et_$invalid_dcw_ptr fixed bin (35) ext;
dcl  gcos_et_$invalid_file_ptr fixed bin (35) ext;
dcl  gcos_et_$irrecoverable_io_err fixed bin (35) ext;
dcl  gcos_et_$need_multirec   fixed bin (35) ext static;
dcl  gcos_et_$request_too_big fixed bin (35) ext static;
dcl  gcos_et_$two_tdcws       fixed bin (35) ext static;
dcl  gcos_mme_bort_$system    ext entry options (variable);
dcl  gcos_write_$bcd_ptr      ext entry (ptr, char(*), bit(8));
dcl  gseg                     ptr;
dcl  hbound                   builtin;
dcl  i                        fixed bin (21);
dcl  ibuffptr                 ptr;
dcl  idptr                    ptr;
dcl  instruction_counter      fixed bin (18)unsigned unal based(addr(scu.ilc));
dcl  internal_buffer          (count) fixed bin (35) based (ibuffptr);
dcl  ioa_                     ext entry options (variable);
dcl  j                        fixed bin (24);
dcl  k                        fixed bin (24);
dcl  major_status		bit (4) aligned;
dcl  max                      builtin;
dcl  mc_save_ptr              ptr;
dcl  minor_status		bit (6) aligned;
dcl  mod                      builtin;
dcl  more_dcws		bit (1);
dcl  mr                       bit(1)	/* "1"b => multirecord request. */;
dcl  multirecord_com          bit(5)static int options(constant)init("00011"b);
dcl  mybuf                    (160) bit(6) unal;
dcl  n                        fixed bin (24);
dcl  nelemt                   fixed bin (21);
dcl  new_next_avail           fixed bin (24);
dcl  null                     builtin;
dcl  opptr                    ptr;
dcl  order                    char(20)	/* holds order type */;
dcl  output_ptr		pointer;
dcl  override                 fixed bin (24);
dcl  posit                    fixed bin (21);
dcl  record                   char(j) based	/* overlay for bcd record */;
dcl  rec_ct_residue           fixed bin (24)/* holds no of unskipped records */;
dcl  rel                      builtin;
dcl  retry_count              fixed bin (24)/* number of attempts left in which */;
dcl  sbuffptr                 ptr;
dcl  scratch_status           bit(72) aligned	/* temp */;
dcl  sc_ga                    bit(1);
dcl  seeksw                   bit(1)	/* sw controlling disk or drum seeks */;
dcl  seek_address             fixed bin (24)based	/* user seek address for disk or drum */;
dcl  seek_pointer             char(5)	/* holds name of pointer to seek */;
dcl  slave_buffer             (count) fixed bin (35) based (sbuffptr);
dcl  slave_status             bit(36) aligned;
dcl  sptr                     ptr;
dcl  storlimit                fixed bin (19)	/* slave core boundary */;
dcl  substr                   builtin;
dcl  successive_tdcws	fixed bin;
dcl  swptr                    ptr;
dcl  tapebuffer               (4096) bit(36) aligned;
dcl  total_count              fixed bin (24);
dcl  total_read		fixed bin (36);
dcl  trace_array              (20) char(4) int static;
dcl  trace_index              fixed bin (24) static int init(0);
dcl  trace_or_stopsw          bit(1) static int init ("0"b);
dcl  transfer_count		fixed bin (21);
dcl  translate                builtin;
dcl  type_dcw                 bit(2);
dcl  unspec                   builtin;
dcl  wc_residue               fixed bin (24);
dcl  where                    fixed bin (21);
dcl  workp                    ptr;
dcl  z320                     (320)bit(36)static int options(constant)init((320)(36)"0"b);
dcl 1 courtesy_call_conditions  like save_machine_conditions based (mcp);

dcl (
    IOTD		init("00"b)
,   IOTP		init("01"b)
,   TDCW		init("10"b)
,   IONTP		init("11"b)
		) bit(2)static internal options(constant);

dcl 1 w		aligned based
,     2 l18	bit(18)unal
,     2 r18	bit(18)unal
;
%page;
dcl 1 op_word aligned based (opptr),		/* model of operation word */
      2 dev_com	bit(6) unal,		/* device command */
      2 zero1	bit(12) unal,		/* zeros */
      2 ioc_com	bit(5) unal,		/* ioc command */
      2 zero2	bit(1) unal,		/* zero */
      2 control	bit(6) unal,		/* control */
      2 count	fixed bin (6)unsigned unal	/* count */;

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

dcl 1 file_code_word aligned based (workp),	/* model of file code word */
      2 fill	bit(24) unal,
      2 fcode	bit(12) unal		/* file code in bcd */;

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

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

dcl 1 dcw aligned based (dcwptr),		/* dcw model */
      2 data_addr	fixed bin (18)unsigned unal,	/* data address */
      2 zero	bit(3) unal,		/* fill */
      2 chr_tally	bit(1) unal,		/* character tally indicator. */
      2 action	bit(2) unal,		/* action */
      2 count	fixed bin (12)unsigned unal	/* word count for transfer */;

dcl 1 mc_save_data based (mc_save_ptr),
   (2 pr_regs (16),
    2 s_regs (8),
    2 scu_0_3 (4),
    2 ici_regs,
    2 scu_5_7 (3),
    2 software_data (8),
    2 pl_regs (8)) fixed bin (35);
%page;
/* 	I/O Simulation Tables					 */


/* 	Command Tables:						 */
/* 								 */
/* 	The command tables contain the possible legal commands for each device	 */
/* 	type. Each command table entry contains the command and the command	 */
/* 	processor address.						 */


/* Table of indices into io_commands list to
   separate MME GEINOS command word sublists
   for various devices.
*/
dcl 1 index	static int options(constant),
      2 (
	disk		init(01),
	tape		init(11),
	printer		init(36),
	typewriter	init(40),
	next		init(44)
		) fixed bin (24);

dcl 1 io (43) internal static options (constant),
	     2 command bit (36) init (

/*   Disk commands:  */
  /*  1 */ "340000000002"b3	/* 34 - seek disk address */
, /*  2 */ "250000002400"b3	/* 25 - read disk continuous */
, /*  3 */ "250000060000"b3	/* 25 - multirecord disk read. */
, /*  4 */ "310000002400"b3	/* 31 - write disk continuous */
, /*  5 */ "310000060000"b3	/* 31 - multirecord disk write. */
, /*  6 */ "700000020001"b3	/* 70 - rewind */
, /*  7 */ "460000020001"b3	/* 46 - backspace record(s) */
, /*  8 */ "440000020001"b3	/* 44 - forward space record(s) */
, /*  9 */ "400000020001"b3	/* 40 - reset status */
, /* 10 */ "000000020001"b3	/* 00 - request status */

/*   Tape commands:  */
, /* 11 */ "050000000000"b3	/* 05 - read tape binary */
, /* 12 */ "150000000000"b3	/* 15 - write tape binary */
, /* 13 */ "030000000000"b3	/* 03 - read tape nine */
, /* 14 */ "130000000000"b3	/* 13 - write tape nine */
, /* 15 */ "700000020001"b3	/* 70 - rewind */
, /* 16 */ "550000020001"b3	/* 55 - write eof */
, /* 17 */ "450000020001"b3	/* 45 - forward space to file mark */
, /* 18 */ "470000020001"b3	/* 47 - backspace to file mark */
, /* 19 */ "440000020001"b3	/* 44 - forward space one record */
, /* 20 */ "460000020001"b3	/* 46 - backspace one record */
, /* 21 */ "150000100000"b3	/* 15 - write file mark */
, /* 22 */ "140000100000"b3	/* 14 - write file mark decimal */
, /* 23 */ "540000020001"b3	/* 54 - erase */
, /* 24 */ "720000020001"b3	/* 72 - rewind and unload */
, /* 25 */ "600000020001"b3	/* 60 - set high density */
, /* 26 */ "610000020001"b3	/* 61 - set low density */
, /* 27 */ "640000020001"b3	/* 64 - set 200 density */
, /* 28 */ "430000020001"b3	/* 43 - set 556 density */
, /* 29 */ "420000020001"b3	/* 42 - set 800 density */
, /* 30 */ "650000020001"b3	/* 65 - set 1600 density */
, /* 31 */ "410000020001"b3	/* 41 - set 6520 density */
, /* 32 */ "400000020001"b3	/* 40 - reset status */
, /* 33 */ "000000020001"b3	/* 00 - request status */
, /* 34 */ "040000000000"b3	/* 04 - read tape bcd */
, /* 35 */ "140000000000"b3	/* 14 - write tape bcd */

/*   Printer commands:  */
, /* 36 */ "300000000000"b3	/* 30 - write printer edited */
, /* 37 */ "300000060001"b3	/* 30 - write printer edited continuous */
, /* 38 */ "400000020001"b3	/* 40 - reset status */
, /* 39 */ "000000020001"b3	/* 00 - request status */

/*   Typewriter commands: */
, /* 40 */ "130000000000"b3	/* 13 - write or write then read */
, /* 41 */ "030000000000"b3	/* 03 - read */
, /* 42 */ "400000020001"b3	/* 40 - reset status */
, /* 43 */ "000000020001"b3	/* 00 - request status */
	     ),

/* Corresponding indices to labeled array location
   to processing routine.
*/
	     2 process fixed bin (24)init (

/*   Disk commands:  */
   1	/* 34 - seek disk address */
,  2	/* 25 - read disk continuous */
,  2	/* 25 - multirecord disk read */
,  3	/* 31 - write disk continuous */
,  3	/* 31 - multirecord disk write. */
,  4	/* 70 - rewind */
,  5	/* 46 - backspace record(s) */
,  6	/* 44 - forward space record(s) */
,  7	/* 40 - reset status */
,  8	/* 00 - request status */

/*   Tape commands:  */
,  9	/* 05 - read tape binary */
, 10	/* 15 - write tape binary */
, 11	/* 03 - read tape nine */
, 12	/* 13 - write tape nine */
, 13	/* 70 - rewind */
, 14	/* 55 - write eof */
, 15	/* 45 - forward space to file mark */
, 16	/* 47 - backspace to file mark */
, 17	/* 44 - forward space one record */
, 18	/* 46 - backspace one record */
, 19	/* 15 - write file mark */
, 20	/* 14 - write file mark decimal */
, 21	/* 54 - erase */
, 22	/* 72 - rewind and unload */
, 23	/* 60 - set high density */
, 24	/* 61 - set low density */
, 25	/* 64 - set 200 density */
, 26	/* 43 - set 556 density */
, 27	/* 42 - set 800 density */
, 28	/* 65 - set 1600 density */
, 41	/* 41 - set 6520 density */
, 29	/* 40 - reset status */
, 30	/* 00 - request status */
, 31	/* 04 - read tape bcd */
, 32	/* 14 - write tape bcd */

/*   Printer commands:  */
, 33	/* 30 - write printer edited */
, 34	/* 30 - write printer edited continuous */
, 35	/* 40 - reset status */
, 36	/* 00 - request status */

/*   Typewriter commands: */
, 37	/* 13 - write or write then read */
, 38	/* 03 - read */
, 39	/* 40 - reset status */
, 40	/* 00 - request status */
	     );
%page;
%include gcos_dcl_ios_;
%page;
%include gcos_xlate_bcd_ascii_;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_dbs_names;
     end gcos_mme_inos_;




		    gcos_mme_laps_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       15642



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



/* ------------------------------------------------------------------- */
/* 							 */
/*  Simulation of GCOS mme which returns CPU time in 64ths of a	 */
/*  milli-second.  The init_timer entry is called by		 */
/*  gcos_run_activity at the beginning of each activity to		 */
/*  remember the CPU timer at the beginning of the activity		 */
/* 							 */
/* 	Written by Peter M. Haber	8/16/72			 */
/*	Modified by M. R. Jordan, October 1977			 */
/* 							 */
/* ------------------------------------------------------------------- */




gcos_mme_laps_: proc (mcp, increment);

dcl  binary builtin;
dcl  bit builtin;
dcl  cpu_time fixed bin(71) aligned;						/* cpu time since activity started */
dcl  divide builtin;
dcl  increment fixed bin(24)aligned;						/* number of paramenter words to skip over */
dcl  virtual_cpu_time_ ext entry returns (fixed bin(71) aligned);

	increment = 0;				/* no parameter words to skip over */

	cpu_time = virtual_cpu_time_ () - gcos_ext_stat_$initial_cpu_time; /* get cpu time for activity */

	mc.regs.q = bit (binary (divide (cpu_time, 1000, 35, 0)*64, 36), 36);
						/* put time in q register in 64ths of a second */

	return;

%include gcos_ext_stat_;


     end gcos_mme_laps_;




		    gcos_mme_lbar_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       37719



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

/* Process MME GELBAR for gcos batch simulator.

   (See DD19C, Rev. 0, GENERAL COMPREHENSIVE
   OPERATING SUPERVISOR, page 4-20 for
   description of function).

   Author: Dave Ward	09/10/80 [my 1st mme handler]
*/
dcl  incr                     fixed bin(24)parm	/* (output) number parameter words following mme. */;
dcl  mcpp                     ptr parm	/* (input) pointer to machine conditions structure. */;
	mcp = mcpp;				/* Assign to local variable (for execution efficiency). */
	gseg = gcos_ext_stat_$gcos_slave_area_seg;	/* Set pointer to gcos user's slave prefix area. */
	lbar_parm_ptr = addrel (gseg, a_reg.loc1);	/* Get pointer to LOC1. */
	w21 = mc.regs.q;				/* Save Q register. */
	w22 = "0"b;				/* MORE timer register. */
	string (w31) = unspec (lbar_parm.bar);		/* Save new BAR register value. */
	w31.b19 = "0"b;
	string (w31.b30_35) = "0"b;
	mr = gcos_ext_stat_$mme_rtrn;			/* Save current location to return after MME. */
	gcos_ext_stat_$mme_rtrn = to_me;		/* Reset return to return to me. */

	bb = "0"b;				/* Running in bar mode. */
	call gcos_get_bar_ (old_bar);
	call gcos_set_slave_ (
	     (lbar_parm.bar)			/* New BAR value. */
	     , addrel (gseg, lbar_parm.ic)		/* Pointer to gcos code to execute. */
	     , bb					/* ^bar bit. */
	     );

to_me:	;					/* Come here when gcos caller concludes (MME GEFINI). */

	call gcos_restore_regs_ (addrel (gseg, lbar_parm.loc2));
	gcos_ext_stat_$mme_rtrn = mr;			/* Reset to label in effect at entry to procedure. */
	if w23 = "0"b then				/* Terminate gcos user. */
	     goto mr;

	w22 = lbar_parm.ic || lbar_parm.i;
	w21fb = w21fb - 0;				/* MORE */
	if fault | timer_runout then do;
dcl (fault,timer_runout) bit(1)static int options(constant)init("0"b);
	     w31.b19 = "1"b;
	     string (w31.b30_35) = "77"b3;
	end;

	bro = (18)"0"b||substr (old_bar, 1, 18);	/* BAR restore value (right justified). */

/* Continue gcos caller (at his slave prefix cell 23-octal). */
	call gcos_set_slave_ (
	     bar_reset
	     , addrel (gseg, "000023"b3)
	     , bb
	     );

/*   Variables for gcos_mme_lbar_:		*/
/*   IDENTIFIER		ATTRIBUTES	*/
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  bar_reset                fixed bin(18);
dcl  bb                       bit(1)aligned;
dcl  bro                      bit(36)based(addr(bar_reset));
dcl  gcos_get_bar_            entry(bit(36));
dcl  gcos_restore_regs_       entry(ptr);
dcl  gcos_set_slave_          entry(fixed bin(18),ptr,bit(1)aligned);
dcl  gseg                     ptr;
dcl  lbar_parm_ptr            ptr;
dcl  mr                       label auto variable;
dcl  old_bar                  bit(36);
dcl  reg_move                 bit (36 * 8) based aligned;
dcl  unspec                   builtin;
dcl  w21fb                    fixed bin(35)based(addr(spp.w21));

dcl 1 a_reg	aligned based(addr(mc.regs.a))
,     2 loc1	fixed bin(18)unsigned unal
,     2 not_used	bit(18)unal;

dcl 1 lbar_parm	aligned based(lbar_parm_ptr)
,     2 bar	fixed bin(18)unsigned unal	/* new bar value. */
,     2 loc2	fixed bin(18)unsigned unal	/* offset to program registers storage. */
,     2 ic	bit(18)unal	/* new IC offset (from new bar). */
,     2 i		bit(18)unal	/* indicator register. */
;

dcl 1 bar_reg	aligned based(addr(lbar_parm.bar))
,     2 base	fixed bin(9)unsigned unal
,     2 bound	fixed bin(9)unsigned unal
;

/* Gcos memory slave program prefix (at BAR.BASE) */
dcl 1 spp		aligned based(gseg)
,     3 w00_20	(00:16)bit(36)
,     3 w21	       bit(36)
,     3 w22	       bit(36)
,     3 w23	       bit(36)
,     3 w24_30	(20:24)bit(36)
,     3 w31
,       4 b00_18	  (00:18)bit(1)unal
,       4 b19	         bit(1)unal
,       4 b20_29	  (20:29)bit(1)unal
,       4 b30_35	  (30:35)bit(1)unal
,     3 w32_100	(26:64)bit(36)
;

%include gcos_ext_stat_;
     end gcos_mme_lbar_;




		    gcos_mme_loop_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       17190



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

/* ***************************************************************************
   ***************************************************************************
   *                                                                         *
   *                                                                         *
   *         mme geloop                                                      *
   *                                                                         *
   *                                                                         *
   * This mme is not implemented.  It is ignored.                            *
   *                                                                         *
   *                                                                         *
   *    Written by R. H. Morrison February 22, 1974                          *
   *    Modified by R.H. Morrison April 4, 1974                              *
   *    Modified by M. R. Jordan, October 1977
   *                                                                         *
   *                                                                         *
   ***************************************************************************
   *************************************************************************** */




gcos_mme_loop_: proc (faultp, increment);

dcl  faultp pointer;						/* unused input parameter */
dcl  increment fixed bin(24);						/* number of mme parameters */

	increment = 0;				/* one mme parameter */
	return;

%include gcos_ext_stat_;


     end gcos_mme_loop_;




		    gcos_mme_more_.pl1              09/09/83  1404.1rew 09/09/83  1007.6      105273



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

/*
   *  MME GEMORE is used to obtain an additional tape handler, additional
   *  links (3840 word blocks), more memory, or to allow allocation of
   *  new files. The user must be prepared to accept a denial return
   *  if the request cannot be satisified.
   *
   *
   *	CALLING SEQUENCE
   *
   *	MME	GEMORE
   *	ZERO	A,B
   *	denial return
   *	success return
   *
   *	C(Q) 0-17		ptr. to cfdesc (A=4-6) or random indicator (A=2)
   *	C(Q) 18-23	requested permissions (A=4-6)
   *	C(Q) 24-35	file code (A=1-6)
   *
   *	A = 0 for more memory	B = no of 1K blocks wanted
   *	A = 1 for 7 track tape	B = tape status
   *	A = 2 for new links or file	B = no of links desired
   *	A = 3 for 9 track tape	B = tape status
   *	A = 4 for cataloged files	B = ptr. to 355 wd. buffer
   *            accessed in created
   *            mode.
   *      A = 5 for cataloged files     B = ptr. to 355 wd. buffer
   *            accessed as random.
   *      A = 6 for cataloged files     B = ptr. to 355 wd. buffer
   *            accessed as sequential.
   *
   *
   Author: DICK SNYDER JUNE 8, 1971
   Change: T. CASEY OCTOBER 1973
   Change: D. KAYDEN  APRIL 1974, JULY 1974, JANUARY 1975
   Change: M. R. Jordan,  January 1977
   Change: Dave Ward	07/28/81 A=7 case (By Dick Hemes)
*/

/*
   Initialize all needed values and verify the action code (A)
   to ensure that this is a good call.
*/
	gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg;
	increment = 2;
	storage_limit = gcos_ext_stat_$storage_limit;
	scup = addr (mc.scu);

	if fixed (scu.ilc, 18)+1 >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEMORE parameter word is outside slave limits.");
	param_ptr = addrel (gseg_ptr, fixed (scu.ilc, 18)+1);
	A = param.a;
	B = param.b;

	if A > 7 then do;
	     ecode = gcos_et_$bad_more_param;
abort:	     call gcos_mme_bort_$system (ecode);
	end;
%page;
/*
   Now that we are sure this is a somewhat valid request (i.e. 0<=A<=7),
   let's see if its for memory.  If so, then process the request.

   At this point:

   A		=0
   B		number of 1K (1024 word) blocks of memory requested (max is 64K)
*/
	if A = 0 then do;

	     if B = 0 then return ;
	     if B > 64 then goto failure ;

	     if gcos_ext_stat_$storage_limit+B*1024 > gcos_ext_stat_$max_mem then go to failure;

	     gcos_ext_stat_$storage_limit = gcos_ext_stat_$storage_limit+B*1024;
	     call gcos_set_slave_$load_bar (divide (gcos_ext_stat_$storage_limit, 512, 17, 0));
	     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);

	     return;
	end;
%page;
/*
   This request is for some file (i.e. not memory).  Lets get the file code
   and see if the file exists already.  When we know this we can decide what
   to do to process the request.
*/
	if substr (mc.regs.q, 25, 12) = (12)"0"b then do ;
	     ecode = gcos_et_$zero_fc_to_more;
	     goto abort;
	end ;

	if A = 7 then goto failure;			/* => file catenation. Treat as EOF. */

	substr (fc, 1, 1) = xlate (fixed (substr (mc.regs.q, 25, 6), 6));
	substr (fc, 2, 1) = xlate (fixed (substr (mc.regs.q, 31, 6), 6));

	do fct_index = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (fct_index) = fc then go to hit;
	end;

	goto action (A);
%page;
/*
   Process a request for accessing an existing permanent file.

   At this point:

   A		=4 - access the file in whichever mode it was created
   A		=5 - access the file as a random file
   A		=6 - access the file as a sequentail file
   B		location of a 355 word buffer for FMS
   C(Q) 0-17	location of catalog/filename block
   C(Q) 18-23	requested permisssions
   C(Q) 24-35	file code (guaranteed unused at this point)
*/
action (4):
action (5):
action (6):

/*
   ??
*/
	cfdesc_loc = fixed (substr (mc.regs.q, 1, 18), 18);
	if cfdesc_loc >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "Catalog/filename description is outside slave limits.");
	do word_index = cfdesc_loc+4 to min (cfdesc_loc+38, storage_limit-1) by 4;
	     if addrel (gseg_ptr, word_index) -> bit36 = (36)"1"b then goto fence_hit;
	end;
	call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "Catalog/filename description fence not found.");

fence_hit: ;
	if B < 64 | B +354 >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "FMS buffer location < 64 or outside slave limits.");

/*
   ??
*/
	call gcos_build_pathname_ (addrel (gseg_ptr, cfdesc_loc), addrel (gseg_ptr, B), dir_name, entry_name, st);
	if substr (st, 2, 11) ^= (11)"0"b then do;

fms_failure:   ;
	     mc.regs.q = substr (st, 1, 36);
	     goto failure;
	end;
	call gcos_verify_access_ (dir_name, entry_name, substr (mc.regs.q, 19, 6), addrel (gseg_ptr, B), st);
	if substr (st, 2, 11) ^= (11)"0"b then goto fms_failure;

/*
   Open the file with no LUD and fill in the appropriate fib entries.
*/
	call gcos_open_file_ (fc, "", fibptr, ""b) ;
	if rtrim (dir_name) = ">" then fib.pathnm = ">" || entry_name;
	else fib.pathnm = rtrim (dir_name) || ">" || entry_name;
	fib.read = substr (mcp -> mc.regs.q, 19, 1);
	fib.write = substr (mcp -> mc.regs.q, 20, 1);
	fib.perm = "1"b;
	if A = 5 then fib.type = "1"b ;

	goto attach;
%page;
/*
   Process a request for an additional tape drive.

   At this point:

   A		=1 for 7 track; =3 for 9 track
   B		if non-zero then a tape must be mounted (=0 use any scratch)
   C(Q) 0-17	location of reel # word (only if non-zero)
   C(Q) 20-23	density specification (see fib declaration for possible values)
   C(Q) 24-35	file code (guaranteed unused at this point)
*/
action (1):
action (3):

/*
   Open the file with no LUD.
*/

/* should make sure a handler is available first */
	call gcos_open_file_ (fc, "", fibptr, "0"b) ;

/*
   Now that we have a drive, set up the fib.
*/
	fib.tape = "1"b;

	if A = 1 then fib.tracks = "01"b;
	else fib.tracks = "10"b;

	reel_no_loc = fixed (substr (mc.regs.q, 1, 18), 18);
	B = fixed (substr (addr (B) -> bit36, 36, 1), 1);
	if B ^= 0 & reel_no_loc ^= 0 then
	     fib.serial_no = addrel (gseg_ptr, reel_no_loc) -> bit30;
	else fib.serial_no = (5)"001001"b;

	fib.tape_name = (12)"010000"b;

	fib.density = substr (mc.regs.q, 21, 4);
	if fib.density = "0111"b then fib.density = "0000"b;

	goto attach ;
%page;
/*
   Process a request for a _n_e_w temporary mass storage file.
   Set access for both read and write and get the size from the
   mme calling sequence.


   At this point:

   A		=2
   B		size of requested file in links (if 0 then request is for a null file)
   C(Q) 17	random file indicator (actually if C(Q)0-17 ^= 0 then random)
   C(Q) 24-35	file code (guaranteed unused at this point)
*/
action (2):

/*
   Open the file with no LUD and fill in the fib.
*/
	call gcos_open_file_ (fc, "", fibptr, "0"b) ;
	fib.read, fib.write = "1"b;
	fib.type = (substr (mc.regs.q, 1, 18) ^= (18)"0"b);
	fib.size = B*3840;
	if fib.size = 0 then fib.null = "1"b ;

/*
   We now have the file ready and the fib filled in so lets attach it.
*/
attach:	;
	call gcos_attach_file_ (fibptr);
	return;

/*
   At this point we have failed to satisfy the users _v_a_l_i_d request.
   We will now return to the denial return point.
*/
failure:	;
	increment = 1 ;
	return ;
%page;
/*
   Process a request for more space on an _e_x_i_s_t_i_n_g mass storage file.
   Make sure that this is a request for a mass storage file.
   If it is, then get the specified number of links.  If the
   number specified is 0 and the file is a permanent file
   then we will choose the growth rate.


   At this point:

   A		any value 1-6 (only 2 is valid)
   B		# of links to be added (if 0 & file is permanent then use 1 llink)
   C(Q) 24-35	file code (guaranteed to be in use at this point)
*/

hit:	;

/*
   If this is not a mass storage request (A=2) then complain.
*/

	if A ^= 2 then do ;
	     ecode = gcos_et_$duplicate_file_more;
	     goto abort ;
	end;

/*
   We cannot grow a SYSOUT file.
*/

	if fct.sysout (fct_index) then do;
	     ecode = gcos_et_$duplicate_file_more;
	     goto abort;
	end ;

/*
   Nor can we grow files assigned to printer, tape or the operators console.
*/

	fibptr = fct.fibptr (fct_index);
	if fib.print | fib.console | fib.tape then do;
	     ecode = gcos_et_$not_mass_store_more;
	     go to abort;
	end;

/*
   A growth request for a null file is always successful.
*/

	if fib.null then return ;

/*
   Calculate the new file size.
*/

	num_words = B*3840;
	if num_words = 0 then if fib.perm then num_words = 320;
	fib.size = fib.size+num_words;

	return;
%page;
/*   Variables for gcos_mme_more_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  A                        fixed bin(18)	/* A field from MME sequence */;
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  B                        fixed bin(18)	/* B field from MME sequence */;
dcl  bit30                    bit(30)based;
dcl  bit36                    bit(36) aligned based	/* General purpose bit string. */;
dcl  cfdesc_loc               fixed bin(18);
dcl  code                     fixed bin(35) based (addr (st));
dcl  dir_name                 char(168)	/* the directory name for a prmfl request */;
dcl  divide                   builtin;
dcl  ecode                    fixed bin(35);
dcl  entry_name               char(32)	/* the entry name for a prmfl request */;
dcl  fc                       char(2)	/* the file code if this is a file request */;
dcl  fct_index                fixed bin(24)	/* index used in searching the file code table */;
dcl  fixed                    builtin;
dcl  gcos_attach_file_        entry (ptr);
dcl  gcos_build_pathname_     entry (ptr, ptr, char(*), char(*), bit(72) aligned);
dcl  gcos_error_              entry options (variable);
dcl  gcos_et_$bad_mme_param   fixed bin(35) ext;
dcl  gcos_et_$bad_more_param  fixed bin(35) ext;
dcl  gcos_et_$duplicate_file_more fixed bin(35) ext;
dcl  gcos_et_$not_mass_store_more fixed bin(35) ext;
dcl  gcos_et_$zero_fc_to_more fixed bin(35) ext;
dcl  gcos_mme_bort_$system    entry options (variable);
dcl  gcos_open_file_          entry (char(*), char(*), ptr, bit(1));
dcl  gcos_set_slave_$load_bar entry (fixed bin(17));
dcl  gcos_verify_access_      entry (char(*), char(*), bit(6), ptr, bit(72) aligned);
dcl  gseg_ptr                 ptr;
dcl  hcs_$set_max_length      entry (char(*), char(*), fixed bin(19), fixed bin(35));
dcl  increment                fixed bin(18)	/* IC increment for return to slave activity */;
dcl  index                    builtin;
dcl  num_words                fixed bin(35);
dcl  param_ptr                ptr	/* ptr to word after MME (for A  B fields) */;
dcl  reel_no_loc              fixed bin(18)	/* location of the reel # word in the gcos_slave_area_seg */;
dcl  rtrim                    builtin;
dcl  st                       bit(72) aligned	/* status return string */;
dcl  storage_limit            fixed bin(18);
dcl  string                   builtin;
dcl  substr                   builtin;
dcl  word_index               fixed bin(18);

dcl 1 param aligned based (param_ptr),			/* structure for accessing the A  B fields */
    2 a fixed bin(18)unsigned unal,
    2 b fixed bin(18)unsigned unal;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_xlate_bcd_ascii_;
     end gcos_mme_more_;




		    gcos_mme_mrel_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       44676



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	M M E  G E M R E L
   *
   *
   *  MME GEMREL  is used to deallocate a specified amount of memory from a requesting
   *  program's total assigned memory. Actual memory deallocation is in multiples of 1024
   *  words. Memory may be released from either the upper bound or the lower bound or
   *  both. Lower memory release will cause address relocation.
   *
   *	CALLING SEQUENCE:
   *
   *	MME     GEMREL
   *
   *	C(A) 0-17		return address relative to the new base address
   *	C(Q) 0-17		number of words of lower memory to release
   *	C(Q) 18-35	number of words of upper memory to release
   *
   *
   *	WRITTEN BY DICK SNYDER, NOVEMBER 18,1970
   *	MODIFIED BY T. CASEY, OCTOBER 1973
   *	MODIFIED BY D. KAYDEN, MAY 1974
   *	Modified by M. R. Jordan, January 1977
   *
   *
   ********************************************************************************************
   ********************************************************************************************
*/



gcos_mme_mrel_: procedure (mcp, increment);

dcl  addr builtin;
dcl  addrel builtin;
dcl  code fixed bin(35);						/*  error code from called support routines  */
dcl  divide builtin;
dcl  fixed builtin;
dcl  gcos_error_ entry options (variable);
dcl  gcos_et_$bad_mme_addr fixed bin(35) ext;
dcl  gcos_mme_bort_$system entry options (variable);
dcl  gcos_set_slave_$load_bar entry (fixed bin(18));
dcl  gseg char (length_in_bytes) based;						/*  gcos_slave are segment mask  */
dcl  hcs_$set_max_length_seg entry (ptr, fixed bin(19), fixed bin(35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35));
dcl  increment fixed bin(18);						/*  number of arguments to this MME  */
dcl  length_in_bytes fixed bin(20);						/*  length of the GCOS job segment in bytes  */
dcl  lower fixed bin(18);						/*	number of words to release on the low end  */
dcl  new_storage_limit fixed bin(18);						/*  new slave storage limit  */
dcl  substr builtin;
dcl  upper fixed bin(18);						/*	number of words to release on the upper end  */
dcl  word bit (36) aligned ;						/*  a one word mask  */

/*

   First initialize the pointer to the SCU data.	Then determine
   how much memory is to be released from the upper and lower ends.

*/


	scup = addr (mc.scu);
	word = (36)"0"b;
	substr (word, 19, 8) = substr (mc.regs.q, 1, 8);
	lower = fixed (word, 18);
	substr (word, 19, 8) = substr (mc.regs.q, 19, 8);
	upper = fixed (word, 18);


/*

   Calculate the new memory size as the old size minus the total
   amount released.  There must be at least 1K to continue.

*/


	new_storage_limit = gcos_ext_stat_$storage_limit-upper-lower;
	if new_storage_limit < 1024 then
	     call gcos_mme_bort_$system (gcos_et_$bad_mme_addr, "Less than 1K memory remaining.");


/*

   Now that we have the new memory limit, save it and load the
   BAR with it.

*/


	gcos_ext_stat_$storage_limit = new_storage_limit;
	call gcos_set_slave_$load_bar (divide (gcos_ext_stat_$storage_limit, 512, 9, 0));


/*

   Now, if there is any memory released on the low end, we will move everything
   down by "lower" words so that we can avoid any base value other than
   zero in the BAR.  This will allow execution with the -no_bar argument to allow
   the user to user debug.

*/


	if lower ^= 0 then do;
	     length_in_bytes = new_storage_limit * 4 ;
	     gcos_ext_stat_$gcos_slave_area_seg -> gseg = addrel (gcos_ext_stat_$gcos_slave_area_seg, lower) -> gseg;
	end ;


/*

   Now truncate the gcos_slave_area_seg to the new size.

*/


	call hcs_$truncate_seg (gcos_ext_stat_$gcos_slave_area_seg, gcos_ext_stat_$storage_limit, code);
	if code ^= 0 then call gcos_error_ (code, "Unable to truncate gcos_slave_area_seg.");
	call hcs_$set_max_length_seg (gcos_ext_stat_$gcos_slave_area_seg, gcos_ext_stat_$storage_limit, code);
	if code ^= 0 then call gcos_error_ (code, "Unable to set max length of gcos_slave_area_seg.");


/*

   Now caculate the proper offset to be applied to scu.ilc to get the user
   back to the location specified in AU.  To do so we take the desired
   location minus the ilc value minus a fudge factor of one.

*/


	increment = fixed (substr (mc.regs.a, 1, 18), 18)-fixed (scu.ilc, 18)-1;

	return;

%include gcos_ext_stat_;


     end gcos_mme_mrel_;




		    gcos_mme_prio_.pl1              09/09/83  1404.1rew 09/09/83  1007.6        7578



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


gcos_mme_prio_: proc (mcp, increment);


/*	Handler for the geprio mme. It does nothing but return to the caller. */

dcl  mcp ptr;						/* Machine conditions ptr. */
dcl  increment fixed;						/* No. of args. passed to this mme. */

	increment = 0;				/* Indicate no args. passed to this mme. */

	return;

     end gcos_mme_prio_;




		    gcos_mme_rels_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       70839



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

/*
   *  MME GERELS is used to deallocate peripherals from a program. In addition, it may be
   *  used to alter the disposition code. The calling sequence is as follows:
   *
   *		MME	GERELS
   *		ZERO	No of files in upper half. Alter flag in lower half.
   *			If flag = 0,following words hold filecodes of
   *			files to be deallocated:
   *
   *		BCI	1,0000F1
   *		BCI	1,0000F2
   *		etc
   *
   *
   *			If flag = 1,following words hold filecodes
   *			preceeded by new disposition code:
   *
   *		BCI	1,000SF1
   *		BCI	1,000RF2
   *
   *
   *	WRITTEN BY DICK SNYDER JANUARY 18,1971
   *	WRITTEN BY D. KAYDEN  APRIL 1974
   *	MODIFIED BY R.H. MORRISON MAY 1975
   *	Modified by Mel Wilson, November 1979 to clear released fct & fib entries,
   preventing erroneous re-allocation
*/
	scup = addr (mc.scu);			/* get addr of scu data */
	i = instruction_counter+1;			/* get offset of first parma */
	wordp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* point to param 1 */
	cnt = fixed (word.upper);			/* get file count */
	if word.lower = "0"b then alter = "0"b;		/* set disp alter flag */
	else alter = "1"b;

	if i+cnt >= gcos_ext_stat_$storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst,
	     "File code list is not completely within slave limits.");


	do j = 1 to cnt;				/* loop to process files */

	     wordp = addrel (wordp, 1);		/* bump pointer to next param word */
	     substr (fc, 1, 1) = xlate (fixed (word1.ch5, 6)); /* get 1st filecode character in ascii */
	     substr (fc, 2, 1) = xlate (fixed (word1.ch6, 6)); /* get 2nd filecode character in ascii */

/*  Look up file code in file code table for match 		 */
	     do fct_index = 1 to hbound (save_data.fibs, 1);
		if fc = fct.filecode (fct_index) then go to hit; /* match ? */
	     end;
	     go to bump;				/* no hit...ignore this one */

hit:	     ;
	     if fct.sysout (fct_index) then go to bump;	/* sysout file - same as no hit */
	     fibptr = fct.fibptr (fct_index);

	     if ^alter then do;			/* Release files request */
		space_to_release = fixed (word.upper);	/* check for partial release */
		if space_to_release = 0 | fib.print | fib.punch | fib.read
		| fib.tape | fib.console then do;	/* total release */
		     released_fibs.nrf = released_fibs.nrf+1;
		     if released_fibs.nrf > hbound (released_fib, 1) then
			call gcos_mme_bort_$system (	/* Exceeded number released fibs. */
			gcos_et_$rel_fibs_exceeded
			, "Over ^i fibs released."
			, hbound (released_fib, 1)
			);
		     saved_fib_ptr = addr (released_fib (released_fibs.nrf));
		     unspec (saved_fib_ptr -> fib) = unspec (fib); /* copy fib data */
		     substr (saved_fib_ptr -> fib.pathnm, 1, 2) = fc; /* stick in the file code */

		     call gcos_close_file_ (fibptr);

		     fib.stream, fib.pathnm = "";	/* clear names from fib */
		     fct (fct_index).filecode = "";	/* clear feleased fct entry */
		     fct (fct_index).fibptr = null ();

		     if ^gcos_ext_stat_$save_data.nosave then do; /* save/restart  */
			temp_file = ^(fib.perm | fib.print | fib.punch | fib.reader | fib.tape | fib.console);
			if temp_file & ^substr (fib.disp, 1, 1) then
			     restart_control.cant_do = "1"b; /* can't do because temp_file not saved */
		     end;
		end;
		else do;				/* partial release */
		     fib.size = fib.size - 3840 * space_to_release;
		     if fib.size <= 0 then
			fib.size = 3840;		/* be sure something is left */

		     if fib.last > fib.size then do;
			fib.last = fib.size;
			call ios_$seek ((fib.stream), "last", "first", fib.last, status);
			if code ^= 0 then
			     call gcos_mme_bort_$system (code,
			     "attempting to truncate mass storage file ""^a""", fc);
		     end;
		end;
	     end;

	     else do;

/* 	Come here if disposition is to be altered. If the disposition is being	 */
/* 	set to save or continue, check for an existing nonzero plud in the fib.	 */
/* 	If the plud is zero, set it = to the filecode. By this means, a file 	 */
/* 	may be created by MME GEMORE, set to S dispositon by MME GERELS and		 */
/* 	referred to in a subsequent activity by using the original file code as	 */
/* 	as the LUD in a file assignment card.					 */


		dis = word1.ch4;			/* get new displacement */
		check = "0"b;			/* turn off check switch */

		if dis = "51"b3 then
		     fib.disp = "01"b;		/* R */
		else
		if dis = "24"b3 then
		     fib.disp = "00"b;		/* D */
		else
		if dis = "62"b3 then do;		/* S */
		     fib.disp = "10"b;
		     check = "1"b;			/* remember to check plud */
		end;
		else
		if dis = "23"b3 then do;		/* C */
		     fib.disp = "11"b;
		     check = "1"b;			/* remember to check plud */
		end;
		else
		if dis = "47"b3 then
		     fib.purge = "1"b;		/* P */
		else
		if dis = "43"b3 then
		     fib.purge = "0"b;		/* L */
		else
		if dis = "44"b3 then do;		/* M */
		     if word1.ch3 = "51"b3 then
			fib.type = "1"b;		/* R = random */
		     else fib.type = "0"b;		/* otherwise linked */
		end;

		else call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst,
		     "Bad disposition specified in request for file code ""^a"".", fc);


		if check then do;			/* check plud if C or S disp */
		     if fib.plud ^= "0"b then go to bump; /* fib.plud already assigned */
		     if verify (substr (fc, 2, 1), "*0123456789") ^= 0 then
			call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst,
			"Cannot make LUD from file code without * or digit as second character.  ""^a""",
			fc);
		     fib.plud = substr (word.lower, 7, 12); /* put filecode in as plud */
		end;

	     end;
bump:	     ;
	end;

	increment = 1+cnt;				/* compute no of param words to skip */
	return;
%page;
/*   Variables for gcos_mme_rels_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  alter                    bit (1)	/* switch to control disp change */;
dcl  check                    bit (1)	/* switch */;
dcl  cnt                      fixed bin(24);
dcl  dis                      bit (6)	/* holder for dispositon char */;
dcl  fc                       char (2)	/* holder for ascii filecode */;
dcl  fct_index                fixed bin(24);
dcl  fixed                    builtin;
dcl  gcos_close_file_         ext entry (ptr);
dcl  gcos_et_$bad_rels_rqst   fixed bin(35) ext;
dcl  gcos_et_$rel_fibs_exceeded fixed bin(35) ext static;
dcl  gcos_mme_bort_$system    entry options (variable);
dcl  i                        fixed bin(24);
dcl  increment                fixed bin(24)/* no.param words to skip over */;
dcl  instruction_counter      fixed bin(18)unsigned unal based(addr(scu.ilc));
dcl  j                        fixed bin(24);
dcl  null                     builtin;
dcl  saved_fib_ptr            ptr;
dcl  size                     builtin;
dcl  space_to_release         fixed bin(18);
dcl  substr                   builtin;
dcl  temp_file                bit (1) aligned	/* flag for temporary file */;
dcl  verify                   builtin;
dcl  wordp                    pointer;

dcl 1 word aligned based (wordp),			/* model of a word */
    2 upper bit (18) unaligned,
    2 lower bit (18) unaligned;

dcl 1 word1 aligned based (wordp),
    2 ch1 bit (6) unaligned,
    2 ch2 bit (6) unaligned,
    2 ch3 bit (6) unaligned,
    2 ch4 bit (6) unaligned,
    2 ch5 bit (6) unaligned,
    2 ch6 bit (6) unaligned;
%page;
%include gcos_ext_stat_;
%page;
%include gcos_restart_control_;
%page;
%include gcos_xlate_bcd_ascii_;
%page;
%include gcos_dcl_ios_;
%page;
%include gcos_fibs;
     end gcos_mme_rels_;




		    gcos_mme_rets_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       15489



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_mme_rets_: proc (mcp, increment);
/* ***************************************************************************************
   *****************************************************************************************
   *
   *
   *	M M E  G E R E T S
   *
   *
   *  MME GERETS is used to unset bits in the program switch word according to corresponding
   *  bits in the Q-register. For each bit position of the Q that contains a 1,
   *  the corresponding bit of the switch word is set to 0. For ecah bit position of
   *  the Q that contains a 0, the corresponding bit of the switch word is not changed.
   *  The resultant setting of the switch word is returned in the Q-register.
   *
   *
   * Author: DICK SNYDER NOVEMBER 6,1970
   * Change: Dave Ward	06/01/81 gcos_ext_stat_.
   *
   *
   ******************************************************************************************
   **************************************************************************************** */
%page;
	increment = 0;				/* no parameter words */

	save_data.psw = save_data.psw & ^mc.regs.q;	/* and negated into psw */
	mc.regs.q = save_data.psw;			/* return new psw */
	return;					/* exit */
%page;
/*   Variables for gcos_mme_rets_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  increment                fixed bin(24);						/* number of param words */;
%page;
%include gcos_ext_stat_;
     end gcos_mme_rets_;




		    gcos_mme_rout_.pl1              09/09/83  1404.1rew 09/09/83  1007.6      155340



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


/* *******************************************************************************************
   *******************************************************************************************
   *
   *
   * 		M M E   G E R O U T
   *
   *	MME GEROUT enables a user program to send output to and receive input
   *	from a remote terminal and to request terminal type.
   *
   *	The following operations are implemented -
   *
   *		3 (octal)  -	Direct Access Output
   *		4 (octal)  -	Direct Access Output, Then Input
   *		5 (octal)  -	User Program Inquiry to Terminal
   *		6 (octal)  -	Program Requests Terminal Type
   *		17 (octal) -	Program Requests Line Disconnect
   *		20 (octal) -	Direct Access Current Line Status
   *
   *	All operations not implemented fall into the categories of paper tape
   *	manipulation or line switching.
   *
   *	Output is written to the stream "user_output" and input is read from
   *	the stream "user_input".  Data is translated to and from the Multics
   *	standard data format.  This allows the stream names to be associated
   *	with any type of device.  The edited i/o mode is used for output to
   *	suppress escape printing.
   *
   *	A terminal break is simulated by a QUIT followed by the command
   *	"program_interrupt".
   *
   *	Direct access is established (if not already) on any correct call with
   *	operation code 3, 4, or 5.
   *
   *	WRITTEN BY DAVID KAYDEN  JANUARY 1974
   *	Modified by M. R. Jordan, October 1977
   *      Modified by A. N. Kepner, March 1978 to allow courtesy call i/o  within cc routines
   *
   *******************************************************************************************
   ****************************************************************************************** */

gcos_mme_rout_: proc (mcp, increment);




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




%include gcos_ext_stat_;

/*	External Entries			*/


dcl  continue_to_signal_      ext entry (fixed bin(35));
dcl  gcos_et_$bad_cc_ptr      fixed bin(35) ext;
dcl  gcos_et_$bad_mme_in_cc   fixed bin(35) ext;
dcl  gcos_et_$bad_rmt_station_id fixed bin(35) ext;
dcl  gcos_et_$bad_rout_op_code fixed bin(35) ext;
dcl  gcos_et_$bad_rout_pgm_id fixed bin(35) ext;
dcl  gcos_et_$bad_status_ret_ptr fixed bin(35) ext;
dcl  gcos_et_$invalid_dcw_ptr fixed bin(35) ext;
dcl  gcos_et_$rmt_term_rec_size fixed bin(35) ext;
dcl  gcos_mme_bort_$system    ext entry options (variable);
dcl  ioa_                     ext entry options (variable);
dcl  ios_$changemode          entry (char (*), char (*), char (*), bit (72) aligned);
dcl  ios_$read_ptr            ext entry (pointer, fixed bin(24), fixed bin(24));
dcl  ios_$write_ptr           ext entry (pointer, fixed bin(24), fixed bin(24));


/*	Work Variables			*/


dcl  increment                fixed bin(24);						/* number of words in mme request 	*/

dcl 1 gerout_word aligned based (opptr),		/* model of word following mme	*/
    2 buffp bit (18) unaligned,			/* buffer pointer			*/
    2 op bit (6) unaligned,				/* operation code of request		*/
    2 id bit (12) unaligned;						/* terminal id of request		*/

dcl 1 gerout_word_ aligned based (opptr),		/* gerout word overlay for op = 20	*/
    2 term_type bit (6) unaligned,			/* terminal type field		*/
    2 pad bit (30) unaligned;

dcl 1 output_buffer aligned based (buffptr),		/* model of output buffer		*/
    2 word_count bit (18) unaligned,			/* number of words to send		*/
    2 inputp bit (18) unaligned,			/* input buffer location		*/
    2 char_count bit (18) unaligned,			/* output character count		*/
    2 control_bits bit (18) unaligned,			/* output control bits		*/
    2 data (1280) bit (9) unaligned;						/* output character data		*/

dcl 1 input_buffer aligned based (inptr),		/* model of input buffer		*/
    2 char_count bit (18) unaligned,			/* input character count		*/
    2 control_bits bit (18) unaligned,			/* input control bits		*/
    2 data (1280) bit (9) unaligned;						/* input character data		*/

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

dcl 1 status_word aligned based (statptr),		/* model of status word	*/
    2 pad bit (30) unaligned,				/* unused portion of word		*/
    2 wait bit (1) unaligned,				/* line waiting to connect to pgm.	*/
    2 idle bit (1) unaligned,				/* terminal is idle			*/
    2 busy bit (1) unaligned,				/* terminal is involved in I/O	*/
    2 complete bit (1) unaligned,			/* I/O transmission is complete	*/
    2 disconnected bit (1) unaligned,			/* terminal is not connected		*/
    2 break bit (1) unaligned;						/* operator sent BREAK (quit key) 	*/

dcl  inquiry_name             bit (36) aligned based (nameptr);						/* program inquiry identification	*/

dcl 1 table (2) aligned internal static,		/* tabled inquiry requests - 2 allowed	*/
    2 name bit (36) aligned,				/* inquiry name of request		*/
    2 routptr ptr;						/* pointer to inquiry request mme	*/

dcl (buffptr, inptr, gseg, opptr, nameptr, sptr, statptr) ptr;

dcl  1 courtesy_call_conditions            like save_machine_conditions based (mcp);
dcl  code                     fixed bin(35);
dcl  iosbuf                   (1297) bit (9);
dcl  new_next_avail           fixed bin(24);
dcl  scratch_word             bit (36) aligned;
dcl  slave_limit              fixed bin(19);
dcl  status                   bit (72) aligned;
dcl (i, j, k) fixed bin(24);

/*	Internal Static Variables		*/

dcl  dac_id                   bit (12) aligned internal static;						/* line id of current direct access	*/
dcl  ackno_break              bit (1) internal static;
dcl  old_mode                 char (128) internal static;
dcl  skip                     bit (1) internal static;
dcl  skip_loc                 label internal static;

/*	Constants				*/

dcl  CR                       bit (9) internal static init ("015"b3     );
dcl  LF                       bit (9) internal static init ("012"b3     );
dcl  NULL                     bit (9) internal static init ("177"b3     );
dcl  zero_word                bit (36) aligned internal static init ((36)"0"b);

dcl (addr, addrel, fixed, substr, unspec) builtin;



/*	P  R  O  C  E  D  U  R  E				*/




	if ^gcos_ext_stat_$save_data.rout then do;	/* once per activity initialization	*/
	     dac_id = (12)"0"b;			/* not in direct access now		*/
	     table.name (1) = zero_word;		/* and no requests tabled		*/
	     table.name (2) = zero_word;
	     ackno_break = "0"b;
	     skip = "0"b;
	     call ios_$changemode ("user_output", "edited", old_mode, status);
	     gcos_ext_stat_$save_data.rout = "1"b;	/* initialization complete		*/
	end;

	gseg = gcos_ext_stat_$gcos_slave_area_seg;	/* get local pointer to slave area	*/
	slave_limit = gcos_ext_stat_$storage_limit;	/* copy slave storage limit, too	*/
	increment = 2;				/* initialize parameter length	*/
	scup = addr (mc.scu);			/* get pointer to scu data		*/
	i = fixed (scu.ilc)+1;			/* get offset of first parameter word	*/
	opptr = addrel (gseg, i);

	k = fixed (gerout_word.op);			/* extract operation code		*/

	if k = 5 then go to inquiry;			/* remote inquiry requested		*/

	if gerout_word.id = (12)"0"b then go to err75;	/* zero terminal id is illegal	*/

	if k = 6 then go to terminal_type;		/* program requests terminal type	*/

	if k ^= 3 then				/* check remaining implemented codes	*/
	     if k ^= 4 then
		if k ^= 15 then			/* if no match then operation is	*/
		     if k ^= 16 then go to err72;	/* undefined or not implemented	*/
						/* not implemented			*/
	sptr = addrel (opptr, 1);			/* return word follows operation word	*/
	if fixed (return_word.status_return) >= slave_limit then go to err41;
	if fixed (return_word.courtesy_call) >= slave_limit then go to err44;
	statptr = addr (scratch_word);		/* allows no status word pointer	*/
	if return_word.status_return ^= (18)"0"b then
	     statptr = addrel (gseg, return_word.status_return);

	unspec (status_word) = zero_word;		/* clear status word		*/

	if k = 3 then go to in_out;			/* output only request		*/

	if k = 4 then go to in_out;			/* output then input request		*/

	if k = 15 then go to disconnect;		/* disconnect request		*/


/*	terminal status request				*/



	if dac_id ^= gerout_word.id then do;		/* if program uses a different id, then	*/
disc:	     status_word.disconnected = "1"b;		/* tell him line is disconnected	*/
	     return;
	end;
	if ackno_break then do;			/* if a "break" has occurred		*/
	     status_word.break = "1"b;		/* then acknowledge it		*/
	     ackno_break = "0"b;
	end;
	else status_word.idle = "1"b;			/* otherwise, the line is idle	*/
	go to type;				/* get the terminal type, too		*/




/*	terminal type request				*/



terminal_type: if dac_id ^= gerout_word.id then do;	/* if id does not match, then 	*/
	     increment = 1;				/* take disconnect return		*/
	     return;
	end;

type:	term_type = "04"b3 ;			/* if id matches, then terminal type	*/
	return;					/* is teleprinter			*/




/*	line disconnect request				*/



disconnect: status_word.disconnected = "1"b;		/* status is always disconnected	*/
	if dac_id ^= gerout_word.id then go to cc_check;	/* if not connected to this id, then 	*/
						/* nothing to do			*/
	dac_id = (12)"0"b;
	ackno_break = "0"b;				/* partial reinitialization		*/

	if ^gcos_ext_stat_$save_data.brief then
	     call ioa_ ("direct access disconnect");

	do i = 1, 2;				/* now check for tabled request	*/
	     if table.name (i) ^= zero_word then do;	/* tabled entry found		*/
		table.name (i) = zero_word;		/* clear table entry		*/
		opptr = table.routptr (i);		/* point to remembered inquiry mme	*/
		dac_id = (2)"22"b3 ;		/* set new terminal id		*/
		gerout_word.id = dac_id;		/* tell program the terminal id	*/
		if ^gcos_ext_stat_$save_data.brief then
		     call ioa_ ("direct access established"); /* this could be removed if not wanted	*/
		go to cc_check;
	     end;
	end;
	go to cc_check;				/* nothing found - not in direct access	*/


/*	remote inquiry request				*/



inquiry:	nameptr = addrel (opptr, 1);			/* set pointer to inquiry name	*/
	if inquiry_name = zero_word then go to err76;	/* zero inquiry name is illegal	*/

	if dac_id = (12)"0"b then do;			/* if not already in direct access,	*/
						/* then establish it		*/
	     dac_id = (2)"21"b3 ;			/* set terminal id			*/
inq1:	     gerout_word.id = dac_id;			/* tell program the terminal id	*/
	     if ^gcos_ext_stat_$save_data.brief then
		call ioa_ ("direct access established"); /* this could be removed if not wanted	*/
	     return;
	end;

/* request must be tabled		*/
	do i = 1, 2;				/* check against tabled inquiries	*/
	     if table.name (i) ^= zero_word then do;
		if inquiry_name = table.name (i) then	/* check for same name already in table	*/
		     if table.routptr (i) = opptr then return; /* if so, location of mme must match	*/
		     else go to err76;		/* otherwise abort			*/
		if table.routptr (i) = opptr then go to err76; /* different names at the same	*/
	     end;					/* location is also illegal		*/
	end;
	do i = 1, 2;				/* now attempt to table the request	*/
	     if table.name (i) = zero_word then do;	/* found a slot			*/
		table.name (i) = inquiry_name;	/* save inquiry name		*/
		table.routptr (i) = opptr;		/* and mme location			*/
		return;
	     end;
	end;
	go to err76;				/* table is full			*/


/*	output or output - input request			*/



in_out:	if dac_id = (12)"0"b then dac_id = gerout_word.id; /* connect by terminal id match	*/

	if dac_id ^= gerout_word.id then go to disc;	/* i/o request to wrong terminal id	*/
	i = fixed (gerout_word.buffp);		/* get address of output buffer	*/
	if i > slave_limit then go to err43;
	buffptr = addrel (gseg, i);			/* pointer to output buffer		*/
	j = fixed (output_buffer.char_count);		/* output character count		*/

	if j > 1296 then go to err74;			/* is buffer size too big (GCOS limit)	*/

	if (fixed (output_buffer.word_count)-1)*4 < j then go to err74; /* check word count	*/

	if k = 4 then
	     if fixed (output_buffer.inputp) + 324 > slave_limit
	     then go to err74;			/* check input buffer against limits	*/

	do i = 1 to j;				/* copy output buffer		*/
	     iosbuf (i) = output_buffer.data (i);
	end;

	skip_loc = return_break;			/* save stack frame for nonlocal transfer */
	skip = "1"b;				/* indicate i/o in progress		*/
	if ackno_break then do;			/* was there a previous break		*/
return_break:  skip = "0"b;				/* then skip i/o			*/
	     status_word.break = "1"b;		/* acknowledge break		*/
	     ackno_break = "0"b;			/* acknowledgement done		*/
	     go to cc_check;
	end;

	do i = 1 to j;				/* convert GCOS buffer to Multics	*/
	     if iosbuf (i) = LF then do;		/* remove initial line feed, if there	*/
		iosbuf (i) = NULL;			/* replace it with a null character	*/
		go to append_lf;
	     end;
	     if iosbuf (i) ^= CR then			/* stop search for line feed on first	*/
		if iosbuf (i) ^= NULL then go to append_lf; /* printable character		*/
	end;

append_lf: if k = 3 then do;				/* now append a "new line" to the end	*/
	     j = j + 1;				/* if this is output only		*/
	     iosbuf (j) = LF;
	end;

	call ios_$write_ptr (addr (iosbuf), 0, j);	/* send output to "user_output"	*/

	if k = 3 then go to io_done;			/* if output only, then skip input	*/

	inptr = addrel (gseg, output_buffer.inputp);	/* get pointer to input buffer	*/

	call ios_$read_ptr (addr (input_buffer.data), 1296, j); /* read from user_input		*/

	if input_buffer.data (j) = LF then		/* there should be a line feed on end	*/
	     input_buffer.data (j) = CR;		/* so replace it with carriage return	*/

	input_buffer.char_count = substr (unspec (j), 19, 18); /* record input character count	*/

io_done:	skip = "0"b;				/* i/o complete			*/
	status_word.complete = "1"b;			/* normal status to program		*/


cc_check:	if return_word.courtesy_call = (18)"0"b then return; /* check for user courtesy call	*/
	if gcos_ext_stat_$save_data.cc then do;		/* Already in courtesy call */

/* Check courtesy call queue for overflow */
	     new_next_avail = mod (courtesy_call.next_avail,
		hbound (courtesy_call.queue, 1))+1;
	     if courtesy_call.next_out = new_next_avail then
		call gcos_mme_bort_$system (gcos_et_$bad_mme_in_cc,
		"Maximum of ^i simultaneous outstanding courtesy calls has been exceeded.",
		hbound (courtesy_call.queue, 1)-1);

/* Add cc address to queue */
	     courtesy_call.queue (courtesy_call.next_avail) =
		fixed (return_word.courtesy_call);
	     courtesy_call.next_avail = new_next_avail;
	end;

	else do;					/* Not in courtesy call yet. */

	     gcos_ext_stat_$save_data.cc = "1"b;	/* indicate that courtesy call in progress */


/* 	Save machine conditions and increment value for return to the caller of	 */
/* 	MME GEINOS when the MME GEENDC is executed. Put courtesy call address		 */
/* 	in increment to cause control to go to courtesy call routine.		 */


	     gcos_ext_stat_$increment_hold = increment;	/* save increment */
	     courtesy_call.hold = courtesy_call_conditions.save_space; /* save MME GEINOS conditions */
	     i = fixed (return_word.courtesy_call);	/* get courtesy call address */
	     j = fixed (scu.ilc);			/* get loc of MME GEINOS */
	     increment = i-j-1;			/* compute increment value to cause control to go to cc rtn */
	end;
	return;


/*	error messages				*/


/*	standard GCOS error messages are used		*/

err41:	code = gcos_et_$bad_status_ret_ptr;
	go to abort;
err43:	code = gcos_et_$invalid_dcw_ptr;
	go to abort;
err44:	code = gcos_et_$bad_cc_ptr;
	go to abort;
err72:	code = gcos_et_$bad_rout_op_code;
	go to abort;
err74:	code = gcos_et_$rmt_term_rec_size;
	go to abort;
err75:	code = gcos_et_$bad_rmt_station_id;
	go to abort;
err76:	code = gcos_et_$bad_rout_pgm_id;
abort:	call gcos_mme_bort_$system (code);


/*	process a terminal break			*/


/*	(simulated by a QUIT followed by the command "program_interrupt") */

rout_interrupt: entry ();


	if gcos_ext_stat_$save_data.rout & dac_id ^= (12)"0"b then do; /* are we in direct access		*/

	     if skip then go to skip_loc;		/* if i/o in progress - abort it	*/
	     ackno_break = "1"b;			/* otherwise remember break		*/
	     return;				/* and tell program later		*/
	end;

	call continue_to_signal_ (code);		/* not in direct access now		*/
	return;					/* so pretend we didn't set handler	*/


/*	restore "user_output" edited/normal mode after an activity	*/


rout_cleanup: entry ();

	call ios_$changemode ("user_output", old_mode, "", status); /* restore edited/normal mode	*/
	old_mode = "";				/* prevent mode from being reset twice	*/
	gcos_ext_stat_$save_data.rout = "0"b;		/* reset direct access flag		*/
	return;

     end gcos_mme_rout_;




		    gcos_mme_save_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       89865



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

/*
   MME GESAVE is used to  write out a program in system loadable format (loadable
   by a MME GECALL).

   CALLING SEQUENCE:

   MME	GESAVE
   BCI	1,XXXXXX	BCD PROGRAM NAME
   ZERO	L(FIRST WORD),NO OF WORDS	FIRST WORD AND NUMBER OF WORDS TO SAVE
   ZERO	XFER ADDR,LOAD INCREMENT	PLACE TO GO WHEN RELOADED,NUMBER TO
   BE SUBTRACTED FROM LOC OF FIRST WORD
   AND XFER ADDR WHEN RELOADED
   RETURN

   IN ADDITION, THE Q REQ MUST CONTAIN THE FILE CODE OF THE FILE ON WHICH
   THE SAVE IS TO BE DONE. THIS FILE MUST BE RANDOM DRUM OR DISK.
   Q upper can also contain an error return location.

   Author: DICK SNYDER OCTOBER 9,1971
   Change: D. KAYDEN  APRIL 1974
   Change: M. R. Jordan, October 1977
   Change: Dave Ward	06/30/81 Revised instituted, fixed bin(24)unsigned instituted, bugs corrected.
*/
	scup = addr (mc.scu);			/* get addr of scu data */
	i = instruction_counter+1;			/* offset to MME GECALL parameter location. */
	callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* get pointer to params */
	call gcos_cv_gebcd_ascii_ (addr (mc.regs.q), 6, addr (fc)); /* get file code in ascii */

	do i = 1 to hbound (save_data.fibs, 1);
	     if fct.filecode (i) = substr (fc, 5, 2) then go to hit; /* look for file */
	end;

	message = "No device assigned to file code ""^a"".";
	ecode = gcos_et_$bad_call_save_device;
die:	;
	if substr (mc.regs.q, 1, 18) ^= (18)"0"b then do;
return_code:   ;
	     increment = q_reg_left_half + instruction_counter;
	     fb35 = gcos_mme_bort_$abort_number (ecode);
	     q_reg_right_half = addr (fb35) -> word.r18;
	     return;
	end;
	else
	call gcos_mme_bort_$system (ecode, message, substr (fc, 5, 2));

hit:	if fct.sysout (i) then go to not_rand;
	fibptr = fct.fibptr (i);
	fib.iocount = fib.iocount + 1;
	if ^fib.type then do;			/* not random disk */
not_rand:
	     message = "File code ""^a"" is not assigned to a random mass-storage file.";
	     ecode = gcos_et_$bad_call_save_device;
	     goto die;
	end;

	if (gesave.first+gesave.count) > gcos_ext_stat_$storage_limit then do;
	     ecode = gcos_et_$io_lim_call_save;
	     message = "";
	     goto die;
	end;

	if gesave.count = 0 then do;
	     ecode = gcos_et_$zero_save_word_cnt;
	     message = "";
	     goto die;
	end;

	if substr (save_data.psw, 16, 1) then do;	/* first time save on this file */

	     call ios_$seek (fib.stream, "last", "first", 1000, status); /* seek just after catalog */
	     if code ^= 0 then do;			/* ios error? */
ioerror:		call check_fs_errcode_ (code, "xxxxxxxx", longerror); /* get error message equivalent to code */
		if substr (mc.regs.q, 1, 18) ^= (18)"0"b then goto return_code;
		else
		call gcos_mme_bort_$system (code, "file code=""^a""^/^a", substr (fc, 5, 2), longerror);
	     end;

	     call ios_$seek (fib.stream, "write", "first", 1000, status); /* seek write also */
	     if code ^= 0 then go to ioerror;

	end;

	preface.name = gesave.prog_name;		/* set up preface data */
	preface.rel_check, preface.rel_abs = 0;
	preface.reloc_words = 0;
	preface.entry = gesave.xfer_addr - gesave.load_incr;
	preface.origin = gesave.first - gesave.load_incr;
	preface.data_words = gesave.count;

/* Calculate checksum. */

	checker_ptr = addrel (gcos_ext_stat_$gcos_slave_area_seg, gesave.first); /* point at it */
	accum = 0;
	do i = 1 to gesave.count;
	     accum = accum + checker (i);
	     if accum > 68719476735 then		/* test for 36 bit overflow */
		accum = accum-68719476736+1;		/* preform end around carry and add */
	end;
	preface.data_check = substr (unspec (accum), 37, 36); /* Save checksum. */

	add = gesave.first - gesave.load_incr;
	cnt = gesave.count;
	ndcw = 0;

loop:	;
	ndcw = ndcw+1;
	preface.dcws (ndcw).data_addr = add + 1024;

	if cnt <= 4096 then do;			/* last one */
	     if cnt = 4096 then
		preface.dcws (ndcw).count = 0;
	     else
	     preface.dcws (ndcw).count = cnt;
	     preface.dcws (ndcw).action = "0"b;		/* indicate that this is last dcw */
	     go to done;				/* fini */
	end;

	preface.dcws (ndcw).count = 0;		/* max count of 4096 */
	cnt = cnt-4096;				/* subtract this from count */
	preface.dcws (ndcw).data_addr = add +1024;
	add = add+4096;				/* kick up address */
	preface.dcws (ndcw).action = "001"b;		/* this isn't the last */
	go to loop;				/* so do more */

done:	call ios_$tell (fib.stream, "write", "first", seek_save, status); /* find out where preface will go */
	if code ^= 0 then go to ioerror;

	call ios_$write (fib.stream, addr (preface), 0, 6+ndcw, i, status); /* write out preface */
	j = gesave.count;				/* get count of words to write */
	if code ^= 0 then go to ioerror;		/* io error, die */

	fib.last = seek_save + 6 + ndcw + j;		/* update end of valid data */
	call ios_$write (fib.stream, checker_ptr, 0, j, i, status); /* write out prog */
	if code ^= 0 then go to ioerror;		/* die */


/* Fill in the catalog. */
	call ios_$seek (fib.stream, "read", "first", 0, status); /* set up to read catalog */
	if code ^= 0 then go to ioerror;		/* oops */

	call ios_$read (fib.stream, addr (catblk), 0, 1000, i, status); /* read catalog */
	if code ^= 0 then go to ioerror;

	if substr (save_data.psw, 16, 1) then catblk.no_ent = 0; /* init catalog if first time */
	substr (save_data.psw, 16, 1) = "0"b;		/* turn off flag */
	i, catblk.no_ent = catblk.no_ent+1;		/* bump no of entries */
	catblk.elblock (i).element = gesave.prog_name;	/* put name in catalog */
	catblk.elblock (i).address = seek_save;		/* put in seek address */

/* Write out the catalog. */
	call ios_$seek (fib.stream, "write", "first", 0, status); /* seek to start of file */
	if code ^= 0 then go to ioerror;		/* lose */

	call ios_$write (fib.stream, addr (catblk), 0, 1000, i, status); /* write out catalog */
	if code ^= 0 then go to ioerror;

	call ios_$seek (fib.stream, "write", "last", 0, status); /* reset write pointer */
	if code ^= 0 then go to ioerror;

	increment = 3;				/* skip 3 param words */
	return;
%page;
/*   Variables for gcos_mme_save_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  accum                    fixed bin(71)	/* accumulator for checksum */;
dcl  add                      fixed bin(24);
dcl  addr                     builtin;
dcl  addrel                   builtin;
dcl  bit                      builtin;
dcl  callp                    ptr;
dcl  checker                  (gesave.count) fixed bin(36)unsigned unal based (checker_ptr)	/* overlay for computing chksum */;
dcl  checker_ptr              ptr;
dcl  check_fs_errcode_ entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl  cnt                      fixed bin(24);
dcl  ecode                    fixed bin(35);
dcl  fb35                     fixed bin(35);
dcl  fc                       char (6);
dcl  fixed                    builtin;
dcl  gcos_cv_gebcd_ascii_     ext entry (pointer, fixed bin(24), pointer);
dcl  gcos_et_$bad_call_save_device fixed bin(35) ext;
dcl  gcos_et_$io_lim_call_save fixed bin(35) ext;
dcl  gcos_et_$zero_save_word_cnt fixed bin(35) ext;
dcl  gcos_mme_bort_$abort_number entry (fixed bin(35)) returns (fixed bin);
dcl  gcos_mme_bort_$system    entry options(variable);
dcl  i                        fixed bin(21);
dcl  increment                fixed bin(24);
dcl  instruction_counter      fixed bin(18)unsigned unal based(addr(scu.ilc));
dcl  ioa_                     entry() options(variable);
dcl  j                        fixed bin(21);
dcl  k                        fixed bin(24);
dcl  longerror                char (100)aligned;
dcl  message                  char (62);
dcl  ndcw                     fixed bin(24);
dcl  prog_name                char (6);
dcl  seek_save                fixed bin(21);
dcl  substr                   builtin;
dcl  unspec                   builtin;

dcl 1 word	aligned based
,2 l18		bit(18)unal
,2 r18		bit(18)unal
;

dcl 1 q_register		aligned based(addr(mc.regs.q))
,2 q_reg_left_half		fixed bin(18)unsigned unal
,2 q_reg_right_half		bit(18)unal
;

dcl 1 gesave aligned based (callp),			/* overlay for gesave parameters */
    2 prog_name	bit(36) unal,			/* name under whcih file to be saved */
    2 first	fixed bin(18)unsigned unal,			/* addr of first word to be saved */
    2 count	fixed bin(18)unsigned unal,			/* no. of words to be saved */
    2 xfer_addr	fixed bin(18)unsigned unal,			/* transfer address */
    2 load_incr	fixed bin(18)unsigned unal		/* loading increment */
;

dcl 1 preface aligned,				/* model of preface record */
    2 data_check	bit(36),				/* checksum of following data words */
    2 rel_check	fixed bin(24),				/* checksum of following reloc. words */
    2 rel_abs	fixed bin(24),				/* 0=absolute|^0=relocatable */
    2 name	bit(36) unal,			/* name of pgm */
    2 entry	fixed bin(18)unsigned unal,			/* entry address */
    2 origin	fixed bin(18)unsigned unal,			/* origin */
    2 reloc_words	fixed bin(18)unsigned unal,			/* no. of relocation words */
    2 data_words	fixed bin(18)unsigned unal,			/* no. of data words */
    2 dcws (64) like dcw_model		/* dcw(s) to load following data records */
;

dcl 1 dcw_model aligned based,			/* model of dcw */
    2 data_addr	fixed bin(18)unsigned unal,
    2 zero	bit(3) unal,
    2 action	bit(3) unal,
    2 count	fixed bin(12)unsigned unal;						/* number of words to xfer */

dcl 1 catblk aligned,
    2 nxt	fixed bin(24),				/* pointer to next calalog block */
    2 no_ent	fixed bin(24),				/* number of entries in catalog */
    2 elblock (499),				/* room for 499 entries */
      3 element	bit(36) unal,			/* prog name */
      3 address	fixed bin(24)			/* offset in file of preface data */
;
%page;
%include gcos_dcl_ios_;
%page;
%include gcos_ext_stat_;
     end gcos_mme_save_;




		    gcos_mme_sets_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       15327



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_mme_sets_: proc (mcp, increment);
/* ***************************************************************************************
   *****************************************************************************************
   *
   *
   *	M M E  G E S E T S
   *
   *
   *  MME GESETS is used to set bits in the program switch word according to corresponding
   *  bits in the Q-register. For each bit position of the Q that contains a 1,
   *  the corresponding bit of the switch word is set to 1. For ecah bit position of
   *  the Q that contains a 0, the corresponding bit of the switch word is not changed.
   *  The resultant setting of the switch word is returned in the Q-register.
   *
   *
   *Author: DICK SNYDER OCTOBER 16,1970
   * Change: Dave Ward	06/01/81 gcos_ext_stat_.
   *
   *
   ******************************************************************************************
   **************************************************************************************** */
%page;
	increment = 0;				/* no parameter words */

	save_data.psw = save_data.psw | mc.regs.q;	/* or q into psw */
	mc.regs.q = save_data.psw;			/* return new psw */
	return;					/* exit */
%page;
/*   Variables for gcos_mme_sets_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  increment                fixed bin(24)/* number of param words */;
%page;
%include gcos_ext_stat_;
     end gcos_mme_sets_;




		    gcos_mme_snap_.pl1              09/09/83  1404.1rew 09/09/83  1007.6       20331



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



/* ***************************************************************************
   ***************************************************************************
   *                                                                         *
   *                                                                         *
   *         mme gesnap                                                      *
   *                                                                         *
   *                                                                         *
   * This mme performs panel and slave core area snaps of gcos programs.     *
   *                                                                         *
   *                                                                         *
   *    Written by R. H. Morrison February 22, 1974                          *
   *    Modified by R.H. Morrison on April 8, 1974                           *
   *    Modified by R.H. Morrison on February 11,1975		       *
   *                                                                         *
   *                                                                         *
   ***************************************************************************
   ************************************************************************ */


gcos_mme_snap_: proc (faultp, increment);

/* ****    DECLARATIONS    **** */

dcl  gcos_mme_snp1_ ext entry;
dcl  faultp pointer;						/* unused input parameter */
dcl  increment fixed bin(24);						/* number of mme parameters */
dcl  gcos_write_$ptr ext entry (ptr, char (*), bit (8));

/* ****    PROCEDURE     **** */

	increment = 1;				/* one mme parameter */
	call gcos_mme_snp1_;			/* take the snap (no arguments required) */
	return;
     end gcos_mme_snap_;




		    gcos_mme_snp1_.alm              09/09/83  1404.1rew 09/09/83  1007.6      373680



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"  *************************************************************                
"  *                                                           *                
"  *                                                           *                
"  * copyright (c) 1974 by honeywell information systems, inc. *                
"  *                                                           *                
"  *                                                           *                
"  *************************************************************                
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"								"
"	gcos_mme_snp1_						"
"								"
"	This procedure is a conversion of the GCOS SR1/G SSA module .MSNP1	"
"	from gmap to alm pure procedure.				"
"								"
"	There are three entry points to this procedure:			"
"								"
"	1.  gcos_mme_snp1_:-  This entry processes a slave program MME	"
"	GESNAP. It requires no arguments.				"
"								"
"	2.  binpt:- This entry is used to snap the slave prefix of	"
"	aborting programs.  It requires three arguments:			"
"	     arg1 is a full word containing the absolute location to print	"
"	     in its upper, and the number of words to print in its lower.	"
"	     arg2 is a full word containing the absolute location to snap	"
"	     in its upper, and the number of words to snap in its lower.	"
"	     arg3 is a full word containing bias to apply to address 	"
"	     for snap in its upper, and 3 bcd characters to print with the	"
"	     first line of output in its lower (m  ,s  ,   ).		"

"								"
"	3.  bord:-  This entry is used to snap registers and memory of 	"
"	aborting programs.  It requires two arguments:			"
"	     arg1 is a full word containing the ic&ir to print.		"
"	     arg2 is a full word which has the same format as the MME 	"
"	     GESNAP parameter.					"
"								"
"	Written by R.H. Morrison	December, 1974			"
"								"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
	name	gcos_mme_snp1_
	entry	gcos_mme_snp1_,bord,binpt
	include	mc
"
"
gcos_mme_snp1_:
	push
	spriap	sp|0	save ap
	ldq	0,dl	change transfer to ep1
	stq	mod
	lda	0,dl	set a & q registers
	ldq	0,dl
	tra	xinit1  


"      ttl     cd600j3.265	 gecos sr1/g		  740704snp1
"      cpr     g,1968,1969,1970                                                 
"      cpr     h,1971,1972                                                      
"      .entry  snp1,xend,,(gesnip,binpt,bord),ssa                        
"      ttls                    g e s n a p                               
bp:    null                                                                     
       stx1    prea                                                         
bp05:  null                                                              
       eax3    0,qu            save location of first word to            
"                              be dumped.                                
       eaq     0,ql            store # words to dump in                  
       stq     wdcnt      word count.                               
       cana    -1,dl           are there any words to be moved?          
       tze     bp20            nope                                             
       eax1    0,au            put location of data to be moved in x1.   
       ldx2    lp|bufad1       x2 = 1st location in output buffer
       ana     -1,dl           isolate # of words to move                
bp10:  ldq     pr3|0,1         start move.                               
       stq     lp|0,2                                                       
       adlx1   1,du            bump move indices.                        
       adlx2   1,du                                                      
       sbla    1,dl            decrement # words to move.                
       tnz     bp10       continue moving.                          
bp20:  stx3    mo10a       store location of next word to dump.      
       tsx1    comp       go find first equal line.                 
       tra     bp30       no equal lines.                           
       tra     comp20     lines not equal, continue search.         
       ldx4    comp20a     first equal line-loc. in comp 20.         
       sblx4   mo10a       calculate # words to move.                
       sta     wdcnt      restore wdcnt to new value.               
       tsx1    output     go output the words.                      
       ldx0    =o542020,du     set up to print * with next line.         
       sxl0    mo30a                                                 
       tsx1    comp       now we skip all equal lines.              
       tra     bp50       less than 17 words left to print.         
       tra     2,ic            unequal lines found.                      
       tra     comp20     equal lines found, keep going             
       sta     wdcnt      restore word count.                       
       ldx3    comp20a     pick up loc. of unequal line.             
       tra     bp20                                                 
bp30:  ldx4    wdcnt      pick up # of words to print.              
       tsx1    output     output last of line.                      
pre:   ldx1    prea                                                            
       tnz     0,1             came from eis register dump routine              
flush: tsx1    write      flush the buffer                                 
xit:   null                                                                     
	return		return to calling procedure
bp50:  eax3    8,3             bump loc. of line by 8 to get past        
"                              equal line.                               
       eax4    -8,au           # words left to x4.                       
       stx3    mo10a       store loc. of last line(s) to print.      
       tra     bp30+1                                               
"                              this routine determines                   
"                              how many words to be printed              
"                              will fit in the current                   
"                              buffer and calls the                      
"                              move routine to put them                  
"                              in the buffer. whenever the               
"                              buffer is found to be full,               
"                              the write routine is called               
"                              to empty the buffer.                      
"                              upon entry                                
"                              x2-next available loc. in lp|bufr.           
"                              x4-number of words to move.               
output:stx1    op20a       save x1 for return.                       
       eax0    bufnd            see if all words to be moved		   
       stx2    op05a            fit in buffer. allow for 2                
       sblx0   op05a           extra words. last loc in buffer-          
"                              first available loc to store in.          
       tmi     op50       nothing fits.                             
       stx0    op15a                                                      
op10:  cmpx4   op15a           will all words fit?                       
       trc     op30       no- see if any fit                               
       eaa     0,4             # words to au.                            
       tsx1    move       go setup sysout record.                   
op20:  ldx1    op20a
       tra     0,1
op30:  cmpx0   9,du            will at least 8 words fit?                
       tnc     op50       no-go flush buffer.                       
       eax0    -1,0            set number of words to move               
       anx0    =o777770,du     to a multiple of 8.                       
       stx0    op40a       save so as to reduce total words.         
       eaa     0,0                                                       
       tsx1    move       set up sysout record.                     
op40:  sblx4   op40a           reduce total words to move by             
       ldx0    =o202020,du       # words just moved.                       
       stx3    mo10a       initialize move rout. with start of       
"                              next line.                                
       sxl0    mo30a       set print character to blank.             
op50:  tsx1    write      go flush the buffer.                      
       tra     output+1                                             
"                              this routine sets up the sysout           
"                              (gefrc) record control words              
"                              for n lines of "binary"                   
"                              print words. it then moves                
"                              the prescribed words to the               
"                              buffer.                                   
"                              upon entry                                
"                              x2-next available loc in bufr.            
"                              au-# words to move                        
"                              mo10a-initialize with loc of               
"                                 first word to move                     
"                              mo20a-initialize with bias to              
"                                 apply to printed location.             
"                              mo30a-initialized with character           
"                                 to print with first loc.               
"                                 e.i. m,s,* or blank.                   
move:  eaq     1,au            construct first gefrc control             
       orq     =o70374,dl      word.                                     
       stq     lp|0,2                                                       
mo10:  ldx3    mo10a           set x3 to first word to move              
"                              set up second sysout control              
"                              word. location, print character           
mo20:  eaq     0,3             apply bias to location
       adlq    mo20a
mo30:  orq     mo30a       or in print character                            
       stq     lp|1,2                                                       
       eax2    2,2             set x2 to "move to" location.             
mo40:  arl     8              shift # word to move into position        
       eax0    256+512,al      and "or" in a and b bits for repeat       
          cana      -1,dl     test for partial 256 word block
          tnz       mo50      move it
mo60:     sbla      1,du      decrement number of full blocks
          tmi       0,1       exit
	odd
mo50:  rpdx    0,1             move last of words
       ldq     pr3|0,3                                                   
       stq     lp|0,2                                                        
       tra     mo60                                                        
"                              this routine compares one line            
"                              (8 words to print in memory dump)         
"                              with the next line and                    
"                              exits 1 when the lines are                
"                              not equal. when the lines are             
"                              equal it exits 2. if there                
"                              are only 2 lines (16 words) or            
"                              less to be processed this                 
"                              routine exits 0. when at                  
"                              least one comparison takes place,         
"                              comp20a contains the first loc.            
"                              of the second line of the                 
"                              current pair.                             
"                              upon entry:                               
"                              wdcnt contains # word still to            
"                                 be processed.                          
"                              x3 contains location for first line.      
comp:  lda     wdcnt      pick up number of words to process.       
comp10:cmpa    17,du           is there less than 17 words.              
       tnc     0,1             yes, exit 0.                              
       eax4    8,3             location of next line to x4.              
       eaa     -8,au           reduce count by 8.                        
       stx4    comp20a     save it for use later.                    
	odd
       rpd     8,1,tnz         compare lines for equality                
       ldq     pr3|0,3                                                        
       cmpq    pr3|0,4                                                        
       tnz     1,1             lines are not equal, exit 1.              
       tra     2,1             lines are equal, exit 2.                  
comp20:ldx3    comp20a           location of next line to x3.              
       tra     comp10                                               
"                                                                        
"                              write output routine                      
"                              this routine calls sysout                 
"                              entry point 1 for sysout on               
"                              p* or entry point 5 for                   
"                              writing to the execution report.          
"                              upon entry                                
"                                 x1 - used for return.                  
"                                 x2 - contains next avail loc in bufr.  
"                                 x4-contains a count that must be saved 
"                              upon exit                                 
"                                 x2-must contain next avail loc in lp|bufr 
"                                 x4-must be preserved throughout.       
write: stx1    writxa          convert to print line format and write
       ldx0    lp|bufad   dev # words for dcw                              
       stx0    wr10a           write routine
       sblx2   wr10a           dev words
       sxl2    lp|bufr-1                                               
       eaa     -1,2            now generate block control word.          
       ora     =o060000,dl    this is for output to execution report
       sta     lp|bufr
"                              develope address portion of dcw.          
       sblx0   lp|.crlal,6
       stx0    lp|bufr-1
       stx4    wr20a
       tsx1    gwrite          convert to print line format
       lxl1    bsn             set block serial number
       stx1    lp|pbufr
       aos     bsn
	lda   	desc2i	descriptor word for block
	arl	18	shift out size
	eaq	1,4	new size
	qls	2	times 4 for ascii pseudo char. count
	lls	18	shift back to a reg.
	sta	desc2	put in argument list
	call	<gcos_write_>|[block_ptr](arglst)
       ldx4    wr20a
writx: ldx1    writxa          restore x1
       ldx2    lp|bufad1
       tra     0,1                                                       
ckore: null                                                                     
       ldaq    lp|.stemp,5        get ic+i and dump parameter                          
       canq    =o400000,dl     do we want registers only                        
       tze     snpc       no-user wants core also                          
       tra     flush      go write registers and exit                      
snpc:  null                                                                     
       anq     =o777777077777 mask out panel/slew info                     
       ldx3    =o622020,du         dump label                                   
       lcx1    lp|.crlal,6
       ldx0    lp|.crlal,6
snps:  null                                                                     
       lda     lp|.salim,5        get slave memory limits                          
       ana     =o776,du        isolate # of words                               
       als     9                                                                
       sbla    1,dl                                                             
"*******                                                                        
" au is last avail mem location, al is all ones. this will override             
" any word count in the lower half of lp|.stemp+1 which is used in a               
" comparison very shortly.                                                      
       stx0    snpmsa      to absolutize starting address                   
       stx1    mo20a       relativize dump locations                        
       sxl3    mo30a       dump label                                       
       canq    -1,dl           is word count zero                               
       tnz     2,ic                                                             
       orq     -1,dl           yes-set count to max                             
       stq     lp|.stemp+1,5      save dump parameter                              
       cmpa    lp|.stemp+1,5      compare 1st address with last avail              
       trc     3,ic            ok                                               
       eax0    0                                                                
       stx0    lp|.stemp+1,5                                                       
       anq     -1,dl           isolate word count                               
       stq     lp|.stemp+2,5      save it                                          
       ldq     lp|.stemp+1,5      now we calculate last word                       
       qrl     18              to be dumped in lower half                       
       asq     lp|.stemp+2,5      of lp|.stemp+2                                      
       arl     18              last avail mem loc to al                         
       sbla    lp|.stemp+2,5      is last word to be dumped greater                
       tpl     3,ic            no-parameter ok                                  
       asa     lp|.stemp+1,5      clip word count in parameter                     
       aos     lp|.stemp+1,5      so as to fit in avail memory                     
       ldq     lp|.stemp+1,5      pick up parameter                                
snpms: adlq    snpmsa            absolutize                                       
       eaa     0                                                                
       tra     bp05                                                        
ckeis: null                                                                     
       ldq     lp|.creis          are there eis registers to be snapped            
       orsq    mo20a      yes - set print location to zero                       
       lcx1    mo20a                                                       
       stx1    mo20a      set print loc to zero                            
       orq     24,dl           # words in reg storage                           
       eax1    rcw                                                         
	odd
       rpd     7,1                                                              
       lda     0,1                                                              
       sta     lp|0,2                                                              
       lda     0,du                                                             
       epp3    lp|0
       tsx1    bp                                                          
       epp3    <gcos_ext_stat_>|[gcos_slave_area_seg],*
       lda     rcw                                                         
       era     7,du            set word count to one                            
       sta     lp|0,2                                                              
       lda     =o770300,du     slew code                                        
       sta     lp|1,2             store slew info in output buffer                 
       adlx2   2,du                                                             
       eax1    0                                                                
       stx1    prea                                                        
       tra     ckore                                                       
rcw:   vfd     18/6,o18/374                                                     
       bci     /*pointer registers & eis info*!2/
snp:   null                    ep1                                              
       lda     lp|.sstke       get ic&i of mme
       adla    1,du                                                             
       ana     =o777777777577  set indicator to slave
       sta     lp|icir                                                        
snp1:  null                                                                     
       lda     lp|icir                                                        
       sta     lp|.sstke
       ldq     lp|.crlal,6
       adlq    lp|icir         address of mme added to qu
       ldq     pr3|0,qu        pick up mme parameter
       staq    lp|.stemp,5                                                         
       ana     =o77,dl         isolate bits used by gecos                       
       ersa    lp|icir       turn them off for printing ir                    
       eax1    .sreg        absolute register pointer
snp7:  stx1    span4a      store register pointer                           
panel: null                                                                     
	lda	lp|.salim+1 	base address register
	sta	lp|icir+1 	store it  
       ldx1    =o770100,du                                                      
"***       q still contains dump parameter                                     
       canq    =o100000,dl     do we slew t-o-p                                 
       tnz     2,ic            yes                                              
       stx1    snp5a       no-slew one line                                 
       ldx2    lp|bufad1  pointer to output buffer
       lda     =o374,dl        device and media code
       stx2    span6a          save record header
       sta     lp|0,2
       adlx2   1,du            bump to first word
       lda     snp5a           slew code
       tsx1    span5+1
snp5:  vfd     o18/772000,18/0                                                  
"***       q still contains dump parameter                                     
       canq    =o200000,dl     do we dump registers                             
       tnz     ckore      no                                               
snpx:  lxl1    mod        is  this  ep3                              
       cmpx1   2,du
       tnz     snp4            no - don't dump even/odd pair
       tsx1    span                                                  
ein:   vfd     18/icir-.sreg+2,o12/2531,1/0,5/31
oin:   vfd     18/icir-.sreg+3,o12/4631,1/0,5/31
shift: oct     011717171717                                                     
       eax1    icr                                                         
       tra     span5                                                       
snp4:  tsx1    span                                                        
icr:   vfd     18/icir-.sreg,o12/3123,1/0,5/30
irr:   vfd     18/icir-.sreg,o12/3151,1/1,5/30
bar:   vfd     18/icir-.sreg+1,o12/2221,1/0,5/30
       vfd     18/6,o12/2551,1/0,5/12      er                                     
       vfd     18/4,o12/2151,1/0,5/31      ar                                     
       vfd     18/5,o12/5051,1/0,5/31      qr                                     
       vfd     18/7,o12/6351,1/0,5/7       tr                                     
       oct     770100000000                                                     
       tsx1    span                                                        
       vfd     18/0,o12/6700,1/0,5/30      x0                                     
       vfd     18/0,o12/6701,1/1,5/30      x1                                     
       vfd     18/1,o12/6702,1/0,5/30      x2                                     
       vfd     18/1,o12/6703,1/1,5/30      x3                                     
       vfd     18/2,o12/6704,1/0,5/30      x4                                     
       vfd     18/2,o12/6705,1/1,5/30      x5                                     
       vfd     18/3,o12/6706,1/0,5/30      x6                                     
       vfd     18/3,o12/6707,1/1,5/30      x7                                     
       oct     770300000000                                                     
       tra     ckeis                                                       
"                                                                        
"              panel dump                                                
"                                                                        
span:  lda     =o374,dl        put out device and media code.            
       stx2    span6a      save record header                        
       sta     lp|0,2                                                       
       adlx2   1,du            bump to first word                        
span5: lda     0,1             pick up parameter                         
       eax4    0,al            test if slew code only.                   
       tze     span1      yes, exit                                 
       cmpx4   =o171717,du                                                      
       tze     1,1                                                              
span4: eaq     0,au            no, pick up register contents
       adlq    span4a
       ldq     lp|0,qu
       ana     =o777700,dl     isolate bcd name                          
       cmpa    =o255100,dl      is this register er?                       
       tnz     2,ic           no-                                        
       qrl     1              yes-align it octally.                      
       ora     =o202017000020    format                                   
       sta     lp|0,2             store register name                       
       adlx2   1,du            bump storage                              
       canx4   1,du            test if bits 0-17                         
       tze     2,ic            are to be converted                       
       tsx3    scon2      yes, convert, store                       
       canx4   =o40,du         test if only 18-35 are convert            
       tze     2,ic            no                                        
       qls     18              yes fetch to high end                     
       anx4    =o36,du         isolate shift for counting                
       lda     =o011717171717     rest of characters and fill              
       arl     0,4             shift character control                   
       tsx3    scon3      convert rest of register                  
       adlx1   1,du            bump to next parameter                    
       tra     span5      back for next one                         
 span1:sta     lp|0,2             end of line, close record                 
       sblx2   span6a      record header                             
span6: ldx4    span6a          store record length to buffer
       stx2    lp|0,4
       adlx2   1,du            increment to point at next                
       adlx2   span6a                                                
       tra     1,1                                                       
"
scon2: lda     1,dl            convert register 36 bits                  
scon3: als     3               convert 36 or less                        
       lls     3                                                         
       tnc     -2,ic           keep going till 1 bit goes thru sign      
       sta     lp|0,2             store converted register                  
       adlx2   1,du                                                      
       tra     0,3             exit                                      
"*******************************************************************************
"*******************************************************************************
"***       ep 1: process mme gesnap                                            
"                calling sequence:                                              
"                  mme gesnap                                                   
"                  vfd 18/a,2/p,1/s,15/n                                        
"                  where a = starting location of snapshot                      
"                        p = panel indicator                                    
"                          00= dump panel, eis registers, and memory            
"                          01= no registers-memory only                         
"                          10= panel and eis registers only                     
"                        s = slew control                                       
"                          0= slew 1 line before snap                           
"                          1= slew t-o-p before snap                            
"                        n = number of words to be snapped                      
"                          0= all the prg's allocated memory starting           
"                             at location ' a ' will be snapped                 
"***                                                                           
gesnip:null                                                                     
       tra     xinit1      go initialize                                    
"***:       ep 2: used to snap the ssa/slave prefix of aborting programs        
"                au = absolute loc of lines to print                            
"                al = # of words to print                                       
"                qu = absolute loc to snap                                      
"                ql = # words to snap                                           
"                x1 = bias to apply to address for snap                         
"                x2 = 3 bcd characters to print with first                      
"                     line of output(m  ,s  , or   )                            
"***:                                                                           
binpt: null                                                                     
	push
	spriap	sp|0	save ap
	ldq	1,dl		change xfer to ep2
	stq	mod
	lda	ap|2,*		get arguments
	ldq	ap|4,*
          ldx1      ap|6,*
          lxl2      ap|6,*
       tra     xinit1      go initialize                                    
"                                                                               
"                                                                               
"***:       ep 3: used to snap registers and memory of aborting programs        
"                ar = ic+i to print                                             
"                qr = dump parameter-same as mme parameter                      
"                x1 = absolute pointer to register storage                      
"***:                                                                           
bord:  null                                                                     
	push
	spriap	sp|0	save ap
	ldq	2,dl		change xfer tp ep3
	stq	mod
	lda	ap|2,*	get arguments
	ldq	ap|4,*
	eax1	.sreg
xinit1:null
       ldx5    0,du		 lower address of slave program (simulated)
       ldx6    0,du		 program number (simulated)
       ldx7    0,du		 processor number (simulated)
       staq    lp|.stemp+8
       sreg    lp|savreg
pinit: null		initialize procedure
"
"	zero temporary storage
"
	stz	workt
	eaa	arglst		first temporary location
	sta	workt
	eaa 	workt		last temporary location
	sbla	workt		length of temporary storage area
	arl	8
	ldx2	0,du
	eax0	0,al
	rptx	0,1
	stz	arglst,2
"
"	construct argument list for call to gcos_write_
"
	lda    	=o000004000004	arg. count and code
	ldq	=o000004,du	descriptor count
	staq	sp|arglst
	epp2	<gcos_ext_stat_>|[prt]	fib pointer
	spri2	sp|arglst+2	 
	epp2	lp|pbufr		record pointer
	spri2	sp|arglst+4	 
	epp2	desc1		descriptor 1
	spri2	sp|arglst+6	 
	epp2	desc2		descriptor 2
	spri2	sp|arglst+8	 
	epp3	<gcos_ext_stat_>|[gcos_slave_area_seg],*	set pointer
          tra       mfalt
desc1:	oct	464000000000
desc2i:	oct   	524000002400
mfalt:    null
"			store bar & set .salim
	sbar	lp|.salim+1	save base address register setting
	ldx5	0,du	zero lower to be sure
	sxl5	lp|.salim+1
	lda	lp|.salim+1
          sta       lp|.salim
	arl	9
	eax5	lp|.salim,*au
	sxl5	lp|.salim
"			get ic & i
	epp2	<gcos_ext_stat_>|[mc]
	ldq	pr2|mc.scu.ilc_word
	adlq	1,dl	mark registers stored
	stq	lp|.sstke		save
"			get machine registers
	ldx2	0,du
	ldx3	0,du
	odd
	rpd	8,1
	ldq	pr2|mc.regs,2
	stq	lp|.sreg,3
"	get pointer registers
	ldx2	0,du
          ldx3      0,du
          odd
          rpd       16,1
          ldq       pr2|mc.prs,2
          stq       lp|eisbf,3
"	get eis info
          ldx2      0,du
          ldx3      16,du
          odd
          rpd       8,1
          ldq       pr2|mc.eis_info,2
          stq       lp|eisbf,3
"	get even and odd instructions
	ldq	pr2|scu.even_inst_word
	stq	lp|icir+2
	ldq	pr2|scu.odd_inst_word
	stq	lp|icir+3
"
xsnp1:	ldq	=o202020,dl
	stq	mo30a
	ldq	snp5
	stq	snp5a
       tra     syot
bp06:  null                                                                     
       sblx1   lp|savreg+5   create print bias                                
       stx1    mo20a       to be applied to print address                   
       sxl2    mo30a       save m/s label                                   
       tra     bp05                                                        
syot:  null                                                                     
       eaa     bufr
       sta     lp|bufad
       adla    1,du
       sta     lp|bufad1
       eaa     pbfnd
       sta     lp|endbuf
       eaa     bufr
       sta     lp|bufr-1
       eaa     eisbf
       sta     lp|.creis
xinix: null                                                                     
       lreg    lp|savreg
xfer:  lxl4    mod
       tra     *+1,4
       tra     snp        ep # 1                                           
       tra     bp06       ep # 2                                           
nopr:  nop     0,du                                                             
bord1: null                    ep # 3                                           
       staq    lp|.stemp,5        save ic+i:dump parameter                         
       sta     lp|icir       ic+i for printing                                
       stx1    span4a     save absolute register pointer                   
       eax1    0,au            instruction at ic is the odd                     
       cana    =o200,dl        is it master or slave                            
       tnz     contd      master                                     
       adlx1   lp|.crlal,6        slave absolutize it                        
       stx1    sizea                                                  
       lda     lp|.salim,5                                                   
       ana     =o776,du        program bound                              
       als     9                                                          
       sbla    1,du            last legal address                         
       adla    lp|.crlal,6        absolutize  it                             
size:  cmpa    sizea           is snap legal                              
       tnc     panel      no, dump panel only                        
contd: null
       lca     =o201,dl                                                   
       ansa    lp|.stemp,5        turn  off  master  mode  bit               
       tra     panel                                                       
"
"	This routine converts the dump record format to print line format
"	and moves therecords to the print buffer (pbufr).
"	This routine is a modification of the write and dump routines
"	of the GCOS SR1/G program GEOT.
"
gwrite:	null
	stx1	wtrsk	save return location
	eax2	bufr	set x2 for block control word
	eax4	pbufr	set x4 for expansion & print buffer
	stx4	talls	initialize output buffer (pbufr) tally
	eax0	bufr	set end of buffer limit
	adlx0	lp|0,2	number of words from record control word
	stx0	nwdpr
writb:	null
	lxl1	lp|0,2	x1 = lower of l.r. cont-wd
	cmpx1	=o060000,du
	tze	cdump	control for dump
	cmpx1	=o070374,du
	tze	dump	dump record
writr:	anx1	=o007700,du
	cmpx1	=o000300,du
	tze	writh	if m/c = 3, accept record
	tra	writc	ignore other m/c's
writh:	null
q.ar:	null
	lda	=o000777,du	mask out all but last nine bits of word
	ora	=o007777,dl	count, media code, and report from
	ansa	lp|0,2	GFRC control word
	ldx0	lp|0,2
	eaa	1,0	move logical record to print buffer
	als	10
	eax0	768,au
	eax3	0,2
	ldx4	talls
	odd
	rpdx	0,1
	lda	lp|0,3	from bufr
	sta	lp|0,4	to pbufr
	stx4	talls
writc:	adlx2	lp|0,2	advance x2 to last word of record
writq:	adlx2	1,du	advance x2 to next l.r.
	sxl2	nwdpr	save l.r. pointer in case of continue
	cmpx2	nwdpr
	trc	writd	skip if we finished buffer
	tra	writb	repeat if more
writd:	null
	eax0	pbufr	develop block length
	stx0	workt
	eax4	-1,4
	sblx4	workt
	sxl4	lp|pbufr	set length in block control word
	ldx1	wtrsk	return address
	ldx5	0,du
	ldx7	0,du
	tra	0,1	return to caller
cdump:	stz	lp|0,2	skip to first logical record
	stz	lp|0,4	zero output block control word
	adlx4	1,du	bump tally
	stx4	talls
	tra	writc
dump:	null
	ldx0	talls
	adlx0	20,du
	cmpx0	lp|endbuf
	trc	writd
dump4: null
dump0:	eax5	0,2	x5 = beginning of logical record
	ldq	lp|1,2	beginning address/line i.d.
	lda	lp|1,5	save address for next line
	ana	-1,du
	ora	=o202020,dl
	sta	lp|1,5
	lda	=o777777,du
	asa	lp|0,5	now only binary data wd count
	adlx2	2,du	first binary data word
dump1:	lda	21,du
	ora	=o374,dl	build control word for 21 word line
	sta	lp|0,4
	stx4	lrcw	save location of rcw
	adlx4	1,du
	ldx0	5,du	convert and store line address
	lda	0,du
	als	3
	lls	3
	sblx0	1,du
	tpl	*-3
	sta	lp|0,4
	adlx4	1,du
	orq	=o202020,dl	trailing blanks after line i.d.
	stq	lp|0,4	store line i.d. and 3 blanks
	adlx4	1,du
	ldx0	5,du	set shift count-1
	ldx1	lp|0,5	set x1 for words/line
	tze	dump2	none if length = 0
	cmpx1	8,du
	tnc	dump3	= exact if <= 8
	ldx1	8,du	= 8 if more in record
dump3:	ldx7	11,du
	ldq	lp|0,2
	als	3
	lls	3
	sblx0	1,du
	tpl	*+4
	ldx0	5,du
	sta	lp|0,4	store expanded word
	adlx4	1,du
	sblx7	1,du
	tpl	dump3+2
	adlx2	1,du
	sblx1	1,du
	tze	dump2	exit
	tmi	dump2	exit
	ldq	=o202000,du	add two trailing blanks after each expanded
	lls	6		data word
	sblx0	1,du
	lls	6
	sblx0	1,du
	tpl	dump3
	ldx0	5,du
	sta	lp|0,4
	adlx4	1,du
	tra	dump3
dump2:	null
	ldq	=o770101010101
	lls	6
	sblx0	1,du
	tpl	*-2
	sta	lp|0,4	store slew characters
	adlx4	1,du
	stx4	talls
dumpa:	null
	ldx1	lp|0,5	no. of binary words in l.r.
	sblx1	8,du
	tze	dump7	end of l.r.
	tmi	dump6	last line was partial
	stx1	lp|0,5
	ldq	lp|1,5
	adlq	8,du
	stq	lp|1,5
dumpb:	null
	eax0	0,4	next address in expansion buffer
	adlx0	20,du
	cmpx0	lp|endbuf
	tnc	dump1
	tra	writd	quick fix
dump6:	eax0	-1,4	correction to rcw for partial record
	sblx0	lrcw
	ldx7	lrcw
	stx0	lp|0,7	record length to rcw
dump7:	eax0	0,4
	adlx0	20,du
	cmpx0	lp|endbuf	has buffer been filled
	tnc	writq+1	no
	sxl2	nwdpr
	cmpx2	nwdpr	has 120 wd buffer been exhausted
	trc	writd	yes - write it out
	tra	writd	quick fix
txtnd:    null
"
"	Temporary
"
	tempd	arglst(5)
	temp	desc2
	temp	prea
	temp	op05a
	temp	op15a
	temp	op20a
	temp	op40a
	temp	mo10a
	temp	mo20a
	temp	mo30a
	temp	comp20a
	temp	wdcnt
	temp	wr10a
	temp	wr20a
	temp	writxa
	temp	snpmsa
	temp	snp5a
	temp	span4a
	temp	span6a
	temp	sizea
	temp	wtrsk
	temp	nwdpr
	temp	talls
	temp	lrcw
	temp	bsn
	temp	workt
	temp	mod
	use	intstat
	join	/link/intstat
icir:	bss	,4		ic+ir,bar,eibf,oibf
bufad:	bss	,1
bufad1:	bss	,1
endbuf:	bss 	,1
	odd
	bss	,1
bufr:	bss	,120
bufnd:    null
pbufr:	bss	,320
pbfnd:	null
eisbf:	bss	,24
	eight
savrgu:	bss	,8
savreg:	bss	,8
"
"	GCOS data base
"
	eight
	segdef	ssa
ssa:	null
	bss	.sstke,8
	eight
	bss	.sreg,8
	bss	.salim,2
	even
	bss	.stemp,10
.crlal:   dec       0
.creis:   bss      ,1
          even
.crmsz:   zero      0,500
 xend: null                                                              
       end




		    gcos_mme_syot_.pl1              09/09/83  1404.1rew 09/09/83  1007.7      102870



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


/*
   ********************************************************************************************
   ********************************************************************************************
   *
   *
   *	M M E   G E S Y O T
   *
   *
   *  MME GESYOT is used to transmit output records to the SYSOUT collector media
   *  for subsequent printing or punching.  SYSOUT collects these records, which may
   *  constitute several different reports for each concurrent activity.
   *
   *
   *	CALLING SEQUENCE
   *
   *      MME       GESYOT
   *      ZERO      FCB,0
   *	return
   *
   *  where FCB is the location (word 0) of the file control block for the file
   *  containing to records to be transmitted.  FCB+2 contains the DCW location.
   *  The DCW contains the buffer location and length.
   *
   *
   *  or to request backdoor file processing:
   *
   *	MME	GESYOT
   *	BCI	1,000FC
   *	BCI	1,AAAAAB
   *	denial return
   *	normal return
   *
   *  where FC is the file code of the users mass storage file;
   *  AAAAA is the banner string used to identify the output;
   *  and B is the type of output (1=punch,2=bcd print,3=ascii print).
   *
   *
   *      WRITTEN BY DICK SNYDER  NOVEMBER 30, 1970
   *      RETYPED BY T.CASEY DECEMBER 1972
   *      MODIFIED BY T.CASEY DECEMBER 1972, MAY 1974
   *	MODIFIED BY D. KAYDEN  MARCH 1974, APRIL 1974, AUGUST 1974
   *	Modified by M. R. Jordan,  April 1977
   *	Modified by S. C. Akers December 1981 Change \014 to %page
   *
   ********************************************************************************************
   ********************************************************************************************
*/


gcos_mme_syot_: proc (mcp, increment);
%page;
dcl  addr builtin;
dcl  addrel builtin;
dcl  bit36 bit (36) aligned based;
dcl  block_end fixed bin(24);
dcl  buffer_size fixed bin(24);
dcl  dcw_loc fixed bin(24);
dcl  dcw_ptr ptr;
dcl  execution_report_flag bit (1) aligned init ("0"b);
dcl  fc char (2);
dcl  fcb_loc fixed bin(24);
dcl  fcword_ptr ptr;
dcl  file_ptr ptr;
dcl  fixed builtin;
dcl  gcos_et_$bad_syot_buffer_ptr fixed bin(35) ext;
dcl  gcos_et_$bad_syot_media_code fixed bin(35) ext;
dcl  gcos_et_$bad_syot_status_ptr fixed bin(35) ext;
dcl  gcos_et_$no_reason fixed bin(35) ext;
dcl  gcos_et_$output_limit_exceeded fixed bin(35) ext;
dcl  gcos_et_$syot_alloc_err fixed bin(35) ext;
dcl  gcos_et_$syot_buffer_too_high fixed bin(35) ext;
dcl  gcos_et_$syot_rec_size_err fixed bin(35) ext;
dcl  gcos_mme_bort_$system entry options (variable);
dcl  gcos_write_$record_ptr ext entry (ptr, char (*), bit (8));
dcl  gseg_ptr ptr;
dcl  i fixed bin(24);
dcl  increment fixed bin(24);
dcl  last_file_ptr ptr;
dcl  null builtin;
dcl  rcw_loc fixed bin(24);
dcl  rcw_ptr ptr;
dcl  rec_len fixed bin(24);
dcl  record_string char (record_string_len) based (record_string_ptr);
dcl  record_string_len fixed bin(20);
dcl  record_string_ptr ptr;
dcl  storage_limit fixed bin(24);
dcl  substr builtin;
dcl  total_rec_len fixed bin(24);
%page;
dcl 1 dcw aligned based (dcw_ptr),
    2 address bit (18) unaligned,
    2 fill bit (6) unaligned,
    2 count bit (12) unaligned;


dcl 1 fcword aligned based (fcword_ptr),
    2 pad bit (24) unaligned,
    2 fc1 bit (6) unaligned,
    2 fc2 bit (6) unaligned;


dcl 1 rcw aligned based (rcw_ptr),
    2 record_len fixed bin(17) unaligned,
    2 processed bit (1) unaligned,
    2 control bit (5) unaligned,
    2 media_code bit (6) unaligned,
    2 report_code bit (6) unaligned;


dcl 1 word aligned based,
    2 upper bit (18) unaligned,
    2 lower bit (18) unaligned;
%page;
/*

   Make sure we have SYSOUT limits left.

*/


	if gcos_ext_stat_$sysout_lines > gcos_ext_stat_$sysout_limit then do;
	     call gcos_mme_bort_$system (gcos_et_$output_limit_exceeded);
	     gcos_ext_stat_$sysout_limit = gcos_ext_stat_$sysout_limit+10000;
	end;


/*

   Now that we know we have the SYSOUT limits to proceed,
   initialize some needed data items and continue.

*/


	increment = 1;
	gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg;
	storage_limit = gcos_ext_stat_$storage_limit;
	scup = addr (mc.scu);


/*

   Get the FCB location from the first word after the MME.  If the FCB location is
   zero, this is a request for a "backdoor" file print.  We do not support this, so
   return the status to say no backdoor file allocated.

*/


	fcb_loc = fixed (addrel (gseg_ptr, fixed (scu.ilc, 18)+1) -> word.upper, 18);
	if fcb_loc = 0 then do;
	     mc.a = (33)"0"b || "101"b;
	     increment = 2;
	     return;
	end;


/*

   Validate the location of word -3 of the FCB.  If good then zero the
   word, as it is used later for a status return;


*/


	if fcb_loc - 3 >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_syot_status_ptr,
	     "MME GESYOT status return word is outside slave limits.");
	addrel (gseg_ptr, fcb_loc-3) -> bit36 = (36)"0"b;


/*

   Now we must get the file code from the FCB and look it up in the file code
   table.  If the file code is "00" or "  ", however, we know it is to go on the
   execution report.  Also, if the file code is not found in the file code table
   the output is to be put on the execution report.

*/


	if fcb_loc-4 >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$no_reason, "MME GESYOT file code word is outside slave limits.");
	fcword_ptr = addrel (gseg_ptr, fcb_loc-4);
	substr (fc, 1, 1) = xlate (fixed (fc1, 6));
	substr (fc, 2, 1) = xlate (fixed (fc2, 6));


	if fc ^= "00" & fc ^= "  " then do;

	     do i = 1 to hbound (save_data.fibs, 1);
		if fct.filecode (i) = fc then do;
		     if fct.sysout (i) & ^fct.dac (i) then go to hit;
		     call gcos_mme_bort_$system (gcos_et_$syot_alloc_err,
			"MME GESYOT file ^a is not assigned to SYSOUT.", fc);
		end;
	     end;

	end;


	execution_report_flag = "1"b;


/*

   Verify the locations of the DCW word, and buffer.  Also check the buffer size.
   If the buffer is empty (size = 0) then don't waste any time on this request.

*/


hit: ;

	dcw_loc = fixed (addrel (gseg_ptr, fcb_loc+2) -> word.lower, 18);
	if dcw_loc >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$bad_syot_buffer_ptr, "MME GESYOT buffer is outside slave limits.");
	dcw_ptr = addrel (gseg_ptr, dcw_loc);


	buffer_size = fixed (dcw.count, 12);
	if buffer_size > 320 then
	     call gcos_mme_bort_$system (gcos_et_$syot_rec_size_err,
	     "MME GESYOT buffer length is greater than 320 words.");
	if buffer_size = 0 then go to return_stat;


	block_end = fixed (dcw.address, 18) + buffer_size;
	if block_end >= storage_limit then
	     call gcos_mme_bort_$system (gcos_et_$syot_buffer_too_high,
	     "MME GESYOT buffer not entirely within slave limits.");


/*

   Now we can process the data buffer passed by the slave job.  But first
   let's initialize some data items.

*/

	last_file_ptr = null;


/*

   NOTE:  The GCOS SYSOUT module assumes that the buffer is located
   two words beyond the DCW word.  This assumption is duplicated in
   the following statement.

*/


	rcw_loc = dcw_loc + 2 + 2;


/*

   Position to the next record in the buffer and verify it's length.

*/


next: ;

	rcw_ptr = addrel (gseg_ptr, rcw_loc);		/* move pointer to rcw of next record */
	rec_len = rcw.record_len;
	if rec_len > 320 then
	     call gcos_mme_bort_$system (gcos_et_$syot_rec_size_err,
	     "MME GESYOT Record Control Word (RCW) specifies record length greater than 320 words.");


/*

   Now see if the record is to be processed.  Check the bit that tells us
   it has already been processed and check for zero media code or record
   length.

*/


	if rcw.processed | rcw.media_code = "00"b3 | rec_len = 0 then do;
	     call write;
	     last_file_ptr = null;
	     go to bump;
	end;


/*

   Process the special media codes for COBOL-74.  These records have some information in the
   first two characters that must be done away with.  These are media codes 9 and 13.

*/


	if rcw.media_code = "11"b3 then do;
	     substr (addrel (rcw_ptr, 1) -> bit36, 1, 12) = "1717"b3;
	     rcw.media_code = "03"b3;
	end;
	else if rcw.media_code = "15"b3 then do;
	     substr (addrel (rcw_ptr, 1) -> bit36, 1, 18) = "177177"b3;
	     rcw.media_code = "07"b3;
	end;


/*

   If this data is to be put on the execution report, then do so.  Only one record will
   be processed from the buffer.

*/


	if execution_report_flag then do;
	     last_file_ptr = gcos_ext_stat_$er;
	     record_string_ptr = rcw_ptr;
	     total_rec_len = rec_len + 1;
	     call write;
	     go to return_stat;
	end;


/*

   Verify the media code of the record.  It must be print or punch.
   If a bad media code is encountered, abort the slave job.  Print
   media codes are 3 and 7, punch media codes are 1, 2, and 10.

*/


	if fixed (rcw.media_code, 6, 0) < 11 then goto media (fixed (rcw.media_code, 6, 0));
	else goto bad_media;


media (1): ;
media (2): ;
media (10): ;

	file_ptr = gcos_ext_stat_$pch;
	goto media_ok;


media (3): ;
media (7): ;

	file_ptr = gcos_ext_stat_$prt;
	goto media_ok;


media (0): ;
media (4): ;
media (5): ;
media (6): ;
media (8): ;
media (9): ;
bad_media: ;

	call gcos_mme_bort_$system (gcos_et_$bad_syot_media_code, "MME GESYOT media code not print or punch.");


media_ok: ;

/*

   If this record has the same destination as the last record, then simply
   add it to the accumulated length.  If not, write it and start a new
   accumulation.  Make sure we count the lines/cards produced to enforce
   SYSOUT limits.

*/


	if last_file_ptr = file_ptr then total_rec_len = total_rec_len+rec_len+1;
	else do;
	     call write;
	     last_file_ptr = file_ptr;
	     record_string_ptr = rcw_ptr;
	     total_rec_len = rec_len + 1;
	end;
	gcos_ext_stat_$sysout_lines = gcos_ext_stat_$sysout_lines + 1;


/*

   After marking the record as processed, calculate the new RCW location and see
   if we are, finished with the current buffer.  If we are, make sure all records
   have been written to the collection file.

*/


bump: ;

	rcw.processed = "1"b;
	rcw_loc = rcw_loc + rec_len + 1;
	if rcw_loc < block_end then go to next;
	call write;


/*

   At this point we are ready to return to the slave job.  Make sure we mark
   the status work to show a termination status with no errors.

*/


return_stat: ;

	addrel (gseg_ptr, fcb_loc-3) -> bit36 = "400000000000"b3;

	return;
%page;
/*

   The write procedure acctually writes the accumulated records to the proper collection
   file for later processing by gcos_sysprint or gcos_syspunch.

*/


write: 	proc;


/*

   Check first to see if we have anything to write...
   If not, then simply exit.

*/


	if last_file_ptr ^= null
	then do;

	     record_string_len = total_rec_len * 4;
	     call gcos_write_$record_ptr (last_file_ptr, record_string, "0"b);
	     end;

	return;


end write;
%page;
%include gcos_ext_stat_;
%page;
%page;
%include gcos_xlate_bcd_ascii_;


     end gcos_mme_syot_;




		    gcos_mme_time_.pl1              09/09/83  1404.1rew 09/09/83  1007.7       27999



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

/* *****************************************************************************************
   *******************************************************************************************
   *
   *
   *	M M E  G E T I M E
   *
   *
   *  MME GETIME provides the requesting program with the date and time of day. Results
   *  are returned in the following manner:
   *
   *	C(A) 0-11		month (BCD digits)
   *	C(A) 12-23	day (BCD)
   *	C(A) 24-35	year (BCD)
   *
   *	C(Q) 0-35		time of day (1/64 milliseconds past midnight)
   *
   *	Author: DICK SNYDER NOVEMBER 10,1970
   *	Change: T. CASEY SEPTEMBER 1973 TO RETURN LOCAL TIME INSTEAD OF E.S.T.
   *	Change: Dave Ward	05/29/81 appropiate FP precision.
   *
   *******************************************************************************************
   ***************************************************************************************** */
	increment = 0;				/* no param words to skip */
	time = clock ();				/* get current time */

	call date_time_ (time, date_time);		/* get ascii date and time */


/* 	Build string of ascii date with out the slashes and convert to bcd		 */

	substr (temp, 1, 2) = substr (date_time, 1, 2);	/* get month */
	substr (temp, 3, 2) = substr (date_time, 4, 2);	/* get day */
	substr (temp, 5, 2) = substr (date_time, 7, 2);	/* get year */

	call gcos_cv_ascii_gebcd_ (addr (temp), 6, addr (mc.regs.a), 6); /* put bcd in user's a reg */

	call decode_clock_value_ (time, m, d, y, i, w, z); /* just to get time since midnight local time,
						   in microseconds, into i */

	i = divide (i, 1000, 71, 0);			/* convert to msecs */
	addr (mc.regs.q) -> mc64ths = i*64;		/* convert to 64ths of a msec */
	return;
%page;
/*   Variables for gcos_mme_time_:		 */
/*   IDENTIFIER		ATTRIBUTES	 */
dcl  clock                    builtin;
dcl  d                        fixed bin(24);
dcl  date_time                char (24)	/* ascii date and time */;
dcl  date_time_               ext entry (fixed bin(71), char (*));
dcl  decode_clock_value_      entry (fixed bin(71), fixed bin(24), fixed bin(24), fixed bin(24), fixed bin(71), fixed bin(24), char(3));
dcl  gcos_cv_ascii_gebcd_     ext entry (pointer, fixed bin(24), pointer, fixed bin);
dcl  i                        fixed bin(71)	/* temp */;
dcl  increment                fixed bin(24)/* no of param words to skip */;
dcl  m                        fixed bin(24);
dcl  mc64ths                  fixed bin(35)based;
dcl  temp                     char (6) aligned	/* temp */;
dcl  time                     fixed bin(71)	/* time in microseconds */;
dcl  w                        fixed bin(24);
dcl  y                        fixed bin(24);
dcl  z                        char (3);
%page;
%include mc;
     end gcos_mme_time_;




		    gcos_mme_user_.pl1              09/09/83  1404.1rew 09/09/83  1007.7       19449



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




gcos_mme_user_: proc (mcp, increment);

dcl  code fixed bin(35);
dcl  gcos_et_$unimp_mme fixed bin(35) ext;
dcl  gcos_mme_bort_$system entry options (variable);
dcl  handler_known bit (1) aligned int static init ("0"b);
dcl  hcs_$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin(35));
dcl  increment fixed bin(24);						/* No. of args. passed to this mme. */
dcl  mme_geuser ext entry (ptr, fixed bin(24));						/* name of user's handler is different from that of this proc */
dcl  null builtin;
dcl  ret_ptr ptr ;

	if handler_known then do;			/* if he terminated it after it was previously initiated
						   in this process, he is sophisticated enough to handle the
						   linkage fault without our help */

call_handler:  call mme_geuser (mcp, increment);
	     return;
	end;

	ret_ptr = null;				/* try to find mme_geuser in the search rules, to avoid
						   giving the average gcos user a linkage fault */
	call hcs_$make_ptr (null, "mme_geuser", "", ret_ptr, code);
						/* code might be error_table_$segknown , so check pointer instead */
	if ret_ptr ^= null then do;
	     handler_known = "1"b;			/*  don't come this way again, in this process */
	     goto call_handler;
	end;

	if gcos_ext_stat_$save_data.debug then				/* if he said "-db" he is no average user */
	     goto call_handler;			/* so go give him a linkage fault */
						/* fall thru to tell user about missing handler, and abort job */

	increment = 0;				/* Indicate no args. passed to this mme. */

	call gcos_mme_bort_$system (gcos_et_$unimp_mme, "No procedure supplied for MME GEUSER.");

	return;

%include gcos_ext_stat_;


     end gcos_mme_user_;




		    gcos_mme_wake_.pl1              09/09/83  1404.1rew 09/09/83  1007.7        7578



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


gcos_mme_wake_: proc (mcp, increment);


/*	Handler for the gewake mme. It does nothing but return to the caller. */

dcl  mcp ptr;						/* Machine conditions ptr. */
dcl  increment fixed;						/* No. of args. passed to this mme. */

	increment = 0;				/* Indicate no args. passed to this mme. */

	return;

     end gcos_mme_wake_;

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