



		    file.pl1                        11/11/89  1133.6r w 11/11/89  0800.0      297891



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

file:						/* For multisegment file, read delimiters. */
     procedure;

/* Modified 13 August 1972, M J Grady.  */
/* Modified July 1973 by E. Stone to work for both 64k and 256k MSFs */
/* Modified September 1974 by E. Stone to pass expand_path_ a maximum of 168 char pathname */
/* Modified 750915 by PG and MJG to eliminate incorrect validation of arguments to read */

/* internal static */

dcl (reading initial ("0"b),
     writing initial ("1"b)) bit (1) aligned internal static;

/* declarations */

dcl (ioname1, type, ioname3, mode4) character (*);
dcl  status5 bit (72) aligned;
dcl  get_system_free_area_ entry returns (ptr);
dcl  free_area area based (fareap),
     fareap ptr init (null) int static;
dcl  pibp6 pointer;
dcl (buffer_bit_offset,				/* Bit offsets and lengths. */
     bits_requested,
     total_bits,
     seg_bit_offset,
     bits_to_move,
     bits_moved,
     current_bit) fixed binary (24);
dcl (ptrbit2,					/* Temporaries for pointer manipulation. */
     ptrbit3,
     offset) fixed binary (35);
dcl (buffer,					/* Pointer to workspace. */
     p,						/* Pointer to file control block. */
     sp,						/* Pointer to status string. */
     seg) pointer;					/* Pointer to file segment. */
dcl  base fixed binary;				/* Base of incremental bit search. */
dcl  byte bit (9) aligned;				/* Temporary for element during short delimiter search. */
dcl  mode character (4) aligned;			/* Copy of mode string. */
dcl  no_delimiter bit (1) aligned;			/* Flag to show we found a delimiter. */
dcl  pointer_name character (8) aligned;		/* Copy of pointer names. */
dcl (i, j) fixed bin (24),				/* Index. */
    (comp,					/* component number for test. */
     switch) fixed binary;
dcl  code fixed binary (35);				/* error code for routines. */
dcl  temp bit (72) aligned;				/* Temporary for delimiter search. */
dcl  infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */
dcl  bits_per_seg fixed bin (24);
dcl (error_table_$badcall,
     error_table_$boundviol,
     error_table_$change_first,
     error_table_$invalid_backspace_read,
     error_table_$invalid_elsize,
     error_table_$invalid_read,
     error_table_$invalid_seek_last_bound,
     error_table_$invalid_setdelim,
     error_table_$invalid_write,
     error_table_$negative_nelem,
     error_table_$ionmat,				/* Ioname already attached. */
     error_table_$negative_offset,
     error_table_$new_offset_negative,
     error_table_$no_room_for_dsb,			/* Can't allocate file control block. */
     error_table_$too_many_read_delimiters,
     error_table_$undefined_order_request,
     error_table_$undefined_ptrname) external fixed binary (35);
dcl  string based bit (9437184) aligned;		/* Overlay of segment and workspace (buffer). */
dcl  chars based character (1048576) aligned;		/* Segment overlay for fast delimiter searches. */
dcl  char1 character (1) aligned;			/* Copy of delimiter table element. */
dcl 1 status based aligned,				/* I/O system status string. */
    2 code fixed binary (35),				/* Overall error code. */
    2 successful bit (4) unaligned,			/* Logical/physical initiation/termination. */
    2 transaction_terminated bit (1) unaligned,		/* No further status change. */
    2 unassigned bit (4) unaligned,
    2 end_of_data bit (1) unaligned,			/* Obvious. */
    2 pad bit (5) unaligned,
    2 ioname_detached bit (1) unaligned,		/* .. */
    2 pad2 bit (2) unaligned,
    2 transaction_index bit (18) unaligned;		/* IO system transaction index. */
dcl  file_util$attach_file entry (pointer, fixed binary (35));
dcl  file_util$detach_file entry (pointer, fixed binary (35));
dcl  file_util$find_seg_ptr entry (pointer, bit (1) aligned, fixed binary, pointer, fixed binary (35));

dcl (add, addr, addrel, bit, divide, fixed, index, length, min, mod, multiply, null, rel, substr, unspec) builtin;

dcl 1 fcb static aligned like pib;			/* First file control block, allocated at translation time */

/* Additional file control blocks, allocated as needed. */
% include file_pib;


dcl (msegp, mbufp) ptr,
    (msegoff, mbufoff, mmove) fixed bin (24),
     mchrarray (0:1) char (1) based,
     mwords (mmove) fixed bin (35) aligned based,
     mchars char (1000) based aligned;

/*  */
file_attach:					/* entry to attach file. */
	entry (ioname1, type, ioname3, mode4, status5, pibp6);
	sp = addr (status5);			/* Set up pointer to status string. */
	if pibp6 ^= null then			/* Is this name already attached? */
	     do;					/* Yes. */
	     code = error_table_$ionmat;		/* Set error code. */
	     go to set_detached_bit;			/* Give up. */
	end;
	if fareap = null then
	     fareap = get_system_free_area_ ();		/* get area to alloc in */
	if fcb.busy then				/* Is the first block in use? */
	     do;					/* Yes. */
	     allocate pib in (free_area) set (p);	/* Get another. */
	     if p = null then			/* Successful? */
		do;				/* No. */
		code = error_table_$no_room_for_dsb;	/* Set error code. */
		go to set_detached_bit;		/* Give up. */
	     end;
	end;
	else
	p = addr (fcb);				/* Use internal block. */
						/* Insert path name of file into control block. */
	p -> pib.device_name.name_size = min (length (ioname3), length (p -> pib.device_name.name_string));
	p -> pib.device_name.name_string = ioname3;	/* .. */
	mode = mode4;				/* Copy mode string. */
	p -> pib.r, p -> pib.w = ""b;			/* Clear both permission flags. */
	if mode = "r   " then			/* Read only? */
	     p -> pib.r = "1"b;			/* Yes, set read permission flag. */
	if mode = "w   " then			/* Write only? */
	     p -> pib.w = "1"b;			/* Yes, set write permission flag. */
	if p -> pib.r | p -> pib.w then go to mode_out;	/* If any set now jump out. */

	if index (mode4, "read") = 0
	& index (mode4, "write") = 0
	then do;
	     p -> pib.r, p -> pib.w = "1"b;
	     go to mode_out;
	end;

	i = index (mode4, "read");
	if i ^= 0 then do;
	     if i > 1 then
		if substr (mode4, i-1, 1) ^= "^"
		then p -> pib.r = "1"b;		/* set read on */
		else;
	     else p -> pib.r = "1"b;
	end;

	i = index (mode4, "write");
	if i ^= 0 then do;
	     if i > 1 then
		if substr (mode4, i-1, 1) ^= "^"
		then p -> pib.w = "1"b;		/* set write on */
		else;
	     else p -> pib.w = "1"b;			/* also set write */
	end;

mode_out:
	call file_util$attach_file (p, code);		/* Initialize data block. */
	if code ^= 0 then				/* Successful? */
	     go to delete_fcb;			/* No, deallocate the control block. */
	p -> pib.outer_module_name = type;		/* Insert our name. */
	p -> pib.device_name_list = addr (p -> pib.device_name); /* Insert pointer for IOS. */
	p -> pib.device_name.next_device = null;	/* Clear pointer to next list bead. */
	p -> pib.busy = "1"b;			/* Mark block as in use. */
	pibp6 = p;				/* Give pointer to block to IOS. */
	go to good;				/* Attach successfully completed. */
						/*  */
file_detach:
	entry (pibp1, ioname2, disposal, status4);
dcl  pibp1 pointer;
dcl (ioname2, disposal) character (*);
dcl  status4 bit (72) aligned;

	p = pibp1;
	sp = addr (status4);
	call file_util$detach_file (p, code);		/* Clean up and free data block. */
	if code = 0 then				/* Successful? */
	     go to delete_fcb;			/* Yes, deallocate control block. */
	if disposal ^= "h" then			/* No, are we requested to hold the control block? */
	     do;					/* No. */
delete_fcb:    p -> pib.busy = ""b;			/* Clear the use flag. */
	     if p ^= addr (fcb) then			/* Is it the original block? */
		free p -> pib in (free_area);		/* No, return it to free storage. */
	     sp -> status.ioname_detached = "1"b;	/* Set detached bit. */
	end;
	if code ^= 0 then				/* Which exit should we take? */
	     go to bad;				/* Erroneous operation, report code. */
	go to good;
						/*  */
file_order:
	entry (pibp1, request, argptr, status4);
dcl  request character (*) aligned;			/* The name of the request. */
dcl  argptr pointer;				/* Pointer to arguments. */

	sp = addr (status4);			/* Get pointer to status string. */
	p = pibp1;				/* Copy pointer to control block. */
	if request = "backspace_read" then		/* Examine request name. */
	     do;					/* This is it. */
	     if ^ p -> pib.r then			/* Is file readable? */
		do;				/* No. */
		code = error_table_$invalid_read;	/* Set error code. */
		go to bad;			/* Give error return. */
	     end;
	     if argptr ^= null then			/* No arguments. */
		do;				/* But some supplied. */
		code = error_table_$badcall;		/* Set error code. */
		go to bad;			/* Give error return. */
	     end;
	     if p -> pib.nreads = 0 then		/* Are there any delimiters? */
		do;				/* No. */
scan (0): scan_none: code = error_table_$invalid_backspace_read; /* No, set error code. */
		go to bad;			/* Return to caller. */
	     end;
	     p -> pib.readbit = add (p -> pib.readbit, - 2 * p -> pib.elsize, 35, 0); /* Back up two bytes. */
try_scan:	     if p -> pib.readbit <= 0 then		/* At beginning of file? */
		do;				/* Yes. */
		p -> pib.readbit = 0;		/* Make sure nonnegative. */
		go to good;			/* Give normal return. */
	     end;
	     bits_per_seg = p -> pib.bits_per_segment;
	     seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get offset in current segment. */
	     comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */
	     if comp ^= p -> pib.lastcomp then do;	/* check to see if same as last time. */
		call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */
		if code ^= 0 then			/* Successful? */
		     go to bad;			/* Give error return. */
		p -> pib.lastcomp = comp;		/* set new component number. */
		p -> pib.lastseg = seg;		/* save new seg number */
	     end;
	     else seg = p -> pib.lastseg;		/* else set seg to be same as last time. */
	     do current_bit = seg_bit_offset by - p -> pib.elsize to 0; /* Scan backwards. */
		temp = substr (seg -> string, current_bit + 1, p -> pib.elsize); /* Extract one byte. */
		go to scan (p -> pib.search_type);	/* Dispatch to proper scan. */

scan (2): scan_bit_table: if substr (p -> pib.readlist, fixed (substr (temp, 1, 9), 9) + 1, 1) then /* Is this a break? */
		     go to scan_done;		/* Yes, terminate the scan. */
		go to scan_loop;			/* No, get next. */

scan (1): scan_1_char:				/* Can't handle special case; treat as packed. */
scan (3): scan_packed: j = 0;				/* Reset array index. */
		do i = 1 to p -> pib.nreads;		/* Compare with each delimiter. */
		     if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Does this match? */
			go to scan_done;		/* Yes, stop. */
		     j = j + p -> pib.elsize;		/* Bump array index. */
		end;
scan_loop:     end;
						/* Adjust read pointer to end of previous segment. */
	     p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset - p -> pib.elsize, 35, 0);
	     go to try_scan;			/* Go check for file beginning, get next segment. */

/* Adjust read pointer to place we found. */
scan_done:     p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset + current_bit + p -> pib.elsize, 35, 0);
	     go to good;				/* Give normal return. */
	end;
	if request = "call" then			/* Is request for file system call? */
	     do;					/* Yes. */
	     argptr -> status.code = p -> pib.call;	/* Give it to caller. */
	     go to good;				/* Return to caller. */
	end;
	code = error_table_$undefined_order_request;	/* Unrecognized request. */
	go to bad;				/* Give error return. */
						/*  */
file_getsize:
	entry (pibp1, elsize, status3);
dcl  elsize fixed binary (24);
dcl  status3 bit (72) aligned;

	p = pibp1;
	sp = addr (status3);
	elsize = p -> pib.elsize;
	go to good;

file_setsize:
	entry (pibp1, elsize, status3);

	p = pibp1;
	sp = addr (status3);
	if elsize < 1 then
	     do;
	     code = error_table_$invalid_elsize;
	     go to bad;
	end;
	bits_per_seg = p -> pib.bits_per_segment;
	if elsize > bits_per_seg then			/* Is it too big? */
	     do;					/* Yes. */
	     code = error_table_$invalid_elsize;	/* Set code. */
	     go to bad;				/* Give error return. */
	end;
	p -> pib.elsize = elsize;
						/* Round pointers to integral element. */
	call round (p -> pib.readbit);
	call round (p -> pib.writebit);
	call round (p -> pib.lastbit);
	call round (p -> pib.highbit);
	call round (p -> pib.boundbit);
	p -> pib.search_type, p -> pib.nreads = 0;	/* Flush any read delimiters. */
	go to good;
						/*  */
file_read:
	entry (pibp1, workspace, offset3, nelem, nelemt, status6);
dcl  workspace pointer;
dcl (offset3, nelem, nelemt) fixed binary (24);
dcl  status6 bit (72) aligned;

	p = pibp1;
	sp = addr (status6);
	nelemt, total_bits = 0;			/* Nothing transmitted yet. */
	if ^ p -> pib.r then
	     do;					/* Improper mode. */
	     code = error_table_$invalid_read;		/* Give error return. */
	     go to bad;
	end;
	buffer = workspace;				/* Copy workspace pointer. */
	buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0); /* Copy workspace offset. */
	if buffer_bit_offset < 0 then			/* It must be non-negative. */
	     do;					/* Bad offset. */
	     code = error_table_$negative_offset;	/* Give error return. */
	     go to bad;
	end;
	bits_requested = multiply (nelem, p -> pib.elsize, 24, 0); /* Copy number of elements desired. */
	if bits_requested < 0 then			/* It, too must be non-negative. */
	     do;					/* Bad buffer size. */
	     code = error_table_$negative_nelem;	/* Give error return. */
	     go to bad;
	end;
	bits_per_seg = p -> pib.bits_per_segment;
	call round (p -> pib.lastbit);		/* Round last pointer to element boundary. */
	no_delimiter = "1"b;			/* Set flag for retry. */
try_read:	seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get bit offset in current segment. */
	bits_to_move = min (add (p -> pib.lastbit, - p -> pib.readbit, 35, 0), bits_requested); /* Get bits to move. */
	bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move); /* Get bits we can move out of cur seg. */
	comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */
	if comp ^= p -> pib.lastcomp then do;		/* check to see if same as last time. */
	     call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */
	     if code ^= 0 then go to good;		/* Not an error...this is an EOF condition */
	     p -> pib.lastcomp = comp;		/* set new component number. */
	     p -> pib.lastseg = seg;			/* save new seg number */
	end;
	else seg = p -> pib.lastseg;			/* else set seg to be same as last time. */
	go to read (p -> pib.search_type);		/* Dispatch to proper delimiter search. */

