



		    nstd_.alm                       11/04/82  1932.4rew 11/04/82  1632.5       11043



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

"	"	"	"	"	"	"	"	"	"
"
"	This is the I/O switch transfer vector for the nstd_dim outer module
"
"	"	"	"	"	"	"	"	"	"

	entry	nstd_module
nstd_module:
	tra	*+1,6		go to proper transfer instruction

	tra	<nstd_dim>|[nstd_attach]
	tra	<nstd_dim>|[nstd_detach]
	tra	<nstd_dim>|[nstd_read]
	tra	<nstd_dim>|[nstd_write]
	tra	<ios_>|[no_entry]
	tra	<nstd_dim>|[nstd_order]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<nstd_dim>|[nstd_getsize]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<nstd_dim>|[nstd_cmode]
	tra 	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]

	end




		    nstd_dim.pl1                    11/04/82  1932.4rew 11/04/82  1606.1      289782



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



/* The non-standard tape DIM.  coded by MAP, 8/70.  Liberally cribbed from NIM */
/* Modified by Dick Snyder 2/71 to allow a mode request of "rw"  or blank (read/write) */
/* Also changed to allow order request "err_count" for on-line T&D's and to add	 */
/* stream data block as specified in MCB 638		   */
/* Modified by Mike Grady to add fixed_record_length order call 11/03/72 */
/* Modified on 09/19/77 by R.J.C. Kissel to call tape_nstd_ to get the max buffer size. */
/* Modified on 02/15/78 by M. R. Jordan to remove the call to tape_nstd_ and add the ,block= and ,blk= strings. */
/* Modified on 04/28/78 by Michael R. Jordan to _n_o_t unload tapes. */
/* Modified on 08/09/78 by Bob May to add TEMPORARY GCOS facility for large buffers .
   This interface will disappear when the GCOS simulator moves to tape_ioi_. */
/* Modified 4/79 by R.J.C. Kissel to add 6250 bpi and data security erase capability. */
/* Modified on 05/10/79 by C. D. Tavares to add name canonicalization support */
/* Modified sometime in 1981 by M. R. Jordan to fix some bugs */

/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
nstd_dim:
     proc;
	return;					/* Shouldn't be called here */

dcl      (name1, type, name2, rw, order)
			  char (*);
dcl      st		  bit (72);
dcl      (sdb_ptr, wksp, ap)	  ptr;
dcl      (
         error_table_$no_backspace,
         error_table_$undefined_order_request,
         error_table_$bad_mode,
         error_table_$buffer_big,
         error_table_$bad_arg,
         error_table_$ionmat
         )		  ext fixed bin (35);
dcl      code		  fixed bin (35);
dcl      setbit		  bit (18),
         rdycmd		  fixed bin (6),
         fix_sw		  bit (1),
         attach_sw		  bit (1),
         j		  fixed bin;
dcl      (off, nelem, nelemt, ring, count, i)
			  fixed bin (17);
dcl      density		  fixed bin;
dcl      temp_name		  char (32);
dcl      1 wait_list,
	 2 n		  fixed bin (17),
	 2 chn		  fixed bin (71);
dcl      1 message,
	 2 channel	  fixed bin (71),
	 2 mess		  fixed bin (71),
	 2 sender		  bit (36),
	 2 origin,
	   3 dersig	  bit (18) unaligned,
	   3 ring		  bit (18) unaligned,
	 2 channel_index	  fixed bin (17);
dcl      dum		  (tseg.buffer_size (1)) fixed bin (35) based;
dcl      sst		  bit (18) aligned based;
dcl      ord		  char (32);

dcl      (addr, addrel, bit, length, null, ptr, rel, rtrim, search, substr, unspec)
			  builtin;
dcl      (bin, bool, divide, index, max, string, lbound, hbound)
			  builtin;

dcl      hcs_$make_seg	  entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin (35));

dcl      (
         tdcm_$tdcm_attach,
         tdcm_$tdcm_detach,
         tdcm_$tdcm_set_signal,
         tdcm_$tdcm_reset_signal,
         tdcm_$tdcm_iocall
         )		  entry (ptr, fixed bin (35)),
         tdcm_$tdcm_set_buf_size
			  entry (ptr, fixed bin, fixed bin (35)),
         tdcm_$tdcm_message	  entry (ptr, char (*), fixed bin, fixed bin (35));
dcl      cv_dec_check_	  entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl      ipc_$create_ev_chn	  ext entry (fixed bin (71), fixed bin (35));
dcl      hcs_$delentry_seg	  entry (ptr, fixed bin (35));
dcl      (
         ioa_,
         ioa_$rsnnl
         )		  entry options (variable);
dcl      ipc_$block		  entry (ptr, ptr, fixed bin (35));
dcl      instance		  fixed bin (35) int static init (1);
						/* used to generate sdb seg name */
