



		    get_at_entry_.pl1               11/11/89  1143.7r w 11/11/89  0802.8       39168



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


/* Last modified (date and reason):
   Aug 10, 1977 by S. Webber to remove references to obsolete dims
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
get_at_entry_:
     proc (stream, dim, device, mode) returns (fixed (35));


/* Parameters. */

dcl  dim char (*);
dcl  device char (*);
dcl  mode char (*);
dcl  stream char (*);

/* Automatic. */

dcl  (i, j) fixed;
dcl  (p, iocb_ptr) ptr;
dcl  1 ics aligned,
       2 sdbptr ptr,
       2 dimptr ptr,
       2 entry fixed;
dcl  1 status aligned,
       2 code fixed (35),
       2 bits bit (36);

/* Procedures. */

dcl  iox_$ios_call ext entry options (variable);
dcl  iox_$look_iocb ext entry (char (*), ptr) returns (fixed (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));

/* Constants. */

dcl  changemode_offset fixed int static init (14);
dcl  error_table_$ioname_not_found fixed (35) ext;
dcl  error_table_$missent fixed (35) ext;
dcl  error_table_$multiple_io_attachment fixed (35) ext;

/* Builtin. */

dcl  (addr, index, null, substr, verify) builtin;

/* Based. */

dcl  1 vcs aligned based,
       2 len fixed,
       2 str char (0 refer (vcs.len));
dcl  1 sdb aligned based (ics.sdbptr),
       2 dim char (32),
       2 device_list_ptr ptr;
dcl  1 device_list aligned based (ics.sdbptr -> sdb.device_list_ptr),
       2 next_ptr ptr,
       2 name_size fixed,
       2 name char (0 refer (device_list.name_size));
%include iocbx;

/* End of declarations. */





	status.code = iox_$look_iocb (stream, iocb_ptr);
	if status.code ^= 0 then return (error_table_$ioname_not_found);
	p = iocb_ptr -> iocb.attach_descrip_ptr;
	if p = null () then return (error_table_$ioname_not_found);
	if iocb_ptr -> actual_iocb_ptr = iocb_ptr
	then if iocb_ptr -> iocb.ios_compatibility ^= null () then do;

/* This is an old IOS-style DIM, hence we can return literally identical results
   to the old "get_at_entry_". */

		ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
		ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
		ics.entry = changemode_offset;
		dim = ics.sdbptr -> sdb.dim;
		device = ics.sdbptr -> sdb.device_list_ptr -> device_list.name;
		call iox_$ios_call (addr (ics), "", mode, status);
		if status.code ^= 0 then mode = "";
		if status.code = error_table_$missent then status.code = 0;
		if ics.sdbptr -> sdb.device_list_ptr -> device_list.next_ptr ^= null ()
		then status.code = error_table_$multiple_io_attachment;
		return (status.code);
		end;

/* The DIM in question is not an old-style DIM so we must do the best we
   can, or else this is a SYN attachment and thus not handled by the DIM.  To begin
   with, we assume that the DIM name is the first word of the attach description. */

	i = index (p -> vcs.str, " ") - 1;
	if i < 0 then i = p -> vcs.len;
	dim = substr (p -> vcs.str, 1, i);
	if dim = "tty_" then dim = "tw_";
	else if dim = "syn_" then dim = "syn";
	else if dim = "netd_" then dim = "ntw_";
	else if dim = "mr_" then dim = "mrd_";
	else if dim = "ocd_" then dim = "oc_";
	else if dim = "discard_" then dim = "discard_output_";

/* Next we assume that the device is the second word of the attach description. */

	j = verify (substr (p -> vcs.str, i + 1), " ") - 1;
	if j < 0 then j = p -> vcs.len - i;
	i = i + j;
	j = index (substr (p -> vcs.str, i + 1), " ") - 1;
	if j < 0 then j = p -> vcs.len - i;
	device = substr (p -> vcs.str, i + 1, j);

/* If this is a SYN attachment, then the mode is null.  Otherwise, we obtain the mode
   by issuing a "modes" call. */

	mode = "";
	if iocb_ptr -> iocb.actual_iocb_ptr = iocb_ptr then do;
	     call iox_$modes (iocb_ptr, "", mode, (0));
	     end;
	return (0);





     end get_at_entry_;




		    ios_.pl1                        11/11/89  1143.7r w 11/11/89  0800.0      268542



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

/* Last modified (Date and Reason):
   Aug 9, 1977 by S. Webber to make better use of static storage and remove refences to obsolete dims.
   August 1981 by C. Hornig to make it compile again.
   19 August 1982 by G. Palter to make ios_$attach work as "documented"
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */

ios_:
     procedure;

/* A replacement for the old I/O switch 'ios_' which implements most of its calls
   via write-arounds to the new I/O system 'iox_'.  However, unknown DIMs continue to
   be supported in a straight-through fashion for compatibility. */


/* Declarations. */

/* Parameters. */

dcl  amount fixed (21);
dcl  breaklist (*) bit (*);
dcl  delimlist (*) bit (*);
dcl  device char (*);
dcl  dim char (*);
dcl  elemsize fixed (21);
dcl  infptr ptr;
dcl  iocb_ptr_ ptr;
dcl  mode char (*);
dcl  name1 char (*);
dcl  name2 char (*);
dcl  nbreaks fixed;
dcl  ndelims fixed;
dcl  nelem fixed (21);
dcl  nelemt fixed (21);
dcl  newmode char (*);
dcl  offset fixed (21);
dcl  oldmode char (*);
dcl  1 oldstatus aligned like status;
dcl  order char (*);
dcl  1 status aligned,
       2 code fixed (35),
       2 bits bit (36);
dcl  stream char (*);
dcl  wsptr ptr;

/* Automatic. */

dcl  actual_iocb_ptr ptr;
dcl  arg0 (zero) char (0) varying;
dcl  blkptr ptr;
dcl  caller_ptr ptr;
dcl  code fixed (35);
dcl  i fixed;
dcl  1 ics aligned,
       2 sdbptr ptr,
       2 dimptr ptr,
       2 entry fixed;