read (2):						/* READ BIT TABLE */
	current_bit = 0;				/* Reset bit count. */
	do while (current_bit < bits_moved);		/* Fill buffer if possible. */
						/* Move one byte for comparison. */
	     byte = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
	     current_bit = current_bit + p -> pib.elsize; /* Count the element. */
	     if substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) then /* Is this it? */
		go to read_delimiter_found;		/* Yes. */
	end;
	go to read_move;				/* Go move the entire string. */

read (3):						/* READ PACKED */
	current_bit = 0;				/* Reset bit count. */
	do while (current_bit < bits_moved);		/* Fill buffer if possible. */
						/* Move one byte for comparison. */
	     temp = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
	     current_bit = current_bit + p -> pib.elsize; /* Count the element. */
	     j = 0;				/* Reset array index. */
	     do i = 1 to p -> pib.nreads;		/* Search the delimiter list. */
		if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Is this it? */
		     go to read_delimiter_found;	/* Yes. */
		j = j + p -> pib.elsize;		/* Update array index. */
	     end;
	end;
	go to read_move;				/* Go move the entire string. */

read (1):						/* READ 1 CHAR */
	i = divide (seg_bit_offset, 9, 17, 0);		/* Compute index of first character in file segment. */
	j = divide (bits_moved, 9, 17, 0);		/* Compute length of rest of segment in characters. */
	unspec (char1) = substr (p -> pib.readlist, 1, 9); /* Copy the delimiter. */
	current_bit = 9 * index (substr (seg -> chars, i + 1, j), char1); /* Look for the break. */
	if current_bit ^= 0 then			/* Any found? */
	     do;					/* Yes. */
read_delimiter_found:
	     no_delimiter = ""b;			/* Clear flag. */
	     bits_moved = current_bit;		/* Correct size of move. */
	end;
read (0):						/* Case of no read delimiters. */
read_move:
	if p -> pib.elsize = 36 then do;
	     msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
	     msegp = addrel (seg, msegoff);
	     mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
	     mbufp = addrel (buffer, mbufoff);
	     mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
	     mbufp -> mwords = msegp -> mwords;
	end;
	else if p -> pib.elsize = 9 then do;
	     msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
	     mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
	     mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
	     substr (buffer -> mchars, mbufoff+1, mmove) = substr (seg -> mchars, msegoff+1, mmove);
	end;
	else do;
	     substr (buffer -> string, buffer_bit_offset + 1, bits_moved) =
		substr (seg -> string, seg_bit_offset + 1, bits_moved);
	end;
	total_bits = total_bits + bits_moved;		/* Count total bits transmitted. */
	nelemt = divide (total_bits, p -> pib.elsize, 24, 0);
	p -> pib.readbit = add (p -> pib.readbit, bits_moved, 35, 0);
	if no_delimiter then			/* Was the delimiter found? */
	     if bits_moved < bits_to_move then		/* No, is more data in other segment? */
		do;				/* Yes. */
		buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */
		bits_requested = bits_requested - bits_moved; /* Decrease "demand". */
		go to try_read;			/* Go try again. */
	     end;
	go to good;
						/*  */
file_write:
	entry (pibp1, workspace, offset3, nelem, nelemt, status6);

	p = pibp1;
	sp = addr (status6);
	nelemt, total_bits = 0;			/* Clear for accumulation of bits transmitted. */
	if ^ p -> pib.w then
	     do;					/* Improper mode. */
	     code = error_table_$invalid_write;		/* Give error return. */
	     go to bad;
	end;
	buffer = workspace;				/* Copy pointer to caller's buffer. */
	buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0);
	if buffer_bit_offset < 0 then			/* Check range. */
	     do;					/* Bad. */
	     code = error_table_$negative_offset;	/* Set up code. */
	     go to bad;				/* Give error return. */
	end;
	bits_requested = multiply (nelem, p -> pib.elsize, 24, 0);
	if bits_requested < 0 then			/* Check range. */
	     do;					/* Bad. */
	     code = error_table_$negative_nelem;	/* Set up code. */
	     go to bad;				/* Give error return. */
	end;
	bits_per_seg = p -> pib.bits_per_segment;
						/* Might we get bounds fault accessing buffer? */
	if fixed (rel (buffer), 18) * 36 + buffer_bit_offset + bits_requested > bits_per_seg then
	     do;					/* Yes. */
	     code = error_table_$boundviol;		/* Off end of buffer. */
	     go to bad;				/* Give error return. */
	end;
	call round (p -> pib.writebit);		/* Round write pointer to element boundary. */
try_write:
	seg_bit_offset = mod (p -> pib.writebit, bits_per_seg); /* Get offset in current segment. */
	bits_to_move = min (add (p -> pib.boundbit, - p -> pib.writebit, 35, 0), bits_requested);
	bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move); /* Get bits we can move. */
	comp = divide (p -> pib.writebit, bits_per_seg, 17, 0); /* get component number */
	if comp ^= p -> pib.lastcomp then do;		/* check to see if same as last time. */
	     call file_util$find_seg_ptr (p, (writing), comp, seg, code); /* Get segment. */
	     if code ^= 0 then			/* Successful? */
		go to bad;			/* Give error return. */
	     p -> pib.lastcomp = comp;		/* set new component number. */
	     p -> pib.lastseg = seg;			/* save new seg number */
	end;
	else seg = p -> pib.lastseg;			/* else set seg to be same as last time. */
	if p -> pib.elsize = 36 then do;
	     msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
	     msegp = addrel (seg, msegoff);
	     mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
	     mbufp = addrel (buffer, mbufoff);
	     mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
	     msegp -> mwords = mbufp -> mwords;
	end;
	else if p -> pib.elsize = 9 then do;
	     msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
	     mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
	     mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
	     substr (seg -> mchars, msegoff+1, mmove) = substr (buffer -> mchars, mbufoff+1, mmove);
	end;
	else do;
	     substr (seg -> string, seg_bit_offset + 1, bits_moved) =
		substr (buffer -> string, buffer_bit_offset + 1, bits_moved);
	end;
	total_bits = total_bits + bits_moved;		/* Count this batch. */
	nelemt = divide (total_bits, p -> pib.elsize, 24, 0);
	p -> pib.writebit = add (p -> pib.writebit, bits_moved, 35, 0);
	if p -> pib.writebit > p -> pib.lastbit then	/* Was file size increased? */
	     do;					/* Yes. */
	     p -> pib.lastbit = p -> pib.writebit;	/* Increase pointer to indicate it. */
	     p -> pib.highbit = p -> pib.lastbit;	/* set high water mark */
	     p -> pib.changed = "1"b;			/* Mark it for setting bit count. */
	end;
	if bits_moved < bits_to_move then		/* Is more data in other segment? */
	     do;					/* Yes. */
	     buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */
	     bits_requested = bits_requested - bits_moved; /* Decrease "demand". */
	     go to try_write;			/* Go try again. */
	end;
	go to good;
						/*  */
file_setdelim:
	entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);
dcl  nbreaks, nreads;				/* Numbers of elements. */
dcl (breaklist, readlist) bit (*) aligned;

	sp = addr (status6);			/* Get pointer to status string. */
	p = pibp1;				/* Copy pointer to control data. */
	if p -> pib.elsize > length (temp) then		/* Will delimiter search work? */
	     do;					/* No. */
	     code = error_table_$invalid_setdelim;	/* Refuse call. */
	     go to bad;
	end;
	bits_per_seg = p -> pib.bits_per_segment;
	if mod (bits_per_seg, p -> pib.elsize) ^= 0 then	/* Will elements span segment boundaries? */
	     do;					/* Yes, delimiter search will not always work. */
	     code = error_table_$invalid_setdelim;	/* Give error code. */
	     go to bad;				/* Refuse call. */
	end;
	if nreads < 0 then				/* Check validity. */
	     do;					/* Bad. */
	     code = error_table_$badcall;		/* Refuse call. */
	     go to bad;
	end;
	if p -> pib.elsize > 9 then			/* Will we have to store the bytes? */
	     do;					/* Yes. */
	     total_bits = nreads * p -> pib.elsize;	/* Compute number of bits required. */
	     if total_bits > length (p -> pib.readlist) then /* Make sure not too many. */
		do;				/* Bad. */
		code = error_table_$too_many_read_delimiters; /* Refuse call. */
		go to bad;
	     end;
	end;
	p -> pib.nreads = nreads;			/* Save the total number of delimiters. */
	if p -> pib.nreads = 1 then			/* Is there only one? */
	     if p -> pib.elsize = 9 then		/* Is it a character? */
		do;				/* Yes, special case. */
		p -> pib.search_type = 1;		/* Set dispatch code. */
		substr (p -> pib.readlist, 1, 9) = substr (readlist, 1, 9); /* Copy the character. */
		go to good;			/* Return to caller. */
	     end;
	if p -> pib.nreads = 0 then			/* Are there no delimiters specified? */
	     do;					/* Yes. */
	     p -> pib.search_type = 0;		/* Set up dispatch code. */
	end;
	else
	if p -> pib.elsize > 9 then			/* Must we use packed array? */
	     do;					/* Yes. */
	     p -> pib.search_type = 3;		/* Remember dispatch code. */
	     substr (p -> pib.readlist, 1, total_bits) = substr (readlist, 1, total_bits); /* Copy the string. */
	end;
	else					/* Element size less than 9 bits. */
	do;					/* We may use bit table. */
	     p -> pib.search_type = 2;		/* Set dispatch code. */
	     p -> pib.readlist = ""b;			/* Clear the table. */
	     j = 0;				/* Set up index of first delimiter. */
	     do i = 1 to p -> pib.nreads;		/* Start copy loop. */
		byte = substr (readlist, j + 1, p -> pib.elsize); /* Extract the byte. */
		substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) = "1"b; /* Mark the table entry. */
		j = j + p -> pib.elsize;		/* Move index to next delimiter. */
	     end;
	end;
	go to good;				/* Give happy return. */
						/*  */
file_getdelim:
	entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);

	sp = addr (status6);			/* Get pointer to status string. */
	p = pibp1;				/* Copy pointer to control data. */
	nbreaks = 0;				/* We have no break characters. */
	go to get (p -> pib.search_type);		/* Dispatch on delimiter code. */

get (0): get_none:					/* Case of no delimiters. */
	nreads = 0;				/* Set caller's count. */
	go to good;				/* Return to caller. */

get (1): get_1_char:				/* Special case. */
	nreads = 1;				/* Give caller number of delimiters. */
	substr (readlist, 1, 9) = substr (p -> pib.readlist, 1, 9); /* Give caller the character. */
	go to good;				/* Return to caller. */

get (2): get_bit_table:				/* Case of 256-entry bit table. */
	base, j = 0;				/* Reset bit and byte indices. */
	do nreads = 0 by 1;				/* Count bytes returned. */
	     i = index (substr (p -> pib.readlist, base + 1), "1"b); /* Find next marked entry. */
	     if i = 0 then				/* No more? */
		go to good;			/* Return to caller. */
	     substr (readlist, j + 1, p -> pib.elsize) = bit (base + i - 1, 9); /* Form matching code. */
	     j = j + p -> pib.elsize;			/* Update output array index. */
	     base = base + i;			/* Update search base. */
	end;
	go to good;				/* Return to caller. */

get (3): get_packed:				/* Case of packed array of bytes. */
	nreads = p -> pib.nreads;			/* Give caller the number of read delimiters. */
	total_bits = p -> pib.nreads * p -> pib.elsize;	/* Compute number of bits required. */
	substr (readlist, 1, total_bits) = substr (p -> pib.readlist, 1, total_bits); /* Give them to caller. */
	go to good;				/* Give happy return. */
						/*  */
file_seek:
	entry (pibp1, ptrname2, ptrname3, offset4, status5);
dcl (ptrname2, ptrname3) character (*);
dcl  offset4 fixed binary (35);

	p = pibp1;
	sp = addr (status5);
	pointer_name = ptrname3;			/* Copy name of reference pointer. */
	call pointerdecode (pointer_name, ptrbit3, switch);
	if switch = 0 then				/* Was name recognizable? */
	     do;
	     code = error_table_$undefined_ptrname;	/* Unrecognizable ptrname3. */
	     go to bad;
	end;
	offset = add (ptrbit3, multiply (offset4, p -> pib.elsize, 35, 0), 35, 0); /* Compute new pointer value. */
	if offset < 0 then
	     do;
	     code = error_table_$new_offset_negative;	/* Resultant offset improper. */
	     go to bad;
	end;
	pointer_name = ptrname2;			/* Copy name of pointer to be set. */
	call pointerdecode (pointer_name, ptrbit2, switch);
	go to seek (switch);			/* Dispatch on pointer name. */

seek (0): seek_0:
	code = error_table_$undefined_ptrname;		/* Improper ptrname2. */
	go to bad;

seek (1): seek_first:
	code = error_table_$change_first;		/* Attempt to change value of first pointer. */
	go to bad;				/* Give error return. */

seek (2): seek_read:
	if ^ p -> pib.r then			/* Do we have read permission? */
	     do;					/* No. */
	     code = error_table_$invalid_read;		/* Set Error code. */
	     go to bad;				/* Give error return. */
	end;
	p -> pib.readbit = min (offset, p -> pib.lastbit);
	go to good;

seek (3): seek_write:
	if ^ p -> pib.w then			/* Do we have write permission? */
	     do;					/* No. */
	     code = error_table_$invalid_write;		/* Set error code. */
	     go to bad;				/* Give error return. */
	end;
	p -> pib.writebit = min (offset, p -> pib.lastbit);
	go to good;

seek (4): seek_last:
	if ^ p -> pib.w then			/* May we write on this file? */
	     do;					/* No. */
	     if offset > p -> pib.highbit then do;
		code = error_table_$invalid_seek_last_bound; /* Give error return. */
		go to bad;
	     end;
	     p -> pib.lastbit = offset;
	     go to good;
	end;
	p -> pib.lastbit = min (offset, p -> pib.boundbit);
	p -> pib.highbit = p -> pib.lastbit;
	go to truncate;

seek (5): seek_bound:
	if ^ p -> pib.w then			/* Do we have write permission? */
	     do;					/* No. */
	     code = error_table_$invalid_seek_last_bound; /* Give error return. */
	     go to bad;
	end;
	p -> pib.boundbit = offset;
	if p -> pib.lastbit > offset then		/* Does change to bound necessitate change to last? */
	     do;					/* Yes. */
	     p -> pib.lastbit = offset;		/* Perform necessary truncation. */