dcl      segnm		  char (32);		/* name of stream data block */
dcl      sav_stat		  bit (36);
dcl      newerr		  fixed bin based (ap);

dcl      cleanup		  condition;		/* cleanup handler for interrupted attachment */

dcl      1 hsbc		  aligned,		/* tape status word format */
	 2 padx		  bit (2) unaligned,
	 2 maj		  bit (4) unaligned,
	 2 min		  bit (6) unaligned,
	 2 pady		  bit (24);

dcl      1 stream_data_block	  aligned based (sdb_ptr),
	 2 outer_module_name  char (32) aligned,
	 2 device_name_list	  ptr,
	 2 tseg_ptr	  ptr,
	 2 retry_cnt	  fixed bin,		/* no. of times to retry i/o */
	 2 some_bits	  aligned,
	   3 no_data_sw	  bit (1) unaligned,	/* 1 = start next blocked i/o */
	   3 fix_rec	  bit (1) unaligned,	/* 1 = fixed record i/o (buffered i/o) */
	   3 eot_bit	  bit (1) unaligned,	/* 1 = end of tape was reached */
	   3 eof_bit	  bit (1) unaligned,	/* 1 = end of file was reached */
	   3 rewind	  bit (1) unaligned,	/* 1 = last tape order was rewind */
	   3 unload	  bit (1) unaligned,	/* 1 = last tape order was unload */
	   3 fix_init	  bit (1) unaligned,	/* initial io for fixed length rec. */
	   3 spare_bits	  bit (29) unaligned,
	 2 max_rec_len	  fixed bin,		/* maximum record length in words */
	 2 fix_rec_size	  fixed bin,		/* length of records for fixed record length option */
	 2 buf_mask	  bit (18),		/* used to get index to block of buffers */
	 2 buf_count	  fixed bin,		/* no. of buffers in data transfer */
	 2 data_count	  fixed bin,		/* no. of buffers read/written  */
	 2 bufchk		  fixed bin,		/* index of current buffer in block  (0 to 2*buffer_count-1) */
	 2 device_name,
	   3 next_device_ptr  ptr,
	   3 name_size	  fixed bin (17),
	   3 name		  char (256) aligned,
	 2 tsegarea	  fixed bin (71);


dcl      1 ord_tab		  (18) aligned internal static,
						/* lookup table for simple order types */
	 2 oname		  char (32) aligned
			  init (/* orders */ "back", "eof", "reset_status", "forward_record", "forward_file",
						/* NOTE: order of these orders */
			  "backspace_file", "erase", "high", "low", "protect", "unload", "rewind",
						/* must be maintained */
			  "d200", "d556", "d800", "d1600", "d6250", "data_security_erase"),
						/* since there is code which is */
						/* dependent on it */
	 2 cmd		  bit (6) aligned
			  init (/* actual orders */ "46"b3, "55"b3, "40"b3, "44"b3, "45"b3, "47"b3, "54"b3, "60"b3,
			  "61"b3, "62"b3, "72"b3, "70"b3, "64"b3, "61"b3, "60"b3, "65"b3, "41"b3, "73"b3);


%include tseg;

/**/

set_block_size:
     entry (a_user_block_size, a_code);

/* Temporary entry to allow users of the GCOS simulators to tell nstd_ to use large buffers.
   Bob May, 08/07/78 */

dcl      a_user_block_size	  fixed bin,		/* size in words */
         a_code		  fixed bin (35);

dcl      user_block_size	  fixed bin int static;	/* override size */

dcl      user_block_size_sw	  bit (1) int static init ("0"b);
						/* to keep track of buffer needs */

	if a_user_block_size ^= 0 then do;
	     user_block_size = a_user_block_size;
	     user_block_size_sw = "1"b;
	end;
	else user_block_size_sw = "0"b;		/* reset function */

	a_code = 0;				/* assume its ok for now. we checked it before */
	return;

/* End of set_block_size Entry */



/* 	A   T   T   A   C   H      E   N   T   R   Y      P   O   I   N   T	 */





nstd_attach:
     entry (name1, type, name2, rw, st, sdb_ptr);

	attach_sw = "0"b;
	if sdb_ptr ^= null then do;			/* check for multiple attachments */

	     substr (st, 1, 36) = unspec (error_table_$ionmat);
	     return;				/* if multiple attachment return error code */
	end;

	on cleanup call clear_attach;			/* cleanup in case user quits while attaching */

/* 	Create name for segment to hold stream data block. Name consists of */
/* 	"nstd_sdbN_" where N is a number which increments by one for */
/* 	each attach call.					 */


	call ioa_$rsnnl ("nstd_sdb^d_", segnm, code, instance);
	instance = instance + 1;			/* bump instance */

	call hcs_$make_seg ("", segnm, "", 01011b, sdb_ptr, code);
						/* Make an sdb */
	if sdb_ptr = null then do;			/* failure? */