dcl  iocb_ptr ptr;
dcl  mask fixed (35);
dcl  1 mystatus aligned like status;
dcl  old_attachment pointer;
dcl  p ptr;
dcl  1 ti aligned,
       2 version fixed,
       2 code fixed (35);

/* Internal Static. */

dcl  free_blks_ptr ptr int static init (null ());
dcl  system_storage_ptr ptr int static init (null ());


/* Procedures. */

dcl  cu_$arg_list_ptr ext entry () returns (ptr);
dcl  cu_$caller_ptr entry (ptr);
dcl  cu_$grow_stack_frame ext entry (fixed, ptr) returns (fixed (35));
dcl  default_handler_$set ext entry (entry);
dcl  hcs_$make_ptr ext entry (ptr, char (*), char (*), ptr) returns (fixed (35));
dcl  get_system_free_area_ entry (ptr);
dcl  hcs_$set_ips_mask ext entry (fixed (35), fixed (35));
dcl  hcs_$reset_ips_mask ext entry (fixed (35), fixed (35));
dcl  discard_$discard_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  mr_$mr_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  netd_$netd_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  ocd_$ocd_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  syn_$syn_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  tty_$tty_attach ext entry (ptr, (*) char (*) varying, bit (1), fixed bin (35));
dcl  iox_$init_standard_iocbs entry;
dcl  iox_$ios_call ext entry options (variable);
dcl  iox_$ios_call_attach ext entry options (variable);
dcl  ios_signal_ ext entry (char (32), fixed (35));
dcl  terminate_process_ ext entry (char (*), ptr);
dcl  unique_chars_ entry (bit (*)) returns (char (15));

/* Constants. */

dcl  zero fixed int static init (0);
dcl  detached_status bit (36) int static init ("0000000000000001"b);
dcl  error_table_$end_of_info fixed (35) ext;
dcl  error_table_$ioname_not_active fixed (35) ext;
dcl  error_table_$long_record fixed (35) ext;
dcl  error_table_$ioname_not_found fixed (35) ext;
dcl  error_table_$ionmat fixed (35) ext;
dcl  error_table_$missent fixed (35) ext;
dcl  error_table_$typename_not_found fixed (35) ext;
dcl  iox_$err_old_dim ext entry options (variable);
dcl  ios_write_around_$ios_write_around_get_line ext entry options (variable);
dcl  ios_write_around_$ios_write_around_get_chars ext entry options (variable);
dcl  ios_write_around_$ios_write_around_put_chars ext entry options (variable);
dcl  ios_write_around_$ios_write_around_control ext entry options (variable);
dcl  ios_write_around_$ios_write_around_modes ext entry options (variable);
dcl  ios_write_around_$ios_write_around_position ext entry options (variable);
dcl  detach_offset fixed int static init (1);
dcl  read_offset fixed int static init (2);
dcl  write_offset fixed int static init (3);
dcl  abort_offset fixed int static init (4);
dcl  order_offset fixed int static init (5);
dcl  resetread_offset fixed int static init (6);
dcl  resetwrite_offset fixed int static init (7);
dcl  setsize_offset fixed int static init (8);
dcl  getsize_offset fixed int static init (9);
dcl  setdelim_offset fixed int static init (10);
dcl  getdelim_offset fixed int static init (11);
dcl  seek_offset fixed int static init (12);
dcl  tell_offset fixed int static init (13);
dcl  changemode_offset fixed int static init (14);
dcl  readsync_offset fixed int static init (19);
dcl  writesync_offset fixed int static init (20);
dcl  stream_output_mode fixed int static init (2);
dcl  stream_input_output_mode fixed int static init (3);

/* Built-in. */

dcl  (addr, divide, length, min, null, size, substr, unspec) builtin;

/* Based. */

dcl  system_storage area based (system_storage_ptr);
dcl  1 aligned_based aligned based,
       2 char (0:9999) char (1) unaligned;
dcl  arg (1) char (length (device)) varying based (p);
dcl  1 args aligned based (p),
       2 nargs fixed (16) unaligned,
       2 other fixed,
       2 arg (0 refer (args.nargs)) ptr;
dcl  fixed_aligned_based fixed (35) aligned based;
dcl  1 blk aligned based (blkptr),
       2 sdbptr ptr,
       2 dimptr ptr,
       2 attach char (234) varying,
       2 open char (50) varying;
%include iocbx;

/* End of declarations. */





/* Beginning of entry point ..... ios_$attach(stream,dim,device,mode,status) ..... */

attach:
     entry (stream, dim, device, mode, status);

	if system_storage_ptr = null then call get_system_free_area_ (system_storage_ptr);
	unspec (status) = "0"b;
	call iox_$find_iocb (stream, iocb_ptr, status.code);
	if status.code ^= 0 then return;
	mask = 0;
	call default_handler_$set (handler);
	if dim = "syn" then go to new;
	else if dim = "tw_" then go to new;
	else if dim = "ntw_" then go to new;
	else if dim = "mrd_" then go to new;
	else if dim = "oc_" then go to new;
	else if dim = "discard_output_" then go to new;
	call cu_$caller_ptr (caller_ptr);
	i = hcs_$make_ptr (caller_ptr, dim, rtrim (dim) || "module", ics.dimptr);
	call hcs_$set_ips_mask (0, mask);
	if ics.dimptr = null () then status.code = error_table_$typename_not_found;
	else if iocb_ptr -> iocb.attach_descrip_ptr = null () then ics.sdbptr = null ();
	else if iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr then ics.sdbptr = null ();
	else if iocb_ptr -> iocb.ios_compatibility ^= ics.dimptr then status.code = error_table_$ionmat;
	else ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	call hcs_$reset_ips_mask (mask, mask);
	if status.code ^= 0 then return;
	call iox_$ios_call_attach (stream, dim, device, mode, status, addr (ics));
	if status.bits & detached_status then return;
	call hcs_$set_ips_mask (0, mask);
	if iocb_ptr -> iocb.attach_descrip_ptr = null () then go to fill_iocb;
	else if iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr then do;
	     call iocb_ptr -> iocb.detach_iocb (iocb_ptr, (0));