truncate:	     p -> pib.changed = "1"b;			/* Mark for later setting bit count. */
	end;
						/* Truncate read, write pointers if necessary. */
	p -> pib.readbit = min (p -> pib.readbit, p -> pib.lastbit);
	p -> pib.writebit = min (p -> pib.writebit, p -> pib.lastbit);
	go to good;
						/*  */
file_tell:
	entry (pibp1, ptrname2, ptrname3, offset4, status5);

	p = pibp1;
	sp = addr (status5);
	pointer_name = ptrname3;			/* Copy name of reference pointer. */
	call pointerdecode (pointer_name, ptrbit3, switch);
	if switch = 0 then				/* Was name recognizable? */
	     do;
	     code = error_table_$undefined_ptrname;	/* Unrecognizable ptrname3. */
	     go to bad;				/* Give error return. */
	end;
	pointer_name = ptrname2;			/* Copy name of pointer whose value is wanted. */
	call pointerdecode (pointer_name, ptrbit2, switch);
	if switch = 0 then				/* Was name recognizable? */
	     do;
	     code = error_table_$undefined_ptrname;	/* Unrecognizable ptrname2. */
	     go to bad;				/* Give error return. */
	end;
	offset4 = divide (add (ptrbit2, - ptrbit3, 35, 0), p -> pib.elsize, 35, 0);
	go to good;
						/*  */
set_detached_bit:
	sp -> status.ioname_detached = "1"b;		/* Indicate detachment. */
bad:	sp -> status.code = code;
	go to done;

good:	sp -> status.successful = "1111"b;		/* Indicate initiation/termination. */
	sp -> status.code = 0;			/* set return code to zero */
done:	sp -> status.transaction_terminated = "1"b;	/* Indicate we are done. */
	if sp -> status.ioname_detached then		/* Was this a detach call? */
	     return;
	if p -> pib.readbit >= p -> pib.lastbit then
	     sp -> status.end_of_data = "1"b;		/* Set EOF indicator. */
	return;					/* Return to caller. */
						/*  */
pointerdecode:					/* Procedure to decode pointer name. */
	procedure (pointername, pointerbit, switch);	/* Returns pointer value and dispatch index. */
dcl  pointername character (8) aligned;			/* Symbolic pointer name. */
dcl  pointerbit fixed binary (35);			/* Returned value of the pointer. */
dcl  switch fixed binary;				/* Label index. */

	     if pointername = "first   " then
		do;
		pointerbit = 0;
		switch = 1;
	     end;
	     else
	     if pointername = "read    " then
		do;
		pointerbit = p -> pib.readbit;
		switch = 2;
	     end;
	     else
	     if pointername = "write   " then
		do;
		call round (p -> pib.writebit);	/* Round write pointer to integral element. */
		pointerbit = p -> pib.writebit;
		switch = 3;
	     end;
	     else
	     if pointername = "last    " then
		do;
		call round (p -> pib.lastbit);	/* Round last pointer to integral elements. */
		pointerbit = p -> pib.lastbit;
		switch = 4;
	     end;
	     else
	     if pointername = "bound   " then
		do;
		pointerbit = p -> pib.boundbit;
		switch = 5;
	     end;
	     else
	     pointerbit, switch = 0;
	end pointerdecode;				/* Return to caller. */
						/*  */
round:	procedure (offset);				/* Procedure to round subject to upper limit. */
dcl  offset fixed binary (35);			/* Bit offset in file. */
dcl (overage, underage) fixed binary (24);		/* Element size and errors. */

	     overage = mod (offset, p -> pib.elsize);	/* Calculate amount of offset over integral elements. */
	     if overage ^= 0 then			/* If zero, we are OK. */
		do;
		underage = p -> pib.elsize - overage;	/* Get amount of increase necessary. */
		if add (infinity, - offset, 35, 0) >= underage then /* Is there room for increase? */
		     offset = add (offset, underage, 35, 0); /* Yes, round up. */
		else
		offset = add (offset, - overage, 35, 0); /* No, truncate down. */
	     end;
	end round;
     end file;




		    file_.alm                       11/11/89  1133.6r w 11/11/89  0800.7       11781



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	Outer Module Transfer Vector for the file outer module.

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

	tra	<file>|[file_attach]
	tra	<file>|[file_detach]
	tra	<file>|[file_read]
	tra	<file>|[file_write]
	tra	<ios_>|[no_entry]
	tra	<file>|[file_order]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<file>|[file_setsize]
	tra	<file>|[file_getsize]
	tra	<file>|[file_setdelim]
	tra	<file>|[file_getdelim]
	tra	<file>|[file_seek]
	tra	<file>|[file_tell]
	tra	<ios_>|[no_entry]
	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




		    file_util.pl1                   11/11/89  1133.6r w 11/11/89  0800.7      116901



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


file_util: procedure;				/* File System Interface Module utility procedures. */

/* Modified 13 August 1972, M J Grady - Honeywell. */
/* Modified July 1973 by E. Stone to work both for 64k and 256k MSFs */
/* Modified 750915 by PG to be able to attach to branches with many names */

dcl  code2 fixed binary (35);				/* Error code (returned). */
dcl  pibp pointer;					/* Pointer to file control block. */
dcl  ap pointer;					/* Temporary pointer. */
dcl  b36 (0: 1) based fixed binary (35);		/* Overlay to access thirtysix-bit elements (words). */
dcl  bit_count fixed binary (24);			/* Bits in segment or segments in directory. */
dcl  bits_per_seg fixed bin (24);
dcl  dname based character (168) aligned;		/* Overlay for directory path name. */
dcl  ename based character (32) aligned;		/* Overlay for entry name. */
dcl  entry character (32) aligned;			/* Temporary for lower level entry name. */
dcl  ep pointer;					/* Pointer to entry structure. */
dcl  error_table_$bad_ms_file external fixed binary (35);
dcl  error_table_$moderr external fixed binary (35);	/* File system error codes. */
dcl  error_table_$noentry external fixed binary (35);
dcl  error_table_$toomanylinks external fixed binary (35);
dcl  error_table_$seg_unknown external fixed bin (35);
dcl  i fixed bin;					/* Index. */
dcl  infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */
dcl  kind fixed binary (2);				/* Entry type. */
dcl  max_length fixed bin (19);			/* max length of component in words */
dcl  msf_sw bit (3) aligned;				/* bit switch for msf_manager_$adjust. */
dcl  n fixed bin;					/* Temporary length. */
dcl  p pointer;					/* Pointer to file control block. */
dcl  path character (168) aligned;			/* Aligned storage for path name. */
dcl  suffix fixed binary;				/* Suffix of desired segment. */
dcl  sys_info$max_seg_size ext fixed bin (19);		/* system maximum segment size in words */
dcl  expand_path_ entry (pointer, fixed binary, pointer, pointer, fixed binary (35));
dcl  hcs_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (19), fixed bin (35));
dcl  hcs_$status_long entry (character (*) aligned, character (*) aligned, fixed binary (1), pointer,
     pointer, fixed binary (35));
dcl  hcs_$status_minf entry (character (*) aligned, character (*) aligned, fixed binary (1),
     fixed binary (2), fixed binary (24), fixed binary (35));
dcl  ioa_$rsnnl entry options (variable);		/* Variable argument list. */
dcl  msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)),
     msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)),
     msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3) aligned, fixed bin (35)),
     msf_manager_$close entry (ptr);

dcl (addr, baseno, baseptr, bit, divide, fixed, empty, mod, null, substr) builtin;

dcl 1 branch,					/* Branch structure filled by status_long. */
    2 ((dir, seg) bit (1), nnames bit (16), nrp bit (18)),	/* Type, number of names, pointer to names. */
    2 dtm bit (36),					/* Date-time segment modified. */
    2 dtu bit (36),					/* Date-time used. */
    2 ((t, r, e, w, a) bit (1), pad1 bit (13), records bit (18)), /* Mode, number of records. */
    2 dtd bit (36),					/* Date-time dumped. */
    2 dtem bit (36),				/* Date-time entry modified. */
    2 acct bit (36),				/* Account ID. */
    2 (curlen bit (12), bit_count bit (24)),		/* Current length, bit count. */
    2 ((did, mdid) bit (4), copysw bit (1), pad2 bit (9), rb (3) bit (6)), /* Dev. ID's, copy sw., rings. */
    2 uid bit (36);					/* Unique ID. */

/* Single element from file control block. */
% include file_pib;
dcl 1 seg1 based aligned,				/* Overlay for word of ring memory. */
    2 (no bit (18), used bit (1), key bit (17)) unaligned;
						/*  */
file_util$attach_file:				/* Entry to attach file */
	entry (pibp, code2);
	p = pibp;					/* Copy pointer to file control block. */
	ap = addr (p -> pib.device_name.name_string);	/* Get pointer to input string. */
	n = p -> pib.device_name.name_size;		/* Compute total number of characters. */
	ep = addr (branch);				/* Get pointer to branch structure. */
	call expand_path_ (ap, n, addr (p -> pib.dir_name), addr (p -> pib.entry_name), code2);
	if code2 ^= 0 then				/* Error in path name? */
	     do;					/* Yes. */
	     p -> pib.call = 1;			/* Mark place of failure. */
	     return;				/* Give error return. */
	end;
	call hcs_$status_long (p -> pib.dir_name, p -> pib.entry_name, 1, ep, null, code2);
	if code2 ^= 0 then				/* Some error? */
	     do;					/* Yes. */
	     if code2 = error_table_$noentry then	/* Is the entry missing? */
		if p -> pib.w then			/* Can we create it? */
		     do;				/* Yes. */
		     p -> pib.level = ""b;		/* File is at top level. */
						/* Initialize actual length. */
		     p -> pib.writebit, p -> pib.lastbit = 0;
		     p -> pib.bits_per_segment = sys_info$max_seg_size * 36;
		     go to attach_common;		/* Go do common stuff. */
		end;
	     p -> pib.call = 2;			/* Mark point of failure. */
	     return;				/* Call foul. */
	end;
	if branch.seg then				/* Is the entry a segment? */
	     do;					/* Yes. */
						/* Check for requested mode. */
	     if ^ branch.r & p -> pib.r | ^ branch.w & p -> pib.w then
		do;				/* No. */
		code2 = error_table_$moderr;		/* Report discrepancy. */
		return;
	     end;
	     p -> pib.level = ""b;			/* File is at upper level. */
						/* Set write, last pointers according to bit count. */
	     p -> pib.writebit, p -> pib.lastbit = fixed (branch.bit_count, 35);
	     call hcs_$get_max_length (p -> pib.dir_name, p -> pib.entry_name, max_length, code2);
	     if code2 ^= 0 then do;
		p -> pib.call = 3;
		return;
	     end;
	     p -> pib.bits_per_segment = max_length * 36;
	     go to attach_common;			/* Go set other initial values. */
	end;
	if branch.dir then				/* Is the entry a directory? */
	     do;					/* Yes. */
	     suffix = fixed (branch.bit_count, 24) - 1;	/* Get suffix of last segment. */
	     if suffix < 0 then			/* Was "bit count" zero? */
		do;				/* Yes. */
		suffix = 0;			/* Set number of complete segments to zero. */
		go to attach_length_zero;		/* Continue attach of zero-length file. */
	     end;
	     call create_lower_level_names (null, suffix, addr (path), addr (entry));
						/* Examine statistics. */
	     call hcs_$status_minf (path, entry, 0, kind, bit_count, code2);
	     if code2 ^= 0 then			/* Successful? */
		do;				/* No. */
		if code2 = error_table_$noentry then	/* Is segment missing? */
		     if p -> pib.w then		/* May we create it? */
			do;			/* Yes. */
attach_length_zero:		bit_count = 0;		/* Assume zero bits in this segment. */
			max_length = sys_info$max_seg_size; /* And system maximum for max length */
			go to attach_lower_level;	/* Go compute total bit count. */
		     end;
		p -> pib.call = 4;			/* Mark point of failure. */
		return;				/* Reflect error. */
	     end;
	     if kind ^= 1 then			/* Is this a segment? */
		do;				/* No. */
		code2 = error_table_$bad_ms_file;	/* Set error code. */
		return;				/* Give error return. */
	     end;
	     call hcs_$get_max_length (path, entry, max_length, code2);
	     if code2 ^= 0 then do;
		p -> pib.call = 5;
		return;
	     end;
attach_lower_level: p -> pib.level = "1"b;		/* File is at lower level. */
						/* Set up current size. */
	     p -> pib.bits_per_segment = max_length * 36;
	     p -> pib.writebit, p -> pib.lastbit = p -> pib.bits_per_segment * suffix + bit_count;
	     go to attach_common;			/* Do common initialization. */
	end;
	code2 = error_table_$toomanylinks;
	return;

attach_common:					/* Some of this initialization should be moved to caller. */
	p -> pib.changed = ""b;			/* Mark bit count as as yet unchanged. */
	p -> pib.elsize = 9;			/* Default size is one character. */
	p -> pib.readbit = 0;			/* Begin reading from beginning. */
	p -> pib.highbit = p -> pib.lastbit;
	p -> pib.boundbit = infinity - mod (infinity, 9); /* Default bound is 2 .P. 35 - 1. */
	p -> pib.lastcomp = -1;			/* init lastcomp to null */
	p -> pib.lastseg = null;			/* init ptr null too */
	ap = addr (p -> pib.seg);			/* Get pointer to ring memory. */
	do i = 0 to 9;				/* Initialize each element. */
	     ap -> b36 (i) = 011111111111111111b;	/* Not used, null key. */
	end;
	p -> pib.search_type = 1;			/* Special case of delimiter search. */
	p -> pib.nreads = 1;			/* Default is one read delimiter.. */
	substr (p -> pib.readlist, 1, 9) = "000001010"b;	/* .. a new-line character. */

	call msf_manager_$open (p -> pib.dir_name, p -> pib.entry_name, p -> pib.fcb_ptr,
	     code2);
	if code2 = error_table_$noentry then code2 = 0;

	return;					/* Return to caller. */
						/*  */
file_util$detach_file:				/* Entry to detach file. */
	entry (pibp, code2);			/* Returns IO system formatted codes. */
	p = pibp;					/* Copy pointer to control data. */
	bits_per_seg = p -> pib.bits_per_segment;
	suffix = divide (p -> pib.lastbit, bits_per_seg, 17, 0); /* calc number of last segment. */
	bit_count = mod (p -> pib.lastbit, bits_per_seg); /* bit count for last seg */
	msf_sw = p -> pib.changed || p -> pib.changed || "1"b; /* this switch controls $adjust */

	call msf_manager_$adjust (p -> pib.fcb_ptr, suffix, bit_count, msf_sw, code2);
						/* call to adjust last bit count and terminate all segs */
	if code2 ^= 0 then
	     if code2 ^= error_table_$seg_unknown
	     & code2 ^= error_table_$noentry then return;

	call msf_manager_$close (p -> pib.fcb_ptr);
	p -> pib.fcb_ptr = null;

	code2 = 0;				/* Detach successful. */
	return;					/* Return to caller. */
						/*  */