BAD_OUT:
	     substr (st, 1, 36) = unspec (code);
	     substr (st, 52, 1) = "1"b;		/* Send back a detach bit */
	     return;
	end;

	outer_module_name = "nstd_";			/* fill in stream data block */
	device_name_list = addr (device_name);
	next_device_ptr = null;			/* only one device */
	name_size = 32;
	name = name2;				/* put in tape name */
	tseg_ptr = addr (tsegarea);			/* set up tseg for DCM use */
	tsegp = tseg_ptr;				/* copy tseg pointer for better code */
	tseg.version_num = tseg_version_2;

	stream_data_block.retry_cnt = 10;		/* set default error retry count */
	fix_init = "0"b;				/* initialization for fixed rec. length */

/* initialize tseg */

	call ipc_$create_ev_chn (tseg.ev_chan, code);	/* create event channel for the */
	if code ^= 0 then
	     go to BAD_ATTACH;			/* signalling of special interrupts */

	tseg.sync = 1;				/* i/o will be synchronous */
	tseg.get_size = 1;				/* we want DCM to tell us record sizes */
	tseg.buffer_offset = 0;			/* start at front of buffer */
	tseg.bufferptr (1) = bin (rel (addr (tseg.buffer (1))), 17);
						/* set up first buffer ptr */
	do i = 1 to 12;
	     tseg.mode (i) = 0;			/* default mode is binary * */
	end;

/* Hook up the dcm */

	if (rw ^= "r" & rw ^= "w" & rw ^= "rw" & rw ^= "") then do;
	     code = error_table_$bad_mode;		/* set error code */
	     go to BAD_ATTACH;
	end;


	if rw = "r" then
	     ring, tseg.write_sw = 0;			/* mode read */
	else ring, tseg.write_sw = 1;			/* mode write */

	if index (name2, ",7track") ^= 0 then		/* set indicator to 7 or 9 track drive type */
	     tseg.tracks = 1;
	else tseg.tracks = 0;

	call tdcm_$tdcm_attach (tsegp, code);		/* ask DCM to grab a drive */
	if code ^= 0 then
	     go to BAD_ATTACH;			/* DCM gripped */
	attach_sw = "1"b;

	max_rec_len = 2800;
	i = index (name2, ",block=") + 7;
	if i <= 7 then do;
	     i = index (name2, ",blk=") + 5;
	     if i <= 5 then
		i = index (name2, ",bk=") + 4;
	end;
	if i > 4 then do;
	     if i > length (name2) then do;
		code = error_table_$bad_arg;
		goto BAD_ATTACH;
	     end;
	     j = search (substr (name2, i), ", ") - 1;
	     if j < 0 then
		j = length (name2) - i + 1;
	     max_rec_len = cv_dec_check_ (substr (name2, i, j), code);
	     if code ^= 0 then do;
		code = error_table_$bad_arg;
		goto BAD_ATTACH;
	     end;
	end;

/* do the special block function only when block=nnnn not specified for individual attach */

	else if user_block_size_sw then
	     max_rec_len = max (user_block_size, max_rec_len);
						/* don't go too small */

	call tdcm_$tdcm_set_buf_size (tsegp, max_rec_len, code);
	if code ^= 0 then
	     goto BAD_ATTACH;

	density = 800;
	tseg.density = "00100"b;

	i = index (name2, ",density=") + 9;
	if i <= 9 then
	     i = index (name2, ",den=") + 5;
	if i > 5 then do;
	     if i > length (name2) then do;
		code = error_table_$bad_arg;
		goto BAD_ATTACH;
	     end;
	     j = search (substr (name2, i), ", ") - 1;
	     if j < 0 then
		j = length (name2) - i + 1;
	     density = cv_dec_check_ (substr (name2, i, j), code);
	     if code ^= 0 then do;
		code = error_table_$bad_arg;
		goto BAD_ATTACH;
	     end;
	end;

	if density = 1600 then do;
	     rdycmd = bin ("65"b3);
	     tseg.density = "00010"b;
	end;

	else if density = 800 then do;
	     rdycmd = bin ("60"b3);
	     tseg.density = "00100"b;
	end;

	else if density = 556 then do;
	     rdycmd = bin ("61"b3);
	     tseg.density = "01000"b;
	end;

	else if density = 200 then do;
	     rdycmd = bin ("64"b3);
	     tseg.density = "10000"b;
	end;

	else if density = 6250 then do;
	     rdycmd = bin ("41"b3);
	     tseg.density = "00001"b;
	end;

	else do;
	     code = error_table_$bad_arg;
	     goto BAD_ATTACH;
	end;

	call tdcm_$tdcm_set_signal (tsegp, code);	/* enable special interrupt so we */
						/* know when operator mounts tape */
	if code ^= 0 then
	     go to BAD_ATTACH;			/* error */

	call ioa_ ("Tape ^a will be mounted with ^[a^;no^] write ring.", name, (ring = 1));

	temp_name = name;
	call tdcm_$tdcm_message (tsegp, temp_name, ring, code);
						/* Send mount message */
	if code ^= 0 then
	     go to BAD_ATTACH;			/* error */
						/* and send info to user */

	name = temp_name;
	name_size = length (rtrim (name));