fill_iocb:
	     blkptr = free_blks_ptr;
	     if blkptr ^= null ()
	     then free_blks_ptr = blkptr -> blk.sdbptr;
	     else do;
		allocate blk in (system_storage) set (blkptr);
		end;
	     if blkptr = null () then do;
		call hcs_$reset_ips_mask (mask, mask);
		return;
		end;
	     blkptr -> blk.sdbptr = ics.sdbptr;
	     blkptr -> blk.dimptr = ics.dimptr;
	     blkptr -> blk.attach = rtrim (dim) || " " || substr (device, 1, min (201, length (device)));
	     blkptr -> blk.open = "IOS compatibility";
	     if mode ^= ""
	     then blkptr -> blk.open = blkptr -> blk.open || " " || substr (mode, 1, min (32, length (mode)));
	     iocb_ptr -> iocb.attach_descrip_ptr = addr (blkptr -> blk.attach);
	     iocb_ptr -> iocb.attach_data_ptr = blkptr;
	     iocb_ptr -> iocb.open_descrip_ptr = addr (blkptr -> blk.open);
	     iocb_ptr -> iocb.open_data_ptr = ics.sdbptr;
	     iocb_ptr -> iocb.detach_iocb = iox_$err_old_dim;
	     iocb_ptr -> iocb.open = iox_$err_old_dim;
	     iocb_ptr -> iocb.close = iox_close;
	     iocb_ptr -> iocb.get_line = ios_write_around_$ios_write_around_get_line;
	     iocb_ptr -> iocb.get_chars = ios_write_around_$ios_write_around_get_chars;
	     iocb_ptr -> iocb.put_chars = ios_write_around_$ios_write_around_put_chars;
	     iocb_ptr -> iocb.modes = ios_write_around_$ios_write_around_modes;
	     iocb_ptr -> iocb.position = ios_write_around_$ios_write_around_position;
	     iocb_ptr -> iocb.control = ios_write_around_$ios_write_around_control;
	     iocb_ptr -> iocb.read_record = iox_$err_old_dim;
	     iocb_ptr -> iocb.write_record = iox_$err_old_dim;
	     iocb_ptr -> iocb.rewrite_record = iox_$err_old_dim;
	     iocb_ptr -> iocb.delete_record = iox_$err_old_dim;
	     iocb_ptr -> iocb.seek_key = iox_$err_old_dim;
	     iocb_ptr -> iocb.read_key = iox_$err_old_dim;
	     iocb_ptr -> iocb.read_length = iox_$err_old_dim;
	     iocb_ptr -> iocb.ios_compatibility = ics.dimptr;
	     call iox_$propagate (iocb_ptr);
	     end;
	call hcs_$reset_ips_mask (mask, mask);
	return;

/* We know about this kind of DIM.  Use write-arounds to the new I/O system to simulate it. */

new:
	status.code = cu_$grow_stack_frame (divide (length (device) + 7, 4, 17, 0), p);
	if status.code ^= 0 then return;
	p -> arg (1) = device;
	call hcs_$set_ips_mask (0, mask);
	old_attachment = null ();
	if iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr then do;
	     call iox_$find_iocb (unique_chars_ (""b), old_attachment, status.code);
	     if status.code ^= 0 then return;
	     call iox_$move_attach (iocb_ptr, old_attachment, status.code);
	     if status.code ^= 0 then return;
	     end;					/* leaves iocb_ptr detached */
	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then status.code = error_table_$ionmat;
	else if dim = "syn" then do;
	     call syn_$syn_attach (iocb_ptr, arg, "0"b, status.code);
	     end;
	else if dim = "tw_" then do;
	     call tty_$tty_attach (iocb_ptr, arg, "0"b, status.code);
	     if status.code = 0 then call iox_$open (iocb_ptr, stream_input_output_mode, "0"b, (0));
	     if status.code = 0 then call iox_$modes (iocb_ptr, mode, "", status.code);
	     end;
	else if dim = "ntw_" then do;
	     call netd_$netd_attach (iocb_ptr, arg, "0"b, status.code);
	     if status.code = 0 then call iox_$open (iocb_ptr, stream_input_output_mode, "0"b, (0));
	     if status.code = 0 then call iox_$modes (iocb_ptr, mode, "", (0));
	     end;
	else if dim = "mrd_" then do;
	     call mr_$mr_attach (iocb_ptr, arg, "0"b, status.code);
	     if status.code = 0 then call iox_$open (iocb_ptr, stream_input_output_mode, "0"b, (0));
	     if status.code = 0 then call iox_$modes (iocb_ptr, mode, "", (0));
	     end;
	else if dim = "oc_" then do;
	     call ocd_$ocd_attach (iocb_ptr, arg, "0"b, status.code);
	     if status.code = 0 then call iox_$open (iocb_ptr, stream_input_output_mode, "0"b, (0));
	     if status.code = 0 then call iox_$modes (iocb_ptr, mode, "", (0));
	     end;
	else if dim = "discard_output_" then do;
	     call discard_$discard_attach (iocb_ptr, arg0, "0"b, status.code);
	     if status.code = 0 then call iox_$open (iocb_ptr, stream_output_mode, "0"b, (0));
	     end;
	else status.code = error_table_$typename_not_found;
	if old_attachment ^= null () then do;
	     if status.code = 0
	     then call iox_$detach_iocb (old_attachment, (0));
	     else call iox_$move_attach (old_attachment, iocb_ptr, (0));
	     call iox_$destroy_iocb (old_attachment, (0));
	     end;
	call hcs_$reset_ips_mask (mask, mask);
	return;

/* End of entry point ..... ios_$attach(stream,dim,device,mode,status) ..... */






/* Beginning of entry point ..... ios_$detach(stream,device,mode,status) ..... */