find_seg_ptr:					/* Entry to get pointer to segment. */
	entry (pibp, bv_can_create, which, seg, code5);	/* Returns raw codes. */

/* parameters */

dcl  bv_can_create bit (1) aligned parameter;		/* ON if missing component can be created */
dcl  which fixed binary;				/* Number of desired segment in file. */
dcl  seg pointer;					/* Pointer to segment (returned). */
dcl  code5 fixed binary (35);				/* Error code (returned). */

	p = pibp;					/* Copy pointer to control block. */
	i = mod (which, 10);			/* Look in the ring memory. */
	ap = addr (p -> pib.seg (i));			/* Get pointer to appropriate word. */
	if ^ap -> seg1.used then goto skip_ck;		/* Is this entry in use? */
	if fixed (ap -> seg1.key, 17) = which then	/* Is this it? */
	     do;					/* Yes. */
	     seg = baseptr (ap -> seg1.no);		/* Make up pointer to segment. */
	     go to have_seg;			/* Give normal return. */
	end;
skip_ck:						/* Call msf_manager_ to get ptr to component */

	call msf_manager_$get_ptr (p -> pib.fcb_ptr, which, (bv_can_create & p -> pib.w), seg, bit_count, code5);
	if seg = null then return;			/* Return with code5 set to reason */

	ap = addr (p -> pib.seg (i));
	ap -> seg1.no = baseno (seg);
	ap -> seg1.key = bit (which, 17);

/* set entry in ring memory */

have_seg:	ap -> seg1.used = "1"b;			/* Indicate recent use of this segment. */
	code5 = 0;				/* No error: clear code. */
	return;					/* Return to caller. */
						/*  */
create_lower_level_names:				/* Procedure to make up names of "multi"-segments. */
	procedure (enp1, suffix, path, entry);
dcl  enp1 pointer,					/* Pointer to entry name to append to directory name. */
     suffix fixed binary,				/* Suffix desired on entry name. */
    (path,					/* Pointer to storage for directory path name. */
     entry) pointer,				/* Pointer to storage for entry name. */
     n fixed bin,					/* Length of resultant string (ignored). */
     enp pointer;					/* Pointer to entry name in control block. */

	     if path ^= null then			/* Is directory path name wanted? */
		do;				/* Yes. */
		enp = enp1;			/* Copy pointer to desired entry name. */
		if enp = null then			/* If none, use entry name in control block. */
		     enp = addr (p -> pib.entry_name);	/* .. */
		if substr (p -> pib.dir_name, 1, 4) = ">   " then /* Is it the root directory? */
		     call ioa_$rsnnl (">^a", path -> dname, n, enp -> ename);
		else
		call ioa_$rsnnl ("^a>^a", path -> dname, n, p -> pib.dir_name, enp -> ename);
	     end;
	     if entry ^= null then			/* Is entry name desired? */
		call ioa_$rsnnl ("^d", entry -> ename, n, suffix);
	end create_lower_level_names;			/* Return to caller. */
     end file_util;




		    make_msf_.pl1                   11/11/89  1133.6r w 11/11/89  0800.0      177795



/****^  ***********************************************************
        *                                                         *
        * 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: style2,ind3 */
make_msf_:
   proc (dirname_arg, ename_arg, rbs, code);

/* Modified July 1973 by E. Stone to work for both 64k and 256k MSFs */
/* Modified Jan 1976 by Vinograd to work if linkage error on delete_ (for ring 1 reload) */
/* Modified 7/26/77 by M. Asherman to respect safety_sw on msf components
   by not allowing reversion to ssf in this case */
/* Modified 05/05/78 by C. D. Tavares to use hcs_$create_branch_, propagating
   safety_sw, copy_sw, and priv_upgrade_sw, on SSF -> MSF and MSF -> SSF */
/* Modified 01/09/78 by CDT to set extended ring brackets on dir portion
   of MSF to match ring brackets of components */
/* Modified 11/26/80 W. Olin Sibert to use automatic area for status_long names because of extensible area problem */
/* Modified:

01/25/82 by Lindsey Spratt: to create an MSF when no SSF exists.  Also,
	  changed to always add status permission to *.*.* on the directory
	  portion of the MSF.
03/24/82 by Lindsey Spratt: Changed error code analysis following call
	  of get_link_target.
06/24/82 by Lindsey Spratt: Changed to use access_mode_values include file.
12/27/84 by Keith Loepere: Version 2 create_branch_info.
02/05/85 by Steve Herbst: Changed to set "s *.*.*" only if there is not already
	  a *.*.* entry on the ACL.
*/

      dcl	    (
	    dirname_arg	       char (*),
	    ename_arg	       char (*),
	    rbs		       (3) fixed bin (6),	/* really an output arg??? */
	    code		       fixed bin (35)
	    )		       parameter;

/* automatic */

      dcl	    acl_count	       fixed bin,
	    aclp		       ptr init (null),
	    acl_area_ptr	       pointer,
	    copysw	       bit (1),
	    cur_ring	       fixed bin,
	    dac		       fixed bin,
	    dap		       ptr init (null),
	    dir_rings	       (2) fixed bin (6),
	    dirname	       char (168),
	    ename		       char (32),
	    (i, ii)	       fixed bin,
	    known		       bit (1) aligned,
	    max_length	       fixed bin (19),
	    path		       char (168),
	    remember_ptr	       ptr,
	    safety_sw	       bit (1) aligned,
	    star_star_sw	       bit (1) aligned,
	    temp_acc	       bit (72) aligned,
	    component_0_existed    bit (1) aligned,
	    SSF_existed	       bit (1) aligned,
	    unique	       char (32),
	    unique_dir	       char (168);

/* This area is used to hold the nams returned by hcs_$status_long. Because it is automatic, things need
   not ever be freed from it. It must be used because hcs_$status_ and extensible areas do not interact
   at all well, due to the 18 bit rel ptrs in the status return structure. 
   It has room for 500 names, which I trust will be sufficient.
   */

      dcl	    names_area	       area (2000) automatic;

/* static */

      dcl	    sys_areap	       pointer internal static initial (null);

/* based */

      dcl	    free_area	       area based (sys_areap);

/* external static */

      dcl	    (
	    error_table_$safety_sw_on,
	    error_table_$noentry,
	    error_table_$segknown
	    )		       ext fixed bin (35) static;

/* entries */

      dcl	    cu_$level_get	       entry returns (fixed bin),
	    delete_$path	       entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
	    get_group_id_$tag_star entry returns (char (32)),
	    get_system_free_area_  entry returns (ptr),
	    get_authorization_     entry () returns (bit (72) aligned),
	    hcs_$add_acl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
	    hcs_$add_dir_acl_entries
			       entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
	    hcs_$add_inacl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin, fixed bin (35)),
	    hcs_$append_branch     entry (char (*), char (*), fixed bin (5), fixed bin (35)),
	    hcs_$append_branchx    entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1),
			       fixed bin (1), fixed bin (24), fixed bin (35)),
	    hcs_$chname_file       entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	    hcs_$create_branch_    ext entry (char (*), char (*), pointer, fixed bin (35)),
	    hcs_$delentry_file     entry (char (*), char (*), fixed bin (35)),
	    hcs_$fs_move_file      entry (char (*), char (*), fixed bin (2), char (*), char (*), fixed bin (35)),
	    hcs_$get_access_class  ext entry (char (*), char (*), bit (72) aligned, fixed bin (35)),
	    hcs_$get_link_target   entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	    hcs_$get_max_length_seg
			       entry (ptr, fixed bin (19), fixed bin (35)),
	    hcs_$get_safety_sw     entry (char (*), char (*), bit (1) aligned, fixed bin (35)),
	    hcs_$get_safety_sw_seg entry (ptr, bit (1) aligned, fixed bin (35)),
	    hcs_$initiate	       entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
			       fixed bin (35)),
	    hcs_$initiate_count    entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
			       fixed bin (35)),
	    hcs_$list_acl	       entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)),
	    hcs_$list_inacl	       entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)),
	    hcs_$set_bc	       entry (char (*), char (*), fixed bin (24), fixed bin (35)),
	    hcs_$set_dir_ring_brackets
			       entry (char (*), char (*), (2) fixed bin (6), fixed bin (35)),
	    hcs_$set_max_length    entry (char (*), char (*), fixed bin (19), fixed bin (35)),
	    hcs_$set_safety_sw     ext entry (char (*), char (*), bit (1) aligned, fixed bin (35)),
	    hcs_$status_long       entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)),
	    hcs_$terminate_file    entry (char (*), char (*), fixed bin (1), fixed bin (35)),
	    unique_chars_	       entry (bit (*)) returns (char (15));

/* builtins and conditions */

      dcl	    (addr, binary, empty, max, null, pointer, prod, rtrim, substr, unspec)
			       builtin;

      dcl	    (cleanup, linkage_error)
			       condition;

/* structures */

      dcl	    1 s_acl	       (acl_count) based (aclp) aligned,
	      2 userid	       char (32),
	      2 mode	       bit (4) unaligned,
	      2 mbz1	       bit (32) unaligned,
	      2 mbz2	       bit (36),
	      2 err_code	       fixed bin (35);

      dcl	    1 d_acl	       (dac) based (dap) aligned,
	      2 userid	       char (32),
	      2 mode	       bit (3) unaligned,
	      2 mbz1	       bit (33) unaligned,
	      2 err_code	       fixed bin (35);

%include create_branch_info;

      dcl	    1 cbi		       like create_branch_info aligned automatic;

%include status_structures;
%include access_mode_values;

      dcl	    1 branch	       like status_branch aligned automatic;

      unspec (cbi) = ""b;
      cbi.version = create_branch_version_2;
      cbi.chase_sw = "1"b;

      if sys_areap = null
      then sys_areap = get_system_free_area_ ();
      status_area_ptr = addr (names_area);
      acl_area_ptr = sys_areap;
      status_ptr = addr (branch);
      unspec (branch) = ""b;

      on cleanup call free_allocated_storage;

      call hcs_$get_link_target (dirname_arg, ename_arg, dirname, ename, code);
						/* get real path name */
      if code = 0
      then
         do;
	  SSF_existed = "1"b;
	  call hcs_$initiate_count (dirname, ename, "", cbi.bitcnt, 0, remember_ptr, code);
						/* find out about seg */

	  if code = 0
	  then known = "0"b;
	  else if code = error_table_$segknown
	  then known = "1"b;
	  else goto error_return;
         end;
      else if code = error_table_$noentry
      then
         do;
	  dirname = dirname_arg;
	  ename = ename_arg;
	  SSF_existed = "0"b;
	  known = "0"b;
         end;
      else goto error_return;

      cur_ring = cu_$level_get ();

      if SSF_existed
      then
         do;
	  call hcs_$status_long (dirname, ename, 1, status_ptr, status_area_ptr, code);
						/* do status get names	*/
	  if code ^= 0
	  then go to error_return;


	  rbs (*) = branch.ring_brackets (*);
	  cbi.rings (*) = branch.ring_brackets (*);
	  cbi.mode = substr (branch.raw_mode, 2, 3);
	  cbi.userid = get_group_id_$tag_star ();
	  cbi.copy_sw = branch.copy_switch;		/* who are we to judge?? */
         end;
      else
         do;
	  rbs (*) = cur_ring;
	  cbi.rings (*) = rbs (*);
	  cbi.mode = SMA_ACCESS;
	  cbi.userid = get_group_id_$tag_star ();
	  cbi.copy_sw = "0"b;
         end;

      if SSF_existed
      then
         do;
	  call hcs_$get_safety_sw (dirname, ename, safety_sw, code);
	  if code ^= 0
	  then goto error_return;
         end;
      else safety_sw = "0"b;

      if SSF_existed
      then
         do;
	  call hcs_$get_access_class (dirname, ename, cbi.access_class, code);
	  if code ^= 0
	  then goto error_return;
         end;
      else cbi.access_class = get_authorization_ ();
      if prod (cbi.rings) = 1 & SSF_existed
      then
         do;					/* ring brackets are 1, 1, 1 */
	  call hcs_$get_access_class (dirname, "", temp_acc, code);
	  if code = 0
	  then if temp_acc ^= cbi.access_class
	       then cbi.priv_upgrade_sw = "1"b;
         end;

      cbi.parent_ac_sw = ^cbi.priv_upgrade_sw;

/* DRV - get volume backup switch from SSF here */

      if SSF_existed
      then
         do;
	  call hcs_$list_acl (dirname, ename, acl_area_ptr, aclp, null, acl_count, code);
						/* get acl on segment */
	  if code ^= 0
	  then
	     do;
	        acl_count = 0;
	        if aclp ^= null
	        then free s_acl in (free_area);
	     end;
         end;
      else
         do;
	  call hcs_$list_inacl (dirname, "", acl_area_ptr, aclp, null, acl_count, cur_ring, code);
	  if code ^= 0
	  then
	     do;
	        acl_count = 0;
	        if aclp ^= null
	        then free s_acl in (free_area);
	     end;
         end;
      if SSF_existed
      then unique = unique_chars_ (""b);		/* make up a unique name */
      else unique = ename;
      unique_dir = rtrim (dirname, " ") || ">" || unique;


      call hcs_$append_branchx (dirname, unique, 01111b, (7), (cbi.userid), 1, 0, 1, code);
						/* make a directory */
      if code ^= 0
      then go to error_return;


      call hcs_$add_inacl_entries (dirname, unique, aclp, acl_count, cur_ring, code);
						/* put seg acl on initial acl */

      dac = acl_count + 1;				/* set to make dir acl */
      allocate d_acl in (free_area) set (dap);		/* allocate room for it */

      star_star_sw = "0"b;
      do ii = 1 to dac - 1;				/* convert acl to dir acl */
         d_acl (ii).userid = s_acl (ii).userid;		/* copy user name */
         if d_acl (ii).userid = "*.*.*" then do;
	  star_star_sw = "1"b;
	  d_acl (ii).mode = d_acl (ii).mode | "100"b;	/* need at least s access to *.*.*    */
         end;
         substr (d_acl (ii).mode, 1, 1) = substr (s_acl (ii).mode, 1, 1);
						/* copy mode bits */
         substr (d_acl (ii).mode, 2, 1) = substr (s_acl (ii).mode, 3, 1);
         substr (d_acl (ii).mode, 3, 1) = substr (s_acl (ii).mode, 3, 1);
         d_acl (ii).mbz1 = "0"b;
      end;

      if ^star_star_sw then do;			/* add "s *.*.*" if not already a *.*.* entry */
         d_acl (dac).userid = "*.*.*";
         d_acl (dac).mode = "100"b;
         d_acl (dac).mbz1 = "0"b;
      end;
      else dac = dac - 1;

      call hcs_$add_dir_acl_entries (dirname, unique, dap, dac, code);

      free d_acl in (free_area);
      free s_acl in (free_area);


      call hcs_$set_safety_sw (dirname, unique, safety_sw, code);
      if code ^= 0
      then goto error_return;

      dir_rings (1) = cbi.rings (1);
      dir_rings (2) = cbi.rings (3);
      call hcs_$set_dir_ring_brackets (dirname, unique, dir_rings, code);
      if code ^= 0
      then goto error_return;

      call hcs_$create_branch_ (unique_dir, "0", addr (cbi), code);
						/* create component "0" */
      if code ^= 0
      then
         do;					/* if can't do it 	*/