/* Do readiness checking/waiting */


	call wait;				/* wait for operator */
	if code ^= 0 then
	     go to BAD_ATTACH;			/* trouble?? */
	call ioa_ ("Tape ^a mounted on drive ^a with ^[a^;no^] write ring.", name, tseg.drive_name, (ring = 1));
	return;					/* and go home */


BAD_ATTACH:
	substr (st, 52, 1) = "1"b;			/* detach bit */
	substr (st, 1, 36) = unspec (code);
	call clear_attach;				/* release drive and stream data block */
	return;

DCM_ERR:
	substr (st, 1, 36) = unspec (code);		/* standard code was returned */
	return;					/* So there */





/* 	R   E   A   D      E   N   T   R   Y      P   O   I   N   T		 */





nstd_read:
     entry (sdb_ptr, wksp, off, nelem, nelemt, st);

	nelemt = 0;				/* Clear it, right away, in case of errors or EOF */
	call check_rewind;
	count = stream_data_block.retry_cnt;		/* Initialize for possible retries */

	if fix_rec then do;

	     if fix_init then do;
		no_data_sw = "1"b;			/* no data yet */
		tseg.buffer_offset = 0;		/* put data in first set of buffs */
		tseg.buffer_count = buf_count;	/* no. of buffers to read */
		tseg.write_sw = 0;			/* set io to read */
		call tdcm_$tdcm_iocall (tsegp, code);	/* start read */
		fix_init = "0"b;
	     end;

	     if tseg.write_sw = 0 then
		go to fix_read;			/* continue reading */
	     call reset_fix_rec;			/* finish write  */
	end;

	tseg.write_sw = 0;				/* set to read */
	if nelem > max_rec_len then
	     go to BAD_BUF;

RLOOP:
	tseg.buffer_size (1) = nelem;			/* We'll read no more than we can, and maybe less */
	tseg.buffer_count = 1;
	tseg.command_count = 0;			/* This is what makes the dcm know it's a read/write request */
	tseg.buffer_offset = 0;			/* use the 1st buffer */

	call tdcm_$tdcm_iocall (tsegp, code);		/* Go get 'em */
	if code ^= 0 then
	     go to DCM_ERR;

	if tseg.completion_status = 1 then do;		/* Good read */

	     call move (1);				/* move data to user's buffer */

GOOD_OUT:						/* Common successful return point */
	     substr (st, 1, 36) = "0"b;
	     nelemt = tseg.buffer_size (1);
	     return;
	end;

/* Here on bad completion status--retry if not done with count */

RECOV:
	if substr (tseg.hardware_status, 3, 4) = "0100"b then
	     go to BAD_ORD;				/* If it's EOF send it back */
	if substr (tseg.hardware_status, 3, 4) = "0011"b	/* data alert */
	then if (substr (tseg.hardware_status, 7, 6) & "100010"b) = "000010"b then
		go to BAD_ORD;			/* don't try any more--will still get blank tape */

RECOV1:
	if count > 0 then do;			/* More re-tries left */

	     count = count - 1;			/* decrement error retry cnt */
	     tseg.command_count = 1;			/* we'll issue one */
	     tseg.command_queue (1) = 100110b;		/* backspace order */
	     call tdcm_$tdcm_iocall (tsegp, code);	/* let DCM do it */
	     if code ^= 0 then
		go to DCM_ERR;			/* error */
	     if tseg.completion_status ^= 1 then do;	/* error on bksp */
		substr (st, 1, 36) = unspec (error_table_$no_backspace);
						/* couldn't bksp due */
		return;				/* to being on bot */
	     end;
	     if tseg.write_sw = 1 then
		go to WLOOP;			/* retry write */
	     go to RLOOP;				/* retry read */

	end;

	else do;					/* can't recover.  */

	     nelemt = tseg.buffer_size (1);		/* amount of buffer actually sent */
	     if tseg.write_sw = 0 then
		call move (1);			/* put data read in user's buffer */

	end;

/* Here when re-tries or order codes fail */

BAD_ORD:
	substr (st, 1, 1) = "1"b;			/* set high order bit of */
						/* status to indicate that actual */
						/* tape major and minor status is being returned */
						/* and not a standard error code */
	if stream_data_block.unload then
	     stream_data_block.rewind = "0"b;		/* don't wait for special */
						/* interrupt after rewind if tape unloaded */
	substr (st, 25, 12) = tseg.hardware_status;	/* return major/minor status */
	return;