detach:
     entry (stream, device, mode, status);
	unspec (status) = "0"b;
	call iox_$look_iocb (stream, iocb_ptr, status.code);
	mask = 0;
	call default_handler_$set (handler);
	call hcs_$set_ips_mask (0, mask);
	if status.code ^= 0 then status.code = error_table_$ioname_not_found;
	else if iocb_ptr -> iocb.attach_descrip_ptr = null () then status.code = error_table_$ioname_not_found;
	else if iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr then do;
	     call iocb_ptr -> iocb.detach_iocb (iocb_ptr, status.code);
	     if status.code = 0 then status.bits = detached_status;
	     end;
	else if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     blkptr = iocb_ptr -> iocb.attach_data_ptr;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = detach_offset;
	     call hcs_$reset_ips_mask (mask, mask);
	     call iox_$ios_call (addr (ics), device, mode, status);
	     call hcs_$set_ips_mask (0, mask);
	     if iocb_ptr -> iocb.attach_descrip_ptr = null () then status.code = error_table_$ioname_not_found;
	     else if iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr then status.code = error_table_$ionmat;
	     else if iocb_ptr -> iocb.ios_compatibility = null () then status.code = error_table_$ionmat;
	     else if status.bits & detached_status then do;
		blkptr -> blk.sdbptr = free_blks_ptr;
		free_blks_ptr = blkptr;
		iocb_ptr -> iocb.attach_descrip_ptr, iocb_ptr -> iocb.attach_data_ptr,
		     iocb_ptr -> iocb.open_descrip_ptr, iocb_ptr -> iocb.open_data_ptr = null ();
		iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
		iocb_ptr -> iocb.open = iox_$err_not_attached;
		iocb_ptr -> iocb.close = iox_$err_not_open;
		iocb_ptr -> iocb.get_line = iox_$err_not_open;
		iocb_ptr -> iocb.get_chars = iox_$err_not_open;
		iocb_ptr -> iocb.put_chars = iox_$err_not_open;
		iocb_ptr -> iocb.control = iox_$err_not_open;
		iocb_ptr -> iocb.modes = iox_$err_not_open;
		iocb_ptr -> iocb.read_record = iox_$err_not_open;
		iocb_ptr -> iocb.write_record = iox_$err_not_open;
		iocb_ptr -> iocb.rewrite_record = iox_$err_not_open;
		iocb_ptr -> iocb.delete_record = iox_$err_not_open;
		iocb_ptr -> iocb.position = iox_$err_not_open;
		iocb_ptr -> iocb.seek_key = iox_$err_not_open;
		iocb_ptr -> iocb.read_key = iox_$err_not_open;
		iocb_ptr -> iocb.read_length = iox_$err_not_open;
		iocb_ptr -> iocb.ios_compatibility = null ();
		call iox_$propagate (iocb_ptr);
		end;
	     end;
	else do;
	     if iocb_ptr -> iocb.open_descrip_ptr ^= null () then call iocb_ptr -> iocb.close (iocb_ptr, status.code);
	     if iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	     then call iocb_ptr -> iocb.detach_iocb (iocb_ptr, status.code);
	     if iocb_ptr -> iocb.attach_descrip_ptr = null () then status.bits = detached_status;
	     end;
	call hcs_$reset_ips_mask (mask, mask);
	return;

/* End of entry point ..... ios_$detach(stream,device,mode,status) ..... */





/* Beginning of entry point ..... ios_$read(stream,wsptr,offset,nelem,nelemt,status) ..... */