del_dir:
	  call hcs_$delentry_file (dirname, unique, 0);	/* delete the unique directory */
	  go to error_return;			/* give up */
         end;

      if SSF_existed
      then
         do;
	  call hcs_$get_max_length_seg (remember_ptr, max_length, code);
						/* Get the max length of the SSF. */
	  if code ^= 0
	  then go to del_zero;			/* Cleanup - delete component zero and the directory. */

	  call hcs_$set_max_length (unique_dir, "0", max_length, code);
						/* Set the max length of component zero. */
	  if code ^= 0
	  then go to del_zero;			/* Cleanup */

/* DRV - set component volume backup switch here */

	  call hcs_$fs_move_file (dirname, ename, 0, unique_dir, "0", code);
						/* move the SSF into component zero */
	  if code ^= 0
	  then
	     do;					/* if can't do it 	*/
del_zero:
	        call hcs_$delentry_file (unique_dir, "0", 0);
						/* delete the component zero, don't save code */
	        go to del_dir;			/* and delete the directory, and give up */
	     end;

	  call hcs_$terminate_file (dirname, ename, binary (known, 1), code);
						/* terminate the SSF, saving the segno if
						   it was known */
	  if code ^= 0
	  then go to error_return;

/* If reloading in ring 1, delete_ may not be found. If so try deleting with hcs */
	  on condition (linkage_error)
	     begin;
	        call hcs_$delentry_file (dirname, ename, code);
	        goto revert_it;
	     end;
	  call delete_$path (dirname, ename, "100111"b, "", code);
						/* delete the SSF */
revert_it:
	  revert linkage_error;
	  if code ^= 0
	  then go to error_return;

	  if known
	  then
	     do;					/* if it was known */
	        call hcs_$initiate (unique_dir, "0", "", 1, 0, remember_ptr, code);
						/* initiate new on with old segno */
	        if code ^= 0
	        then go to error_return;
	     end;

	  do i = 1 to branch.nnames;			/* add all the names */
	     call hcs_$chname_file (dirname, unique, "", (status_entry_names (i)), code);
	     if code ^= 0
	     then go to error_return;
	  end;

	  call hcs_$chname_file (dirname, unique, unique, "", code);
						/* delete the unique name */

         end;
      call hcs_$set_bc (dirname, ename, 1, code);		/* remember that we have one already in MSF */

      go to return_statement;

/*  Entry unmake_msf takes MSF path, and makes component zero
   if it exists into an SSF with the same name.  Otherwise,
   it leaves a new, zero length segment, after deleting the MSF.  */

unmake_msf_:
   entry (dirname_arg, ename_arg, copysw, rbs, code);

      cur_ring = cu_$level_get ();

      unspec (cbi) = ""b;
      cbi.version = create_branch_version_2;
      cbi.chase_sw = "1"b;
      cbi.parent_ac_sw = "1"b;			/* for now */
      cbi.rings = cur_ring;
      cbi.userid = get_group_id_$tag_star ();
      cbi.mode = "101"b;

      if sys_areap = null
      then sys_areap = get_system_free_area_ ();
      status_area_ptr = addr (names_area);
      acl_area_ptr = sys_areap;
      unspec (branch) = ""b;
      status_ptr = addr (branch);

      on cleanup call free_allocated_storage;

      call hcs_$get_link_target (dirname_arg, ename_arg, dirname, ename, code);
						/* get real path name */
      if code ^= 0
      then go to error_return;

      path = rtrim (dirname, " ") || ">" || ename;

      call hcs_$initiate_count (path, "0", "", cbi.bitcnt, 0, remember_ptr, code);
						/* see about component zero */

      if code ^= 0
      then if code ^= error_table_$segknown
	 then
	    do;
	       component_0_existed = "0"b;		/* not there */
	       known = "0"b;
	       cbi.bitcnt = 0;			/* zero bitcount */
	    end;
	 else
	    do;
	       component_0_existed = "1"b;		/* did exist */
	       known = "1"b;			/* and was known in the process */
	    end;
      else
         do;
	  component_0_existed = "1"b;			/* existed */
	  known = "0"b;				/* but wasn't known */
         end;

      if component_0_existed				/* component zero exists */
      then
         do;					/* make sure safety_sw is off */
	  call hcs_$get_safety_sw_seg (remember_ptr, safety_sw, code);
	  if code = 0
	  then if safety_sw				/* mustn't delete msf components */
	       then code = error_table_$safety_sw_on;
	  if code ^= 0				/* error has occurred */
	  then go to error_return;			/* abort */

	  call hcs_$get_access_class (path, "0", cbi.access_class, code);
	  if code ^= 0
	  then goto error_return;

	  call hcs_$get_access_class (path, "", temp_acc, code);
	  if code ^= 0
	  then goto error_return;

	  if cbi.access_class ^= temp_acc
	  then cbi.priv_upgrade_sw = "1"b;
	  cbi.parent_ac_sw = ^cbi.priv_upgrade_sw;

/* DRV - get volume backup switch from component 0 here */

         end;

      call hcs_$list_inacl (dirname, ename, acl_area_ptr, aclp, null, acl_count, cur_ring, code);
						/* get initial acl */

      call hcs_$status_long (dirname, ename, 1, addr (branch), status_area_ptr, code);
						/* find out names */
      if code ^= 0
      then go to error_return;

      unique = unique_chars_ (""b);			/* make up a unique name */

      call hcs_$create_branch_ (dirname, unique, addr (cbi), code);
      if code ^= 0
      then go to error_return;

      call hcs_$add_acl_entries (dirname, unique, aclp, acl_count, code);
						/* put initial acl back on again */

      if component_0_existed
      then
         do;					/* if comp. 0 used to exist */
	  call hcs_$get_max_length_seg (remember_ptr, max_length, code);
	  if code ^= 0
	  then go to del_comp;			/* Get max length of comp. 0. */

	  call hcs_$set_max_length (dirname, unique, max_length, code);
	  if code ^= 0
	  then go to del_comp;			/* Transfer max length of comp. 0 to SSF. */


	  if copysw
	  then
	     do;					/* We want to save contents of comp. 0. */
	        call hcs_$fs_move_file (path, "0", 0, dirname, unique, code);
						/* move the old one into the new */
	        if code ^= 0
	        then
		 do;				/* error and recovery */
del_comp:
		    call hcs_$delentry_file (dirname, unique, 0);
		    go to error_return;
		 end;

	     end;

/* DRV - set SSF volume backup switch here */

         end;

      call delete_$path (dirname, ename, "100111"b, "", code);
						/* delete the old MSF */
      if code ^= 0
      then go to error_return;

      do i = 1 to branch.nnames;			/* move in old names */
         call hcs_$chname_file (dirname, unique, "", (status_entry_names (i)), code);
         if code ^= 0
         then go to error_return;
      end;

      call hcs_$chname_file (dirname, unique, unique, "", code);
						/* delete unique name */

      if known
      then
         do;					/* if it was known */
	  call hcs_$initiate (dirname, ename, "", 1, 0, remember_ptr, code);
						/* initiate with old segno */
	  if code ^= 0
	  then go to error_return;
         end;



return_statement:
error_return:
      call free_allocated_storage;

      return;

/*  Internal proc free_allocated_storage looks at all the pointers used by this
						   subroutine to point to free storage, and frees everything that
						   hasn't been freed yet.  */

free_allocated_storage:
   proc;

      if aclp ^= null
      then free s_acl in (free_area);

      if dap ^= null
      then free d_acl in (free_area);

      return;

   end free_allocated_storage;

   end make_msf_;




		    msf_manager_.pl1                11/11/89  1133.6r w 11/11/89  0800.0      444294



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


/* msf_manager_ manipulates multi-segment files.

   It uses file control blocks, created by the open entry.
   */


/****^  HISTORY COMMENTS:
  1) change(83-12-20,Margolin), approve(), audit(), install():
     pre-hcom comments:
     Initially coded May 1972 by Dan Bricklin.
     Modified July 1973 by E. Stone to work for both 64k and 256k MSFs
     to terminate MSFs completely, and to save the bitcount in the adjust entry
     
     Modified April 1974 by E. Stone to add the acl_delete and acl_add entries
     to remove the obsolete entries list_acl and replace_acl which depended on CACLS
     
     Modified by Kobziar on 7-10-74 to have the acl commands change the msf dir acl last
     
     Modified 9/6/75 by Steve Herbst to chase links and store link target in fcb
     
     Modified 6/21/77 by M. Asherman to call hcs_$initiate and initiate_count with
     proper setting of the copy_ctl_sw argument
     
     Modified 7/26/77 by M. Asherman to honor setting of safety_switch on msf
     by not deleting components on call to adjust entry in this case
     
     Modified 05/05/78 by C. D. Tavares to add AIM-upgraded MSF capability.
     error_table_$inconsistent_msf added and error codes reworked 09/10/79 S. Herbst
     Modified:
     06/08/82 by Lindsey Spratt:  Added new entrypoint, msf_get_ptr, which
                 guarantees the msf is always an MSF (i.e., even with only
                 component 0 there is a directory with one component named "0").
                 Changed to use the pathname_ function to build fcb.path.
     
     2/1/83 Jay Pattin to make ACL entries force access if necessary.
     6/23/83 Jay Pattin to fix bug in access forcing change
     Repaired to properly return acls for users with null effective access,
     BIM, 831010.
     12/20/83 by Matthew Pierret: Changed acl entries to always ensure that the MSF
            directory has an acl entry for *.*.* and that all MSF directory acl
            entries have modes no less than 's'.
  2) change(84-01-19,Pierret), approve(), audit(), install():
     Added substr around the (d e)name_arg args when
            assigning their values to fcb.(d e)name to avoid potential
            stringsize conditions.
     12/27/84 by Keith Loepere for version 2 create_branch_info.
  3) change(85-12-24,Margolin), approve(86-02-24,MCR7325),
     audit(86-06-19,Lippard), install(86-07-17,MR12.0-1097):
     Changed msf_manager_$adjust to truncate to the bit boundary instead of the
     word boundary.  Fixed some declarations.
  4) change(86-07-11,Margolin), approve(86-07-11,MCR7325),
     audit(86-07-11,GDixon), install(86-07-17,MR12.0-1097):
     Simplified code based upon new bit-boundary modifications of change (3).
  5) change(87-01-07,GWMay), approve(87-01-07,PBF7325), audit(87-01-09,GDixon),
     install(87-01-12,MR12.0-1268):
     added the subroutines "msf_initiate_file_" and "msf_terminate_file_" to
     provide to needed functions of the system subroutines "initiate_file_" and
     "terminate_file_".  The internal routines are needed because the system
     subroutines are located in the systems_standard_library and are not
     available at system reload time.  The subroutines cannot be moved to
     system_library_1 because they also reference >sss subroutines.
                                                   END HISTORY COMMENTS */


/* format: style2 */
msf_manager_:
     procedure;