fix_read:						/* proc to do quick reads for fixed recs */
	fix_sw = "0"b;				/* indicate read */

fix_com:
	if nelem ^= fix_rec_size then
	     go to BAD_BUF;				/* must ask for 1 buff at a time */

	if no_data_sw then do;			/* any data left ? */

	     if eof_bit then do;			/* did we get eof last time ? */
		substr (st, 1, 1) = "1"b;		/* yes reflect status */
		substr (st, 25, 12) = substr (sav_stat, 1, 12);
						/* put in saved eof code (9 or 7) */
		eof_bit = "0"b;
		fix_init = "1"b;			/* restart read */
		return;				/* done it */
	     end;

	     if eot_bit then do;			/* have we already said eot ? */
		substr (st, 1, 1) = "1"b;		/* yes, but do it again */
		substr (st, 25, 12) = "000011100000"b;	/* eot status */
		return;				/* maybe we can convince him */
	     end;

	     bufchk = tseg.buffer_offset;		/* return data starting with this buff */
	     setbit = bit (bin (tseg.buffer_offset, 18), 18);
						/* switch buffers with x-or */
restart:
	     setbit = bool (setbit, buf_mask, "0110"b);	/* do sw */
	     tseg.buffer_offset = bin (setbit, 17);	/* get number */
	     tseg.sync = 0;				/* make sure */
	     tseg.buffer_count = buf_count;		/* read n buffers of data */
	     call tdcm_$tdcm_iocall (tsegp, code);	/* start io */
	     if code ^= 0 then
		go to DCM_ERR;
	     if tseg.completion_status ^< 2 then do;	/* bad error */

		string (hsbc) = tseg.hardware_status;	/* copy status */
		if hsbc.maj = "0100"b then do;
		     data_count = tseg.error_buffer - 1;/* indicate amt we got */
		     sav_stat = tseg.hardware_status;	/* save for 9 or 7 code */
		     if data_count = 0 then
			go to BAD_ORD;		/* no more data  send error */
		     eof_bit = "1"b;		/* tape mark */
		     no_data_sw = "0"b;
		     go to fix_out;			/* finish proccessing data */
		end;

		if hsbc.maj ^= "0011"b then
		     go to BAD_ORD;			/* only recoverable is data alert */

		if hsbc.min & "100000"b then do;	/* eot marker sensed (write only) */
		     setbit = bool (setbit, buf_mask, "0110"b);
						/* switch buffers */
		     tseg.buffer_offset = bin (setbit, 17) + tseg.error_buffer;
						/* start with one after eot mark */
		     tseg.buffer_count = buf_count - tseg.error_buffer;
						/* and do only ones remaining */
		     call tdcm_$tdcm_iocall (tsegp, code);
		     setbit = bool (setbit, buf_mask, "0110"b);
		     tseg.buffer_offset = bin (setbit, 17);
						/* set to do next bunch */
		     tseg.buffer_count = buf_count;	/* set to reissue past io(last one completed) */
		     call tdcm_$tdcm_iocall (tsegp, code);
						/* go to DCM */
		     substr (st, 1, 1) = "1"b;	/* reflect eot to user */
		     substr (st, 25, 12) = "000011100000"b;
						/* eot status */
		     eot_bit = "1"b;		/* remember this fact */
		     return;			/* go to user */
		end;

		do j = 1 to count;			/* retry io */
		     setbit = bool (setbit, buf_mask, "0110"b);
						/* back to buffers which failed */
		     tseg.buffer_offset = bin (setbit, 17);
						/* set tseg */
		     do i = 1 to tseg.error_buffer;	/* backspaces n times */
			tseg.command_queue (i) = 100110b;
						/* backspace rec op */
		     end;
		     tseg.command_count = tseg.error_buffer;
						/* go to it */
		     tseg.buffer_count = 0;		/* clear it since last attempt didnt go */
		     tseg.sync = 1;			/* we will wait for these io's */
		     call tdcm_$tdcm_iocall (tsegp, code);
						/* do backup */
		     if code ^= 0 then
			go to DCM_ERR;
		     if tseg.completion_status ^< 2 then do;
						/* bad error */
			substr (st, 1, 36) = unspec (error_table_$no_backspace);
			return;
		     end;
		     tseg.buffer_count = buf_count;	/* retry io again */
		     call tdcm_$tdcm_iocall (tsegp, code);
						/* go -- this is sync so it will wait */
		     if tseg.completion_status < 2 then
			go to restart;		/* go this time restart the io we wanted */
		end;
		go to BAD_ORD;			/* retry failed us */
	     end;

	     no_data_sw = "0"b;			/* we data now */
	     data_count = buf_count;			/* this much */
	end;