read:
     entry (stream, wsptr, offset, nelem, nelemt, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = read_offset;
	     call iox_$ios_call (addr (ics), wsptr, offset, nelem, nelemt, status);
	     end;
	else do;
	     call iox_$get_line (iocb_ptr, addr (wsptr -> aligned_based.char (offset)), nelem, nelemt, status.code);
	     if status.code = error_table_$long_record then status.code = 0;
	     end;
	return;

/* End of entry point ..... ios_$read(stream,wsptr,offset,nelem,nelemt,status) ..... */





/* Beginning of entry point ..... ios_$write(stream,wsptr,offset,nelem,nelemt,status) ..... */

write:
     entry (stream, wsptr, offset, nelem, nelemt, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = write_offset;
	     call iox_$ios_call (addr (ics), wsptr, offset, nelem, nelemt, status);
	     end;
	else do;
	     call iox_$put_chars (iocb_ptr, addr (wsptr -> aligned_based.char (offset)), nelem, status.code);
	     if status.code = 0
	     then nelemt = nelem;
	     else nelemt = 0;
	     end;
	return;

/* End of entry point ..... ios_$write(stream,wsptr,offset,nelem,nelemt,status) ..... */





/* Beginning of entry point ..... ios_$abort(stream,oldstatus,status) ..... */

abort:
     entry (stream, oldstatus, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = abort_offset;
	     call iox_$ios_call (addr (ics), oldstatus, status);
	     end;
	else call iox_$control (iocb_ptr, "abort", null (), status.code);
	return;

/* End of entry point ..... ios_$abort(stream,oldstatus,status) ..... */





/* Beginning of entry point ..... ios_$order(stream,order,infptr,status) ..... */

order:
     entry (stream, order, infptr, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = order_offset;
	     call iox_$ios_call (addr (ics), order, infptr, status);
	     end;
	else call iox_$control (iocb_ptr, order, infptr, status.code);
	return;

/* End of entry point ..... ios_$order(stream,order,infptr,status) ..... */





/* Beginning of entry point ..... ios_$resetread(stream,status) ..... */

resetread:
     entry (stream, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = resetread_offset;
	     call iox_$ios_call (addr (ics), status);
	     end;
	else call iox_$control (iocb_ptr, "resetread", null (), status.code);
	return;

/* End of entry point ..... ios_$resetread(stream,status) ..... */





/* Beginning of entry point ..... ios_$resetwrite(stream,status) ..... */

resetwrite:
     entry (stream, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = resetwrite_offset;
	     call iox_$ios_call (addr (ics), status);
	     end;
	else call iox_$control (iocb_ptr, "resetwrite", null (), status.code);
	return;

/* End of entry point ..... ios_$resetwrite(stream,status) ..... */





/* Beginning of entry point ..... ios_$setsize(stream,elemsize,status) ..... */

setsize:
     entry (stream, elemsize, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = setsize_offset;
	     call iox_$ios_call (addr (ics), elemsize, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$setsize(stream,elemsize,status) ..... */





/* Beginning of entry point ..... ios_$getsize(stream,elemsize,status) ..... */

getsize:
     entry (stream, elemsize, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = getsize_offset;
	     call iox_$ios_call (addr (ics), elemsize, status);
	     end;
	else elemsize = 9;
	return;

/* End of entry point ..... ios_$getsize(stream,elemsize,status) ..... */





/* Beginning of entry point ..... ios_$setdelim(stream,nbreaks,breaklist,ndelims,delimlist,status) ..... */

setdelim:
     entry (stream, nbreaks, breaklist, ndelims, delimlist, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = setdelim_offset;
	     call iox_$ios_call (addr (ics), nbreaks, breaklist, ndelims, delimlist, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$setdelim(stream,nbreaks,breaklist,ndelims,delimlist,status) ..... */





/* Beginning of entry point ..... ios_$getdelim(stream,nbreaks,breaklist,ndelims,delimlist,status) ..... */

getdelim:
     entry (stream, nbreaks, breaklist, ndelims, delimlist, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = getdelim_offset;
	     call iox_$ios_call (addr (ics), nbreaks, breaklist, ndelims, delimlist, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$getdelim(stream,nbreaks,breaklist,ndelims,delimlist,status) ..... */





/* Beginning of entry point ..... ios_$seek(stream,name1,name2,amount,status) ..... */

seek:
     entry (stream, name1, name2, amount, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = seek_offset;
	     call iox_$ios_call (addr (ics), name1, name2, amount, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$seek(stream,name1,name2,amount,status) ..... */





/* Beginning of entry point ios_$tell(stream,name1,name2,amount,status) ..... */

tell:
     entry (stream, name1, name2, amount, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = tell_offset;
	     call iox_$ios_call (addr (ics), name1, name2, amount, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$tell(stream,name1,name2,amount,status) ..... */





/* Beginning of entry point ..... ios_$changemode(stream,newmode,oldmode,status) ..... */

changemode:
     entry (stream, newmode, oldmode, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = changemode_offset;
	     call iox_$ios_call (addr (ics), newmode, oldmode, status);
	     end;
	else call iox_$modes (iocb_ptr, newmode, oldmode, status.code);
	return;

/* End of entry point ..... ios_$changemode(stream,newmode,oldmode,status) ..... */





/* Beginning of entry point ..... ios_$readsync(stream,mode,amount,status) ..... */

readsync:
     entry (stream, mode, amount, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = readsync_offset;
	     call iox_$ios_call (addr (ics), mode, amount, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$readsync(stream,mode,amount,status) ..... */






/* Beginning of entry point ..... ios_$writesync(stream,mode,amount,status) ..... */

writesync:
     entry (stream, mode, amount, status);
	call setup ();
	if iocb_ptr -> iocb.ios_compatibility ^= null () then do;
	     ics.sdbptr = iocb_ptr -> iocb.open_data_ptr;
	     ics.dimptr = iocb_ptr -> iocb.ios_compatibility;
	     ics.entry = writesync_offset;
	     call iox_$ios_call (addr (ics), mode, amount, status);
	     end;
	else status.code = error_table_$missent;
	return;

/* End of entry point ..... ios_$writesync(stream,mode,amount,status) ..... */









/* Internal procedure called by most entry points of the IOS write-arounds to clear
   the status argument, look up the IOCB pointer, and verify that the IOCB is attached
   and open.  If there are any errors, a non-local go-to causes the write-around
   to return immediately to its caller. */

setup:
     proc;
	unspec (status) = "0"b;
	call iox_$look_iocb (stream, iocb_ptr, status.code);
	if status.code ^= 0 then status.code = error_table_$ioname_not_found;
	else if iocb_ptr -> iocb.attach_descrip_ptr = null () then status.code = error_table_$ioname_not_found;
	else if iocb_ptr -> iocb.open_descrip_ptr = null () then status.code = error_table_$ioname_not_active;
	else return;
	go to return;
     end setup;

/* End of internal procedure ..... setup() ..... */





return:
	return;





/* Internal procedure to handle faults while IPS interrupts
   are masked.  While not masked, any signals are simply
   passed on up the stack to their normal handlers.  For a
   fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O
   control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts
   masked nor a restart with a possibly changed mask. */

handler:
     proc (p1, name, p2, p3, continue);

dcl  (p1, p2, p3) ptr;
dcl  name char (*);
dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  addr builtin;

	if mask ^= 0 then do;
	     ti.version = 0;
	     ti.code = error_table_$unable_to_do_io;
	     call terminate_process_ ("fatal_error", addr (ti));
	     end;
	if name ^= "cleanup" then continue = "1"b;

     end handler;





/* Handler for the 'close' I/O operation--the only new I/O call permitted to an
   old DIM.  It closes and detaches the IOCB. */

iox_close:
     entry (iocb_ptr_) returns (fixed);
	mask = 0;
	call default_handler_$set (handler);
	call hcs_$set_ips_mask (0, mask);
	if iocb_ptr_ -> iocb.close ^= iox_close then do;
	     call hcs_$reset_ips_mask (mask, mask);
	     call iox_$close (iocb_ptr_, code);
	     return (code);
	     end;
	actual_iocb_ptr = iocb_ptr_ -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = detach_offset;
	call hcs_$reset_ips_mask (mask, mask);
	call iox_$ios_call (addr (ics), "", "", mystatus);
	call hcs_$set_ips_mask (0, mask);
	if iocb_ptr_ -> iocb.close ^= iox_close then do;
	     call hcs_$reset_ips_mask (mask, mask);
	     call iocb_ptr -> iocb.close (iocb_ptr_, code);
	     return (code);
	     end;
	if mystatus.bits & detached_status then do;
	     blkptr -> blk.sdbptr = free_blks_ptr;
	     free_blks_ptr = blkptr;
	     actual_iocb_ptr -> iocb.attach_descrip_ptr, actual_iocb_ptr -> iocb.attach_data_ptr,
		actual_iocb_ptr -> iocb.open_descrip_ptr, actual_iocb_ptr -> iocb.open_data_ptr = null ();
	     actual_iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
	     actual_iocb_ptr -> iocb.open = iox_$err_not_attached;
	     actual_iocb_ptr -> iocb.close = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.get_line = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.get_chars = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.put_chars = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.modes = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.position = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.control = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.read_record = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.write_record = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.rewrite_record = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.delete_record = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.seek_key = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.read_key = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.read_length = iox_$err_not_open;
	     actual_iocb_ptr -> iocb.ios_compatibility = null ();
	     call iox_$propagate (actual_iocb_ptr);
	     mystatus.code = 0;
	     end;
	call hcs_$reset_ips_mask (mask, mask);
	return (mystatus.code);

/* End of 'close' handler. */





/* Beginning of entry point ..... ios_$no_entry( ... ,status) ..... */

no_entry:
     entry;
	p = cu_$arg_list_ptr ();
	i = p -> args.nargs;
	if i ^= 0 then p -> args.arg (i) -> fixed_aligned_based = error_table_$missent;
	return;

/* End of entry point ..... ios_$no_entry( ... ,status) ..... */





/* Beginning of entry point ..... ios_$read_ptr(wsptr,nelem,nelemt) ..... */

read_ptr:
     entry (wsptr, nelem, nelemt);
rloop:
	call iox_$get_line (iox_$user_input, wsptr, nelem, nelemt, code);
	if code ^= 0
	then if code ^= error_table_$long_record & code ^= error_table_$end_of_info then do;
		call ios_signal_ ("user_input", code);
		go to rloop;
		end;
	return;

/* End of entry point ..... ios_$read_ptr(wsptr,nelem,nelemt) ..... */





/* Beginning of entry point ..... ios_$write_ptr(wsptr,offset,nelem) ..... */

write_ptr:
     entry (wsptr, offset, nelem);
wloop:
	call iox_$put_chars (iox_$user_output, addr (wsptr -> aligned_based.char (offset)), nelem, code);
	if code ^= 0 then do;
	     call ios_signal_ ("user_output", code);
	     go to wloop;
	     end;
	return;

/* End of entry point ..... ios_$write_ptr(wsptr,offset,nelem) ..... */





/* Beginning of entry point ..... ios_$ios_quick_init() ..... */

ios_quick_init:
     entry;

	call iox_$init_standard_iocbs;
	return;

/* End of entry point ..... ios_$ios_quick_init() ..... */
%page;
%include iox_dcls;

     end ios_;




		    ios_signal_.pl1                 11/11/89  1143.7r w 11/11/89  0802.8       17964



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


/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
ios_signal_:
     proc (strname, io_status);

/* This procedure signals io_error for ios_, since the code involved would have
   made ios_ too long for a fast command loop. */

/* Coded 8/73 by M. Weaver
   Last modified (date and reason):
   Aug 9, 1977 by S. Webber to make better use of static storage
   Oct 28,1977 by M. R. Jordan to make io_status fixed bin(35) rather than bit(72) aligned
*/

declare  strname char (32) aligned;
declare  io_status fixed bin (35);
declare  1 io_err_info aligned,			/* structure to passed to condition handler */
%include cond_info_structure;
	2 stream_name char (32), 2 status, 3 code fixed bin (35), 3 io_bits bit (36);

declare  (addr, null, size) builtin;

declare  signal_ entry (char (*), ptr, ptr);

/* fill in info structure */

	io_err_info.length = size (io_err_info);
	io_err_info.version = 1;
	string (io_err_info.action_flags) = "0"b;
	io_err_info.info_string = "An error has occurred using ios_.  Check stream names and status.";
	io_err_info.status_code = 0;
	io_err_info.stream_name = strname;
	io_err_info.status.code = io_status;
	io_err_info.status.io_bits = (36)"0"b;

	call signal_ ("io_error", null, addr (io_err_info));
						/* if returned to, try again */

	return;

     end ios_signal_;




		    ios_write_around_.pl1           11/11/89  1143.7r w 11/11/89  0802.8      132192



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


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
ios_write_around_:
     procedure;

/*  Modified 5/75 by S.E. Barr to implement real tty_ dim */
/* Modified May 1981 by C. Hornig to use legal PL/1 etc. */

/* Parameters. */

dcl  actlen fixed (21);
dcl  args (*) char (*) varying;
dcl  extend_bit bit (1) aligned;
dcl  code fixed bin (35);
dcl  buflen fixed (21);
dcl  bufptr ptr;
dcl  infptr ptr;
dcl  iocb_ptr ptr;
dcl  loud_sw bit (1) aligned;
dcl  mode fixed;
dcl  newmode char (*);
dcl  oldmode char (*);
dcl  order char (*);
dcl  u1 fixed;
dcl  u2 fixed (21);

/* Automatic. */

dcl  actual_iocb_ptr ptr;
dcl  blkptr ptr;
dcl  ch128 char (128);
dcl  device char (201) varying;
dcl  hisname char (32) varying;
dcl  1 ics aligned,
       2 sdbptr ptr,
       2 dimptr ptr,
       2 entry fixed;
dcl  m fixed (21);
dcl  mask bit (36) aligned;
dcl  myname char (32) varying;
dcl  n fixed (21);
dcl  p ptr;
dcl  1 status aligned,
       2 code fixed (35),
       2 bits bit (36);

/* Based. */

dcl  system_area area based (get_system_free_area_ ());
dcl  1 cm_str based (infptr),
       2 len fixed bin (21),
       2 str char (cm_str.len);
dcl  1 blk aligned based (blkptr),
       2 sdbptr ptr,
       2 dimptr ptr,
       2 attach char (207) varying,
       2 open char (27) varying;
dcl  char_aligned_based char (9999) aligned based;

/* Procedures. */

dcl  char_offset_ entry (ptr) returns (fixed bin (21)) reducible;
dcl  com_err_ ext entry options (variable);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$ios_call ext entry options (variable);
dcl  iox_$ios_call_attach ext entry options (variable);
dcl  ntw_$ntw_module ext;
dcl  mrd_$mrd_module ext;
dcl  oc_$oc_module ext;

/* Constants. */

dcl  error_table_$bad_mode fixed (35) ext;
dcl  error_table_$end_of_info fixed (35) ext;
dcl  error_table_$noarg fixed (35) ext;
dcl  error_table_$no_operation fixed (35) ext;
dcl  error_table_$not_detached fixed (35) ext;
dcl  error_table_$long_record fixed (35) ext;
dcl  error_table_$wrong_no_of_args fixed (35) ext;

dcl  detach_offset fixed int static init (1) options (constant);
dcl  read_offset fixed int static init (2) options (constant);
dcl  write_offset fixed int static init (3) options (constant);
dcl  abort_offset fixed int static init (4) options (constant);
dcl  order_offset fixed int static init (5) options (constant);
dcl  resetread_offset fixed int static init (6) options (constant);
dcl  resetwrite_offset fixed int static init (7) options (constant);
dcl  changemode_offset fixed int static init (14) options (constant);
dcl  Qnl char (1) aligned int static init ("
") options (constant);

/* Built-in. */

dcl  (addr, addrel, hbound, mod, null, pointer, substr) builtin;

/* Condition */

dcl  any_other condition;
%page;
join:
	mask = ""b;
	on any_other call handler;

	if hbound (args, 1) < 1 then call error (error_table_$noarg, (iocb_ptr -> iocb.name));
	if hbound (args, 1) > 1 then call error (error_table_$wrong_no_of_args, args (2));

	ics.sdbptr = null ();
	call hcs_$set_ips_mask (""b, mask);
	if iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	then call error (error_table_$not_detached, (iocb_ptr -> iocb.name));
	call iox_$ios_call_attach (iocb_ptr -> iocb.name, (hisname), (args (1)), "", status, addr (ics));
	if status.code ^= 0 then call error (status.code, device);
	allocate blk in (system_area) set (blkptr);
	blkptr -> blk.sdbptr = ics.sdbptr;
	blkptr -> blk.dimptr = ics.dimptr;
	blkptr -> blk.attach = myname || " " || args (1);
	iocb_ptr -> iocb.attach_descrip_ptr = addr (blkptr -> blk.attach);
	iocb_ptr -> iocb.attach_data_ptr = blkptr;
	iocb_ptr -> iocb.detach_iocb = ios_write_around_detach;
	iocb_ptr -> iocb.open = ios_write_around_open;
	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (mask, mask);
	code = 0;
	return;

/* End of entry point ..... attach (iocb_ptr,args,loud_sw) ..... */





/* Internal procedure to handle all attach errors.  Calls "com_err_" if the "loud_sw"
   is set.  In any case, returns to caller of attach external procedure with proper
   error code after ensuring that the IPS interrupt mask is restored. */

error:
     procedure (c, mess);
dcl  c fixed (35) parameter;
dcl  mess varying char (*) aligned parameter;

	if mask ^= ""b then call hcs_$reset_ips_mask (mask, mask);
	if loud_sw then call com_err_ (c, myname, "^a", mess);
	status.code = c;
	go to return;
     end error;





return:
	code = status.code;
	return;





/* Internal procedure to handle faults while IPS interrupts
   are masked.  While not masked, any signals are simply
   passed on up the stack to their normal handlers.  For a
   fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O
   control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts
   masked nor a restart with a possibly changed mask. */

/* Actually, this is pretty silly. The worst that can happen
   is a fatal error, and that is unlikely. So we just fix the
   mask and hope for the best. */

handler:
     procedure;

	if mask ^= ""b then do;
	     call hcs_$reset_ips_mask (mask, mask);
	     mask = ""b;
	     end;

	call continue_to_signal_ ((0));

     end handler;




/* Beginning of entry point ..... netd_$netd_attach(iocb_ptr,args,loud_sw) ..... */

netd_attach:
     entry (iocb_ptr, args, loud_sw, code);

	myname = "netd_";
	hisname = "ntw_";
	ics.dimptr = addr (ntw_$ntw_module);
	go to join;

/* End of entry point ..... netd_$netd_attach(iocb_ptr,args,loud_sw) ..... */






/* Beginning of entry point ..... mr_$mr_attach(iocb_ptr,args,loud_sw) ..... */

mr_attach:
     entry (iocb_ptr, args, loud_sw, code);

	myname = "mr_";
	hisname = "mrd_";
	ics.dimptr = addr (mrd_$mrd_module);
	go to join;

/* End of entry point ..... mr_$mr_attach(iocb_ptr,args,loud_sw) ..... */





/* Beginning of entry point ..... ocd_$ocd_attach(iocb_ptr,args,loud_sw) ..... */

ocd_attach:
     entry (iocb_ptr, args, loud_sw, code);

	myname = "ocd_";
	hisname = "oc_";
	ics.dimptr = addr (oc_$oc_module);
	go to join;

/* End of entry point ..... ocd_$ocd_attach(iocb_ptr,args,loud_sw) ..... */
%page;
/* Handler for the 'detach_iocb' I/O operation. */

ios_write_around_detach:
     entry (iocb_ptr, code);

	mask = ""b;
	on any_other call handler;
	call hcs_$set_ips_mask (""b, mask);
	blkptr = iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = detach_offset;
	call iox_$ios_call (addr (ics), "", "retain", status);
	if status.code ^= 0 then do;
	     call hcs_$reset_ips_mask (mask, mask);
	     code = status.code;
	     return;
	     end;
	free blkptr -> blk;
	iocb_ptr -> iocb.attach_descrip_ptr, iocb_ptr -> iocb.attach_data_ptr = null ();
	iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
	iocb_ptr -> iocb.open = iox_$err_not_attached;
	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (mask, mask);
	code = 0;
	return;

/* End of 'detach_iocb' handler. */
%page;
/* Handler for the 'open' I/O operation. */

ios_write_around_open:
     entry (iocb_ptr, mode, extend_bit, code);

	mask = ""b;
	on any_other call handler;
	call hcs_$set_ips_mask (""b, mask);
	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	if /* case */ mode = Stream_input then blkptr -> blk.open = "stream_input";
	else if mode = Stream_output then blkptr -> blk.open = "stream_output";
	else if mode = Stream_input_output then blkptr -> blk.open = "stream_input_output";
	else do;
	     call hcs_$reset_ips_mask (mask, mask);
	     code = error_table_$bad_mode;
	     return;
	     end;
	actual_iocb_ptr -> iocb.open_descrip_ptr = addr (blkptr -> blk.open);
	actual_iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;
	actual_iocb_ptr -> iocb.open = iox_$err_not_closed;
	actual_iocb_ptr -> iocb.close = ios_write_around_close;
	if mode ^= Stream_output then do;
	     actual_iocb_ptr -> iocb.get_line = ios_write_around_get_line;
	     actual_iocb_ptr -> iocb.get_chars = ios_write_around_get_chars;
	     actual_iocb_ptr -> iocb.position = ios_write_around_position;
	     end;
	if mode ^= Stream_input then do;
	     actual_iocb_ptr -> iocb.put_chars = ios_write_around_put_chars;
	     end;
	actual_iocb_ptr -> iocb.modes = ios_write_around_modes;
	actual_iocb_ptr -> iocb.control = ios_write_around_control;
	call iox_$propagate (actual_iocb_ptr);
	call hcs_$reset_ips_mask (mask, mask);
	code = 0;
	return;

/* End of 'open' handler. */
%page;
/* Handler for the 'close' I/O operation. */

ios_write_around_close:
     entry (iocb_ptr, code);

	mask = ""b;
	on any_other call handler;
	call hcs_$set_ips_mask (""b, mask);
	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	actual_iocb_ptr -> iocb.open_descrip_ptr = null ();
	actual_iocb_ptr -> iocb.detach_iocb = ios_write_around_detach;
	actual_iocb_ptr -> iocb.open = ios_write_around_open;
	actual_iocb_ptr -> iocb.close = iox_$err_not_open;
	actual_iocb_ptr -> iocb.get_line = iox_$err_not_open;
	actual_iocb_ptr -> iocb.get_chars = iox_$err_not_open;
	actual_iocb_ptr -> iocb.put_chars = iox_$err_not_open;
	actual_iocb_ptr -> iocb.control = iox_$err_not_open;
	actual_iocb_ptr -> iocb.modes = iox_$err_not_open;
	actual_iocb_ptr -> iocb.position = iox_$err_not_open;
	call iox_$propagate (actual_iocb_ptr);
	call hcs_$reset_ips_mask (mask, mask);
	code = 0;
	return;

/* End of 'close' handler. */
%page;
/* Handler for the 'get_line' I/O operation. */

ios_write_around_get_line:
     entry (iocb_ptr, bufptr, buflen, actlen, code);

	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = read_offset;
	m = mod (char_offset_ (bufptr), 4);
	p = addrel (bufptr, 0);			/* zeroes character offset */
	call iox_$ios_call (addr (ics), p, m, buflen, actlen, status);
	if status.code ^= 0 then do;
	     code = status.code;
	     return;
	     end;
	if actlen = 0 then do;
eof:
	     code = error_table_$end_of_info;
	     return;
	     end;
	if substr (p -> char_aligned_based, m + actlen, 1) ^= Qnl
	then if actlen = buflen then do;
		code = error_table_$long_record;
		return;
		end;
	     else goto eof;
	else do;
	     code = 0;
	     return;
	     end;

/* End of 'get_line' handler. */
%page;
/* Handler for the 'get_chars' I/O operation. */

ios_write_around_get_chars:
     entry (iocb_ptr, bufptr, buflen, actlen, code);

	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = read_offset;
	m = mod (char_offset_ (bufptr), 4);
	p = addrel (bufptr, 0);
	call iox_$ios_call (addr (ics), p, m, buflen, actlen, status);
	if status.code ^= 0 then do;
	     code = status.code;
	     return;
	     end;
	if actlen = 0 then goto eof;
	code = 0;
	return;

/* End of 'get_chars' handler. */
%page;
/* Handler for the 'put_chars' I/O operation. */

ios_write_around_put_chars:
     entry (iocb_ptr, bufptr, buflen, code);

	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = write_offset;
	m = mod (char_offset_ (bufptr), 4);
	p = addrel (bufptr, 0);
	call iox_$ios_call (addr (ics), p, m, buflen, 0, status);
	code = status.code;
	return;

/* End of 'put_chars' handler. */
%page;
/* Handler for the 'control' I/O operation. */

ios_write_around_control:
     entry (iocb_ptr, order, infptr, code);

	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	if /* case */ order = "abort" then do;
	     ics.entry = abort_offset;
	     call iox_$ios_call (addr (ics), (72)"0"b, status);
	     end;
	else if order = "resetread" then do;
	     ics.entry = resetread_offset;
	     call iox_$ios_call (addr (ics), status);
	     end;
	else if order = "resetwrite" then do;
	     ics.entry = resetwrite_offset;
	     call iox_$ios_call (addr (ics), status);
	     end;
	else if order = "changemode" then do;
	     ics.entry = changemode_offset;
	     call iox_$ios_call (addr (ics), cm_str.str, cm_str.str, status);
	     end;
	else do;
	     ics.entry = order_offset;
	     call iox_$ios_call (addr (ics), order, infptr, status);
	     end;
	code = status.code;
	return;

/* End of 'control' handler. */
%page;
/* Handler for the 'position' I/O operation. */

ios_write_around_position:
     entry (iocb_ptr, u1, u2, code);

	if (u1 ^= 0) | (u2 < 0) then do;
	     code = error_table_$no_operation;
	     return;
	     end;
	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = read_offset;
	m = 0;
	do while (m < u2);
	     call iox_$ios_call (addr (ics), addr (ch128), 0, 128, n, status);
	     if n = 0 then goto eof;
	     if substr (ch128, n, 1) = Qnl then m = m + 1;
	end;
	code = 0;
	return;

/* End of 'position' handler. */
%page;
/* Handler for the 'modes' I/O operation. */

ios_write_around_modes:
     entry (iocb_ptr, newmode, oldmode, code);

	actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
	ics.sdbptr = blkptr -> blk.sdbptr;
	ics.dimptr = blkptr -> blk.dimptr;
	ics.entry = changemode_offset;
	call iox_$ios_call (addr (ics), newmode, oldmode, status);
	code = status.code;
	return;

/* End of 'modes' handler. */
%page;
%include iocb;
%include iox_dcls;
%include iox_modes;

     end ios_write_around_;



		    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