/**** *
   NOTE: This program contains a partial fix for a problem. The problem was
   that the dir acl was is changed to match the msf acl.   Thus, when a user
   had null effective access to an MSF, she had null access to the msf
   dir, and could not list the acl of the first component.  

   This was fixed partially by changing the acl entries to never change the
   acl such that 's' mode is removed from any entry.  The remaining problem
   is that existing MSFs that have null access modes on the MSF dir are not
   helped by the change.

   This can be wrote around by using the acl of the dir itself to deduce
   the MSF acl. Unfortunately, there is no extended acl on the dir,
   so the extended modes are returned null.

    The complete fix is to run MSF's in ring 2, leaving s to * on the
    ring 2 dir, and thus allowing component zero's acl to be listed,
    always.

    This should be addresses at a later time. --BIM */


	dcl     aclp		 ptr;
	dcl     areap		 ptr;
	dcl     area_ret_ptr	 ptr;
	dcl     acl_idx		 fixed bin;
	dcl     bc		 fixed bin (24);
	dcl     bitcount		 fixed bin (24);
	dcl     cleanup		 condition;
	dcl     (code, code1)	 fixed bin (35);
	dcl     component		 fixed bin;
	dcl     createsw		 bit (1);
	dcl     force_msf_creation	 bit (1) aligned;
	dcl     forced_access	 bit (1) aligned;
	dcl     char		 builtin;
	dcl     changed		 bit (1);
	dcl     current_user	 char (32);
	dcl     cu_$level_get	 entry returns (fixed bin (3));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     dac		 fixed bin;
	dcl     dap		 ptr init (null);
	dcl     delete		 fixed bin static init (2) options (constant);
	dcl     delete_$path	 entry (char (*), char (*), bit (6) aligned, char (*), fixed bin (35));
	dcl     delete_$ptr		 entry (ptr, bit (6) aligned, char (*), fixed bin (35));
	dcl     divide		 builtin;
	dcl     dname_arg		 char (*);
	dcl     ename_arg		 char (*);
	dcl     entry_name		 char (32);
	dcl     eptr		 ptr init (null);
	dcl     error_table_$badpath	 ext fixed bin (35);
	dcl     error_table_$badcall	 ext fixed bin (35);
	dcl     error_table_$dirseg	 ext fixed bin (35);
	dcl     error_table_$incorrect_access
				 fixed bin (35) ext static;
	dcl     error_table_$inconsistent_msf
				 ext fixed bin (35);
	dcl     error_table_$no_s_permission
				 ext fixed bin (35);
	dcl     error_table_$noentry	 ext fixed bin (35);
	dcl     error_table_$nomatch	 ext fixed bin (35);
	dcl     error_table_$not_seg_type
				 ext fixed bin (35);
	dcl     error_table_$safety_sw_on
				 ext fixed (35);
	dcl     fcbp		 ptr;
	dcl     free_area		 area based (get_system_free_area_ ());
	dcl     get_group_id_	 entry returns (char (32));
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$add_acl_entries	 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_inacl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
	dcl     hcs_$create_branch_	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$delete_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_inacl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
	dcl     hcs_$get_access_class	 ext entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     hcs_$get_link_target	 entry (char (*), char (*), char (168), char (32), fixed bin (35));
	dcl     hcs_$get_max_length	 entry (char (*), char (*), fixed bin (19), fixed bin (35));
	dcl     hcs_$get_max_length_seg
				 entry (ptr, fixed bin (19), fixed bin (35));
	dcl     hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
	dcl     hcs_$get_user_effmode	 entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     hcs_$list_dir_acl	 entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     hcs_$list_acl	 entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin, pointer, fixed bin (35));
	dcl     hcs_$replace_acl	 entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));
	dcl     hcs_$replace_dir_acl	 entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));
	dcl     hcs_$replace_inacl	 entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (3),
				 fixed bin (35));
	dcl     hcs_$set_bc		 entry (char (*), char (*), fixed bin (24), fixed bin (35));
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     hcs_$set_max_length	 entry (char (*), char (*), fixed bin (19), fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				 fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     hcs_$terminate_file	 entry (char (*), char (*), fixed bin (1), fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     hcs_$truncate_file	 entry (char (*), char (*), fixed bin, fixed bin (35));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin (35));
	dcl     ltrim		 builtin;
	dcl     min		 builtin;
	dcl     mod		 builtin;
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     i			 fixed bin;
	dcl     index		 builtin;
	dcl     ibp		 ptr;
	dcl     j			 fixed bin;
	dcl     lastp		 ptr init (null);
	dcl     length		 builtin;
	dcl     make_msf_		 entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
	dcl     max		 builtin;
	dcl     max_length		 fixed bin (19);
	dcl     msf		 fixed bin static init (2) options (constant);
	dcl     name		 char (32);
	dcl     names		 (1000) char (32) based (nptr);
	dcl     not_exists		 fixed bin static init (-1) options (constant);
	dcl     nptr		 ptr init (null);
	dcl     null		 builtin;
	dcl     num_of_entries	 fixed bin;
	dcl     P_switches		 bit (3) parameter;
	dcl     ring		 fixed bin (3);
	dcl     scode		 fixed bin (35);
	dcl     saved_mode		 bit (36) aligned;
	dcl     segptr		 ptr;
	dcl     sds		 bit (1);
	dcl     set_bc_sw		 bit (1) def (switches) pos (1);
	dcl     ssf		 fixed bin static init (1) options (constant);
	dcl     STAR_STAR_USERID	 init ("*.*.*") char (32) aligned internal static options (constant);
	dcl     substr		 builtin;
	dcl     switches		 bit (3);
	dcl     sys_info$max_seg_size	 ext fixed bin (19);
	dcl     temp_acc		 bit (72) aligned;
	dcl     temp_segptr		 ptr;
	dcl     terminate		 fixed bin static init (1) options (constant);
	dcl     terminate_sw	 bit (1) def (switches) pos (3);
	dcl     truncate_sw		 bit (1) def (switches) pos (2);
	dcl     type		 fixed bin (2);
	dcl     (addr, unspec)	 builtin;
	dcl     unmake_msf_		 entry (char (*), char (*), bit (1), (3) fixed bin (3), fixed bin (35));

	dcl     1 s_acl		 (acl_count) based (aclp) aligned,
		2 userid		 char (32),
		2 mode		 bit (3) unaligned,
		2 mbz1		 bit (33) unaligned,
		2 mbz2		 bit (36),
		2 err_code	 fixed bin (35),
	        1 d_acl		 (dac) based (dap) aligned,
		2 userid		 char (32),
		2 mode		 bit (3) unaligned,
		2 mbz1		 bit (33) unaligned,
		2 err_code	 fixed bin (35),
	        1 d_acl_entry	 aligned like d_acl;
%page;

%include access_mode_values;
%include acl_structures;
%page;
%include create_branch_info;
%page;
%include terminate_file;
%page;
%include system_constants;
%page;
	dcl     1 branch_info	 aligned automatic like create_branch_info;

	dcl     1 entries		 (num_of_entries) based (eptr) aligned,
		2 type		 bit (2) unal,
		2 nname		 bit (16) unal,
		2 nindex		 fixed bin (17) unal;

	dcl     1 fcb		 based (fcbp) aligned,
						/* the multi-segment file control block */
		2 version		 fixed bin,	/* version of this structure - 0 now */
		2 type		 fixed bin,	/* form of msf - ssf, msf, or not_exists */
		2 max_components	 fixed bin,	/* maximum number of components (same as bitcount) */
		2 max_len		 fixed bin (19),	/* Max number of words in each component. */
		2 pad		 (1) fixed bin,
		2 pathnames	 unaligned,	/* dirnname, ename, and combined of the file */
		  3 dname		 char (168),
		  3 ename		 char (32),
		  3 path		 char (168),
		2 initiated_components,		/* information about the initiated components in the file */
		  3 number	 fixed bin,	/* how many are initiated */
		  3 highest_value	 fixed bin,	/* the highest component value of those inited */
		  3 listp		 ptr,		/* ptr to head of the list of inited segs */
		2 rbs		 (3) fixed bin (3), /* save ring bracks */
		2 upgrade_sw	 bit (1) aligned,	/* if components are multiclass segments */
		2 access_class	 bit (72) aligned;	/* acc if upgrade_sw ON */
						/* DRV - add volume backup switch to FCB here */

	dcl     1 initiation_bead	 based (ibp) aligned,
						/* one for each initiated component of the msf */
		2 component	 fixed bin,	/* which component it is */
		2 bitcount	 fixed bin (24),	/* its bitcount */
		2 segptr		 ptr,		/* a ptr to it */
		2 next		 ptr;		/* next bead in list or null */





/*  */
/* The open entry creates a file control block, returning a ptr.  It puts it in the area returned
   by get_system_free_area_.  The file need not exist to have a file control block. */


open:
     entry (dname_arg, ename_arg, fcbp, code);






	fcbp = null;				/* first set fcbp to null, in case of errors */


	allocate fcb in (free_area) set (fcbp);		/* allocate the file control block */

	fcb.version = 0;				/* set the version to the current version - 0 */
	fcb.dname = substr (dname_arg, 1, min (length (fcb.dname), length (dname_arg)));
	fcb.ename = substr (ename_arg, 1, min (length (fcb.ename), length (ename_arg)));
						/* substr is used to prevent potential stringsize */
	fcb.number = 0;				/* none are initiated */
	fcb.highest_value = 0;			/* so no highest value of those initiated */
	fcb.listp = null;				/* no list of those initiated */

	call hcs_$status_minf (fcb.dname, fcb.ename, 1, type, bitcount, code);
						/* find out about it */

	if code = 0 | code = error_table_$no_s_permission
	then do;
		if type < 1 | type > 2
		then go to BAD_MSF;
		fcb.type = type;			/* if no error, then type of msf is type */
		if code = 0
		then call hcs_$get_link_target (fcb.dname, fcb.ename, fcb.dname, fcb.ename, code1);
	     end;
	else do;					/* else if error, then not_exists */
		fcb.type = not_exists;
		fcb.max_len = sys_info$max_seg_size;	/* File will grow to largest allowed size. */
		fcb.rbs (*) = cu_$level_get ();
		fcb.upgrade_sw = ""b;

/* DRV - initialize volume backup switch in FCB here */

	     end;

/* concatenate the dname and ename to make a path name */

	fcb.path = pathname_ ((fcb.dname), (fcb.ename));

	if fcb.type = ssf
	then do;					/* If single segment file. */
		fcb.max_components = 1;		/* Only one component. */
		call hcs_$get_max_length (fcb.dname, fcb.ename, fcb.max_len, code);
		if code ^= 0
		then go to free_it;			/* Get max length of existing SSF. */

		call hcs_$get_access_class (fcb.dname, fcb.ename, fcb.access_class, code);
		if code ^= 0
		then goto free_it;

		call hcs_$get_access_class (fcb.dname, "", temp_acc, code);
		if code ^= 0
		then do;
			code = 0;
			fcb.upgrade_sw = "0"b;
		     end;
		else if fcb.access_class ^= temp_acc
		then fcb.upgrade_sw = "1"b;


/* DRV - get volume backup switch from SSF here and insert it into FCB */

	     end;

	else if fcb.type ^= msf
	then fcb.max_components = 0;			/* if not exists, then no components */

	else do;					/* is already an MSF */
		if bitcount = 0
		then do;				/* if type directory, and zero bc, then error */
			code = error_table_$dirseg;
free_it:
			free fcbp -> fcb in (free_area);
						/* free the file control block */
			return;
		     end;

		fcb.max_components = bitcount;	/* otherwise, get number of components from bitcount */

		call hcs_$get_ring_brackets (fcb.path, "0", fcb.rbs, code);
						/* get ring brackets of component 0 */
		if code ^= 0
		then fcb.rbs (*) = cu_$level_get ();

		call hcs_$get_max_length (fcb.path, "0", fcb.max_len, code);
						/* Get max length of component 0. */
		if code ^= 0
		then fcb.max_len = sys_info$max_seg_size;

		call hcs_$get_access_class (fcb.path, "0", fcb.access_class, code);
		if code ^= 0
		then fcb.upgrade_sw = ""b;

		else do;
			call hcs_$get_access_class (fcb.path, "", temp_acc, code);
			if code ^= 0
			then fcb.upgrade_sw = ""b;
			else if temp_acc ^= fcb.access_class
			then fcb.upgrade_sw = "1"b;
		     end;

/* DRV - get volume backup switch from component 0 here */

		code = 0;

	     end;

	return;					/* return to caller */


/* The msf_get_ptr entry works like the get_ptr entry (below) except it
forces the creation of an MSF, even if only component 0 is referenced.  If the
file already exists as an SSF, however, it won't be converted as long as only
component 0 is referenced.  */

msf_get_ptr:
     entry (fcbp, component, createsw, segptr, bc, code);
	force_msf_creation = "1"b;
	goto GET_PTR_JOIN;

/* The get_ptr entry will return a ptr to the specified component in the
file.  If not found, it will attempt to create it if createsw = "1"b.  If the
file is a single_segment_file (SSF), and a component greater than zero is
requested, this entry will call make_msf_ to change the file from an SSF to an
MSF.  */

get_ptr:
     entry (fcbp, component, createsw, segptr, bc, code);

	force_msf_creation = "0"b;
GET_PTR_JOIN:
	code = 0;
	segptr = null;				/* start with a null return pointer */

	if component < 0
	then go to BAD_ARG;				/* make a check on the request */

	if fcb.type = not_exists
	then /* if the file did not previously exist then */
	     if ^createsw
	     then go to NOT_FOUND;			/* if the callers does not want it created, error */
	     else do;
		     if ^force_msf_creation
		     then do;
			     call hcs_$make_seg (dname, ename, "", 01010b, segptr, code);
						/* otherwise, create a segment */
			     if segptr = null
			     then return;		/* if unable, then error */

			     call hcs_$get_link_target (dname, ename, fcb.dname, fcb.ename, code);
						/* store target in fcb */
			     if code ^= 0
			     then return;
			     i = index (fcb.dname, " ");
			     if i = 0
			     then if fcb.ename = ""
				then fcb.path = fcb.dname;
				else go to BAD_PATH;
			     else fcb.path = substr (fcb.dname, 1, i - 1) || ">" || fcb.ename;
			     bc = 0;		/* bitcount starts at zero */
			     fcb.type = ssf;	/* starts as an ssf */
			     fcb.max_components = 1;	/* with only one component */
			     if component = 0
			     then go to fill_in_bead; /* if caller only wants comp. zero, then almost done */
			end;
		     call make_msf_ (dname, ename, fcb.rbs, code);
						/* otherwise, change it to an msf */
		     if code ^= 0
		     then return;			/* error */
		     fcb.type = msf;		/* now it is an msf */
		     call delete_$path (path, "0", "100100"b, "", code);
						/* delete the zero component */
		     if code ^= 0
		     then return;
		     fcb.max_components = 0;		/* none inited now */
		     go to make_seg_msf;		/* now pretend that we started with an msf */
		end;

	if fcb.type = ssf
	then do;					/* if it was an ssf */
		if component ^= 0
		then /* if caller wants other than comp. zero */
		     if createsw
		     then do;			/* and wants it to be created then */
			     call make_msf_ (dname, ename, fcb.rbs, code);
						/* change to an msf */
			     if code ^= 0
			     then return;
			     fcb.type = msf;
			     go to make_seg_msf;	/* and pretend we started that way */
			end;
		     else go to NOT_FOUND;		/* else, if not to be created, error */

		if initiated_components.number = 1
		then do;				/* if a component has already been inited */
			ibp = fcb.listp;		/* only can be one - component zero, what we want */
already_initiated:
			bc = initiation_bead.bitcount;/* we have the bitcount saved from an init call */
			segptr = initiation_bead.segptr;
						/* and the ptr saved */
			return;			/* that's it, finished */
		     end;

		else do;				/* else, if not already inited */
			call hcs_$initiate_count (dname, ename, "", bc, 1, segptr, code);
						/* try to initiated it */
			if segptr = null
			then return;		/* error */
			go to fill_in_bead;		/* make an initiation bead */
		     end;

	     end;


	if fcb.type ^= msf
	then go to BAD_CONTROL_BLOCK;			/* bad type field in fcb */

	ibp = find_component (component);		/* see if comp. already was initiated */
	if ibp ^= null
	then go to already_initiated;			/* if so, return the old values */

not_initiated:
	call hcs_$initiate_count (path, make_char (component), "", bc, 1, segptr, code);
						/* else try to initiate it */

	if segptr ^= null
	then go to fill_in_bead;			/* ok, so make an initiation bead */

	if ^createsw
	then return;				/* if not to create it, then give up */
make_seg_msf:
	current_user = get_group_id_$tag_star ();
	entry_name = make_char (component);

	unspec (branch_info) = ""b;

	branch_info.version = create_branch_version_2;
	branch_info.chase_sw = ""b;
	branch_info.priv_upgrade_sw = fcb.upgrade_sw;
	branch_info.parent_ac_sw = ^branch_info.priv_upgrade_sw;
	branch_info.access_class = fcb.access_class;
	branch_info.mode = "101"b;
	branch_info.rings = fcb.rbs;
	branch_info.userid = current_user;

	call hcs_$create_branch_ (path, entry_name, addr (branch_info), code);
	if code ^= 0
	then return;

	call hcs_$set_max_length (path, entry_name, fcb.max_len, code);
	if code ^= 0
	then return;

/* DRV - set volume backup switch on new seg here */

	call hcs_$initiate (path, entry_name, "", 0, 1, segptr, code);
	if segptr = null
	then return;				/* if failed, then give up */

	bc = 0;					/* bitcount starts at zero */
	if component + 1 > fcb.max_components
	then do;					/* if max_components needs to be upped */
		fcb.max_components = component + 1;
		call hcs_$set_bc (dname, ename, component + 1, code);
		if code ^= 0
		then return;
	     end;

fill_in_bead:
	allocate initiation_bead in (free_area) set (ibp);/* make an initiation bead */

	initiation_bead.component = component;		/* fill it in */
	initiation_bead.bitcount = bc;
	initiation_bead.segptr = segptr;
	initiation_bead.next = fcb.listp;		/* thread this at the head of the list */
						/* open initializes first fcb.listp to null */

	if component >= fcb.max_components
	then fcb.max_components = component + 1;
	fcb.highest_value = max (fcb.highest_value, component);
						/* remember highest value */
	fcb.listp = ibp;				/* thread into list */
	fcb.number = fcb.number + 1;

	code = 0;

	return;					/* thats it */

/* The adjust entry can set the bitcount, truncate, and terminate the components of an MSF.  It
   is given a maximum component, and bitcount within that component.  All components before
   that component are given bitcount sys_info$max_seg_size, and all after are deleted.
   What it is to do is determined by switches: "bxt"b, where b is set bitcount,
   x is truncate, and t is terminate. */


adjust:
     entry (fcbp, component, bc, P_switches, code);






	switches = P_switches;

	if component < 0
	then go to BAD_ARG;				/* check argument */

	if fcb.type = not_exists
	then go to NOT_FOUND;			/* see if file is around */

	if fcb.type = ssf
	then do;					/* if only a single segment */
		if component ^= 0
		then go to SEGMENT;			/* can't adjust to that length (>0) */
		ibp = find_component (0);		/* see if it was initiated */
adjust_ssf:
		if truncate_sw & (mod (bc, 36) ^= 0)
		then if ibp = null
		     then begin;			/* have to zero extra bits */
			     temp_segptr = null;
			     on cleanup
				begin;
				     if temp_segptr ^= null
				     then call msf_terminate_file_ (temp_segptr, 0, TERM_FILE_TERM, (0));
				end;

			     call msf_initiate_file_ (dname, ename, W_ACCESS, temp_segptr, (0), code);
			     if code ^= 0
			     then return;
			     if set_bc_sw
			     then do;
				     call msf_terminate_file_ (temp_segptr, bc, TERM_FILE_TRUNC_BC_TERM, code);
				     set_bc_sw = "0"b;
				end;
			     else call msf_terminate_file_ (temp_segptr, bc, (TERM_FILE_TRUNC | TERM_FILE_TERM),
				     code);
			     if code ^= 0
			     then return;
			     truncate_sw = "0"b;
			end;
		     else do;
			     if set_bc_sw
			     then do;
				     call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC_BC,
					code);
				     initiation_bead.bitcount = bc;
				     set_bc_sw = "0"b;
				end;
			     else call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC, code);
			     if code ^= 0
			     then return;
			     truncate_sw = "0"b;
			end;


		if set_bc_sw
		then do;				/* if we are to set the bitcount */
			if ibp = null
			then call hcs_$set_bc (dname, ename, bc, code);
						/* use normal entry if no pointer to set bc */
			else call hcs_$set_bc_seg (initiation_bead.segptr, bc, code);
						/* else use faster ptr entry if we have it */
			if code ^= 0
			then return;
			if ibp ^= null
			then initiation_bead.bitcount = bc;
		     end;

		if truncate_sw
		then do;				/* shall we truncate it? */
			if ibp = null
			then call hcs_$truncate_file (dname, ename, divide (bc, 36, 17, 0), code);
						/* use the truncate entries */
			else call hcs_$truncate_seg (initiation_bead.segptr, divide (bc, 36, 17, 0), code);
			if code ^= 0
			then return;
		     end;

		if terminate_sw
		then do;				/* shall we terminate it */
			if ibp = null
			then call hcs_$terminate_file (dname, ename, 0, code);
			else call remove_bead (terminate);
						/* remove the initiation bead while terming it */
			code = 0;			/* set code to 0 */
		     end;

		return;

	     end;

	if fcb.type ^= msf
	then go to BAD_CONTROL_BLOCK;			/* not msf */

	if component = 0
	then do;					/* it msf, and want to end up with ssf */
		lastp = null;			/* terminate and remove beads of all ^=0 */
		ibp = fcb.listp;
		do i = 1 to fcb.number while (ibp ^= null);
		     if initiation_bead.component ^= 0
		     then call remove_bead (terminate);
		     else lastp = ibp;
		     if lastp = null
		     then ibp = fcb.listp;
		     else ibp = lastp -> initiation_bead.next;
		end;
		if fcb.listp = null
		then fcb.number = 0;		/* if none left (0 not inited) */
		else fcb.number = 1;		/* if zero was initied */
		call unmake_msf_ (dname, ename, (bc ^= 0), fcb.rbs, code);
						/* make an ssf, copy only if bc>0 */
		if code ^= 0
		then if code ^= error_table_$safety_sw_on
						/* real error */
		     then return;			/* abort */
		     else go to adjust_loop;		/* still zero contents */
		fcb.type = ssf;
		fcb.max_components = 1;
		go to adjust_ssf;			/* pretend we are an ssf */
	     end;

	if component > fcb.max_components
	then go to BAD_ARG;				/* component too high */