fix_out:						/* come here to finish sending data */
	call move (bufchk + 1);			/* move data to buffer */
	bufchk = bufchk + 1;			/* this one next time */
	data_count = data_count - 1;			/* reduce number of buffers full */
	if data_count = 0 then
	     no_data_sw = "1"b;			/* set sw saying none left */
	nelemt = nelem;				/* set count */
	substr (st, 1, 36) = "0"b;			/* no error */
	return;



/* 	W   R   I   T   E      E   N   T   R   Y      P   O   I   N   T	 */




nstd_write:
     entry (sdb_ptr, wksp, off, nelem, nelemt, st);

	nelemt = 0;				/* Clear it */
	call check_rewind;
	count = stream_data_block.retry_cnt;		/* no. of possible retries */

	if fix_rec then do;
	     if fix_init then do;
		tseg.sync = 0;
		no_data_sw = "0"b;			/* mark buffers empty now */
		data_count = buf_count;		/* n to fill before write */
		tseg.buffer_offset = buf_count;	/* set so first switch will go */
		bufchk = 0;			/* start filling buffers at offset 0 */
		tseg.write_sw = 1;
		fix_init = "0"b;
	     end;

	     if tseg.write_sw = 1 then
		go to fix_r_write;			/* check for write access */
	     call reset_fix_rec;			/* clean up after read */
	end;


	tseg.write_sw = 1;				/* set io to write */
	if nelem > max_rec_len then do;		/* buffer too large for DCM? */

BAD_BUF:
	     substr (st, 1, 36) = unspec (error_table_$buffer_big);
						/* put error in status */
	     return;
	end;

WLOOP:
	tseg.buffer_size (1) = nelem;			/* copy no elements */
	tseg.command_count = 0;			/* not doing a special command */
	tseg.buffer_count = 1;			/* one buffer */
	tseg.buffer_offset = 0;			/* use the 1st buffer */

	call move (1);				/* move data into tseg buffer for write */
	call tdcm_$tdcm_iocall (tsegp, code);		/* issue write */
	if code ^= 0 then
	     go to DCM_ERR;				/* error */
	if tseg.completion_status = 1 then
	     go to GOOD_OUT;			/* success */
	if substr (tseg.hardware_status, 3, 5) = "00111"b then do;
						/* If it's EOT send it back */
	     nelemt = tseg.buffer_size (1);		/* But give him the nelemt */
	     go to BAD_ORD;
	end;
	go to RECOV1;				/* go try to recover from write error */




fix_r_write:
	fix_sw = "1"b;				/* indicate write */
	go to fix_com;				/* go to common routine for this */


/* 	O   R   D   E   R      E   N   T   R   Y      P   O   I   N   T	 */




nstd_order:
     entry (sdb_ptr, order, ap, st);

	call check_rewind;

	ord = order;				/* Copy arg for better code */

	if fix_rec then
	     call reset_fix_rec;			/* clear out buffers */

	do i = lbound (ord_tab, 1) to hbound (ord_tab, 1);/* look in table for common orders */

	     if ord = ord_tab (i).oname then do;

		tseg.command_queue (1) = bin (ord_tab (i).cmd);
						/* hit..pick up command */
		if i = 11 then
		     stream_data_block.unload = "1"b;	/* remember that unload done */
		if i = 12 then
		     stream_data_block.rewind = "1"b;	/* remember that rewind done */
		go to COM;			/* go issue command */
	     end;

	end;


	if ord = "fixed_record_length" then do;		/* fix_rec order call */

	     fix_rec = "1"b;			/* set bit */
	     fix_rec_size = newerr;			/* just happens to be based var with ptr to arg */
	     buf_count = divide (max_rec_len, fix_rec_size, 17, 0);
						/* get num buffers */
	     if buf_count < 1 then
		go to BAD_BUF;			/* too big? */
	     if buf_count > 6 then
		buf_count = 6;			/* 6 is most we can use */
	     tseg.get_size = 0;			/* no sizes, we know them */
	     buf_mask = bit (bin (buf_count, 18), 18);	/* for x-or of buffer offset */
	     eof_bit, eot_bit = "0"b;			/* reset bits */
	     tseg.sync = 0;				/* set sync mode for io */
	     do i = 1 to 2 * buf_count;		/* init buffer sizes and ptrs */
		tseg.buffer_size (i) = fix_rec_size;	/* known size */
		tseg.bufferptr (i) = bin (rel (addrel (addr (tseg.buffer (1)), (i - 1) * fix_rec_size)), 17);
						/* rel buf addrs */
	     end;
	     fix_init = "1"b;			/* start io on 1st read */
	     go to ORD_OUT;				/* return */
	end;


	if ord = "bcd" then do;			/*  "bcd" hardware mode */
	     do i = 1 to 12;
		tseg.mode (i) = 1;
	     end;
	     go to ORD_OUT;
	end;
	if ord = "binary" then do;			/* "binary" hardware mode */
	     do i = 1 to 12;
		tseg.mode (i) = 0;
	     end;
	     go to ORD_OUT;
	end;
	if ord = "nine" then do;			/* "nine" hardware mode */
	     do i = 1 to 12;
		tseg.mode (i) = 2;
	     end;
	     go to ORD_OUT;
	end;
	if ord = "saved_status" then do;
STAT:
	     ap -> sst = tseg.hardware_status;		/* copied from tseg; this will get special iom stuff too */
	     go to ORD_OUT;
	end;
	if ord = "request_status" then do;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = 000000b;
	     call tdcm_$tdcm_iocall (tsegp, code);	/* call DCM */
	     if code ^= 0 then
		go to DCM_ERR;
	     if tseg.completion_status ^= 1 then
		go to BAD_ORD;
	     go to STAT;
	end;
	if ord = "err_count" then do;
	     if ap = null then do;			/* new error supplied? */
		stream_data_block.retry_cnt = 10;	/* no..use default */
		go to ORD_OUT;
	     end;
	     if newerr > 100 | newerr < 0 then
		go to UOR;			/* yes..is it legal ? */
	     stream_data_block.retry_cnt = newerr;	/* yes..use it */
	     go to ORD_OUT;
	end;

UOR:
	substr (st, 1, 36) = unspec (error_table_$undefined_order_request);
						/* bum order */
	return;

COM:
	if stream_data_block.rewind then do;		/* rewind to be done?? */

	     call tdcm_$tdcm_set_signal (tsegp, code);	/* yes..tell DCM we want to know when it's done */
	     if code ^= 0 then
		go to DCM_ERR;			/* DCM squawked */
	end;

	tseg.command_count = 1;
	call tdcm_$tdcm_iocall (tsegp, code);		/* issue order */
	if tseg.completion_status ^= 1 then
	     go to BAD_ORD;

	if stream_data_block.rewind then		/* was a rewind just issued? */
	     if substr (tseg.hardware_status, 3, 4) = "0"b
		& /* yes..was the tape */ substr (tseg.hardware_status, 11, 1) then do;
						/* positioned on load point? */

		stream_data_block.rewind = "0"b;	/* yes..turn off rewind sw */
		call tdcm_$tdcm_reset_signal (tsegp, code);
						/* there won't be a special interrupt */
		if code ^= 0 then
		     go to DCM_ERR;			/* goof */
	     end;

ORD_OUT:
	substr (st, 1, 36) = "0"b;			/* return good status */
	return;

nstd_getsize:
     entry (sdb_ptr, size, st);

dcl      size		  fixed bin;

	size = 36;				/* nstd_ deals only in words */

	return;

/* 	D   E   T   A   C   H      E   N   T   R   Y      P   O   I   N   T		 */




nstd_detach:
     entry (sdb_ptr, type, name2, st);

	call check_rewind;
	if fix_rec then do;
	     call reset_fix_rec;
	end;
	if stream_data_block.unload then
	     go to DET;				/* don't unload if user already did */
	tseg.buffer_count = 0;
	tseg.command_queue (1) = 111000b;		/* rewind tape */
	tseg.command_count = 1;
	call tdcm_$tdcm_iocall (tsegp, code);		/* have DCM do it */
	if code ^= 0 then
	     go to DCM_ERR;				/* error */
	if tseg.completion_status ^= 1 then
	     go to BAD_ORD;				/* failure on order */

DET:
	call tdcm_$tdcm_detach (tsegp, code);		/* detach tape drive */
	if code ^= 0 then
	     go to DCM_ERR;				/* error */

	call hcs_$delentry_seg (sdb_ptr, code);		/* then try to get rid of sdb */
	if code ^= 0 then do;			/* error */
	     substr (st, 1, 36) = unspec (code);	/* return error code to caller */
	     go to DET_BIT;				/* but indicate that detach worked */
	end;

	substr (st, 1, 36) = "0"b;
DET_BIT:
	substr (st, 52, 1) = "1"b;			/* your detach bit */
	return;


/**/
nstd_cmode:
     entry (sdb_ptr, rw, oldrw, st);

dcl      oldrw		  char (*);

	tsegp = tseg_ptr;

	if tseg.write_sw = 1 then
	     oldrw = "w";
	else oldrw = "r";

	if (rw ^= "w") & (rw ^= "r") & (rw ^= "rw") & (rw ^= "") then do;
	     substr (st, 1, 36) = unspec (error_table_$bad_mode);
	     return;
	end;

	if fix_rec then
	     call reset_fix_rec;			/* clear buffs */

	if rw = "r" then
	     tseg.write_sw = 0;
	else tseg.write_sw = 1;

	substr (st, 1, 36) = "0"b;
	return;

/**/

/* internal proc to clear out write ahead buffs */