adjust_loop:
	forced_access = "0"b;
	on cleanup call free_allocated_storage;		/* in case we are quitted out of, cleanup area */

	call hcs_$star_ (path, "**", 2, get_system_free_area_ (), num_of_entries, eptr, nptr, code);
						/* find all the names(i.e. components) */
	if code ^= 0
	then go to finished_adjust;			/* error */

	do i = 1 to num_of_entries;			/* do for each entry */
	     name = names (entries (i).nindex);		/* find the i-th name */
	     j = cv_dec_check_ (name, code);		/* see that it is a number */
	     if code ^= 0
	     then go to BAD_MSF;
	     if j < 0
	     then go to BAD_MSF;			/* check that it is ok */

	     ibp = find_component (j);		/* see if we perchance have a ptr to it */

	     if j = component
	     then /* if the adjusting component */
		if truncate_sw
		then do;				/* shall we truncate that one? */
			if mod (bc, 36) = 0
			then do;
				if ibp = null
				then call hcs_$truncate_file (path, name, divide (bc, 36, 17, 0), code);
				else call hcs_$truncate_seg (initiation_bead.segptr, divide (bc, 36, 17, 0), code);
				if code ^= 0
				then go to finished_adjust;
			     end;
			else if ibp = null
			then begin;		/* have to initiate it to zero the bits */
				temp_segptr = null;
				on cleanup
				     begin;
					if temp_segptr ^= null
					then call msf_terminate_file_ (temp_segptr, 0, TERM_FILE_TERM, (0));
				     end;

				call msf_initiate_file_ (path, name, W_ACCESS, temp_segptr, (0), code);
				if code ^= 0
				then go to finished_adjust;
				if set_bc_sw
				then call msf_terminate_file_ (temp_segptr, bc, TERM_FILE_TRUNC_BC_TERM, code);
				else call msf_terminate_file_ (temp_segptr, bc,
					(TERM_FILE_TRUNC | TERM_FILE_TERM), code);
				if code ^= 0
				then go to finished_adjust;
			     end;
			else do;
				if set_bc_sw
				then call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC_BC,
					code);
				else call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC, code);
				if code ^= 0
				then go to finished_adjust;
			     end;


		     end;

	     if j <= component
	     then do;				/* up to and including adjusting comp */
		     if set_bc_sw
		     then do;			/* shall we set the bitcount? */
			     if j = component
			     then bitcount = bc;	/* adjusting - do to "bc" */
			     else do;		/* else an entire file's worth */
				     if ibp = null
				     then call hcs_$get_max_length (path, name, max_length, code);
				     else call hcs_$get_max_length_seg (initiation_bead.segptr, max_length, code);
				     if code ^= 0
				     then go to finished_adjust;
				     bitcount = 36 * max_length;
				end;
			     if ^(truncate_sw & (j = component) & (mod (bc, 36) ^= 0))
						/** truncate_sw processing handles last
				    component in this case **/
			     then do;
				     if ibp = null
				     then call hcs_$set_bc (path, name, bitcount, code);
						/* set the bitcount */
				     else call hcs_$set_bc_seg (initiation_bead.segptr, bitcount, code);
				     if code ^= 0
				     then go to finished_adjust;
				end;
			     if ibp ^= null
			     then initiation_bead.bitcount = bitcount;
			end;

		     if terminate_sw
		     then do;			/* shall we terminate it? */
			     if ibp = null
			     then call hcs_$terminate_file (path, name, 0, code);
			     else call remove_bead (terminate);
						/* remove initiation bead while terming */
			     code = 0;		/* set code to 0 */
			end;
		end;

	     else do;				/* components after the adjusting one */
		     if ibp = null
		     then call delete_$path (path, name, "000100"b, "", code);
						/* delete it */
		     else do;
			     call remove_bead (delete);
			     code = scode;
			end;
		     if code ^= 0
		     then if code = error_table_$safety_sw_on
			then do;			/* still zero contents */
				call hcs_$truncate_file (path, name, 0, code);
				if code ^= 0
				then go to finished_adjust;
						/* abort */
				call hcs_$set_bc (path, name, 0, code);
				if code ^= 0
				then go to finished_adjust;
				else code = error_table_$safety_sw_on;
						/*
						   prevents resetting max_components */
			     end;
			else go to finished_adjust;
		end;

	end;

	if (code = 0) & (component + 1 ^= fcb.max_components)
	then do;					/* have to reset the max_components */
		fcb.max_components = component + 1;
		call hcs_$set_bc (dname, ename, component + 1, code);
	     end;

finished_adjust:
	if code ^= 0
	then if code = error_table_$safety_sw_on	/* not an error to user */
	     then code = 0;
	call free_allocated_storage;			/* clean up */

	return;

/* The close entry frees the file control block.  It will terminate all components that are still
   thought to be initiaed, freeing their initiation beads. */


close:
     entry (fcbp);




	lastp = null;
	ibp = fcb.listp;

	do i = 1 to fcb.number + 1 while (ibp ^= null);
	     call remove_bead (terminate);
	     ibp = fcb.listp;
	end;

	free fcbp -> fcb in (free_area);

	return;

/* The acl_list entry returns the acl on the MSF */


acl_list:						/* entry for listing acls */
     entry (fcbp, areap, area_ret_ptr, aclp, acl_count, code);


	if fcb.type = msf
	then do;

		eptr, nptr, dap = null;
		forced_access = "0"b;

		on cleanup call free_allocated_storage ();
						/* in case we are quitted out of, cleanup area */
		call ensure_access ("1"b);

		ring = cu_$level_get ();		/* get validation level */
		call hcs_$list_acl (path, "0", areap, area_ret_ptr, aclp, acl_count, code);
		if code = error_table_$incorrect_access
		then call DEDUCE_ACL_FROM_DIR_ACL;
		if code = error_table_$noentry | code = error_table_$dirseg
		then code = error_table_$inconsistent_msf;

		call free_allocated_storage ();
	     end;

	else if fcb.type = ssf
	then call hcs_$list_acl (dname, ename, areap, area_ret_ptr, aclp, acl_count, code);

	else go to BAD_CONTROL_BLOCK;

	return;

/* The acl_delete entry deletes the acl on an MSF */


acl_delete:					/* entry for deleting acls */
     entry (fcbp, aclp, acl_count, code);



	if fcb.type = not_exists
	then go to NOT_FOUND;			/* dumb move */

	if fcb.type = ssf
	then do;					/* one segment simple case */
		call hcs_$delete_acl_entries (dname, ename, aclp, acl_count, code);
						/* do it */
		return;
	     end;

	if fcb.type ^= msf
	then go to BAD_CONTROL_BLOCK;

	eptr, nptr, dap = null;
	forced_access = "0"b;

	on cleanup call free_allocated_storage;		/* in case we are quitted out of, cleanup area */
	call ensure_access ("0"b);

	ring = cu_$level_get ();			/* get current level */
	call hcs_$delete_inacl_entries (dname, ename, aclp, acl_count, ring, code);
						/* remove entries from inacl */
	if code ^= 0
	then go to error_return;


	call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code);
						/* get all names */
	if code ^= 0
	then if code = error_table_$nomatch
	     then go to DEL_DIR;
	     else go to error_return;

	do i = 1 to num_of_entries;			/* go through list */
	     call hcs_$delete_acl_entries (path, names (entries (i).nindex), aclp, acl_count, code);
	     if code ^= 0
	     then do;
INCONSISTENT:
		     code = error_table_$inconsistent_msf;
		     go to error_return;
		end;
	end;


	call free_allocated_storage;

DEL_DIR:						/* delete the directory acl entries on the msf directory */
	call hcs_$delete_dir_acl_entries (dname, ename, aclp, acl_count, code);
						/* remove entries from dir acl */
	if code ^= 0
	then go to error_return;

/* the *.*.* entry should not be removed from the directory acl */
/* see if that entry is included in the segment acl */
	do acl_idx = 1 to acl_count while (s_acl (acl_idx).userid ^= STAR_STAR_USERID);
	end;
	if acl_idx <= acl_count
	then do;					/* the *.*.* entry was deleted - return it */
		d_acl_entry.userid = STAR_STAR_USERID;
		d_acl_entry.mode = S_ACCESS;
		d_acl_entry.mbz1 = "0"b;
		d_acl_entry.err_code = 0;

		call hcs_$add_dir_acl_entries (dname, ename, addr (d_acl_entry), 1 /* acl count */, code);
						/* add the directory acl entry for *.*.* */
		if code ^= 0
		then go to error_return;
	     end;

	return;

/* The acl_add entry adds the acl on an MSF */


acl_add:						/* entry for adding acls */
     entry (fcbp, aclp, acl_count, code);


	if fcb.type = not_exists
	then go to NOT_FOUND;			/* dumb move */

	if fcb.type = ssf
	then do;					/* one segment simple case */
		call hcs_$add_acl_entries (dname, ename, aclp, acl_count, code);
						/* do it */
		return;
	     end;

	if fcb.type ^= msf
	then go to BAD_CONTROL_BLOCK;

	eptr, nptr, dap = null;
	forced_access = "0"b;

	on cleanup call free_allocated_storage;		/* in case we are quitted out of, cleanup area */
	call ensure_access ("0"b);

	ring = cu_$level_get ();			/* get current level */
	call hcs_$add_inacl_entries (dname, ename, aclp, acl_count, ring, code);
						/* add entries to inacl */
	if code ^= 0
	then go to error_return;

	call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code);
						/* get all names */
	if code ^= 0
	then if code = error_table_$nomatch
	     then go to ADD_DIR;
	     else go to error_return;

	do i = 1 to num_of_entries;			/* go through list */
	     call hcs_$add_acl_entries (path, names (entries (i).nindex), aclp, acl_count, code);
	     if code ^= 0
	     then go to INCONSISTENT;
	end;