reset_fix_rec:
     proc;
	tseg.sync = 1;				/* set sync for orders */
	fix_rec = "0"b;

	if fix_init then do;			/* no io yet - no clean up */
	     fix_init = "0"b;
	     return;
	end;

	if tseg.write_sw = 1 then do;			/* write remaining buffers */

	     setbit = bit (bin (tseg.buffer_offset, 18), 18);
	     setbit = bool (setbit, buf_mask, "0110"b);
	     tseg.buffer_offset = bin (setbit, 17);
	     tseg.buffer_count = bufchk;
	     tseg.command_count = 0;
	     call tdcm_$tdcm_iocall (tsegp, code);
	     if code ^= 0 then
		go to DCM_ERR;
	     if tseg.completion_status ^< 2 then
		go to BAD_ORD;
	     if ord = "eof" then do;			/* RESET to fixed_length_record */
		fix_rec = "0"b;
		fix_init = "1"b;
	     end;
	     return;
	end;

	if eof_bit then do;				/* no io pending */
	     data_count = data_count + 1;		/* backspace over file */
	     eof_bit = "0"b;
	     go to BACKSPACE;			/* no io pending */
	end;

	tseg.buffer_count = 0;			/* no data transfer */
	tseg.command_count = 0;			/* no commands */
	call tdcm_$tdcm_iocall (tsegp, code);		/* complete last read */
	if code ^= 0 then
	     go to DCM_ERR;

	if tseg.completion_status = 0 then
	     go to BACKSPACE;			/* no io pending */
	if tseg.completion_status = 1 then do;
	     data_count = data_count + buf_count;
	     go to BACKSPACE;
	end;
	data_count = data_count + tseg.error_buffer;

BACKSPACE:					/* backspace records read but not asked for */
	tseg.buffer_count = 0;
	do i = 1 to data_count;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = 100110b;
	     call tdcm_$tdcm_iocall (tsegp, code);	/* backspace one record */
	     if code ^= 0 then
		go to DCM_ERR;
	end;

	return;

     end;						/*						*/



/* 	Internal procedure to wait for a special interrupt from the tape controller.	 */
/* 	Used to wait for interrupt when tape drive made ready and after a rewind.	 */


wait:
     proc;


READY_CHK:
	wait_list.n = 1;				/* will wait for one event channel */
	wait_list.chn = tseg.ev_chan;			/* which is the one associated with this tseg */
	call ipc_$block (addr (wait_list), addr (message), code);
						/* go blocked waiting */
	if code ^= 0 then do;			/* error */
	     substr (st, 1, 36) = unspec (code);
	     return;
	end;

/* 	We could have gotten another drive's wakeup so....		 */


	tseg.command_count = 1;			/* ready to do one order */
	tseg.buffer_count = 0;
	tseg.command_queue (1) = rdycmd;		/* which is a reset status */
	call tdcm_$tdcm_iocall (tsegp, code);		/* issue order */
	if code ^= 0 then
	     return;				/* goof..exit */
	if tseg.completion_status ^= 1 then
	     go to READY_CHK;			/* not us..wait some more */

	stream_data_block.rewind = "0"b;		/* turn off rewind sw */
	call tdcm_$tdcm_reset_signal (tsegp, code);	/* disable special interrupt */
	return;

     end;

/*  Move copies data from a tseg buffer into the user's buffer after a read or copies
   *  data from the user's buffer ito a tseg buffer before a write.
*/

move:
     proc (no);

dcl      no		  fixed bin;		/* index to tseg buffer */
dcl      ptseg		  ptr;			/* ptr to current tseg buffer */
dcl      puser		  ptr;			/* ptr to current user buffer */

	ptseg = ptr (tsegp, tseg.bufferptr (no));	/* tseg buffer */
	puser = addrel (wksp, off);			/* user buffer */

	if tseg.write_sw = 1 then
	     ptseg -> dum = puser -> dum;		/* copy into tseg buffer for a write */
	else puser -> dum = ptseg -> dum;		/* copy into user's buffer for a read */

	return;
     end move;

/*  Called if attachment was not completed.  It releases the stream data block and the tape drive */

clear_attach:
     proc;

	if attach_sw then
	     call tdcm_$tdcm_detach (tsegp, code);	/* detach tape drive */
	if sdb_ptr ^= null then
	     call hcs_$delentry_seg (sdb_ptr, code);	/* delete stream data block */

	return;

     end clear_attach;



/*  check_rewind goes blocked if the tape is still rewinding.  */

check_rewind:
     proc;

	tsegp = tseg_ptr;				/* copy for better access */
	if stream_data_block.rewind then do;		/* wait if rewind just done */
	     rdycmd = 100000b;			/* Use reset status command here. */
	     call wait;
	     if code ^= 0 then
		go to DCM_ERR;			/* error?? */
	end;

	return;

     end check_rewind;

     end;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