ADD_DIR:						/* add the directory acl on the msf directory */
	dac = acl_count;				/* the directory and segment acl's have the same number of entries */

	call GET_DIR_ACL;				/* get structure for directory acls */

	call hcs_$add_dir_acl_entries (dname, ename, dap, dac, code);
						/* add entries to dir acl */
	if code ^= 0
	then go to error_return;


	call free_allocated_storage;

	return;

/* The acl_replace entry replaces the acl on an MSF */


acl_replace:					/* entry for replacing acls */
     entry (fcbp, aclp, acl_count, sds, code);




	if fcb.type = not_exists
	then go to NOT_FOUND;			/* dumb move */

	if fcb.type = ssf
	then do;					/* one segment simple case */
		call hcs_$replace_acl (dname, ename, aclp, acl_count, sds, code);
						/* do it */
		return;
	     end;

	if fcb.type ^= msf
	then go to BAD_CONTROL_BLOCK;

	eptr, nptr, dap = null;
	forced_access = "0"b;

	on cleanup call free_allocated_storage;		/* in case we are quitted out of, cleanup area */
	call ensure_access ("0"b);

	ring = cu_$level_get ();			/* get current level */
	call hcs_$replace_inacl (dname, ename, aclp, acl_count, sds, ring, code);
						/* put new acl on inacl */
	if code ^= 0
	then go to error_return;

	call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code);
						/* get all names */
	if code ^= 0
	then if code = error_table_$nomatch
	     then go to RPL_DIR;
	     else go to error_return;

	do i = 1 to num_of_entries;			/* go through list */
	     call hcs_$replace_acl (path, names (entries (i).nindex), aclp, acl_count, sds, code);
	     if code ^= 0
	     then go to INCONSISTENT;
	end;

RPL_DIR:						/* replace the directory acl on the msf directory */
						/* is there an entry for *.*.* in the given acl? */
	do acl_idx = 1 to acl_count while (s_acl (acl_idx).userid ^= STAR_STAR_USERID);
	end;
	if acl_idx <= acl_count
	then dac = acl_count;			/* a *.*.* entry is in the segment acl */
	else dac = acl_count + 1;			/* no *.*.* entry is in the segment acl - the directory acl needs an extra entry */

	call GET_DIR_ACL;				/* allocate a directory acl (d_acl) and convert the segment acl */
						/* entries into directory acl entries */

	if dac > acl_count
	then do;					/* add an entry for *.*.* */
		d_acl (dac).userid = STAR_STAR_USERID;
		d_acl (dac).mode = S_ACCESS;
		d_acl (dac).mbz1 = "0"b;
		d_acl (dac).err_code = 0;
	     end;


	call hcs_$replace_dir_acl (dname, ename, dap, dac, sds, code);
						/* put on dir acl */


error_return:
	call free_allocated_storage;

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


find_component:					/* sees if initiation bead exists for which */
     proc (which) returns (ptr);


	dcl     ip		 ptr,
	        which		 fixed bin;






	if fcb.highest_value < component
	then return (null);				/* greater than highest value inited, so not there */

	ip = fcb.listp;				/* start at begining of list */
	lastp = null;

	do while (ip ^= null);			/* look through whole list */
	     if ip -> initiation_bead.component = which
	     then return (ip);			/* if comp "which", then return ptr to bead */
	     lastp = ip;				/* lastp points to last bead */
	     ip = ip -> initiation_bead.next;		/* now look for next */
	end;

	return (null);				/* not found */

     end find_component;


remove_bead:					/* remove an initiation bead */
     proc (how);					/* how says to delete or terminate */



	dcl     how		 fixed bin;



	if how = terminate
	then call hcs_$terminate_noname (initiation_bead.segptr, scode);
						/* if terminate,then do it */
	else if how = delete
	then call delete_$ptr (initiation_bead.segptr, "000100"b, "", scode);
						/* else if delete,then delete it */

	if lastp = null
	then fcb.listp = ibp -> initiation_bead.next;	/* if no bead before it in list */
	else lastp -> initiation_bead.next = ibp -> initiation_bead.next;
						/* else fill in bead before it, to unthread */

	fcb.number = fcb.number - 1;			/* decrement number inited */

	free ibp -> initiation_bead in (free_area);	/* free the initiation bead */

	return;					/* that's it for this routine */

     end remove_bead;
%page;
GET_DIR_ACL:					/* transform segment acls to directory acls */
     proc;					/* for adding or replacing the acl of the MSF itself */
						/* 'dac' must be set to the number of directory acl entries */

	dcl     acl_idx		 fixed bin;



	allocate d_acl in (free_area) set (dap);

	do acl_idx = 1 to acl_count;			/* copy segment acl to directory acl */
	     d_acl (acl_idx).userid = s_acl (acl_idx).userid;
						/* copy user name */
	     if (s_acl (acl_idx).mode & W_ACCESS) = ""b
	     then d_acl (acl_idx).mode = S_ACCESS;	/* all dir entries must have at least 's' */
	     else d_acl (acl_idx).mode = SMA_ACCESS;	/* 'w' on msf requires 'sma' on dir */

	     d_acl (acl_idx).mbz1 = "0"b;
	     d_acl (acl_idx).err_code = 0;
	end;

     end GET_DIR_ACL;
%page;
ensure_access:
     proc (list_switch);

	declare list_switch		 bit (1) aligned,
	        mode		 fixed bin (5),
	        1 one_acl		 aligned,
		2 name		 char (32),
		2 mode		 bit (36),
		2 code		 fixed bin (35);

	call hcs_$get_user_effmode (dname, ename, "", -1, mode, code);
	if code ^= 0
	then return;				/* let actual acl error be reported */

	if mode >= SM_ACCESS_BIN
	then return;				/* have sufficient access */

	one_acl.name = get_group_id_ ();
	call hcs_$list_dir_acl (dname, ename, null (), null (), addr (one_acl), 1, (0));
	changed = (one_acl.code = 0);
	saved_mode = one_acl.mode;

	one_acl.mode = SMA_ACCESS;
	forced_access = "1"b;

	call hcs_$add_dir_acl_entries (dname, ename, addr (one_acl), 1, (0));

	if ^list_switch
	then do i = 1 to acl_count;			/* if we are going to frob it, don't put it back */
		if s_acl.userid (i) = one_acl.name
		then do;
			forced_access = "0"b;
			return;
		     end;
	     end;

	return;
     end ensure_access;


remove_access:
     proc ();

	declare 1 delete_acl	 aligned,
		2 name		 char (32),
		2 code		 fixed bin (35),
	        1 one_acl		 aligned,
		2 name		 char (32),
		2 mode		 bit (36),
		2 code		 fixed bin (35);

	if changed
	then do;
		one_acl.name = get_group_id_ ();
		one_acl.mode = saved_mode;

		call hcs_$add_dir_acl_entries (dname, ename, addr (one_acl), 1, (0));
	     end;
	else do;
		delete_acl.name = get_group_id_ ();
		call hcs_$delete_dir_acl_entries (dname, ename, addr (delete_acl), 1, (0));
	     end;

	return;
     end remove_access;
%page;
free_allocated_storage:				/* clean up routine */
     proc;

	if forced_access
	then call remove_access ();

	if nptr ^= null
	then free names in (free_area);

	if eptr ^= null
	then free entries in (free_area);

	if dap ^= null
	then free dap -> d_acl in (free_area);

	return;

     end free_allocated_storage;			/**/
make_char:
     proc (c_number) returns (char (32));

/* change a number into a char(32) string */


	dcl     c_number		 fixed bin;


	return (ltrim (char (c_number)));

     end make_char;





/*  */
/* Error reporting statements */


BAD_ARG:
BAD_CONTROL_BLOCK:
	code = error_table_$badcall;
	return;

BAD_MSF:
	code = error_table_$inconsistent_msf;
	return;

BAD_PATH:
	code = error_table_$badpath;
	return;

NOT_FOUND:
	code = error_table_$noentry;
	return;

SEGMENT:
	code = error_table_$not_seg_type;
	return;

msf_initiate_file_:
     procedure (P_dirname, P_entryname, P_mode, P_seg_ptr, P_bit_count, P_code);


/* parameters */

	declare P_bit_count		 fixed binary (24);
	declare P_code		 fixed binary (35);
	declare P_dirname		 char (*);
	declare P_entryname		 char (*);
	declare P_mode		 bit (*);
	declare P_seg_ptr		 pointer;

/* automatic */

	declare bit_count		 fixed binary (24);
	declare code		 fixed binary (35);
	declare 1 effective_mode,
		2 pad1		 bit (1),
		2 read		 bit (1),
		2 execute		 bit (1),
		2 write		 bit (1),
		2 pad2		 bit (1);
	declare effective_mode_bin	 fixed binary (5);
	declare 1 required_mode,
		2 read		 bit (1),
		2 execute		 bit (1),
		2 write		 bit (1);

/* builtin */

	declare (bit, null, string)	 builtin;

/* external static */

	declare error_table_$no_e_permission
				 fixed binary (35) external static;
	declare error_table_$no_r_permission
				 fixed binary (35) external static;
	declare error_table_$no_w_permission
				 fixed binary (35) external static;

	declare hcs_$fs_get_mode	 entry (pointer, fixed binary (5), fixed binary (35));
	declare hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2),
				 pointer, fixed binary (35));

	string (required_mode) = P_mode;
	P_seg_ptr = null;
	P_bit_count = 0;
	P_code = 0;

	call hcs_$initiate_count (P_dirname, P_entryname, "", bit_count, 0, P_seg_ptr, code);

	if P_seg_ptr = null
	then return;

	call hcs_$fs_get_mode (P_seg_ptr, effective_mode_bin, code);
	if code = 0
	then do;
		string (effective_mode) = bit (effective_mode_bin);

		if required_mode.read & ^effective_mode.read
		then code = error_table_$no_r_permission;

		else if required_mode.write & ^effective_mode.write
		then code = error_table_$no_w_permission;

		else if required_mode.execute & ^effective_mode.execute
		then code = error_table_$no_e_permission;
	     end;

	if code ^= 0
	then do;
		call msf_terminate_file_ (P_seg_ptr, 0, TERM_FILE_TERM, 0);
		P_code = code;
		P_bit_count = 0;
	     end;
	else P_bit_count = bit_count;

	return;

     end msf_initiate_file_;
%page;
msf_terminate_file_:
     procedure (P_seg_ptr, P_bit_count, P_switches, P_code);

	declare P_seg_ptr		 pointer;
	declare P_bit_count		 fixed binary (24);
	declare P_switches		 bit (*);
	declare P_code		 fixed binary (35);

/* automatic */

	declare bit_count		 fixed binary (24);
	declare code		 fixed binary (35);
	declare 1 tfs		 aligned like terminate_file_switches;

/* based */

	declare segment		 bit (BITS_PER_SEGMENT) based;

/* builtin */

	declare (divide, mod, null, pointer, string, substr)
				 builtin;

/* entry */

	declare hcs_$set_bc_seg	 entry (pointer, fixed binary (24), fixed binary (35));
	declare hcs_$terminate_noname	 entry (pointer, fixed binary (35));
	declare hcs_$truncate_seg	 entry (pointer, fixed binary (19), fixed binary (35));


	P_code = 0;
	bit_count = P_bit_count;
	string (tfs) = P_switches;

	if P_seg_ptr = null
	then return;

	P_seg_ptr = pointer (P_seg_ptr, 0);


	if tfs.truncate
	then do;
		substr (P_seg_ptr -> segment, bit_count + 1, mod (-bit_count, 36)) = ""b;
		call hcs_$truncate_seg (P_seg_ptr, divide (bit_count + 35, 36, 19), code);
		if code ^= 0
		then P_code = code;
	     end;

	if tfs.set_bc
	then do;
		call hcs_$set_bc_seg (P_seg_ptr, bit_count, code);
		if code ^= 0 & P_code = 0
		then P_code = code;
	     end;

	if tfs.terminate
	then do;
		call hcs_$terminate_noname (P_seg_ptr, code);
		if code ^= 0 & P_code = 0
		then P_code = code;
		P_seg_ptr = null;
	     end;

     end msf_terminate_file_;
%page;
DEDUCE_ACL_FROM_DIR_ACL:
     procedure;


	declare 1 dracl		 (dracl_count) aligned like directory_acl_entry based (dracl_ptr);
	declare dracl_ptr		 pointer;
	declare dracl_count		 fixed bin;
	declare ax		 fixed bin;

	code = 0;
	dracl_ptr = null ();
	on cleanup
	     begin;
		if dracl_ptr ^= null
		then do;
			free dracl;
			dracl_ptr = null ();
		     end;
	     end;

	if aclp = null ()
	then call FULL_DEDUCE_ACL;
	else call SPECIFIC_DEDUCE_ACL;
	return;

FULL_DEDUCE_ACL:
     procedure;


	declare user_area		 area based (areap);

	call hcs_$list_dir_acl (fcb.dname, fcb.ename, get_system_free_area_ (), dracl_ptr, null (), dracl_count, code);
	if code ^= 0
	then return;

	acl_count = dracl_count;
	allocate segment_acl_array in (user_area);
	do ax = 1 to dracl_count;
	     segment_acl_array (ax).access_name = dracl (ax).access_name;
	     segment_acl_array (ax).mode = TRANSLATE_MODE (dracl (ax).mode);
	     segment_acl_array (ax).extended_mode = ""b;	/* This is WRONG, but we cannot fix it. */
	     segment_acl_array (ax).status_code = 0;
	end;
	free dracl;
	area_ret_ptr = acl_ptr;
	return;
     end FULL_DEDUCE_ACL;

SPECIFIC_DEDUCE_ACL:
     procedure;

	declare system_area		 area based (get_system_free_area_ ());

	dracl_count = acl_count;
	allocate dracl in (system_area);
	dracl (*) = segment_acl_array (*), by name;
	call hcs_$list_dir_acl (fcb.dname, fcb.ename, null (), null (), dracl_ptr, dracl_count, code);
	if code ^= 0
	then do;
		segment_acl_array (*).status_code = dracl (*).status_code;
		free dracl;
		return;
	     end;

	do ax = 1 to acl_count;
	     segment_acl_array (ax).mode = TRANSLATE_MODE (dracl (ax).mode);
	     segment_acl_array (ax).extended_mode = ""b;
	end;

	free dracl;
	return;

     end SPECIFIC_DEDUCE_ACL;
     end DEDUCE_ACL_FROM_DIR_ACL;

TRANSLATE_MODE:
     procedure (Dir_bits) returns (bit (36) aligned);
	declare Dir_bits		 bit (36) aligned;

	return (substr (Dir_bits, 1, 1) || "0"b || substr (Dir_bits, 2, 1));
     end TRANSLATE_MODE;

     end msf_manager_;





		    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
