



		    ms_salv_util_v2_.pl1            05/10/85  0856.6r w 05/06/85  1619.0      119205



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

ms_salv_util_v2_: proc (a_forward, a_salv_ptr, a_new_alloc_ptr, a_nrec, a_alloc_len, a_saved_messages, a_saved_blocks,
	a_last_saved_ms_ptr, a_code);

/* Adapted from original version 2 ms_salv_util_ by J.Stern, 11/4/74 */

dcl (a_saved_blocks,				/* number of saved message blocks (argument) */
     a_saved_messages,				/* number of saved messages (argument) */
     block_bit_count,				/* bit count of message portion in block */
     block_hdr_data,				/* words in header */
     block_trailer_data,				/* words in trailer */
     first_full_block_bit_count,			/* bits allocated to first block message portion */
     full_block_bit_count,				/* bits allocated to message portion */
     i,						/* do loop index */
     label_var,					/* label variable */
     max_message_blocks,				/* maximum blocks in a message */
     message_blocks,				/* number of unchecked blocks in message */
     mseg_data_v2_$block_hdr_data ext,			/* words in header */
     mseg_data_v2_$block_trailer_data ext,			/* words in trailer */
     saved_blocks init (0),				/* number of saved message blocks (internal) */
     saved_messages init (0),				/* number of saved messages (internal) */
     tsaved_blocks,					/* blocks saved in message */
     zero_words (8) init (0, 0, 0, 0, 0, 0, 0, 0)
     ) fixed bin;

dcl (a_alloc_len,
     a_nrec,
     alloc_len,					/* length of allocation bit string */
     backward_offset,				/* offset to backward threaded message */
     bit_off,					/* offset of allocation bit for block */
     block_ms_words,				/* allocated size for message portion */
     block_offset,					/* offset to message block */
     block_size,					/* size of message block in words */
     first_block_ms_words,				/* allocated size for first block message portion */
     forward_offset,				/* offset to forward threaded message */
     max_message_size,				/* maximum words in a message */
     message_words,					/* word count of message */
     ms_offset,					/* offset to first block of message */
     mseg_data_v2_$block_size ext,			/* default block size */
     mseg_data_v2_$max_message_size ext,
     next_block_offset,				/* offset to next message block in message */
     nrec,
     previous_offset init (0),			/* offset to previous message */
     seg_size,					/* maximum size of message segment */
     tr_offset)					/* offset from beginning of block to trailer */
     fixed bin (18);

dcl (
     a_code,					/* error code */
     code init (0)
     ) fixed bin (35);

dcl (a_forward,					/* ON if salvage is forward (argument) */
     first_block,					/* ON if block is first block in message */
     forward)					/* ON if salvage is forward (internal) */
     bit (1) aligned;

dcl (
     mseg_data_v2_$mseg_tr36 ext				/* trailer recognition pattern */
     ) bit (36) aligned;

dcl (a_last_saved_ms_ptr,				/* pointer to last saved message (argument) */
     a_new_alloc_ptr,				/* pointer to new allocation bits(argument) */
     a_salv_ptr,					/* pointer to where to begin salvaging */
     check_ptr,					/* pointer to be tested for validity */
     last_saved_ms_ptr init (null),			/* pointer to last saved message(internal) */
     new_alloc_ptr,					/* pointer to new allocation bits(argument) */
     next_ms_ptr,					/* pointer to next message */
     test_block_ptr,				/* pointer to message block being tested */
     test_ms_ptr)					/* pointer to message being tested */
     ptr;

dcl (addrel, divide, fixed, mod, null, ptr, rel) builtin;

dcl  bit_mask (alloc_len) based (new_alloc_ptr) bit (1) unaligned; /* mask for setting allocation bits */

dcl  zeroes char (32) aligned based (addr (zero_words (1)));


% include mseg_hdr_v2;

% include ms_block_hdr_v2;

% include ms_block_trailer_v2;


dcl  hcs_$get_max_length_seg ext entry
    (ptr, fixed bin (18), fixed bin (35));

dcl  ptr_is_good_v2_$ms_salvager_entry ext entry
    (ptr, fixed bin (18)) returns (bit (1) aligned);

/*  */

	max_message_size = mseg_data_v2_$max_message_size;
	mptr = ptr (a_salv_ptr, 0);			/* make pointer to message segment */
	block_size = fixed (mseg_hdr_v2.block_size, 18);
	call hcs_$get_max_length_seg (mptr, seg_size, code);
	if code ^= 0
	then go to FIN;
	if block_size <= 0				/* check for reasonable value */
	then
SET_BLOCK_SIZE:
	block_size = fixed (mseg_data_v2_$block_size);	/* take external one if bad */
	else
	if mod (seg_size, block_size) ^= 0
	then go to SET_BLOCK_SIZE;
	max_message_blocks = divide (max_message_size, block_size, 18, 0); /* compute max blocks in message */
	block_hdr_data = mseg_data_v2_$block_hdr_data;
	block_trailer_data = mseg_data_v2_$block_trailer_data;

	forward = a_forward;			/* copy argument */
	next_ms_ptr = a_salv_ptr;			/* where to begin salvaging */
	nrec = a_nrec;
	alloc_len = a_alloc_len;
	ms_offset = fixed (rel (next_ms_ptr), 18);	/* offset of where to begin salvaging */
	new_alloc_ptr = a_new_alloc_ptr;		/* copy argument */
	last_saved_ms_ptr = null;			/* initialize pointer to last saved message */
	tr_offset = block_size - block_trailer_data;	/* initialize trailer offset */
	first_block_ms_words =			/* intialize word count of full first block */
	block_size - (block_hdr_data + block_trailer_data);
	first_full_block_bit_count =			/* initialize bit count of full first block */
	first_block_ms_words * 36;
	full_block_bit_count =			/* initialize bit count of full block */
	(block_size - block_hdr_data) * 36;
	block_ms_words =				/* initialize word count of full block */
	block_size - block_hdr_data;

/*  */

	begin;

dcl  bit_offset (max_message_blocks) fixed bin (18);	/* array of offsets into alloc bits */

LABEL (1):     
CHECK_MESSAGE: 

	     first_block = "1"b;			/* remember this is a first block of a message */
	     tsaved_blocks = 0;			/* initialize blocks saved in message */

	     test_ms_ptr = next_ms_ptr;		/* set pointer to message to be tested */
	     ms_offset = fixed (rel (next_ms_ptr), 18);	/* set offset of message to be tested */
	     tr_ptr = addrel (test_ms_ptr, tr_offset);	/* make a pointer to the trailer */
	     if tr_ptr -> ms_block_trailer_v2.tr_pattern ^= mseg_data_v2_$mseg_tr36 /* no trailer pattern */
	     then go to FIN;
	     forward_offset =			/* get offset to next message */
	     fixed (tr_ptr -> ms_block_trailer_v2.f_offset, 18);
	     if forward_offset ^= 0
	     then if forward_offset > nrec*1024		/* forward offset off end of segment */
	     then go to FIN;			/* give up */
	     if forward_offset = 0			/* this should be last message in segment */
	     then if mseg_hdr_v2.last_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then go to FIN;			/* give up */
	     backward_offset =			/* get offset to previous message */
	     fixed (tr_ptr -> ms_block_trailer_v2.b_offset, 18);
	     if backward_offset ^= 0
	     then if backward_offset > nrec*1024	/* previous offset off end of message */
	     then go to FIN;
	     if backward_offset = 0			/* this should be first message */
	     then if mseg_hdr_v2.first_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then go to FIN;

	     if ms_size = "0"b			/* check for zeroing out */
	     | time = "0"b
	     | sender_id = zeroes
	     then go to FIN;

	     if (forward)				/* forward salvage */
	     then do;

		if previous_offset ^= 0		/* there was a previous message */
		then if backward_offset ^=
		previous_offset			/* this message doesn't point to it */
		then go to FIN;			/* give up */
		check_ptr,			/* create pointer to next message */
		next_ms_ptr = ptr (test_ms_ptr, forward_offset);

	     end;

	     else					/* backward salvage */
	     do;

		if previous_offset ^= 0		/* there was a previous message */
		then if forward_offset ^=
		previous_offset			/* this message doesn't point to it */
		then go to FIN;			/* give up */
		check_ptr,			/* create pointer to next message */
		next_ms_ptr = ptr (test_ms_ptr, backward_offset);

	     end;

	     previous_offset = ms_offset;		/* remember for next message check */

	     if fixed (rel (next_ms_ptr), 18) ^= 0	/* there is a next message */
	     then if (^ptr_is_good_v2_$ms_salvager_entry (next_ms_ptr, block_size)) /* bad offset to next message */
	     then go to FIN;			/* give up */

	     message_words =			/* calculate number of words in message */
	     divide (fixed (tr_ptr -> ms_block_trailer_v2.ms_size, 18)+35, 36, 18, 0);

	     if message_words <= 0			/* bad word count */
	     then go to FIN;			/* give up */
	     if message_words > max_message_size
	     then go to FIN;

	     if message_words <= first_block_ms_words	/* calculate blocks in message */
	     then message_blocks = 1;
	     else
	     message_blocks =
	     divide (message_words-first_block_ms_words+block_ms_words-1, block_ms_words, 17, 0)+1;
	     block_offset = fixed (rel (test_ms_ptr), 18);

	     test_block_ptr = test_ms_ptr;		/* set pointer for testing rest of block */

/*  */

/* check the block header */

LABEL (2):     
CHECK_BLOCK:   

/* check to see if the block has been allocated */

	     bit_off = divide (block_offset, block_size, 18, 0)+1; /* calculate bit offset in alloc bits */

	     do i = 1 to tsaved_blocks;		/* check against other blocks in this message */
		if bit_offset (i) = bit_off		/* block is used */
		then go to FIN;			/* give up */
	     end;

	     if new_alloc_ptr -> bit_mask (bit_off) = "1"b /* block is used */
	     then go to FIN;

	     if test_block_ptr -> ms_block_hdr.first_block ^=
	     first_block				/* bad first block flag */
	     then go to FIN;

	     block_bit_count =			/* get size of message portion in block */
	     fixed (test_block_ptr -> ms_block_hdr.block_count, 17);
	     if block_bit_count <= 0			/* bad block bit count */
	     then go to FIN;			/* give up */

	     if (first_block)			/* first block of a message */
	     then do;

		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     first_full_block_bit_count	/* error in block bit count */
		     then go to FIN;
		end;
		else				/* no blocks follow */
		if block_bit_count >
		first_full_block_bit_count		/* error in block bit count */
		then go to FIN;
	     end;

	     else					/* not first block in message */
	     do;
		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     full_block_bit_count		/* error in block bit count */
		     then go to FIN;		/* give up */
		end;
		else				/* last block in message */
		if block_bit_count > full_block_bit_count /* bad block bit count */
		then go to FIN;			/* give up */
	     end;

	     next_block_offset =			/* get the offset to the next message block */
	     fixed (test_block_ptr -> ms_block_hdr.f_offset, 18);

	     bit_offset (tsaved_blocks + 1) = bit_off;	/* remember location of block */

	     if message_blocks = 1			/* last block in message */
	     then do;
		if next_block_offset ^= 0		/* block pointer bad */
		then go to FIN;
		else				/* legitimate end of message */
		do;
		     saved_blocks =			/* add in saved blocks */
		     saved_blocks + tsaved_blocks +1;
		     do i = 1 to tsaved_blocks + 1;	/* turn on the appropriate allocation bits */
			new_alloc_ptr -> bit_mask (bit_offset (i)) = "1"b;
		     end;
		     saved_messages =		/* add in saved message */
		     saved_messages + 1;
		     last_saved_ms_ptr = test_ms_ptr;	/* set pointer to saved message */
		     check_ptr = next_ms_ptr;		/* prepare to check pointer */
		     label_var = 1;			/* prepare for next message check */
		end;
	     end;

	     else					/* not end of message */
	     do;
		first_block = "0"b;			/* remember next block is not a first block */
		message_blocks = message_blocks - 1;	/* decrement blocks left to check */
		tsaved_blocks = tsaved_blocks + 1;	/* increment temporary saved block count */
		block_offset = next_block_offset;	/* reset for testing next block */
		test_block_ptr,			/* make a pointer to the next block */
		check_ptr =			/* prepare to check the pointer */
		ptr (test_block_ptr, next_block_offset);
		label_var = 2;			/* prepare for next block check */
	     end;



	     if (ptr_is_good_v2_$ms_salvager_entry (check_ptr, block_size)) /* new pointer is ok */
	     then go to LABEL (label_var);		/* check next block */

	end;					/* of BEGIN block */

/*  */

FIN:	

	a_saved_messages = saved_messages;		/* return appropriate values */
	a_saved_blocks = saved_blocks;
	a_last_saved_ms_ptr = last_saved_ms_ptr;
	a_code = code;
	return;

     end ms_salv_util_v2_;




		    ms_salv_util_v3_.pl1            05/10/85  0856.6r w 05/06/85  1619.0      127143



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

ms_salv_util_v3_: proc (a_forward, a_salv_ptr, a_new_alloc_ptr, a_new_ht_ptr, a_block_size, a_seg_size, a_alloc_len, a_hdr_alloc_len,
	     a_mseg_access_class, a_saved_messages, a_saved_blocks, a_last_saved_ms_ptr);

/* Modified for version 3 message segments by J. Stern, 10/30/74 */
/* Modified by J. Stern, 11/14/75 */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */

dcl (a_saved_blocks,				/* number of saved message blocks (argument) */
     a_saved_messages,				/* number of saved messages (argument) */
     block_bit_count,				/* bit count of message portion in block */
     block_hdr_size,				/* words in header */
     block_trailer_size,				/* words in trailer */
     first_full_block_bit_count,			/* bits allocated to first block message portion */
     full_block_bit_count,				/* bits allocated to message portion */
     i,						/* do loop index */
     htx,						/* hash table index */
     max_message_blocks,				/* maximum blocks in a message */
     message_blocks,				/* number of unchecked blocks in message */
     saved_blocks init (0),				/* number of saved message blocks (internal) */
     saved_messages init (0),				/* number of saved messages (internal) */
     tsaved_blocks,					/* blocks saved in message */
     zero_words (8) init (0, 0, 0, 0, 0, 0, 0, 0)
     ) fixed bin;

dcl (a_alloc_len,					/* length of allocation bit string */
     a_hdr_alloc_len,				/* the part of alloc_len devoted to the header */
     a_block_size,					/* block size */
     a_seg_size,					/* max length of message seg */
     alloc_len,					/* length of allocation bit string */
     hdr_alloc_len,
     backward_offset,				/* offset to backward threaded message */
     bit_off,					/* offset of allocation bit for block */
     block_ms_words,				/* allocated size for message portion */
     block_offset,					/* offset to message block */
     block_size,					/* size of message block in words */
     first_block_ms_words,				/* allocated size for first block message portion */
     forward_offset,				/* offset to forward threaded message */
     max_message_size,				/* maximum words in a message */
     message_words,					/* word count of message */
     ms_offset,					/* offset to first block of message */
     mseg_data_v3_$block_size ext,			/* default block size */
     mseg_data_v3_$max_message_size ext,
     next_block_offset,				/* offset to next message block in message */
     seg_size,
     previous_offset init (0),			/* offset to previous message */
     tr_offset)					/* offset from beginning of block to trailer */
     fixed bin (18);

dcl (a_forward,					/* ON if salvage is forward (argument) */
     first_block,					/* ON if block is first block in message */
     forward)					/* ON if salvage is forward (internal) */
     bit (1) aligned;

dcl (a_last_saved_ms_ptr,				/* pointer to last saved message (argument) */
     a_new_alloc_ptr,				/* pointer to new allocation bits(argument) */
     a_new_ht_ptr,					/* pointer to new hash table (argument) */
     a_salv_ptr,					/* pointer to where to begin salvaging */
     last_saved_ms_ptr init (null),			/* pointer to last saved message(internal) */
     new_alloc_ptr,					/* pointer to new allocation bits(argument) */
     new_ht_ptr,					/* pointer to new hash table (internal) */
     next_ms_ptr,					/* pointer to next message */
     test_block_ptr,				/* pointer to message block being tested */
     test_ms_ptr)					/* pointer to message being tested */
     ptr;

dcl  prev_ms_id bit (72) aligned;			/* previous message id */

dcl (a_mseg_access_class,
     mseg_access_class) bit (72) aligned;		/* message segment access class */

dcl 1 new_hash_table aligned based (new_ht_ptr),		/* new hash table */
    2 last_in_bucket (0:511) bit (18) unaligned;

dcl (addr, addrel, divide, fixed, mod, null, ptr, rel, size, substr) builtin;

dcl  bit_mask (alloc_len) based (new_alloc_ptr) bit (1) unaligned; /* mask for setting allocation bits */

dcl  zeroes char (32) aligned based (addr (zero_words (1)));


% include mseg_hdr_v3;

% include ms_block_hdr_v3;

% include ms_block_trailer_v3;


dcl  aim_check_$greater_or_equal ext entry
    (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

/*  */

	mptr = ptr (a_salv_ptr, 0);			/* make pointer to message segment */

	max_message_size = mseg_data_v3_$max_message_size;
	block_size = a_block_size;
	max_message_blocks = divide (max_message_size, block_size, 18, 0); /* compute max blocks in message */
	block_hdr_size = size (ms_block_hdr);
	block_trailer_size = size (ms_block_trailer);

	forward = a_forward;			/* copy argument */
	next_ms_ptr = a_salv_ptr;			/* where to begin salvaging */
	seg_size = a_seg_size;
	alloc_len = a_alloc_len;
	hdr_alloc_len = a_hdr_alloc_len;
	ms_offset = fixed (rel (next_ms_ptr), 18);	/* offset of where to begin salvaging */
	call check_offset (ms_offset);
	new_alloc_ptr = a_new_alloc_ptr;		/* copy argument */
	new_ht_ptr = a_new_ht_ptr;
	mseg_access_class = a_mseg_access_class;
	tr_offset = block_size - block_trailer_size;	/* initialize trailer offset */
	first_block_ms_words =			/* intialize word count of full first block */
	     block_size - (block_hdr_size + block_trailer_size);
	first_full_block_bit_count =			/* initialize bit count of full first block */
	     first_block_ms_words * 36;
	full_block_bit_count =			/* initialize bit count of full block */
	     (block_size - block_hdr_size) * 36;
	block_ms_words =				/* initialize word count of full block */
	     block_size - block_hdr_size;
	if forward then prev_ms_id = (72) "0"b;
	else prev_ms_id = (72) "1"b;

/*  */

	begin;

dcl  bit_offset (max_message_blocks) fixed bin (18);	/* array of offsets into alloc bits */

CHECK_MESSAGE:

	     first_block = "1"b;			/* remember this is a first block of a message */
	     tsaved_blocks = 0;			/* initialize blocks saved in message */

	     test_ms_ptr = next_ms_ptr;		/* set pointer to message to be tested */
	     ms_offset = fixed (rel (next_ms_ptr), 18);	/* set offset of message to be tested */
	     tr_ptr = addrel (test_ms_ptr, tr_offset);	/* make a pointer to the trailer */
	     if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* no trailer pattern */
	     then go to FIN;
	     forward_offset =			/* get offset to next message */
		fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
	     if forward_offset ^= 0
	     then call check_offset (forward_offset);	/* forward offset off end of segment */
	     else if mseg_hdr.last_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then go to FIN;			/* give up */
	     backward_offset =			/* get offset to previous message */
		fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
	     if backward_offset ^= 0
	     then call check_offset (backward_offset);	/* previous offset off end of message */
	     else if mseg_hdr.first_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then go to FIN;

	     if ms_size = "0"b			/* check for zeroing out */
	     | ms_id = "0"b
	     | sender_id = zeroes
	     then go to FIN;

	     if ^aim_check_$greater_or_equal (mseg_access_class, access_class)
	     then go to FIN;
	     if ^aim_check_$greater_or_equal (access_class, sender_authorization)
	     then go to FIN;

	     htx = fixed (substr (ms_id, 64, 9));	/* get hash table index of message */
	     block_offset = fixed (tr_ptr -> ms_block_trailer.back_in_bucket);
	     if block_offset ^= 0			/* not end of thread */
	     then call check_offset (block_offset);	/* check the hash bucket offset */

	     if (forward)				/* forward salvage */
	     then do;

		if previous_offset ^= 0		/* there was a previous message */
		then if backward_offset ^=
		     previous_offset		/* this message doesn't point to it */
		     then go to FIN;		/* give up */
		next_ms_ptr = ptr (test_ms_ptr, forward_offset);

		if substr (prev_ms_id, 19, 54) >= substr (ms_id, 19, 54)
		then do;				/* should be monotonically increasing */
		     ms_id = ""b;			/* make ms_id look bad for backward salvage too!! */
		     go to FIN;
		end;

	     end;

	     else					/* backward salvage */
	     do;

		if previous_offset ^= 0		/* there was a previous message */
		then if forward_offset ^=
		     previous_offset		/* this message doesn't point to it */
		     then go to FIN;		/* give up */
		next_ms_ptr = ptr (test_ms_ptr, backward_offset);

		if substr (prev_ms_id, 19, 54) <= substr (ms_id, 19, 54)
		then go to FIN;			/* should be monotonically decreasing */

	     end;

	     previous_offset = ms_offset;		/* remember for next message check */
	     prev_ms_id = ms_id;

	     message_words =			/* calculate number of words in message */
		divide (fixed (tr_ptr -> ms_block_trailer.ms_size, 18)+35, 36, 18, 0);

	     if message_words <= 0			/* bad word count */
	     then go to FIN;			/* give up */
	     if message_words > max_message_size
	     then go to FIN;

	     if message_words <= first_block_ms_words	/* calculate blocks in message */
	     then message_blocks = 1;
	     else
	     message_blocks =
		divide (message_words-first_block_ms_words+block_ms_words-1, block_ms_words, 17, 0)+1;
	     block_offset = ms_offset;

	     test_block_ptr = test_ms_ptr;		/* set pointer for testing rest of block */

/*  */

/* check the block header */

CHECK_BLOCK:

/* check to see if the block has been allocated */

	     bit_off = divide (block_offset, block_size, 18, 0)+1; /* calculate bit offset in alloc bits */

	     do i = 1 to tsaved_blocks;		/* check against other blocks in this message */
		if bit_offset (i) = bit_off		/* block is used */
		then go to FIN;			/* give up */
	     end;

	     if new_alloc_ptr -> bit_mask (bit_off) = "1"b /* block is used */
	     then go to FIN;

	     if test_block_ptr -> ms_block_hdr.first_block ^=
	     first_block				/* bad first block flag */
	     then go to FIN;

	     block_bit_count =			/* get size of message portion in block */
		fixed (test_block_ptr -> ms_block_hdr.block_count, 17);
	     if block_bit_count <= 0			/* bad block bit count */
	     then go to FIN;			/* give up */

	     if (first_block)			/* first block of a message */
	     then do;

		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     first_full_block_bit_count	/* error in block bit count */
		     then go to FIN;
		end;
		else				/* no blocks follow */
		if block_bit_count >
		first_full_block_bit_count		/* error in block bit count */
		then go to FIN;
	     end;

	     else					/* not first block in message */
	     do;
		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     full_block_bit_count		/* error in block bit count */
		     then go to FIN;		/* give up */
		end;
		else				/* last block in message */
		if block_bit_count > full_block_bit_count /* bad block bit count */
		then go to FIN;			/* give up */
	     end;

	     next_block_offset =			/* get the offset to the next message block */
		fixed (test_block_ptr -> ms_block_hdr.f_offset, 18);

	     bit_offset (tsaved_blocks + 1) = bit_off;	/* remember location of block */

	     if message_blocks = 1			/* last block in message */
	     then do;
		if next_block_offset ^= 0		/* block pointer bad */
		then go to FIN;
		else				/* legitimate end of message */
		do;
		     saved_blocks =			/* add in saved blocks */
			saved_blocks + tsaved_blocks +1;
		     do i = 1 to tsaved_blocks + 1;	/* turn on the appropriate allocation bits */
			new_alloc_ptr -> bit_mask (bit_offset (i)) = "1"b;
		     end;
		     back_in_bucket = new_hash_table.last_in_bucket (htx); /* set back ptr to previous last */
		     new_hash_table.last_in_bucket (htx) = rel (test_ms_ptr); /* make this one the last in bucket */
		     saved_messages =		/* add in saved message */
			saved_messages + 1;
		     last_saved_ms_ptr = test_ms_ptr;	/* set pointer to saved message */
		     go to CHECK_MESSAGE;
		end;
	     end;

	     else					/* not end of message */
	     do;
		call check_offset (next_block_offset);	/* check offset to next block */
		first_block = "0"b;			/* remember next block is not a first block */
		message_blocks = message_blocks - 1;	/* decrement blocks left to check */
		tsaved_blocks = tsaved_blocks + 1;	/* increment temporary saved block count */
		block_offset = next_block_offset;	/* reset for testing next block */
		test_block_ptr =			/* make a pointer to the next block */
		     ptr (test_block_ptr, next_block_offset);
		go to CHECK_BLOCK;
	     end;

	end;					/* of BEGIN block */

/*  */

FIN:

	a_saved_messages = saved_messages;		/* return appropriate values */
	a_saved_blocks = saved_blocks;
	a_last_saved_ms_ptr = last_saved_ms_ptr;
	return;


check_offset: proc (a_relp);				/* procedure to check validity of an offset */

dcl (a_relp, relp) fixed bin (18);

	     relp = a_relp;
	     if relp + block_size > seg_size then go to FIN; /* offset beyond max length of segment */
	     if mod (relp, block_size) ^= 0 then go to FIN; /* not offset of a block */
	     relp = divide (relp, block_size, 18, 0) +1;	/* convert block offset to block number */
	     if relp <= hdr_alloc_len then go to FIN;	/* offset within header blocks */
	     if relp > alloc_len then go to FIN;	/* offset beyond last block */

	end check_offset;

     end ms_salv_util_v3_;




		    ms_salv_util_v4_.pl1            05/09/85  1152.2r w 05/06/85  1619.0      131202



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


ms_salv_util_v4_: proc (a_forward, a_salv_ptr, a_new_alloc_ptr, a_new_ht_ptr, a_block_size, a_seg_size, a_alloc_len, a_hdr_alloc_len,
	     a_mseg_access_class, a_saved_messages, a_saved_blocks, a_last_saved_ms_ptr);

/* Modified for version 3 message segments by J. Stern, 10/30/74 */
/* Modified by J. Stern, 11/14/75 */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */
/* Modified 4/82 by E. N. Kittlitz to detect discrepancy 'twixt ms_size and total block_count */
/* Modified 1984-10-19 BIM to remove bogus access class check that deleted
    messages sent down. */

dcl (a_saved_blocks,				/* number of saved message blocks (argument) */
     a_saved_messages,				/* number of saved messages (argument) */
     block_bit_count,				/* bit count of message portion in block */
     block_hdr_size,				/* words in header */
     block_trailer_size,				/* words in trailer */
     first_full_block_bit_count,			/* bits allocated to first block message portion */
     full_block_bit_count,				/* bits allocated to message portion */
     i,						/* do loop index */
     htx,						/* hash table index */
     max_message_blocks,				/* maximum blocks in a message */
     message_blocks,				/* number of unchecked blocks in message */
     saved_blocks init (0),				/* number of saved message blocks (internal) */
     saved_messages init (0),				/* number of saved messages (internal) */
     tsaved_blocks,					/* blocks saved in message */
     zero_words (8) init (0, 0, 0, 0, 0, 0, 0, 0)
     ) fixed bin;

dcl (a_alloc_len,					/* length of allocation bit string */
     a_hdr_alloc_len,				/* the part of alloc_len devoted to the header */
     a_block_size,					/* block size */
     a_seg_size,					/* max length of message seg */
     alloc_len,					/* length of allocation bit string */
     hdr_alloc_len,
     backward_offset,				/* offset to backward threaded message */
     bit_off,					/* offset of allocation bit for block */
     block_ms_words,				/* allocated size for message portion */
     block_offset,					/* offset to message block */
     block_size,					/* size of message block in words */
     first_block_ms_words,				/* allocated size for first block message portion */
     forward_offset,				/* offset to forward threaded message */
     max_message_size,				/* maximum words in a message */
     message_words,					/* word count of message */
     ms_offset,					/* offset to first block of message */
     mseg_data_v4_$block_size ext,			/* default block size */
     mseg_data_v4_$max_message_size ext,
     next_block_offset,				/* offset to next message block in message */
     seg_size,
     previous_offset init (0),			/* offset to previous message */
     tr_offset)					/* offset from beginning of block to trailer */
     fixed bin (18);

dcl (a_forward,					/* ON if salvage is forward (argument) */
     first_block,					/* ON if block is first block in message */
     forward)					/* ON if salvage is forward (internal) */
     bit (1) aligned;

dcl (a_last_saved_ms_ptr,				/* pointer to last saved message (argument) */
     a_new_alloc_ptr,				/* pointer to new allocation bits(argument) */
     a_new_ht_ptr,					/* pointer to new hash table (argument) */
     a_salv_ptr,					/* pointer to where to begin salvaging */
     last_saved_ms_ptr init (null),			/* pointer to last saved message(internal) */
     new_alloc_ptr,					/* pointer to new allocation bits(argument) */
     new_ht_ptr,					/* pointer to new hash table (internal) */
     next_ms_ptr,					/* pointer to next message */
     test_block_ptr,				/* pointer to message block being tested */
     test_ms_ptr)					/* pointer to message being tested */
     ptr;

dcl  ms_size fixed bin (24);				/* used to check trailer.ms_size with hdr.block_count sum */

dcl  prev_ms_id bit (72) aligned;			/* previous message id */

dcl (a_mseg_access_class,
     mseg_access_class) bit (72) aligned;		/* message segment access class */

dcl 1 new_hash_table aligned based (new_ht_ptr),		/* new hash table */
    2 last_in_bucket (0:511) bit (18) unaligned;

dcl (addr, addrel, divide, fixed, mod, null, ptr, rel, size, substr) builtin;

dcl  bit_mask (alloc_len) based (new_alloc_ptr) bit (1) unaligned; /* mask for setting allocation bits */

dcl  zeroes char (32) aligned based (addr (zero_words (1)));


%include mseg_hdr_v4;
dcl mptr pointer;

%include ms_block_hdr_v4;

%include ms_block_trailer_v4;


dcl  aim_check_$greater_or_equal ext entry
    (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

/*  */

	mptr = ptr (a_salv_ptr, 0);			/* make pointer to message segment */

	max_message_size = mseg_data_v4_$max_message_size;
	block_size = a_block_size;
	max_message_blocks = divide (max_message_size, block_size, 18, 0); /* compute max blocks in message */
	block_hdr_size = size (ms_block_hdr);
	block_trailer_size = size (ms_block_trailer);

	forward = a_forward;			/* copy argument */
	next_ms_ptr = a_salv_ptr;			/* where to begin salvaging */
	seg_size = a_seg_size;
	alloc_len = a_alloc_len;
	hdr_alloc_len = a_hdr_alloc_len;
	ms_offset = fixed (rel (next_ms_ptr), 18);	/* offset of where to begin salvaging */
	call check_offset (ms_offset);
	new_alloc_ptr = a_new_alloc_ptr;		/* copy argument */
	new_ht_ptr = a_new_ht_ptr;
	mseg_access_class = a_mseg_access_class;
	tr_offset = block_size - block_trailer_size;	/* initialize trailer offset */
	first_block_ms_words =			/* intialize word count of full first block */
	     block_size - (block_hdr_size + block_trailer_size);
	first_full_block_bit_count =			/* initialize bit count of full first block */
	     first_block_ms_words * 36;
	full_block_bit_count =			/* initialize bit count of full block */
	     (block_size - block_hdr_size) * 36;
	block_ms_words =				/* initialize word count of full block */
	     block_size - block_hdr_size;
	if forward then prev_ms_id = (72) "0"b;
	else prev_ms_id = (72) "1"b;

/*  */

	begin;

dcl  bit_offset (max_message_blocks) fixed bin (18);	/* array of offsets into alloc bits */

CHECK_MESSAGE:

	     first_block = "1"b;			/* remember this is a first block of a message */
	     tsaved_blocks = 0;			/* initialize blocks saved in message */

	     test_ms_ptr = next_ms_ptr;		/* set pointer to message to be tested */
	     ms_offset = fixed (rel (next_ms_ptr), 18);	/* set offset of message to be tested */
	     tr_ptr = addrel (test_ms_ptr, tr_offset);	/* make a pointer to the trailer */
	     if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* no trailer pattern */
	     then call FIN;
	     forward_offset =			/* get offset to next message */
		fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
	     if forward_offset ^= 0
	     then call check_offset (forward_offset);	/* forward offset off end of segment */
	     else if mptr -> mseg_hdr_v4.last_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then call FIN;			/* give up */
	     backward_offset =			/* get offset to previous message */
		fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
	     if backward_offset ^= 0
	     then call check_offset (backward_offset);	/* previous offset off end of message */
	     else if mptr -> mseg_hdr_v4.first_ms_offset ^= rel (test_ms_ptr) /* header doesn't agree */
	     then call FIN;

	     if ms_block_trailer.ms_size = "0"b		/* check for zeroing out */
	     | ms_block_trailer.ms_id = "0"b
	     | ms_block_trailer.sender_id = zeroes
	     then call FIN;

	     if ^aim_check_$greater_or_equal (mseg_access_class, ms_block_trailer.access_class)
	     then call FIN;

	     htx = fixed (substr (ms_block_trailer.ms_id, 64, 9));	/* get hash table index of message */
	     block_offset = fixed (tr_ptr -> ms_block_trailer.back_in_bucket); 
	     if block_offset ^= 0			/* not end of thread */
	     then call check_offset (block_offset);	/* check the hash bucket offset */

	     if (forward)				/* forward salvage */
	     then do;

		if previous_offset ^= 0		/* there was a previous message */
		then if backward_offset ^=
		     previous_offset		/* this message doesn't point to it */
		     then call FIN;		/* give up */
		next_ms_ptr = ptr (test_ms_ptr, forward_offset);

		if substr (prev_ms_id, 19, 54) >= substr (ms_block_trailer.ms_id, 19, 54)
		then do;				/* should be monotonically increasing */
		     ms_block_trailer.ms_id = ""b;	/* make ms_id look bad for backward salvage too!! */
		     call FIN;
		end;

	     end;

	     else					/* backward salvage */
	     do;

		if previous_offset ^= 0		/* there was a previous message */
		then if forward_offset ^=
		     previous_offset		/* this message doesn't point to it */
		     then call FIN;		/* give up */
		next_ms_ptr = ptr (test_ms_ptr, backward_offset);

		if substr (prev_ms_id, 19, 54) <= substr (ms_block_trailer.ms_id, 19, 54)
		then call FIN;			/* should be monotonically decreasing */

	     end;

	     previous_offset = ms_offset;		/* remember for next message check */
	     prev_ms_id = ms_block_trailer.ms_id;

	     ms_size = fixed (tr_ptr -> ms_block_trailer.ms_size, 24);
	     message_words =			/* calculate number of words in message */
		divide (ms_size + 35, 36, 18, 0);

	     if message_words <= 0			/* bad word count */
	     then call FIN;			/* give up */
	     if message_words > max_message_size
	     then call FIN;

	     if message_words <= first_block_ms_words	/* calculate blocks in message */
	     then message_blocks = 1;
	     else
	     message_blocks =
		divide (message_words-first_block_ms_words+block_ms_words-1, block_ms_words, 17, 0)+1;
	     block_offset = ms_offset;

	     test_block_ptr = test_ms_ptr;		/* set pointer for testing rest of block */

/*  */

/* check the block header */

CHECK_BLOCK:

/* check to see if the block has been allocated */

	     bit_off = divide (block_offset, block_size, 18, 0)+1; /* calculate bit offset in alloc bits */

	     do i = 1 to tsaved_blocks;		/* check against other blocks in this message */
		if bit_offset (i) = bit_off		/* block is used */
		then call FIN;			/* give up */
	     end;

	     if new_alloc_ptr -> bit_mask (bit_off) = "1"b /* block is used */
	     then call FIN;

	     if test_block_ptr -> ms_block_hdr.first_block ^=
	     first_block				/* bad first block flag */
	     then call FIN;

	     block_bit_count =			/* get size of message portion in block */
		fixed (test_block_ptr -> ms_block_hdr.block_count, 17);
	     if block_bit_count <= 0			/* bad block bit count */
	     then call FIN;			/* give up */

	     ms_size = ms_size - block_bit_count;	/* decrement total size of message */
	     if ms_size < 0 then call FIN;		/* disagreement between trailer and total of blocks */

	     if (first_block)			/* first block of a message */
	     then do;

		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     first_full_block_bit_count	/* error in block bit count */
		     then call FIN;
		end;
		else				/* no blocks follow */
		if block_bit_count >
		first_full_block_bit_count		/* error in block bit count */
		then call FIN;
	     end;

	     else					/* not first block in message */
	     do;
		if message_blocks ^= 1		/* another block follows */
		then do;
		     if block_bit_count ^=
		     full_block_bit_count		/* error in block bit count */
		     then call FIN;		/* give up */
		end;
		else				/* last block in message */
		if block_bit_count > full_block_bit_count /* bad block bit count */
		then call FIN;			/* give up */
	     end;

	     next_block_offset =			/* get the offset to the next message block */
		fixed (test_block_ptr -> ms_block_hdr.f_offset, 18);

	     bit_offset (tsaved_blocks + 1) = bit_off;	/* remember location of block */

	     if message_blocks = 1			/* last block in message */
	     then do;
		if next_block_offset ^= 0		/* block pointer bad */
		then call FIN;
		else if ms_size ^= 0		/* disagreement between trailer.ms_size and sum of blocks */
		then call FIN;
		else				/* legitimate end of message */
		do;
		     saved_blocks =			/* add in saved blocks */
			saved_blocks + tsaved_blocks +1;
		     do i = 1 to tsaved_blocks + 1;	/* turn on the appropriate allocation bits */
			new_alloc_ptr -> bit_mask (bit_offset (i)) = "1"b;
		     end;
		     back_in_bucket = new_hash_table.last_in_bucket (htx); /* set back ptr to previous last */
		     new_hash_table.last_in_bucket (htx) = rel (test_ms_ptr); /* make this one the last in bucket */
		     saved_messages =		/* add in saved message */
			saved_messages + 1;
		     last_saved_ms_ptr = test_ms_ptr;	/* set pointer to saved message */
		     go to CHECK_MESSAGE;
		end;
	     end;

	     else					/* not end of message */
	     do;
		call check_offset (next_block_offset);	/* check offset to next block */
		first_block = "0"b;			/* remember next block is not a first block */
		message_blocks = message_blocks - 1;	/* decrement blocks left to check */
		tsaved_blocks = tsaved_blocks + 1;	/* increment temporary saved block count */
		block_offset = next_block_offset;	/* reset for testing next block */
		test_block_ptr =			/* make a pointer to the next block */
		     ptr (test_block_ptr, next_block_offset);
		go to CHECK_BLOCK;
	     end;

	end;					/* of BEGIN block */

/*  */

FIN:	procedure;
	go to GIVE_UP_AND_RETURN;
	end FIN;

GIVE_UP_AND_RETURN:
	a_saved_messages = saved_messages;		/* return appropriate values */
	a_saved_blocks = saved_blocks;
	a_last_saved_ms_ptr = last_saved_ms_ptr;
	return;


check_offset: proc (a_relp);				/* procedure to check validity of an offset */

dcl (a_relp, relp) fixed bin (18);

	     relp = a_relp;
	     if relp + block_size > seg_size then call FIN; /* offset beyond max length of segment */
	     if mod (relp, block_size) ^= 0 then call FIN; /* not offset of a block */
	     relp = divide (relp, block_size, 18, 0) +1;	/* convert block offset to block number */
	     if relp <= hdr_alloc_len then call FIN;	/* offset within header blocks */
	     if relp > alloc_len then call FIN;	/* offset beyond last block */

	end check_offset;

     end ms_salv_util_v4_;




		    ms_salvager_v2_.pl1             05/10/85  0856.7r w 05/06/85  1619.0      116442



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

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */
%;
ms_salvager_v2_: proc (a_mptr, a_saved_messages, a_code);

/* Adapted from original version 2 ms_salvager_ by J. Stern, 11/4/74 */

dcl  establish_cleanup_proc_ entry (entry);

dcl (
     a_saved_messages,				/* number of saved messages (argument) */
     block_bits,					/* number of bits in a message block */
     dirl,					/* length of dir portion of message seg pname */
     i,						/* do loop index */
     mseg_data_v2_$block_trailer_data ext,			/* word count of trailer size */
     max_hdr_ms_len ext,				/* maximum length of header message */
     mseg_data_v2_$version_number ext,			/* current version of message segment primitives */
     saved_blocks init (0),				/* number of saved message blocks */
     saved_messages init (0),				/* number of saved messages (internal) */
     status_words (0: 9),				/* storage for status information */
     tsaved_blocks,					/* number of saved blocks per pass */
     tsaved_messages)				/* number of saved messages per pass */
     fixed bin;

dcl (alloc_len,					/* length of allocation bit string */
     block_offset,					/* offset to a message block */
     block_size,					/* size of message block */
     hdr_alloc_len,					/* number of allocation bits used for header */
     mseg_data_v2_$block_size ext,
     nrec,					/* number of records used by message segment */
     seg_size,					/* maximum size of a segment */
     temp,					/* calculation variable */
     trailer_offset) fixed bin (18);

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35);

dcl  dir char (168) aligned;				/* directory portion of message segment pathname */

dcl  ent char (32) aligned;				/* entry portion of message segment pathname */

dcl (forward init ("1"b),				/* ON if salvage is forward */
     set_block_size init ("0"b),			/* ON if block size in hdr to be set */
     total_success init ("0"b))			/* ON if salvage pass is totally successful */
     bit (1) aligned;

dcl  mseg_data_v2_$mseg_b36 ext bit (36) aligned;		/* header recognition pattern */

dcl (addr, addrel, bit, divide, fixed, mod, null, ptr, rel, substr) builtin;

dcl (a_mptr,					/* pointer to message segment (argument) */
     block_ptr,					/* pointer to a message block */
     end_ptr,					/* pointer to last message for salvage pass */
     eptr,                                                  /* pointer to status information */
     last_backward_ptr init (null),			/* pointer to last saved message in backward salvage */
     last_forward_ptr init (null),			/* pointer to last saved message in forward salvage */
     last_saved_ms_ptr,				/* pointer to last message saved in a pass */
     new_alloc_ptr,					/* pointer to new allocation bit string */
     old_first_ptr,					/* pointer to old first message */
     old_last_ptr,					/* pointer to old last message */
     salv_ptr)					/* pointer to beginning point for salvage */
     ptr;

dcl  block_mask bit (block_bits) aligned based;		/* mask for zeroing out unused message blocks */

dcl  hdr_ms_mask bit (36*max_hdr_ms_len) aligned based;	/* for zeroing out header message */

dcl 1 status_dope based (eptr) aligned,			/* mask for getting nrec from status info */
    2 pad (7) fixed bin aligned,
    2 curlen bit (12) unaligned;

dcl  error_table_$bad_segment ext fixed bin (35);
dcl  error_table_$no_message ext fixed bin (35);

/*  */

% include mseg_hdr_v2;

% include ms_block_trailer_v2;

dcl  hcs_$fs_get_path_name ext entry
    (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35));

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35));

dcl  hcs_$status_long ext entry
    (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35));

dcl  hcs_$truncate_seg ext entry
    (ptr, fixed bin, fixed bin (35));

dcl  ptr_is_good_v2_$ms_salvager_entry ext entry
    (ptr, fixed bin (18)) returns (bit (1) aligned);

dcl  ms_salv_util_v2_ ext entry
    (bit (1) aligned, ptr, ptr, fixed bin (18), fixed bin (18), fixed bin, fixed bin, ptr, fixed bin (35));

/*  */
          eptr = addr (status_words);
	mptr = a_mptr;				/* copy argument */

	call establish_cleanup_proc_ (cleanup_handler);

cleanup_handler: proc;
	     call hcs_$truncate_seg (mptr, 1, code);	/* throw everything away */
	     go to FIN;
	end;


	call hcs_$get_max_length_seg (mptr, seg_size, code);
	if code ^= 0 then go to FIN;

	block_size = fixed (mseg_hdr_v2.block_size, 18);	/* fetch block size */
	if block_size <= 0
	then do;
SET_BLOCK_SIZE:
	     block_size = fixed (mseg_data_v2_$block_size, 18); /* take default and hope it's right */
	     set_block_size = "1"b;			/* remember to set later */
	end;

	else					/* block size not <= 0 */
	if mod (seg_size, block_size) ^= 0		/* bad block size */
	then go to SET_BLOCK_SIZE;


	alloc_len = divide (seg_size, block_size, 18, 0);	/* compute length of allocation bits */

	temp = divide ((fixed (rel (addr (mptr -> mseg_hdr_v2.hdr_ms_end)), 18)+1)*36 + alloc_len+35, 36, 18, 0);
	hdr_alloc_len = divide (temp+block_size-1, block_size, 18, 0); /* compute alloc bits used by header */
	max_hdr_ms_len = temp - fixed (rel (addr (mptr -> mseg_hdr_v2.hdr_ms)), 17);

	trailer_offset = fixed (block_size-mseg_data_v2_$block_trailer_data, 18); /* compute trailer offset */

	call hcs_$fs_get_path_name (mptr, dir, dirl, ent, code); /* get dir and ent names of segment */
	if code ^= 0
	then go to FIN;

	call hcs_$status_long (dir, ent, 1, eptr, null, code); /* get number of records used by message segment */
	if code ^= 0
	then go to FIN;

	nrec = fixed (status_dope.curlen, 18);

/*  */

	begin;

dcl  new_alloc_bits bit (alloc_len) init ("0"b) aligned;	/* new allocation bit string */

	     new_alloc_ptr = addr (new_alloc_bits);	/* set pointer to new bit string */

	     old_first_ptr, salv_ptr =		/* set possible first message,salvage ptr */
	     ptr (mptr, fixed (mseg_hdr_v2.first_ms_offset, 18));
	     old_last_ptr, end_ptr =			/* set possible last message,end salvage ptr */
	     ptr (mptr, fixed (mseg_hdr_v2.last_ms_offset, 18));
	     do i = 1 to hdr_alloc_len;		/* turn on header allocation bits */
		substr (new_alloc_bits, i, 1) = "1"b;
	     end;

/* salvage */

SALVAGE_LOOP:  

	     if (ptr_is_good_v2_$ms_salvager_entry (salv_ptr, block_size)) /* check validity of salvaging pointer */
	     then if (fixed (rel (salv_ptr), 18))+block_size <= nrec*1024
	     then do;				/* pointer is valid, go */

		tsaved_messages = 0;		/* initialize number of saved messages per pass */
		last_saved_ms_ptr = null;		/* initialize pointer to last saver message */
		call ms_salv_util_v2_
		(forward, salv_ptr, new_alloc_ptr, nrec, alloc_len,
		tsaved_messages, tsaved_blocks, last_saved_ms_ptr, code);
		if code ^= 0
		then go to FIN;
		saved_messages =			/* add in number of saved messages */
		saved_messages + tsaved_messages;
		saved_blocks =			/* add in number of saved blocks */
		saved_blocks + tsaved_blocks;
		if last_saved_ms_ptr = end_ptr	/* total success? */
		then total_success = "1"b;		/* set a flag to remember */

		if tsaved_messages ^= 0		/* partial success? */
		then do;				/* yes */

		     if (forward)			/* forward salvage? */
		     then last_forward_ptr =		/* yes, save pointer to last good message */
		     last_saved_ms_ptr;

		     else				/* backward salvage */
		     last_backward_ptr =		/* save pointer to last good message */
		     last_saved_ms_ptr;

		end;

		if (total_success)			/* if successful, don't need another pass */
		then go to SET_HEADER_DATA;

	     end;

	     if (forward)				/* first pass at salvaging? */
	     then do;				/* yes, prepare for next pass */
		forward = "0"b;			/* set direction of salvage */
		salv_ptr = old_last_ptr;		/* set salvaging pointer */
		end_ptr = old_first_ptr;		/* set hopeful end of salvage ptr */
		go to SALVAGE_LOOP;
	     end;

/*  */

/* join message fragments */

	     if saved_messages ^= 0			/* any success in salvaging? */
	     then do;				/* yes */

		if set_block_size			/* need to set block size in header */
		then mseg_hdr_v2.block_size = block_size; /* do it */

		if last_forward_ptr ^= null		/* forward salvage partly successful */
		then do;				/* yes */

		     if last_backward_ptr ^= null	/* backward salvage partly successful? */
		     then do;			/* yes */
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer_v2.f_offset =
			bit (fixed (rel (last_backward_ptr), 18), 18);
			addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer_v2.b_offset =
			bit (fixed (rel (last_forward_ptr), 18), 18);
		     end;

		     else				/* backward salvage unsuccessful */
		     do;
			mseg_hdr_v2.last_ms_offset =	/* reset last message offset in header */
			bit (fixed (rel (last_forward_ptr), 18), 18);
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer_v2.f_offset =
			"0"b;			/* zero out next offset of new last message */
		     end;

		end;

		else				/* forward salvage no good */
		do;				/* backward salvage must have been */
		     mseg_hdr_v2.first_ms_offset =	/* reset first message offset */
		     bit (fixed (rel (last_backward_ptr), 18), 18);
		     addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer_v2.b_offset =
		     "0"b;			/* zero prev message offset of new 1st message */
		end;

/* reset other header data */

SET_HEADER_DATA:	

		if (total_success)			/* was salvaging totally successful? */
		then do;				/* yes */

		     if (forward)			/* direction was forward */
		     then mseg_hdr_v2.last_ms_offset =	/* reset last message offset */
		     bit (fixed (rel (last_forward_ptr), 18), 18);

		     else				/* direction was backward */
		     mseg_hdr_v2.first_ms_offset =	/* reset first message offset */
		     bit (fixed (rel (last_backward_ptr), 18), 18);

		end;

		block_bits = fixed (block_size*36, 17);	/* set length of block mask */
		do i = 1 to alloc_len;		/* zero out unused blocks */
		     if substr (new_alloc_bits, i, 1) = "0"b /* block is unused */
		     then do;
			block_offset = block_size * fixed (i-1, 18);
			if divide (block_offset+block_size, 1000, 18, 0) > nrec
			then go to FIN;		/* block offset off end of records used, only 0s left */
			block_ptr = ptr (salv_ptr, block_offset);
			block_ptr -> block_mask = "0"b;
		     end;
		end;

	     end;

	     if mseg_hdr_v2.switches.ms_in_hdr		/* there is a message in the header */
	     then do;
		if mseg_hdr_v2.hdr_ms_len <= 0 |		/* check for a reasonable length */
		mseg_hdr_v2.hdr_ms_len > max_hdr_ms_len
		then do;				/* unreasonable length */
		     mseg_hdr_v2.switches.ms_in_hdr = "0"b; /* delete the message */
		     addr (mseg_hdr_v2.hdr_ms) -> hdr_ms_mask = "0"b;
		end;
	     end;

	     if saved_messages ^= 0			/* something was saved */
	     | mseg_hdr_v2.switches.ms_in_hdr
	     then do;				/* reset the header data */
		mseg_hdr_v2.space_left =		/* reset space left */
		alloc_len- (hdr_alloc_len+saved_blocks);
		mseg_hdr_v2.alloc_bits = new_alloc_bits;	/* reset allocation bit string */
		mseg_hdr_v2.number_of_messages =
		saved_messages;			/* set message count */
		mseg_hdr_v2.alloc_len = alloc_len;	/* set allocation bits length */
		mseg_hdr_v2.mseg_pattern = mseg_data_v2_$mseg_b36; /* set header pattern */
		mseg_hdr_v2.version_number = mseg_data_v2_$version_number; /* set version number */
	     end;

	     if saved_messages = 0			/* no messages were saved */
	     then do;
		if mseg_hdr_v2.switches.ms_in_hdr	/* a header message was saved */
		then mseg_hdr_v2.first_ms_offset,	/* zero out forward and backward offsets */
		mseg_hdr_v2.last_ms_offset = "0"b;
		else				/* no success salvaging */
		do;
		     call hcs_$truncate_seg (mptr, 1, code); /* throw everything away */
		end;
	     end;

	end;					/* of BEGIN block */

FIN:	

	if saved_messages ^= 0 | mseg_hdr_v2.switches.ms_in_hdr /* something was saved */
	then do;
	     mseg_hdr_v2.switches.aip = "0"b;		/* turn of aip bit */
	     mseg_hdr_v2.switches.os = "1"b;		/* message segment was salvaged */
	end;
	a_saved_messages = saved_messages;		/* return number of saved messages */
	a_code = code;				/* return code */
	return;

     end ms_salvager_v2_;




		    ms_salvager_v3_.pl1             05/10/85  0856.7r w 05/06/85  1619.0      101034



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


ms_salvager_v3_: proc (a_mptr, a_code);

/* Modified for version 3 message segments by J. Stern, 10/30/74 */
/* Modified to use mseg_error_ by J. Stern, 11/12/75 */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */

dcl (
     mseg_dir,					/* mseg directory name */
     comp1)					/* 1st component of directory name */
     char (168) aligned;

dcl (
     mseg_name,					/* mseg entryname */
     comp2)					/* 2nd component of directory name */
     char (32) aligned;

dcl (
     i,						/* do loop index */
     dir_len,					/* length of mseg directory */
     saved_blocks init (0),				/* number of saved message blocks */
     saved_messages init (0),				/* number of saved messages (internal) */
     original_messages,				/* number of messages before salvaging */
     tsaved_blocks,					/* number of saved blocks per pass */
     tsaved_messages)				/* number of saved messages per pass */
     fixed bin;

dcl (alloc_len,					/* length of allocation bit string */
     block_offset,					/* offset to a message block */
     block_size,					/* size of message block */
     hdr_alloc_len,					/* number of allocation bits used for header */
     mseg_data_v3_$block_size ext,
     seg_size,					/* maximum size of a segment */
     hdr_size,					/* number of words in header before alloc_bits */
     trailer_offset) fixed bin (18);

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code, (internal) */
     error_table_$fatal_error ext
     ) fixed bin (35);

dcl  reason char (40);				/* reason for salvager failure */

dcl  forward bit (1) aligned;				/* ON if salvage is forward */

dcl (addr, addrel, bit, divide, fixed, null, ptr, rel, size, substr) builtin;

dcl (a_mptr,					/* pointer to message segment (argument) */
     end_ptr,					/* pointer to last message for salvage pass */
     last_backward_ptr init (null),			/* pointer to last saved message in backward salvage */
     last_forward_ptr init (null),			/* pointer to last saved message in forward salvage */
     last_saved_ms_ptr,				/* pointer to last message saved in a pass */
     salv_ptr)					/* pointer to beginning point for salvage */
     ptr;

dcl  mseg_access_class bit (72) aligned;		/* message segment access class */

dcl  hdr_ms_mask bit (36*max_hdr_ms_len) aligned based;	/* for zeroing out header message */

dcl  ring_brackets (3) fixed bin(3) init(1,4,4);		/* for setting ring brackets of copy */

dcl 1 new_hash_table aligned,				/* hash table regenerated by salvage */
    2 last_in_bucket (0:511) bit (18) unaligned init ((512) (18) "0"b);

/*  */

%include mseg_hdr_v3;


%include ms_block_trailer_v3;


dcl  admin_gate_$guaranteed_eligibility_on ext entry;

dcl  expand_path_ ext entry
    (ptr, fixed bin, ptr, ptr, fixed bin (35));

dcl  copy_seg_$no_message ext entry
    (char (*)aligned, char (*)aligned, char (*)aligned, char (*)aligned,
     char (*)aligned, bit (1)aligned, fixed bin (35));

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35));

dcl  hcs_$set_ring_brackets ext entry
    (char (*)aligned, char (*)aligned, (3) fixed bin (3), fixed bin (35));

dcl  hcs_$truncate_seg ext entry
    (ptr, fixed bin (18), fixed bin (35));

dcl  read_allowed_ ext entry
    (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

dcl  hcs_$fs_get_path_name ext entry
    (ptr, char (*)aligned, fixed bin, char (*)aligned, fixed bin (35));

dcl  hcs_$get_access_class_seg ext entry
    (ptr, bit (72) aligned, fixed bin (35));

dcl  ms_salv_util_v3_ ext entry
    (bit (1) aligned, ptr, ptr, ptr, fixed bin (18), fixed bin (18), fixed bin (18), fixed bin (18),
     bit (72) aligned, fixed bin, fixed bin, ptr);

dcl  mseg_error_v3_ entry options (variable);

dcl  set_lock_$lock ext entry
    (bit (36)aligned, fixed bin, fixed bin (35));

/*  */

	mptr = a_mptr;				/* copy argument */

	call admin_gate_$guaranteed_eligibility_on ();	/* lock the message segment in case */
	call set_lock_$lock (mseg_hdr.lock, 20, code);	/* it is not already locked */

	call hcs_$get_access_class_seg (mptr, mseg_access_class, code);
	if code ^= 0 then do;
	     reason = "Cannot get access class.";
	     go to GRIPE;
	end;

	call hcs_$get_max_length_seg (mptr, seg_size, code);
	if code ^= 0 then do;
	     reason = "Cannot get max length.";
	     go to GRIPE;
	end;

	mseg_hdr.switches.sip = "1"b;			/* turn on "salvage in progress" flag */

	block_size = fixed (mseg_hdr.block_size, 18);	/* fetch block size */
	if block_size <= 0 | block_size > seg_size
	then block_size = fixed (mseg_data_v3_$block_size, 18); /* take default and hope it's right */

	alloc_len = divide (seg_size, block_size, 18, 0); /* compute length of allocation bits */

	hdr_size = divide ((fixed (rel (addr (mptr -> mseg_hdr.alloc_bits)), 18))*36 + alloc_len+35, 36, 18, 0);

	if hdr_size > seg_size then do;		/* forget it */
	     code = error_table_$fatal_error;
	     go to FIN;
	end;

	hdr_alloc_len = divide (hdr_size+block_size-1, block_size, 18, 0); /* compute alloc bits used by header */

	trailer_offset = fixed (block_size-size (ms_block_trailer), 18); /* compute trailer offset */

	original_messages = mseg_hdr.number_of_messages;

/*  */

	begin;

dcl  new_alloc_bits bit (alloc_len) init (""b) aligned;	/* new allocation bit string */

	     do i = 1 to hdr_alloc_len;		/* turn on header allocation bits */
		substr (new_alloc_bits, i, 1) = "1"b;
	     end;

	     if mseg_hdr.first_ms_offset ^= ""b		/* non-zero first message offset */
	     then do;				/* set up for forward salvage */
		salv_ptr = ptr (mptr, fixed (mseg_hdr.first_ms_offset, 18));
		end_ptr = ptr (mptr, fixed (mseg_hdr.last_ms_offset, 18));
		forward = "1"b;			/* first attempt forward salvage */
	     end;
	     else go to BACKWARD;			/* try backward salvage */

/* salvage */

SALVAGE_LOOP:

	     tsaved_messages = 0;			/* initialize number of saved messages per pass */
	     last_saved_ms_ptr = null;		/* initialize pointer to last saved message */
	     call ms_salv_util_v3_
		(forward, salv_ptr, addr (new_alloc_bits), addr (new_hash_table),
		block_size, seg_size, alloc_len, hdr_alloc_len, mseg_access_class,
		tsaved_messages, tsaved_blocks, last_saved_ms_ptr);
	     saved_messages =			/* add in number of saved messages */
		saved_messages + tsaved_messages;
	     saved_blocks =				/* add in number of saved blocks */
		saved_blocks + tsaved_blocks;
	     if last_saved_ms_ptr = end_ptr		/* total success? */
	     then go to REST_OF_HEADER;

	     if tsaved_messages ^= 0			/* partial success? */
	     then do;				/* yes */

		if (forward)			/* forward salvage? */
		then last_forward_ptr =		/* yes, save pointer to last good message */
		     last_saved_ms_ptr;

		else				/* backward salvage */
		last_backward_ptr =			/* save pointer to last good message */
		     last_saved_ms_ptr;

	     end;

	     if (forward)				/* first pass at salvaging? */
	     then
BACKWARD:		if mseg_hdr.last_ms_offset ^= ""b	/* non-zero last message offset */
		then do;				/* yes, prepare for next pass */
		     forward = "0"b;		/* set direction of salvage */
		     salv_ptr = ptr (mptr, fixed (mseg_hdr.last_ms_offset, 18)); /* set salvaging pointer */
		     end_ptr = ptr (mptr, fixed (mseg_hdr.first_ms_offset, 18)); /* set hopeful end of salvage ptr */
		     go to SALVAGE_LOOP;
		end;

/*  */

/* join message fragments */

	     if saved_messages ^= 0			/* any success in salvaging? */
	     then do;				/* yes */

		if last_forward_ptr ^= null		/* forward salvage partly successful */
		then do;				/* yes */

		     if last_backward_ptr ^= null	/* backward salvage partly successful? */
		     then do;			/* yes */
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer.f_offset =
			     bit (fixed (rel (last_backward_ptr), 18), 18);
			addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer.b_offset =
			     bit (fixed (rel (last_forward_ptr), 18), 18);
		     end;

		     else				/* backward salvage unsuccessful */
		     do;
			mseg_hdr.last_ms_offset =	/* reset last message offset in header */
			     bit (fixed (rel (last_forward_ptr), 18), 18);
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer.f_offset =
			     "0"b;		/* zero out next offset of new last message */
		     end;

		end;

		else				/* forward salvage no good */
		do;				/* backward salvage must have been */
		     mseg_hdr.first_ms_offset =	/* reset first message offset */
			bit (fixed (rel (last_backward_ptr), 18), 18);
		     addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer.b_offset =
			"0"b;			/* zero prev message offset of new 1st message */
		end;

	     end;

	     else					/* no messages saved */
	     mseg_hdr.first_ms_offset,
		mseg_hdr.last_ms_offset = (18) "0"b;	/* zero first and last offsets */

REST_OF_HEADER:

	     i = alloc_len - index (reverse (new_alloc_bits), "1"b) +1; /* get last used block index */
	     block_offset = i * block_size;		/* get offset of end of last block */
	     call hcs_$truncate_seg (mptr, block_offset, code); /* truncate to last used block */
	     mseg_hdr.block_size = block_size;		/* reset block size */
	     mseg_hdr.space_left =			/* reset space left */
		alloc_len - hdr_alloc_len - saved_blocks;
	     mseg_hdr.alloc_bits = new_alloc_bits;	/* reset allocation bit string */
	     mseg_hdr.number_of_messages = saved_messages; /* set message count */
	     mseg_hdr.alloc_len = alloc_len;		/* set allocation bits length */
	     mseg_hdr.mseg_pattern = header_pattern;	/* set header pattern */
	     mseg_hdr.version_number = version_number;	/* set version number */
	     mseg_hdr.hash_table = new_hash_table;	/* copy new hash table */

	     if mseg_hdr.switches.ms_in_hdr		/* header message exists */
	     then if ^read_allowed_ (mseg_access_class, mseg_hdr.hdr_ms_access_class) /* bad access class */
		then do;				/* wipe out header message */
		     mseg_hdr.switches.ms_in_hdr = "0"b;
ZERO_HDR_MS:	     mseg_hdr.hdr_ms = ""b;
		     mseg_hdr.hdr_ms_access_class = (72) "0"b;
		end;
		else;				/* keep header message */
	     else go to ZERO_HDR_MS;			/* just to be neat */

	     mseg_hdr.switches.mip = "0"b;		/* turn off mip bit */
	     mseg_hdr.switches.os = "1"b;		/* indicate salvage occurred */
	     mseg_hdr.switches.sip = "0"b;		/* turn off salvage in progress bit */

	end;					/* of BEGIN block */

	if original_messages > saved_messages then
	     call mseg_error_v3_ (mptr, 0, "ms_salvager_v3_", "^d message(s) may be lost.",
	     original_messages - saved_messages);

FIN:

	a_code = code;				/* return code */
	return;

GRIPE:	call mseg_error_v3_ (mptr, code, "ms_salvager_v3_", reason);
	go to FIN;

     end ms_salvager_v3_;




		    ms_salvager_v4_.pl1             05/09/85  1152.2r w 05/06/85  1619.0      104004



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


ms_salvager_v4_: proc (a_mptr, a_code);

/* Modified for version 3 message segments by J. Stern, 10/30/74 */
/* Modified to use mseg_error_ by J. Stern, 11/12/75 */

dcl (
     mseg_dir,					/* mseg directory name */
     comp1)					/* 1st component of directory name */
     char (168);

dcl (
     mseg_name,					/* mseg entryname */
     comp2)					/* 2nd component of directory name */
     char (32);

dcl (
     i,						/* do loop index */
     dir_len,					/* length of mseg directory */
     saved_blocks init (0),				/* number of saved message blocks */
     saved_messages init (0),				/* number of saved messages (internal) */
     original_messages,				/* number of messages before salvaging */
     tsaved_blocks,					/* number of saved blocks per pass */
     tsaved_messages)				/* number of saved messages per pass */
     fixed bin;

dcl (alloc_len,					/* length of allocation bit string */
     block_offset,					/* offset to a message block */
     block_size,					/* size of message block */
     hdr_alloc_len,					/* number of allocation bits used for header */
     mseg_data_v4_$block_size ext,
     seg_size,					/* maximum size of a segment */
     hdr_size,					/* number of words in header before alloc_bits */
     trailer_offset) fixed bin (18);

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code, (internal) */
     error_table_$fatal_error ext
     ) fixed bin (35);

dcl  reason char (40);				/* reason for salvager failure */

dcl  forward bit (1) aligned;				/* ON if salvage is forward */

dcl (addr, addrel, bit, divide, fixed, null, ptr, rel, size, substr) builtin;

dcl (a_mptr,					/* pointer to message segment (argument) */
     end_ptr,					/* pointer to last message for salvage pass */
     last_backward_ptr init (null),			/* pointer to last saved message in backward salvage */
     last_forward_ptr init (null),			/* pointer to last saved message in forward salvage */
     last_saved_ms_ptr,				/* pointer to last message saved in a pass */
     salv_ptr)					/* pointer to beginning point for salvage */
     ptr;

dcl  mseg_access_class bit (72) aligned;		/* message segment access class */

dcl  hdr_ms_mask bit (36*max_hdr_ms_len) aligned based;	/* for zeroing out header message */

dcl  ring_brackets (3) fixed bin(3) init(1,4,4);		/* for setting ring brackets of copy */

dcl 1 new_hash_table aligned,				/* hash table regenerated by salvage */
    2 last_in_bucket (0:511) bit (18) unaligned init ((512) (18) "0"b);

/*  */

%include mseg_hdr_v4;
declare version_number fixed bin init (4) int static options (constant);
dcl      header_pattern bit (36) aligned init ((18) "01"b);	/* header identification pattern */
 declare mptr pointer;
%include ms_block_trailer_v4;


dcl  admin_gate_$guaranteed_eligibility_on ext entry;

dcl  expand_path_ ext entry
    (ptr, fixed bin, ptr, ptr, fixed bin (35));

dcl  copy_seg_$no_message entry
    (char(*), char(*), char(*), char(*), char(*), bit(1) aligned, fixed bin(35));

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35));

dcl  hcs_$set_ring_brackets ext entry
    (char (*), char (*), (3) fixed bin (3), fixed bin (35));

dcl  hcs_$truncate_seg ext entry
    (ptr, fixed bin (18), fixed bin (35));

dcl  read_allowed_ entry
    (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

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

dcl  hcs_$get_access_class_seg ext entry
    (ptr, bit (72) aligned, fixed bin (35));

dcl  ms_salv_util_v4_ ext entry
    (bit (1) aligned, ptr, ptr, ptr, fixed bin (18), fixed bin (18), fixed bin (18), fixed bin (18),
     bit (72) aligned, fixed bin, fixed bin, ptr);

dcl  mseg_error_v4_ entry options (variable);

dcl  set_lock_$lock ext entry
    (bit (36)aligned, fixed bin, fixed bin (35));

/*  */

	mptr = a_mptr;				/* copy argument */

	call admin_gate_$guaranteed_eligibility_on ();	/* lock the message segment in case */
	call set_lock_$lock (mptr -> mseg_hdr_v4.lock, 20, code);	/* it is not already locked */

	call hcs_$get_access_class_seg (mptr, mseg_access_class, code);
	if code ^= 0 then do;
	     reason = "Cannot get access class.";
	     go to GRIPE;
	end;

	call hcs_$get_max_length_seg (mptr, seg_size, code);
	if code ^= 0 then do;
	     reason = "Cannot get max length.";
	     go to GRIPE;
	end;

	mptr -> mseg_hdr_v4.switches.sip = "1"b;			/* turn on "salvage in progress" flag */

	block_size = fixed (mptr -> mseg_hdr_v4.block_size, 18);	/* fetch block size */
	if block_size <= 0 | block_size > seg_size
	then block_size = fixed (mseg_data_v4_$block_size, 18); /* take default and hope it's right */

	alloc_len = divide (seg_size, block_size, 18, 0); /* compute length of allocation bits */

	hdr_size = divide ((fixed (rel (addr (mptr -> mseg_hdr_v4.alloc_bits)), 18))*36 + alloc_len+35, 36, 18, 0);

	if hdr_size > seg_size then do;		/* forget it */
	     code = error_table_$fatal_error;
	     go to FIN;
	end;

	hdr_alloc_len = divide (hdr_size+block_size-1, block_size, 18, 0); /* compute alloc bits used by header */

	trailer_offset = fixed (block_size-size (ms_block_trailer), 18); /* compute trailer offset */

	original_messages = mptr -> mseg_hdr_v4.number_of_messages;

/*  */

	begin;

dcl  new_alloc_bits bit (alloc_len) init (""b) aligned;	/* new allocation bit string */

	     do i = 1 to hdr_alloc_len;		/* turn on header allocation bits */
		substr (new_alloc_bits, i, 1) = "1"b;
	     end;

	     if mptr -> mseg_hdr_v4.first_ms_offset ^= ""b		/* non-zero first message offset */
	     then do;				/* set up for forward salvage */
		salv_ptr = ptr (mptr, fixed (mptr -> mseg_hdr_v4.first_ms_offset, 18));
		end_ptr = ptr (mptr, fixed (mptr -> mseg_hdr_v4.last_ms_offset, 18));
		forward = "1"b;			/* first attempt forward salvage */
	     end;
	     else go to BACKWARD;			/* try backward salvage */

/* salvage */

SALVAGE_LOOP:

	     tsaved_messages = 0;			/* initialize number of saved messages per pass */
	     last_saved_ms_ptr = null;		/* initialize pointer to last saved message */
	     call ms_salv_util_v4_
		(forward, salv_ptr, addr (new_alloc_bits), addr (new_hash_table),
		block_size, seg_size, alloc_len, hdr_alloc_len, mseg_access_class,
		tsaved_messages, tsaved_blocks, last_saved_ms_ptr);
	     saved_messages =			/* add in number of saved messages */
		saved_messages + tsaved_messages;
	     saved_blocks =				/* add in number of saved blocks */
		saved_blocks + tsaved_blocks;
	     if last_saved_ms_ptr = end_ptr		/* total success? */
	     then go to REST_OF_HEADER;

	     if tsaved_messages ^= 0			/* partial success? */
	     then do;				/* yes */

		if (forward)			/* forward salvage? */
		then last_forward_ptr =		/* yes, save pointer to last good message */
		     last_saved_ms_ptr;

		else				/* backward salvage */
		last_backward_ptr =			/* save pointer to last good message */
		     last_saved_ms_ptr;

	     end;

	     if (forward)				/* first pass at salvaging? */
	     then
BACKWARD:		if mptr -> mseg_hdr_v4.last_ms_offset ^= ""b	/* non-zero last message offset */
		then do;				/* yes, prepare for next pass */
		     forward = "0"b;		/* set direction of salvage */
		     salv_ptr = ptr (mptr, fixed (mptr -> mseg_hdr_v4.last_ms_offset, 18)); /* set salvaging pointer */
		     end_ptr = ptr (mptr, fixed (mptr -> mseg_hdr_v4.first_ms_offset, 18)); /* set hopeful end of salvage ptr */
		     go to SALVAGE_LOOP;
		end;

/*  */

/* join message fragments */

	     if saved_messages ^= 0			/* any success in salvaging? */
	     then do;				/* yes */

		if last_forward_ptr ^= null		/* forward salvage partly successful */
		then do;				/* yes */

		     if last_backward_ptr ^= null	/* backward salvage partly successful? */
		     then do;			/* yes */
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer.f_offset =
			     bit (fixed (rel (last_backward_ptr), 18), 18);
			addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer.b_offset =
			     bit (fixed (rel (last_forward_ptr), 18), 18);
		     end;

		     else				/* backward salvage unsuccessful */
		     do;
			mptr -> mseg_hdr_v4.last_ms_offset =	/* reset last message offset in header */
			     bit (fixed (rel (last_forward_ptr), 18), 18);
			addrel (last_forward_ptr, trailer_offset) -> ms_block_trailer.f_offset =
			     "0"b;		/* zero out next offset of new last message */
		     end;

		end;

		else				/* forward salvage no good */
		do;				/* backward salvage must have been */
		     mptr -> mseg_hdr_v4.first_ms_offset =	/* reset first message offset */
			bit (fixed (rel (last_backward_ptr), 18), 18);
		     addrel (last_backward_ptr, trailer_offset) -> ms_block_trailer.b_offset =
			"0"b;			/* zero prev message offset of new 1st message */
		end;

	     end;

	     else					/* no messages saved */
	     mptr -> mseg_hdr_v4.first_ms_offset,
		mptr -> mseg_hdr_v4.last_ms_offset = (18) "0"b;	/* zero first and last offsets */

REST_OF_HEADER:

	     i = alloc_len - index (reverse (new_alloc_bits), "1"b) +1; /* get last used block index */
	     block_offset = i * block_size;		/* get offset of end of last block */
	     call hcs_$truncate_seg (mptr, block_offset, code); /* truncate to last used block */
	     mptr -> mseg_hdr_v4.block_size = block_size;		/* reset block size */
	     mptr -> mseg_hdr_v4.space_left =			/* reset space left */
		alloc_len - hdr_alloc_len - saved_blocks;
	     mptr -> mseg_hdr_v4.alloc_bits = new_alloc_bits;	/* reset allocation bit string */
	     mptr -> mseg_hdr_v4.number_of_messages = saved_messages; /* set message count */
	     mptr -> mseg_hdr_v4.alloc_len = alloc_len;		/* set allocation bits length */
	     mptr -> mseg_hdr_v4.mseg_pattern = header_pattern;	/* set header pattern */
	     mptr -> mseg_hdr_v4.version_number = version_number;	/* set version number */
	     mptr -> mseg_hdr_v4.hash_table = new_hash_table;	/* copy new hash table */

	     if mptr -> mseg_hdr_v4.switches.ms_in_hdr		/* header message exists */
	     then if ^read_allowed_ (mseg_access_class, mptr -> mseg_hdr_v4.hdr_ms_access_class) /* bad access class */
		then do;				/* wipe out header message */
		     mptr -> mseg_hdr_v4.switches.ms_in_hdr = "0"b;
ZERO_HDR_MS:	     mptr -> mseg_hdr_v4.hdr_ms = ""b;
		     mptr -> mseg_hdr_v4.hdr_ms_access_class = (72) "0"b;
		end;
		else;				/* keep header message */
	     else go to ZERO_HDR_MS;			/* just to be neat */

	     mptr -> mseg_hdr_v4.switches.mip = "0"b;		/* turn off mip bit */
	     mptr -> mseg_hdr_v4.switches.os = "1"b;		/* indicate salvage occurred */
	     mptr -> mseg_hdr_v4.switches.sip = "0"b;		/* turn off salvage in progress bit */

	end;					/* of BEGIN block */

	if original_messages > saved_messages then
	     call mseg_error_v4_ (mptr, 0, "ms_salvager_v4_", "^d message(s) may be lost.",
	     original_messages - saved_messages);

FIN:

	a_code = code;				/* return code */
	return;

GRIPE:	call mseg_error_v4_ (mptr, code, "ms_salvager_v4_", reason);
	go to FIN;

     end ms_salvager_v4_;




		    mseg_data_v2_.alm               05/10/85  0901.8r w 05/06/85  1619.0        7452



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

segdef		max_message_size
segdef		block_size
segdef		version_number
segdef		block_hdr_data
segdef		block_trailer_data
segdef		mseg_b36
segdef		mseg_tr36

max_message_size:	dec 2048
block_size:	dec 32
version_number:	dec 2
block_hdr_data:	dec 1
block_trailer_data:	dec 13
mseg_b36:		oct 252525252525
mseg_tr36:	oct 777777777777

end




		    mseg_data_v3_.alm               05/10/85  0901.8r w 05/06/85  1619.0       10350



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

"  Modified for version 3 message segments by J. Stern, 10/18/74
"  Modified to increase max_message_size essentially to
"  infinity by K. T. Pogran, 6/4/75
"  Modified to temporarily limit max_message_size to
"  2**18 bits (approximately) by Ken Pogran.
"  Modified 3/77 by Charlie Davis for the installation of version 4 message segments

segdef		max_message_size
segdef		block_size

max_message_size:	dec 7280		" A tad less than 2**18 bits
block_size:	dec 32

end




		    mseg_data_v4_.alm               05/09/85  1152.2r w 05/06/85  1619.0       10386



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

"  Modified for version 3 message segments by J. Stern, 10/18/74
"  Modified to increase max_message_size essentially to
"  infinity by K. T. Pogran, 6/4/75
"  Modified to temporarily limit max_message_size to
"  2**18 bits (approximately) by Ken Pogran.
"  Remodified to increase max_message_size essentially to
"  infinity by Charlie Davis, 3/77

segdef		max_message_size
segdef		block_size

max_message_size:	dec 261120	" Infinity, essentially
block_size:	dec 32

end




		    mseg_error_v3_.pl1              05/10/85  0856.7r w 05/06/85  1619.0       38709



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


mseg_error_v3_: proc (mptr, ecode, caller);

/*  This procedure formats error messages for the message
   segment facility and enters these error messages into
   the syserr log.  An error message contains the following
   parts:

   1.  name of the calling procedure
   2.  message segment pathname
   3.  process group id
   4.  system error message
   5.  caller-supplied message

*/
/* Written by J. Stern, 11/11/75 */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */


dcl  mptr ptr;					/* message segment pointer */
dcl  ecode fixed bin (35);				/* error code (input!) */
dcl  caller char (*);				/* procedure name of caller */

dcl  buffer char (512) aligned;			/* buffer to construct error message */
dcl  bi fixed bin;					/* current length of buffer */
dcl  dir char (168);				/* directory name */
dcl  dirlen fixed bin;				/* length of dir */
dcl  ent char (32);					/* entry name */
dcl  code fixed bin (35);				/* error code */
dcl  pgid char (32);				/* process group id */
dcl  short_mess char (8) aligned;			/* short error message */
dcl  long_mess char (100) aligned;			/* long error message */
dcl  nargs fixed bin;				/* number of arguments */
dcl  argp ptr;					/* argument list ptr */
dcl  ioa_string char (256);				/* string returned by ioa_ */
dcl  len fixed bin;					/* length of ioa_string */


dcl (null, substr, length, reverse, verify) builtin;

dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  get_group_id_ entry returns (char (32));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  admin_gate_$syserr entry options (variable);

/*  */

	bi = 0;					/* set initial buffer length */

/* add caller name to buffer */

	if caller ^= "" then do;
	     call strip_add (caller);
	     call add (":");
	end;

/* add message segment pathname to buffer */

	if mptr ^= null then do;
	     call hcs_$fs_get_path_name (mptr, dir, dirlen, ent, code);
	     if code ^= 0 then
		call add (" Cannot get pathname.");
	     else do;
		call add (" ");
		call add (substr (dir, 1, dirlen));
		call add (">");
		call strip_add (ent);
	     end;
	end;

/* add process group id to buffer */

	call add (" for ");
	pgid = get_group_id_ ();
	call strip_add (pgid);

/* add system error message to buffer */

	if ecode ^= 0 then do;
	     call add (" ");
	     call convert_status_code_ (ecode, short_mess, long_mess);
	     call strip_add ((long_mess));
	end;

/* add ioa_ message to buffer */

	call cu_$arg_count (nargs);
	if nargs > 3 then do;
	     call add (" ");
	     call cu_$arg_list_ptr (argp);
	     call ioa_$general_rs (argp, 4, 5, ioa_string, len, "0"b, "0"b);
	     call strip_add (substr (ioa_string, 1, len));
	end;

/* now just spit it out */

finish:	call admin_gate_$syserr (15, substr (buffer, 1, bi));
	return;


strip_add: proc (item);				/* strips trailing blanks and adds item to buffer */

dcl  item char (*);
dcl (i, j) fixed bin;
dcl  strip_sw bit (1) aligned;


	     strip_sw = "1"b;			/* strip trailing blanks */
	     go to join;

add:	     entry (item);				/* adds item to buffer */

	     strip_sw = "0"b;


join:	     i = length (item);
	     if i = 0 then return;

	     if strip_sw then do;
		j = verify (reverse (item), " ");
		if j = 0 then return;		/* item was all blanks */
		i = i -j + 1;
	     end;

	     if bi + i > length (buffer) then i = length (buffer) - bi;
	     substr (buffer, bi+1, i) = substr (item, 1, i);
	     bi = bi + i;
	     if bi = length (buffer) then go to finish;

	end strip_add;


     end mseg_error_v3_;




		    mseg_error_v4_.pl1              05/09/85  1152.2r w 05/06/85  1619.0       37917



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


mseg_error_v4_: proc (mptr, ecode, caller);

/*  This procedure formats error messages for the message
   segment facility and enters these error messages into
   the syserr log.  An error message contains the following
   parts:

   1.  name of the calling procedure
   2.  message segment pathname
   3.  process group id
   4.  system error message
   5.  caller-supplied message

*/
/* Written by J. Stern, 11/11/75 */


dcl  mptr ptr;					/* message segment pointer */
dcl  ecode fixed bin (35);				/* error code (input!) */
dcl  caller char (*);				/* procedure name of caller */

dcl  buffer char (512) aligned;			/* buffer to construct error message */
dcl  bi fixed bin;					/* current length of buffer */
dcl  dir char (168);				/* directory name */
dcl  dirlen fixed bin;				/* length of dir */
dcl  ent char (32);					/* entry name */
dcl  code fixed bin (35);				/* error code */
dcl  pgid char (32);				/* process group id */
dcl  short_mess char (8) aligned;			/* short error message */
dcl  long_mess char (100) aligned;			/* long error message */
dcl  nargs fixed bin;				/* number of arguments */
dcl  argp ptr;					/* argument list ptr */
dcl  ioa_string char (256);				/* string returned by ioa_ */
dcl  len fixed bin;					/* length of ioa_string */


dcl (null, substr, length, reverse, verify) builtin;

dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  get_group_id_ entry returns (char (32));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);
dcl  admin_gate_$syserr entry options (variable);

/*  */

	bi = 0;					/* set initial buffer length */

/* add caller name to buffer */

	if caller ^= "" then do;
	     call strip_add (caller);
	     call add (":");
	end;

/* add message segment pathname to buffer */

	if mptr ^= null then do;
	     call hcs_$fs_get_path_name (mptr, dir, dirlen, ent, code);
	     if code ^= 0 then
		call add (" Cannot get pathname.");
	     else do;
		call add (" ");
		call add (substr (dir, 1, dirlen));
		call add (">");
		call strip_add (ent);
	     end;
	end;

/* add process group id to buffer */

	call add (" for ");
	pgid = get_group_id_ ();
	call strip_add (pgid);

/* add system error message to buffer */

	if ecode ^= 0 then do;
	     call add (" ");
	     call convert_status_code_ (ecode, short_mess, long_mess);
	     call strip_add ((long_mess));
	end;

/* add ioa_ message to buffer */

	call cu_$arg_count (nargs);
	if nargs > 3 then do;
	     call add (" ");
	     call cu_$arg_list_ptr (argp);
	     call ioa_$general_rs (argp, 4, 5, ioa_string, len, "0"b, "0"b);
	     call strip_add (substr (ioa_string, 1, len));
	end;

/* now just spit it out */

finish:	call admin_gate_$syserr (15, substr (buffer, 1, bi));
	return;


strip_add: proc (item);				/* strips trailing blanks and adds item to buffer */

dcl  item char (*);
dcl (i, j) fixed bin;
dcl  strip_sw bit (1) aligned;


	     strip_sw = "1"b;			/* strip trailing blanks */
	     go to join;

add:	     entry (item);				/* adds item to buffer */

	     strip_sw = "0"b;


join:	     i = length (item);
	     if i = 0 then return;

	     if strip_sw then do;
		j = verify (reverse (item), " ");
		if j = 0 then return;		/* item was all blanks */
		i = i -j + 1;
	     end;

	     if bi + i > length (buffer) then i = length (buffer) - bi;
	     substr (buffer, bi+1, i) = substr (item, 1, i);
	     bi = bi + i;
	     if bi = length (buffer) then go to finish;

	end strip_add;


     end mseg_error_v4_;




		    mseg_upgrade_from_v2_.pl1       05/10/85  0856.7r w 05/06/85  1619.0       59634



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

/* Support for upgrading version 2 message segments to the version supported by bound_mseg_ */

/* Created:  May 1985 by G. Palter */

/* format: style3,linecom */

mseg_upgrade_from_v2_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_mseg_operation_ptr			/* -> description of the operation forcing the upgrade (I) */
			pointer parameter;

dcl	P_salvage_completed bit (1) aligned parameter;	/* salvage: set ON => salvage succeeded (O) */

dcl	P_callers_area_ptr	pointer parameter;		/* read_message: -> area in which to place the message (I) */
dcl	P_code		fixed binary (35) parameter;	/* read_message: set to standard system status code (O) */


/* Local copies of parameters */

dcl	callers_area_ptr	pointer;

dcl	code		fixed binary (35);


/* Remaining declarations */

/* format: idind30 */

dcl	1 v2_wakeup_state		aligned,
	  2 state,
	    3 switches		aligned,
	      4 allow_normal	bit (1) unaligned,
	      4 allow_urgent	bit (1) unaligned,
	      4 pad		bit (34) unaligned,
	    3 lock_id		bit (36) aligned,
	    3 event_channel		fixed bin (71),
	    3 process_id		bit (36) aligned,
	  2 pad			(64 - 5) bit (36) aligned;

/* format: idind20 */

dcl	msg_ptr		pointer;
dcl	msg_sender_id	character (32) aligned;
dcl	(msg_time, old_msg_time)
			fixed binary (54);
dcl	(msg_location, msg_len, old_msg_location)
			fixed binary (18);
dcl	msg_sender_level	fixed binary;

dcl	error_table_$bad_subr_arg
			fixed binary (35) external;

dcl	ms_salvager_v2_	entry (pointer, fixed binary, fixed binary (35));
dcl	mseg_util_v2_$incremental_read
			entry (pointer, bit (2) aligned, pointer, fixed binary (18), fixed binary (54),
			fixed binary, pointer, fixed binary (18), fixed binary (18), fixed binary (54),
			character (32) aligned, fixed binary, fixed binary (35));
dcl	mseg_util_v2_$read	entry (pointer, bit (2) aligned, pointer, fixed binary (18), fixed binary (54),
			fixed binary, pointer, fixed binary (18), character (32) aligned, fixed binary,
			fixed binary (35));

dcl	(addr, bit, fixed, string, substr, unspec)
			builtin;
%page;
/* Salvage the version 2 message segment */

mseg_upgrade_from_v2_$salvage:
     entry (P_mseg_operation_ptr, P_salvage_completed);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	call ms_salvager_v2_ (mseg_ptr, (0), code);	/* it will report problems via admin_gate_ */

	P_salvage_completed = (code = 0);

	return;
%page;
/* Get the wakeup acceptance state of a version 2 message segment -- In version 2 segments, the wakeup state is stored in
   the header "message".  We will convert said "message" into the appropriate wakeup_state structure. */

mseg_upgrade_from_v2_$get_wakeup_state:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	if mseg_ptr -> mseg_hdr_v2.ms_in_hdr
	then do;
		unspec (v2_wakeup_state) = unspec (mseg_ptr -> mseg_hdr_v2.hdr_ms);
		mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;
		string (mseg_operation.wakeup_state.flags) = string (v2_wakeup_state.switches);
		mseg_operation.wakeup_state.event_channel = v2_wakeup_state.event_channel;
		mseg_operation.wakeup_state.access_class = mseg_operation.access_info.access_class;
		mseg_operation.wakeup_state.process_id = v2_wakeup_state.process_id;
		mseg_operation.wakeup_state.lock_id = v2_wakeup_state.lock_id;
		mseg_operation.wakeup_state_valid = "1"b;
	     end;

	else mseg_operation.wakeup_state_valid = "0"b;

	return;
%page;
/* Read the requested message from a version 2 message segment */

mseg_upgrade_from_v2_$read_message:
     entry (P_mseg_operation_ptr, P_callers_area_ptr, P_code);

	mseg_operation_ptr = P_mseg_operation_ptr;
	callers_area_ptr = P_callers_area_ptr;
	code = error_table_$bad_subr_arg;		/* in case our caller's mseg_message_info is invalid */

	mseg_ptr = mseg_operation.mseg_ptr;

	mseg_message_info_ptr = addr (mseg_operation.message_info);

	if mseg_message_info.message_code = MSEG_READ_FIRST
	then call mseg_util_v2_$read (mseg_ptr, "10"b, callers_area_ptr, msg_location, msg_time, 0, msg_ptr, msg_len,
		msg_sender_id, msg_sender_level, code);

	else if mseg_message_info.message_code = MSEG_READ_LAST
	then call mseg_util_v2_$read (mseg_ptr, "01"b, callers_area_ptr, msg_location, msg_time, 0, msg_ptr, msg_len,
		msg_sender_id, msg_sender_level, code);

	else do;
		old_msg_location = fixed (substr (mseg_message_info.ms_id, 1, 18), 18, 0);
		old_msg_time = fixed (substr (mseg_message_info.ms_id, 19, 54), 54, 0);

		if mseg_message_info.message_code = MSEG_READ_SPECIFIED
		then call mseg_util_v2_$incremental_read (mseg_ptr, "00"b, callers_area_ptr, old_msg_location,
			old_msg_time, 0, msg_ptr, msg_len, msg_location, msg_time, msg_sender_id, msg_sender_level,
			code);

		else if mseg_message_info.message_code = MSEG_READ_BEFORE_SPECIFIED
		then call mseg_util_v2_$incremental_read (mseg_ptr, "10"b, callers_area_ptr, old_msg_location,
			old_msg_time, 0, msg_ptr, msg_len, msg_location, msg_time, msg_sender_id, msg_sender_level,
			code);

		else if mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED
		then call mseg_util_v2_$incremental_read (mseg_ptr, "01"b, callers_area_ptr, old_msg_location,
			old_msg_time, 0, msg_ptr, msg_len, msg_location, msg_time, msg_sender_id, msg_sender_level,
			code);
	     end;

	if code = 0
	then do;	/*** Read succeeded -- Fill in the mseg_message_info appropriately */
		mseg_message_info.ms_ptr = msg_ptr;
		mseg_message_info.ms_len = msg_len;
		mseg_message_info.ms_id = bit (msg_location, 18) || bit (msg_time, 54);
		mseg_message_info.ms_access_class = mseg_operation.access_info.access_class;
		mseg_message_info.sender_id = msg_sender_id;
		mseg_message_info.sender_process_id = ""b;
		mseg_message_info.sender_level = msg_sender_level;
		mseg_message_info.sender_authorization = mseg_operation.access_info.access_class;
		mseg_message_info.sender_max_authorization = mseg_operation.access_info.access_class;
		mseg_message_info.sender_audit = ""b;
	     end;

	P_code = code;

	return;

/* format: off */
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_hdr_v2;
/* format: on */

     end mseg_upgrade_from_v2_;




		    mseg_upgrade_from_v3_.pl1       05/10/85  0856.7r w 05/06/85  1619.0       51408



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

/* Support for upgrading version 3 message segments to the version supported by bound_mseg_ */

/* Created:  May 1985 by G. Palter */

/* format: style3,linecom */

mseg_upgrade_from_v3_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_mseg_operation_ptr			/* -> description of the operation forcing the upgrade (I) */
			pointer parameter;

dcl	P_salvage_completed bit (1) aligned parameter;	/* salvage: set ON => salvage succeeded (O) */

dcl	P_callers_area_ptr	pointer parameter;		/* read_message: -> area in which to place the message (I) */
dcl	P_code		fixed binary (35) parameter;	/* read_message: set to standard system status code (O) */


/* Local copies of parameters */

dcl	callers_area_ptr	pointer;

dcl	code		fixed binary (35);


/* Remaining declarations */

/* format: idind30 */

dcl	1 v3_wakeup_state		aligned,
	  2 state,
	    3 switches		aligned,
	      4 allow_normal	bit (1) unaligned,
	      4 allow_urgent	bit (1) unaligned,
	      4 pad		bit (34) unaligned,
	    3 lock_id		bit (36) aligned,
	    3 event_channel		fixed bin (71),
	    3 process_id		bit (36) aligned,
	  2 pad			(64 - 5) bit (36) aligned;

/* format: idind20 */

dcl	1 local_mra	aligned like mseg_return_args;

dcl	error_table_$bad_subr_arg
			fixed binary (35) external;

dcl	ms_salvager_v3_	entry (pointer, fixed binary (35));
dcl	mseg_util_v3_$incremental_read
			entry (pointer, pointer, bit (2) aligned, bit (72) aligned, pointer, bit (1) aligned,
			fixed binary (35));
dcl	mseg_util_v3_$read	entry (pointer, pointer, bit (1) aligned, pointer, bit (1) aligned, fixed binary (35));

dcl	(addr, string, unspec)
			builtin;
%page;
/* Salvage the version 3 message segment */

mseg_upgrade_from_v3_$salvage:
     entry (P_mseg_operation_ptr, P_salvage_completed);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	call ms_salvager_v3_ (mseg_ptr, code);		/* it will report problems via admin_gate_ */

	P_salvage_completed = (code = 0);

	return;
%page;
/* Get the wakeup acceptance state of a version 3 message segment -- In version 3 segments, the wakeup state is stored in
   the header "message".  We will convert said "message" into the appropriate wakeup_state structure. */

mseg_upgrade_from_v3_$get_wakeup_state:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	if mseg_ptr -> mseg_hdr.ms_in_hdr
	then do;
		unspec (v3_wakeup_state) = unspec (mseg_ptr -> mseg_hdr.hdr_ms);
		mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;
		string (mseg_operation.wakeup_state.flags) = string (v3_wakeup_state.switches);
		mseg_operation.wakeup_state.event_channel = v3_wakeup_state.event_channel;
		mseg_operation.wakeup_state.access_class = mseg_ptr -> mseg_hdr.hdr_ms_access_class;
		mseg_operation.wakeup_state.process_id = v3_wakeup_state.process_id;
		mseg_operation.wakeup_state.lock_id = v3_wakeup_state.lock_id;
		mseg_operation.wakeup_state_valid = "1"b;
	     end;

	else mseg_operation.wakeup_state_valid = "0"b;

	return;
%page;
/* Read the requested message from a version 3 message segment */

mseg_upgrade_from_v3_$read_message:
     entry (P_mseg_operation_ptr, P_callers_area_ptr, P_code);

	mseg_operation_ptr = P_mseg_operation_ptr;
	callers_area_ptr = P_callers_area_ptr;
	code = error_table_$bad_subr_arg;		/* in case our caller's mseg_message_info is invalid */

	mseg_ptr = mseg_operation.mseg_ptr;

	mseg_message_info_ptr = addr (mseg_operation.message_info);

	if mseg_message_info.message_code = MSEG_READ_FIRST
	then call mseg_util_v3_$read (mseg_ptr, callers_area_ptr, "0"b, addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_LAST
	then call mseg_util_v3_$read (mseg_ptr, callers_area_ptr, "1"b, addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_SPECIFIED
	then call mseg_util_v3_$incremental_read (mseg_ptr, callers_area_ptr, "00"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_BEFORE_SPECIFIED
	then call mseg_util_v3_$incremental_read (mseg_ptr, callers_area_ptr, "10"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED
	then call mseg_util_v3_$incremental_read (mseg_ptr, callers_area_ptr, "01"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	if code = 0
	then do;	/*** Read succeeded -- Fill in the mseg_message_info appropriately */
		mseg_message_info.ms_ptr = local_mra.ms_ptr;
		mseg_message_info.ms_len = local_mra.ms_len;
		mseg_message_info.ms_id = local_mra.ms_id;
		mseg_message_info.ms_access_class = local_mra.access_class;
		mseg_message_info.sender_id = local_mra.sender_id;
		mseg_message_info.sender_process_id = ""b;
		mseg_message_info.sender_level = local_mra.level;
		mseg_message_info.sender_authorization = local_mra.sender_authorization;
		mseg_message_info.sender_max_authorization = local_mra.sender_authorization;
		mseg_message_info.sender_audit = ""b;
	     end;

	P_code = code;

	return;

/* format: off */
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_hdr_v3;
%page; %include mseg_return_args_v3;
/* format: on */

     end mseg_upgrade_from_v3_;




		    mseg_upgrade_from_v4_.pl1       05/10/85  0856.7r w 05/06/85  1619.0       51831



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

/* Support for upgrading version 4 message segments to the version supported by bound_mseg_ */

/* Created:  May 1985 by G. Palter */

/* format: style3,linecom */

mseg_upgrade_from_v4_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_mseg_operation_ptr			/* -> description of the operation forcing the upgrade (I) */
			pointer parameter;

dcl	P_salvage_completed bit (1) aligned parameter;	/* salvage: set ON => salvage succeeded (O) */

dcl	P_callers_area_ptr	pointer parameter;		/* read_message: -> area in which to place the message (I) */
dcl	P_code		fixed binary (35) parameter;	/* read_message: set to standard system status code (O) */


/* Local copies of parameters */

dcl	callers_area_ptr	pointer;

dcl	code		fixed binary (35);


/* Remaining declarations */

/* format: idind30 */

dcl	1 v4_wakeup_state		aligned,
	  2 state,
	    3 switches		aligned,
	      4 allow_normal	bit (1) unaligned,
	      4 allow_urgent	bit (1) unaligned,
	      4 pad		bit (34) unaligned,
	    3 lock_id		bit (36) aligned,
	    3 event_channel		fixed bin (71),
	    3 process_id		bit (36) aligned,
	  2 pad			(64 - 5) bit (36) aligned;

/* format: idind20 */

dcl	1 local_mra	aligned like mseg_return_args;

dcl	error_table_$bad_subr_arg
			fixed binary (35) external;

dcl	ms_salvager_v4_	entry (pointer, fixed binary (35));
dcl	mseg_util_v4_$incremental_read_priv
			entry (pointer, pointer, bit (2) aligned, bit (72) aligned, pointer, bit (1) aligned,
			fixed binary (35));
dcl	mseg_util_v4_$read_priv
			entry (pointer, pointer, bit (1) aligned, pointer, bit (1) aligned, fixed binary (35));

dcl	(addr, string, unspec)
			builtin;
%page;
/* Salvage the version 4 message segment */

mseg_upgrade_from_v4_$salvage:
     entry (P_mseg_operation_ptr, P_salvage_completed);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	call ms_salvager_v4_ (mseg_ptr, code);		/* it will report problems via admin_gate_ */

	P_salvage_completed = (code = 0);

	return;
%page;
/* Get the wakeup acceptance state of a version 4 message segment -- In version 4 segments, the wakeup state is stored in
   the header "message".  We will convert said "message" into the appropriate wakeup_state structure. */

mseg_upgrade_from_v4_$get_wakeup_state:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;

	mseg_ptr = mseg_operation.mseg_ptr;

	if mseg_ptr -> mseg_hdr_v4.ms_in_hdr
	then do;
		unspec (v4_wakeup_state) = unspec (mseg_ptr -> mseg_hdr_v4.hdr_ms);
		mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;
		string (mseg_operation.wakeup_state.flags) = string (v4_wakeup_state.switches);
		mseg_operation.wakeup_state.event_channel = v4_wakeup_state.event_channel;
		mseg_operation.wakeup_state.access_class = mseg_ptr -> mseg_hdr_v4.hdr_ms_access_class;
		mseg_operation.wakeup_state.process_id = v4_wakeup_state.process_id;
		mseg_operation.wakeup_state.lock_id = v4_wakeup_state.lock_id;
		mseg_operation.wakeup_state_valid = "1"b;
	     end;

	else mseg_operation.wakeup_state_valid = "0"b;

	return;
%page;
/* Read the requested message from a version 4 message segment */

mseg_upgrade_from_v4_$read_message:
     entry (P_mseg_operation_ptr, P_callers_area_ptr, P_code);

	mseg_operation_ptr = P_mseg_operation_ptr;
	callers_area_ptr = P_callers_area_ptr;
	code = error_table_$bad_subr_arg;		/* in case our caller's mseg_message_info is invalid */

	mseg_ptr = mseg_operation.mseg_ptr;

	mseg_message_info_ptr = addr (mseg_operation.message_info);

	if mseg_message_info.message_code = MSEG_READ_FIRST
	then call mseg_util_v4_$read_priv (mseg_ptr, callers_area_ptr, "0"b, addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_LAST
	then call mseg_util_v4_$read_priv (mseg_ptr, callers_area_ptr, "1"b, addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_SPECIFIED
	then call mseg_util_v4_$incremental_read_priv (mseg_ptr, callers_area_ptr, "00"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_BEFORE_SPECIFIED
	then call mseg_util_v4_$incremental_read_priv (mseg_ptr, callers_area_ptr, "10"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	else if mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED
	then call mseg_util_v4_$incremental_read_priv (mseg_ptr, callers_area_ptr, "01"b, mseg_message_info.ms_id,
		addr (local_mra), "0"b, code);

	if code = 0
	then do;	/*** Read succeeded -- Fill in the mseg_message_info appropriately */
		mseg_message_info.ms_ptr = local_mra.ms_ptr;
		mseg_message_info.ms_len = local_mra.ms_len;
		mseg_message_info.ms_id = local_mra.ms_id;
		mseg_message_info.ms_access_class = local_mra.access_class;
		mseg_message_info.sender_id = local_mra.sender_id;
		mseg_message_info.sender_process_id = ""b;
		mseg_message_info.sender_level = local_mra.level;
		mseg_message_info.sender_authorization = local_mra.sender_authorization;
		mseg_message_info.sender_max_authorization = local_mra.sender_authorization;
		mseg_message_info.sender_audit = ""b;
	     end;

	P_code = code;

	return;

/* format: off */
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_hdr_v4;
%page; %include mseg_return_args_v4;
/* format: on */

     end mseg_upgrade_from_v4_;




		    mseg_util_v2_.pl1               05/10/85  0856.8r w 05/06/85  1619.0      166203



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


mseg_util_v2_: proc;

/* Adapted from the original version 2 mseg_util_ by J. Stern, 11/4/74 */

dcl (a_mptr,					/* pointer to the message segment */
     prev_tr_ptr,					/* pointer to previous message trailer */
     next_tr_ptr,					/* pointer to next message trailer */
     ms_ptr,					/* pointer to message wanted */
     a_ret_ptr,					/* pointer to returned message */
     ret_ptr init (null),
     deletep,					/* pointer to block to be zeroed out */
     t_ptr,					/* scan pointer for returning message */
     a_area_ptr,					/* pointer to allocated area */
     a_ms_ptr,					/* pointer to updating message */
     area_ptr) ptr;

dcl (last,					/* ON if message is last in block */
     first,					/* ON if message is first in block */
     update,					/* ON if message is being updated */
     ms_end,					/* ON when end of message is found */
     read,					/* ON if message is to be read */
     delete) bit (1) aligned;				/* on if message is to be deleted */

dcl (tr_offset,					/* offset from beginning of block to trailer */
     ms_count,					/* number of messages in segment */
     mseg_data_v2_$block_trailer_data ext,			/* number of data words in block trailer */
     mseg_data_v2_$block_hdr_data ext,			/* number of data words in block header */
     prev_offset,					/* offset to previous message */
     next_offset,					/* offset to next message */
     block_size,					/* size of a message block */
     blocks_in_message,				/* number of blocks used for message */
     blocks_left,					/* number of free blocks in message segment */
     copy_size,					/* size of bit copy mask */
     delete_size,					/* bit size of block to be zeroed out */
     incr_size,					/* for stepping copy-to pointer */
     a_ms_len,					/* length of message in block trailer */
     ms_len,
     found_ms_len,					/* actual message size */
     a_loc,					/* location of message */
     loc,
     a_ret_loc,					/* location of incremental message */
     bit_off) fixed bin (18);				/* location of allocation bit to be turned off */

dcl (a_ms_wanted,					/* flag telling which message is wanted */
     ms_wanted,
     a_dir,					/* direction of incremental search */
     dir init ("0"b)) bit (2) aligned;

dcl (
     mseg_data_v2_$mseg_tr36 ext
     ) bit (36) aligned;

dcl (a_time,					/* time message was sent */
     a_ret_time,
     time) fixed bin (54);

dcl (
     a_level,					/* user level: 0 = non-own entry, 1 = own entry (argument) */
     alloc_len,					/* length of allocation bit string */
     level,					/* user level: 0 = non-own entry, 1 = own entry (internal) */
     a_user_level,					/* the callers' initial level */
     user_level,
     ms_word_len,					/* length of message in words */
     zero_words (8) int static init (0, 0, 0, 0, 0, 0, 0, 0), /* for uid credibility check */
     name_len) fixed bin;				/* length of person-project portion of group id */

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35);

dcl (addr, addrel, bit, divide, fixed, index, null, ptr, rel, substr) builtin;

dcl (
     cleanup
     ) condition;

dcl  area_array area (30) aligned based (area_ptr),	/* for allocating */
     ms_word_array (ms_word_len) fixed bin aligned based (ret_ptr);

dcl (caller_id,					/* id of caller */
     ms_sender_id) char (32) aligned;			/* id of message sender */

dcl  a_sender_id char (32) aligned;			/* id of message sender */

dcl  bit_copy_mask bit (copy_size) based;		/* bit copy mask */

dcl  bits (incr_size) bit (1) based unaligned;		/* for resetting copy-to pointer */

dcl  zeroes char (32) aligned based (addr (zero_words (1))); /* for uid credibility check */

% include mseg_hdr_v2;

% include ms_block_hdr_v2;

% include ms_block_trailer_v2;

dcl  error_table_$bad_segment ext fixed bin (35);
dcl  error_table_$moderr ext fixed bin (35);
dcl  error_table_$no_message ext fixed bin (35);

dcl  get_group_id_$tag_star ext entry
     returns (char (32) aligned);

dcl  ptr_is_good_v2_ ext entry
    (ptr) returns (bit (1) aligned);

/*  */
read:	entry (a_mptr, a_ms_wanted, a_area_ptr, a_loc, a_time, a_user_level, a_ret_ptr, a_ms_len, a_sender_id,
	a_level, a_code);

	ms_wanted = a_ms_wanted;
	area_ptr = a_area_ptr;
	read = "1"b;
	update,
	delete = "0"b;
	go to COMMON;

delete:	entry (a_mptr, a_loc, a_time, a_user_level, a_code);

	ms_wanted = "11"b;				/* delete by id only */
	update,
	read = "0"b;
	delete = "1"b;
	go to COMMON;

read_and_delete: entry (a_mptr, a_ms_wanted, a_area_ptr, a_user_level, a_ret_ptr, a_ms_len, a_sender_id,
	a_level, a_code);

	ms_wanted = a_ms_wanted;
	area_ptr = a_area_ptr;
	read, delete = "1"b;
	update = "0"b;
	go to COMMON;

incremental_read: entry (a_mptr, a_dir, a_area_ptr, a_loc, a_time, a_user_level, a_ret_ptr, a_ms_len, a_ret_loc,
	a_ret_time, a_sender_id, a_level, a_code);

	ms_wanted = "11"b;
	dir = a_dir;
	area_ptr = a_area_ptr;
	read = "1"b;
	delete = "0"b;
	update = "0"b;
	go to COMMON;


update:	entry (a_mptr, a_ms_ptr, a_ms_len, a_loc, a_time, a_user_level, a_code);

	read,
	delete = "0"b;
	update = "1"b;
	ms_len = a_ms_len;

/*  */

COMMON:	

	on condition (cleanup)			/* establish cleanup handler to free allocated message */
	begin;
	     if ret_ptr ^= null			/* a message was allocated */
	     then do;
		free ms_word_array in (area_array);	/* free it */
		a_ret_ptr = null;			/* and return null argument ptr */
	     end;
	     a_code = error_table_$bad_segment;		/* make sure salvaging happens */
	end;

	code = 0;
	mptr = a_mptr;
	alloc_len = fixed (bit (mseg_hdr_v2.alloc_len, 16), 17); /* pick allocation bit string length out of header */

	user_level = a_user_level;
	if user_level ^= 0				/* user calling for his own message */
	then do;
	     caller_id = get_group_id_$tag_star ();	/* get his pers-proj name */
	     name_len = index (caller_id, "*")-2;
	     caller_id = substr (caller_id, 1, name_len);
	end;

	if ms_wanted = "11"b			/* copy id if given */
	then do;
	     time = a_time;
	     loc = a_loc;				/* copy message location also */
	end;

	first, last, ms_end = "0"b;			/* initialize flags */

	ms_count =				/* get number of messages */
	fixed (mptr -> mseg_hdr_v2.number_of_messages, 18);

	block_size = fixed (mseg_hdr_v2.block_size, 18);	/* pick out block size from header */

	tr_offset =				/* calculate trailer offset */
	block_size-mseg_data_v2_$block_trailer_data;

	if (delete)				/* user is deleting a message */
	then do;
	     blocks_left =				/* get present number of free blocks */
	     fixed (mptr -> mseg_hdr_v2.space_left, 18);
	     delete_size = block_size*36;		/* compute bit size for zeroing blocks */
	end;

/*  */

/* locate the message */

	if ms_wanted = "01"b			/* last message wanted */
	then do;
	     loc = fixed (mptr -> mseg_hdr_v2.last_ms_offset, 18);
	     ms_ptr = ptr (mptr, loc);		/* make pointer to last message */
	     last = "1"b;				/* set flag to remember */
	     if ms_count = 1			/* only one message */
	     then first = "1"b;			/* it is first also */
	end;

	else if ms_wanted = "10"b			/* first message wanted */
	then do;
	     loc = fixed (mptr -> mseg_hdr_v2.first_ms_offset, 18);
	     ms_ptr = ptr (mptr, loc);		/* make pointer to first message */
	     first = "1"b;				/* set flag to remember */
	     if ms_count = 1			/* only one message */
	     then last = "1"b;			/* it is last also */
	end;

	if (first | last)
	then if ((^ptr_is_good_v2_ (ms_ptr))| (^ms_ptr -> ms_block_hdr.first_block))
	then go to BAD_SEG;				/* inconsistency, must be at least one message in segment */

	if ms_wanted = "11"b			/* locate message by unique id */
	then do;

/* check the validity of the given offset */

	     ms_ptr = ptr (mptr, loc);		/* make pointer to message */
	     if ((^ptr_is_good_v2_ (ms_ptr))| (ms_ptr -> ms_block_hdr.first_block ^= "1"b))
	     then go to NO_MSG;


	     tr_ptr = addrel (ms_ptr, tr_offset);	/* get pointer to trailer data */

	     if tr_ptr -> ms_size = "0"b		/* make credibility check on trailer */
	     | tr_ptr -> ms_block_trailer_v2.time = "0"b
	     | tr_ptr -> sender_id = zeroes
	     | tr_ptr -> ms_block_trailer_v2.tr_pattern ^= mseg_data_v2_$mseg_tr36
	     then go to BAD_SEG;

	     if tr_ptr -> ms_block_trailer_v2.time = bit (fixed (time, 54), 54) /* message time correct */
	     then do;

		if (delete) then do;		/* message is to be deleted */

		     if fixed (mptr -> mseg_hdr_v2.first_ms_offset, 18) = loc /* first message */
		     then first = "1"b;		/* set flag to remember */

		     if fixed (mptr -> mseg_hdr_v2.last_ms_offset, 18) = loc /* last message */
		     then last = "1"b;		/* set flag to remember */

		end;

	     end;

	     else					/* message time specified is incorrect */
	     go to NO_MSG;

/* incremental message wanted */

	     if dir ^= "0"b
	     then do;

		if dir = "10"b			/* previous message wanted */
		then do;				/* increment message pointer */
		     if tr_ptr -> ms_block_trailer_v2.b_offset ^= "0"b
		     then do;
			loc = fixed (tr_ptr -> ms_block_trailer_v2.b_offset, 18);
			ms_ptr = ptr (ms_ptr, loc);
		     end;
		     else do;			/* error, no previous message */
			if fixed (mseg_hdr_v2.first_ms_offset, 18) ^= loc
			then go to BAD_SEG;		/* format error, not first message */
NO_MSG:			code = error_table_$no_message;
			go to FIN;
		     end;
		end;

		else if dir = "01"b			/* next message wanted */
		then do;				/* increment message pointer */
		     if tr_ptr -> ms_block_trailer_v2.f_offset ^= "0"b
		     then do;
			loc = fixed (tr_ptr -> ms_block_trailer_v2.f_offset, 18);
			ms_ptr = ptr (ms_ptr, loc);
		     end;
		     else do;			/* error, no next message */
			if fixed (mseg_hdr_v2.last_ms_offset, 18) ^= loc
			then go to BAD_SEG;		/* format error, not last message */
			go to NO_MSG;
		     end;
		end;

	     end;

	end;

/* get information from the first block trailer */

	tr_ptr =					/* get pointer to trailer */
	addrel (ms_ptr, tr_offset);

	if tr_ptr -> ms_size = "0"b			/* make trailer credibility check */
	| tr_ptr -> ms_block_trailer_v2.time = "0"b
	| tr_ptr -> sender_id = zeroes
	| tr_ptr -> ms_block_trailer_v2.tr_pattern ^= mseg_data_v2_$mseg_tr36
	then go to BAD_SEG;

	if dir ^= "0"b				/* pick up incremental id */
	then time = fixed (tr_ptr -> ms_block_trailer_v2.time, 54);

	if (delete) then do;

	     if (^first)
	     then do;				/* not first message */
		prev_offset =			/* get offset to previous message */
		fixed (tr_ptr -> ms_block_trailer_v2.b_offset, 18);
		prev_tr_ptr =			/* make pointer to previous trailer */
		ptr (mptr, prev_offset+tr_offset);
	     end;

	     if (^last)
	     then do;				/* not last message */
		next_offset =			/* get offset to next message */
		fixed (tr_ptr -> ms_block_trailer_v2.f_offset, 18);
		next_tr_ptr =			/* make pointer to next trailer */
		ptr (mptr, next_offset+tr_offset);
	     end;

	end;

	ms_sender_id =
	tr_ptr -> ms_block_trailer_v2.sender_id;		/* pick out senders' id */
	level = fixed (ms_block_trailer_v2.ring_no, 17);	/* pick out validation level */

/* make final access check */

	if user_level ^= 0				/* user called for own message */
	then if caller_id ^= substr (ms_sender_id, 1, name_len) /* this is not his message */
	then do;
	     ms_len = 0;				/* not found */
	     if (delete | update)			/* no "d" permission, not own message */
	     then code = error_table_$moderr;
	     else					/* user not deleting */
	     if dir = "0"b				/* ordinary read */
	     then time = fixed (bit (tr_ptr -> ms_block_trailer_v2.time, 54), 54); /* return message time */
	     go to FIN;
	end;

	if update
	then if fixed (tr_ptr -> ms_block_trailer_v2.ms_size, 18) ^= ms_len /* incorrect message size specified */
	then go to NO_MSG;

/* allocate an area for the returned message */

	ms_len = fixed (ms_block_trailer_v2.ms_size, 18);	/* pick out message size */

	if (read)
	then do;
	     ms_word_len = divide (ms_len+35, 36, 17, 0);	/* compute word length from bit count */
	     allocate ms_word_array in (area_array) set (ret_ptr); /* allocate the area */
	     t_ptr = ret_ptr;			/* initialize scan pointer */
	end;

	else					/* not reading message */
	if update					/* updating message */
	then t_ptr = a_ms_ptr;			/* initialize scan ptr */

/*  */
/* chase the message thread */

	found_ms_len = 0;				/* initialize size of found message */

	blocks_in_message = 0;			/* initialize count */
	block_ptr = ms_ptr;				/* initialize block pointer */
	ms_end = "0"b;				/* initialize end of message flag */

	if (delete | update)			/* user is deleting or updating a message */
	then mseg_hdr_v2.aip = "1"b;			/* turn on aip bit */

	do while (^ms_end);

	     blocks_in_message =			/* increment message block count */
	     blocks_in_message + 1;

	     found_ms_len = found_ms_len + fixed (ms_block_hdr.block_count, 18); /* increment message size */
	     if found_ms_len > ms_len			/* more message than block trailer specified */
	     then do;				/* error in message segment */
BAD_SEG:		
		code = error_table_$bad_segment;
		go to FIN;
	     end;


	     if (read | update)
	     then do;				/* return message for reading */
		copy_size =			/* set size of copy mask */
		fixed (block_ptr -> ms_block_hdr.block_count, 18);
		incr_size = copy_size + 1;		/* to step copy-to ptr later */
		if read				/* reading message */
		then t_ptr -> bit_copy_mask =		/* copy message */
		addrel (block_ptr, mseg_data_v2_$block_hdr_data) -> bit_copy_mask;
		else				/* not reading */
		if update				/* updating message */
		then addrel (block_ptr, mseg_data_v2_$block_hdr_data) -> bit_copy_mask
		= t_ptr -> bit_copy_mask;		/* overwrite */
	     end;

	     if (delete)
	     then do;				/* user is deleting a message */
		bit_off = divide (fixed (rel (block_ptr), 18), block_size, 18, 0)+1; /* calculate alloc bit for block */
		if substr (mseg_hdr_v2.alloc_bits, bit_off, 1) = "0"b /* block not in use */
		then go to BAD_SEG;			/* format error */
		else
		substr (mseg_hdr_v2.alloc_bits, bit_off, 1) = "0"b; /* turn bit off */
		deletep = block_ptr;		/* remember block ptr to delete later */
	     end;

	     if blocks_in_message = 1			/* first block */
	     then if ms_wanted ^= "11"b		/* id not given */
	     then do;				/* get id */
		tr_ptr = addrel (block_ptr, block_size-mseg_data_v2_$block_trailer_data);
		time = fixed (bit (tr_ptr -> ms_block_trailer_v2.time, 54), 54);
	     end;

	     if block_ptr -> ms_block_hdr.f_offset = "0"b
	     then do;				/* message block is last in message */
		if found_ms_len ^= ms_len		/* found size doesn't agree with trailer */
		then go to BAD_SEG;			/* format error */
		else
		ms_end = "1"b;			/* indicate end of message */
	     end;

	     else do;
		block_ptr =			/* step the block pointer */
		ptr (block_ptr, fixed (block_ptr -> ms_block_hdr.f_offset, 18));
		if (read) then t_ptr =		/* increment copy-to pointer */
		addr (t_ptr -> bits (incr_size));
	     end;

	     if (delete)				/* message is being deleted */
	     then do;
		copy_size = delete_size;		/* set size of copy mask */
		deletep -> bit_copy_mask = "0"b;	/* use mask to zero out block */
	     end;

	end;

/*  */
/* finish deleting message if requested */

	if (delete) then do;

	     blocks_left =				/* calculate new remaining blocks */
	     blocks_left + blocks_in_message;

	     if ms_count > 1			/* there will be a remaining message */
	     then do;

/* unthread the message */

		if (first) then do;			/* unthread first message */
		     mptr -> mseg_hdr_v2.first_ms_offset =
		     bit (fixed (next_offset, 18), 18);	/* reset header offset to new first message */
		     next_tr_ptr -> ms_block_trailer_v2.b_offset =
		     "0"b;			/* reset new first message back pointer */
		end;

		if (last) then do;			/* unthread last message */
		     mptr -> mseg_hdr_v2.last_ms_offset =
		     bit (fixed (prev_offset, 18), 18);	/* reset header offset to new last message */
		     prev_tr_ptr -> ms_block_trailer_v2.f_offset =
		     "0"b;			/* reset new last message forward pointer */
		end;

		if (^first) then if (^last) then do;	/* unthread mid message */
		     prev_tr_ptr -> ms_block_trailer_v2.f_offset =
		     bit (fixed (next_offset, 18), 18);	/* reset forward offset of previous message */
		     next_tr_ptr -> ms_block_trailer_v2.b_offset =
		     bit (fixed (prev_offset, 18), 18);	/* reset backward offset of next message */
		end;

	     end;

	     else					/* no messages left */
	     mseg_hdr_v2.first_ms_offset,		/* zero out hdr pointers */
	     mseg_hdr_v2.last_ms_offset = "0"b;

/* update header after deletion */

	     mptr -> mseg_hdr_v2.space_left =		/* reset space left */
	     fixed (blocks_left);

	     ms_count = ms_count - 1;
	     mptr -> mseg_hdr_v2.number_of_messages =	/* reset number of messages */
	     fixed (ms_count);

	     mptr -> mseg_hdr_v2.aip = "0"b;		/* turn off allocation in progress bit */

	end;

FIN:	

	if code = 0
	then do;

	     if (read)
	     then a_ms_len = ms_len;

	     if (^delete & ^update)
	     then do;
		a_time = time;			/* return loc and time if not given */
		a_loc = loc;
	     end;

	     if dir ^= "0"b				/* return incremental data */
	     then do;
		a_ret_time = time;
		a_ret_loc = loc;
	     end;

	end;

	else do;					/* error, return null arguments */

	     if (read)
	     then a_ms_len = 0;

	     if (^delete & ^update)
	     then a_time, a_loc = 0;

	     if dir ^= "0"b
	     then a_ret_loc, a_ret_time = 0;

	     if ret_ptr ^= null			/* a message was allocated */
	     then do;
		free ms_word_array in (area_array);	/* free it */
		a_ret_ptr = null;			/* return null argument */
	     end;

	end;

	a_code = code;

	if (read)					/* return allocation pointer for freeing */
	then do;
	     a_ret_ptr = ret_ptr;
	     if code = 0
	     then do;
		a_sender_id = ms_sender_id;
		a_level = level;
	     end;
	     else
	     if ^update
	     then do;
		if user_level = 0
		then a_sender_id = "";
		a_level = -1;
	     end;
	end;

	return;


     end mseg_util_v2_;




		    mseg_util_v3_.pl1               05/10/85  0856.8r w 05/06/85  1619.0      212472



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


mseg_util_v3_: proc;

/* Modified for version 3 message segments by J. Stern, 10/22/74 */
/* Modified to use mseg_error_ by J. Stern, 11/12/75 */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */

dcl (a_mptr,					/* pointer to the message segment */
     prev_tr_ptr,					/* pointer to previous message trailer */
     next_tr_ptr,					/* pointer to next message trailer */
     prev_in_bucket_ptr,				/* pointer to previous message in hash bucket */
     ms_ptr,					/* pointer to message wanted */
     ret_ptr init (null),
     deletep,					/* pointer to block to be zeroed out */
     a_arg_ptr,					/*  pointer to return_arg structure (argument) */
     arg_ptr,					/* pointer to return_arg structure (internal) */
     t_ptr,					/* scan pointer for returning message */
     a_area_ptr,					/* pointer to allocated area */
     a_ms_ptr,					/* pointer to updating message */
     area_ptr) ptr;

dcl (read init ("0"b),				/* ON for read or read and delete entry */
     incr_read init ("0"b),				/* ON for incremental read entry */
     delete init ("0"b),				/* ON for delete or read and delete entry */
     update init ("0"b),				/* ON for update entry */
     get_count init ("0"b),				/* ON for get_count entry */
     mseg_priv,					/* ON if calling process has privileged access */
     a_own,					/* ON if reading own message (argument) */
     own,						/* ON if reading own message (internal) */
     last,					/* ON if message is last in segment */
     first,					/* ON if message is first in segment */
     search_sw,					/* ON if message id not found for incremental reading */
     ms_end) bit (1) aligned;				/* ON when end of message is found */

dcl  back_in_bucket_offset bit (18) aligned;		/* offset of message one back in hash bucket */

dcl (tr_offset,					/* offset from beginning of block to trailer */
     ms_count,					/* number of messages in segment */
     a_count,					/* message count (argument) */
     count,					/* message count (internal) */
     prev_offset,					/* offset to previous message */
     next_offset,					/* offset to next message */
     block_size,					/* size of a message block */
     blocks_in_message,				/* number of blocks used for message */
     copy_size,					/* size of bit copy mask */
     delete_size,					/* bit size of block to be zeroed out */
     a_ms_len,					/* length of message in block trailer */
     ms_len,
     found_ms_len,					/* actual message size */
     update_len,					/* size of update message */
     loc,
     bit_off) fixed bin (18);				/* location of allocation bit to be turned off */

dcl (a_first_or_last,				/* ON if last message wanted (argument) */
     first_or_last) bit (1) aligned;			/* ON if last message wanted (internal) */

dcl (a_dir,					/* direction of incremental search */
     dir init ("00"b)) bit (2) aligned;

dcl (a_ms_id,					/* message ID (argument) */
     ms_id) bit (72) aligned;				/* message ID (internal) */

dcl (authorization,					/* authorization of calling process */
     access_class) bit (72) aligned;			/* access class of message segment */

dcl  privileges bit (36) aligned;			/* privileges of calling process */
dcl 1 based_priv unal based (addr (privileges)) like aim_template.privileges;

dcl (
     alloc_len,					/* length of allocation bit string */
     level,					/* user level: 0 = non-own entry, 1 = own entry (internal) */
     ms_word_len,					/* length of message in words */
     htx,						/* hash table index */
     id_len) fixed bin;				/* length of person-project portion of group id */

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35);

dcl (addr, addrel, bit, divide, fixed, index, null, ptr, rel, size, substr) builtin;

dcl (
     area,
     cleanup
     ) condition;

dcl  area_array area (30) aligned based (area_ptr),	/* for allocating */
     ms_word_array (ms_word_len) fixed bin aligned based (ret_ptr);

dcl (caller_id,					/* id of caller */
     ms_sender_id) char (32) aligned;			/* id of message sender */

dcl  proc_name char (32);				/* procedure name */
dcl  reason char (40);				/* reason why operation failed */

dcl  bit_copy_mask bit (copy_size) based;		/* bit copy mask */

dcl  bits (copy_size) bit (1) based unaligned;		/* for resetting copy-to pointer */

dcl 1 return_args aligned based (arg_ptr),		/* return argument structure */
    2 ms_ptr ptr,					/* pointer to message */
    2 ms_len fixed bin (18),				/* length of message in bits */
    2 sender_id char (32),				/* person-project ID of message sender */
    2 level fixed bin,				/* validation level of sender */
    2 ms_id bit (72),				/* unique ID of message */
    2 sender_authorization bit (72),			/* access authorization of message sender */
    2 access_class bit (72);				/* message access class */

% include mseg_hdr_v3;

% include ms_block_hdr_v3;

% include ms_block_trailer_v3;

% include aim_template;

dcl  error_table_$bad_segment ext fixed bin (35);
dcl  error_table_$ai_restricted ext fixed bin (35);
dcl  error_table_$no_message ext fixed bin (35);
dcl  error_table_$inconsistent ext fixed bin (35);
dcl  error_table_$bigarg ext fixed bin (35);
dcl  error_table_$noalloc ext fixed bin (35);

dcl  get_group_id_$tag_star ext entry returns (char (32) aligned);
dcl  get_authorization_ ext entry returns (bit (72) aligned);
dcl  get_privileges_ ext entry returns (bit (36) aligned);
dcl  hcs_$get_access_class_seg ext entry (ptr, bit (72) aligned, fixed bin (35));
dcl  mseg_error_v3_ entry options (variable);
dcl  read_allowed_ ext entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  read_write_allowed_ ext entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

/*  */
read:	entry (a_mptr, a_area_ptr, a_first_or_last, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_$read";
	first_or_last = a_first_or_last;
	area_ptr = a_area_ptr;
	read = "1"b;
	go to COMMON;

delete:	entry (a_mptr, a_ms_id, a_own, a_code);

	proc_name = "mseg_util_$delete";
	ms_id = a_ms_id;
	delete = "1"b;
	go to COMMON;

read_and_delete: entry (a_mptr, a_area_ptr, a_first_or_last, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_$read_and_delete";
	first_or_last = a_first_or_last;
	area_ptr = a_area_ptr;
	read, delete = "1"b;
	go to COMMON;

incremental_read: entry (a_mptr, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_$incremental_read";
	ms_id = a_ms_id;
	dir = a_dir;
	if dir = "11"b then do;			/* undefined */
	     code = error_table_$inconsistent;
	     go to FIN;
	end;
	area_ptr = a_area_ptr;
	incr_read = "1"b;
	go to COMMON;


update:	entry (a_mptr, a_ms_ptr, a_ms_len, a_ms_id, a_own, a_code);

	proc_name = "mseg_util_$update";
	update = "1"b;
	ms_id = a_ms_id;
	go to COMMON;

get_count: entry (a_mptr, a_count, a_code);

	proc_name = "mseg_util_$get_count";
	get_count = "1"b;
	own = "0"b;
	go to COMMON2;

/*  */

COMMON:
	own = a_own;

COMMON2:
	mptr = a_mptr;
	code = 0;
	search_sw = "0"b;

	ms_count =				/* get number of messages */
	     fixed (mptr -> mseg_hdr.number_of_messages, 18);

	block_size = fixed (mseg_hdr.block_size, 18);	/* pick out block size from header */

	tr_offset = block_size - size (ms_block_trailer); /* calculate trailer offset */

/* See if first or last message wanted */

	if get_count then go to COUNT;		/* start counting with first message */

	if read then do;				/* read first or last message */
	     if first_or_last = "1"b			/* last message wanted */
	     then do;
		dir = "10"b;			/* prepare to scan backward */
LAST:		loc = fixed (mptr -> mseg_hdr.last_ms_offset, 18); /* get offset of last message */
	     end;

	     else do;				/* first message wanted */
COUNT:		dir = "01"b;			/* prepare to scan forward */
FIRST:		loc = fixed (mptr -> mseg_hdr.first_ms_offset, 18); /* get offset of first message */
	     end;
	     if delete then do;
		ms_ptr = ptr (mptr, loc);
		tr_ptr = addrel (ms_ptr, tr_offset);
		ms_id = tr_ptr -> ms_block_trailer.ms_id;
		go to THREAD;
	     end;
	end;

/* look up message ID in hash table */

	else do;					/* for incr read, update ; delete */
THREAD:	     htx = fixed (substr (ms_id, 64, 9));	/* hash table index = low 9 bits of message ID */
	     loc = fixed (hash_table.last_in_bucket (htx), 18); /* get loc of last message in bucket */
	     prev_in_bucket_ptr = null;		/* no previous message yet */

	     do while (loc ^= 0);			/* search bucket for matching message ID */
		ms_ptr = ptr (mptr, loc);		/* get ptr to first block of message */
		if ^ms_ptr -> ms_block_hdr.first_block	/* check if really first block */
		then do;
		     reason = "not first block in hash lookup";
		     go to BAD_SEG;
		end;
		tr_ptr = addrel (ms_ptr, tr_offset);	/* get trailer ptr */
		if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* check pattern */
		then do;
		     reason = "bad trailer pattern in hash lookup";
		     go to BAD_SEG;
		end;
		if tr_ptr -> ms_block_trailer.ms_id = ms_id /* found it */
		then go to FOUND_ID;
		prev_in_bucket_ptr = tr_ptr;		/* remember ptr to this message */
		loc = fixed (tr_ptr -> ms_block_trailer.back_in_bucket, 18); /* go back one in bucket */
	     end;

	     if incr_read then
		if dir ^= "00"b then do;		/* forward or backward incr read */
		     search_sw = "1"b;		/* search for next message even though this message is gone */
		     if dir = "10"b then go to LAST;	/* search for largest message id < ms_id */
		     else go to FIRST;		/* search for smallest message id > ms_id */
		end;

	     go to NO_MSG;				/* bucket exhausted */
FOUND_ID:
	end;


/* prepare to check access */

	authorization = get_authorization_ ();		/* get caller's authorization */
	privileges = get_privileges_ ();		/* get caller's privileges */
	mseg_priv = based_priv.ring1;			/* get ring 1 privilege flag */
	if own					/* caller can only reference his own message */
	then do;
	     caller_id = get_group_id_$tag_star ();	/* get caller's goup id */
	     id_len = index (caller_id, ".*");		/* find index of the ".*" tag */
	end;

/* get_count */

	if get_count
	then do;
	     if mseg_priv				/* caller has privileged access */
	     then do;
FULL_COUNT:	a_count = ms_count;			/* return full count */
		go to FIN;
	     end;
	     call hcs_$get_access_class_seg (mptr, access_class, code); /* get message seg access class */
	     if code ^= 0 then go to FIN;
	     if read_allowed_ (authorization, access_class) /* caller is authorized to see all messages */
	     then go to FULL_COUNT;			/* return full count */
	     count = 0;				/* initialize count */
	     go to READ;				/* get count of read-accessible messages */
	end;

/* incremental read */

	else if search_sw then go to READ;
	else if incr_read
	then do;
	     if own				/* must be caller's own message */
	     then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		then go to NO_MSG;			/* pretend it doesn't exist */
	     if ^mseg_priv				/* no special access privilege */
	     then if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read permit */
		then go to NO_MSG;			/* pretend it doesn't exist */

	     if dir = "10"b				/* previous message wanted */
	     then do;				/* increment message pointer */
		if tr_ptr -> ms_block_trailer.b_offset = "0"b
		then do;				/* error, no previous message */
		     if fixed (mseg_hdr.first_ms_offset, 18) ^= loc
		     then do;
			reason = "bad first offset";
			go to BAD_SEG;
		     end;
NO_MSG:		     code = error_table_$no_message;
		     go to FIN;
		end;
		loc = fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
		go to READ;
	     end;

	     else if dir = "01"b			/* next message wanted */
	     then do;				/* increment message pointer */
		if tr_ptr -> ms_block_trailer.f_offset = "0"b
		then do;				/* error, no next message */
		     if fixed (mseg_hdr.last_ms_offset, 18) ^= loc
		     then do;
			reason = "bad last offset";
			go to BAD_SEG;
		     end;
		     go to NO_MSG;
		end;
		loc = fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
		go to READ;
	     end;

	end;

/* read */

	else if read
	then do;
READ:	     do while (loc ^= 0);			/* scan for read-accessible message */
		ms_ptr = ptr (mptr, loc);		/* get ptr to first block of message */
		if ^ms_ptr -> ms_block_hdr.first_block	/* check if really first block */
		then do;
		     reason = "not first block";
		     go to BAD_SEG;
		end;
		tr_ptr = addrel (ms_ptr, tr_offset);	/* get trailer ptr */
		if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* check pattern */
		then do;
		     reason = "bad trailer pattern";
		     go to BAD_SEG;
		end;
		if own				/* must be caller's own message */
		then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		     then go to NEXT;		/* skip it */
		if ^mseg_priv			/* no special access privileges */
		then do;
		     if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read permit */
		     then go to NEXT;		/* skip over this one */
		     if delete			/* read and delete requested */
		     then if ^read_write_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class)
			then go to AI_ERR;		/* cannot delete this message */
		end;
		if get_count			/* get_count entry */
		then count = count + 1;		/* increment count of read-accessible messages */
		else if search_sw
		then if dir = "01"b
		     then if substr (tr_ptr -> ms_block_trailer.ms_id, 19, 54) > substr (ms_id, 19, 54)
			then go to EXIT;		/* found the one we're searching for */
			else go to NEXT;
		     else if substr (tr_ptr -> ms_block_trailer.ms_id, 19, 54) < substr (ms_id, 19, 54)
		     then go to EXIT;		/* found it */
		     else go to NEXT;
		else go to EXIT;			/* found a message to read, exit loop */
NEXT:
		if dir = "01"b			/* scanning forward */
		then loc = fixed (tr_ptr -> ms_block_trailer.f_offset, 18); /* get loc of next message */
		else loc = fixed (tr_ptr -> ms_block_trailer.b_offset, 18); /* get loc of previous message */
	     end;

	     if get_count				/* we're finished counting */
	     then do;
		a_count = count;
		go to FIN;
	     end;
	     go to NO_MSG;				/* couldn't find anything to read */
EXIT:	end;

/* update or delete */

	else if update | delete
	then do;
	     if own				/* must be caller's own message */
	     then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		then go to NO_MSG;			/* pretend it doesn't exist */
	     if ^mseg_priv				/* no special access privilege */
	     then if ^read_write_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read-write permit */
		then if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* not even read permit */
		     then go to NO_MSG;		/* pretend it doesn't exist */
		     else do;			/* caller has read permit, but not modify */
AI_ERR:			code = error_table_$ai_restricted;
			go to FIN;
		     end;
	end;

/* prepare to perform requested operation */

	ms_len = fixed (ms_block_trailer.ms_size, 18);	/* pick out message size */

	if update
	then do;
	     update_len = a_ms_len;
	     if update_len > ms_len			/* incorrect message size specified */
	     then do;
		code = error_table_$bigarg;		/* user message too big */
		go to FIN;
	     end;
	     t_ptr = a_ms_ptr;			/* initialize copy ptr */
	end;

	if delete
	then do;

	     if fixed (mptr -> mseg_hdr.first_ms_offset, 18) = loc /* first message */
	     then first = "1"b;			/* set flag to remember */
	     else first = "0"b;
	     if fixed (mptr -> mseg_hdr.last_ms_offset, 18) = loc /* last message */
	     then last = "1"b;			/* set flag to remember */
	     else last = "0"b;

	     if (^first)
	     then do;				/* not first message */
		prev_offset =			/* get offset to previous message */
		     fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
		prev_tr_ptr =			/* make pointer to previous trailer */
		     ptr (mptr, prev_offset+tr_offset);
	     end;

	     if (^last)
	     then do;				/* not last message */
		next_offset =			/* get offset to next message */
		     fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
		next_tr_ptr =			/* make pointer to next trailer */
		     ptr (mptr, next_offset+tr_offset);
	     end;

	     back_in_bucket_offset = tr_ptr -> ms_block_trailer.back_in_bucket;

	     delete_size = block_size * 36;		/* the block size in bits */
	     alloc_len = mptr -> mseg_hdr.alloc_len;	/* a local copy of the number of allocation bits */

	end;

	if read | incr_read
	then do;
	     ms_sender_id = tr_ptr -> ms_block_trailer.sender_id; /* pick out senders' id */
	     level = fixed (ms_block_trailer.ring_no, 17); /* pick out validation level */
	     ms_id = tr_ptr -> ms_block_trailer.ms_id;	/* pick out message id */
	     authorization = tr_ptr -> ms_block_trailer.sender_authorization; /* pick out sender authorization */
	     access_class = tr_ptr -> ms_block_trailer.access_class; /* pick out message access class */

/* allocate an area for the returned message */

	     on cleanup begin;			/* establish cleanup handler to free allocated message */
		if ret_ptr ^= null			/* a message was allocated */
		then do;
		     free ms_word_array in (area_array); /* free it */
		     a_arg_ptr -> return_args.ms_ptr = null; /* and return null argument ptr */
		end;
	     end;

	     on area begin;
		code = error_table_$noalloc;
		go to FIN;
	     end;

	     ms_word_len = divide (ms_len+35, 36, 17, 0); /* compute word length from bit count */
	     allocate ms_word_array in (area_array) set (ret_ptr); /* allocate the area */
	     t_ptr = ret_ptr;			/* initialize scan pointer */
	end;

/*  */
/* chase the message thread */

	found_ms_len = 0;				/* initialize size of found message */

	blocks_in_message = 0;			/* initialize count */
	block_ptr = ms_ptr;				/* initialize block pointer */
	ms_end = "0"b;				/* initialize end of message flag */

	if delete					/* user is deleting a message */
	then mseg_hdr.mip = "1"b;			/* turn on mip bit */

	do while (^ms_end);

	     blocks_in_message =			/* increment message block count */
		blocks_in_message + 1;

	     found_ms_len = found_ms_len + fixed (ms_block_hdr.block_count, 18); /* increment message size */
	     if found_ms_len > ms_len			/* more message than block trailer specified */
	     then do;				/* error in message segment */
		reason = "message too long";
		go to BAD_SEG;
	     end;


	     if (read | incr_read | update)
	     then do;				/* return message for reading */
		copy_size =			/* set size of copy mask */
		     fixed (block_ptr -> ms_block_hdr.block_count, 18);
		if update then do;			/* updating message */
		     if found_ms_len > update_len then do; /* update only part of this block */
			copy_size = copy_size - (found_ms_len - update_len);
			ms_end = "1"b;
		     end;
		     addrel (block_ptr, size (ms_block_hdr)) -> bit_copy_mask
			= t_ptr -> bit_copy_mask;	/* overwrite */
		end;
		else				/* reading message */
		t_ptr -> bit_copy_mask =		/* copy message */
		     addrel (block_ptr, size (ms_block_hdr)) -> bit_copy_mask;
		t_ptr = addr (t_ptr -> bits (copy_size + 1)); /* increment copy ptr */
	     end;

	     if (delete)
	     then do;				/* user is deleting a message */
		bit_off = divide (fixed (rel (block_ptr), 18), block_size, 18, 0)+1; /* calculate alloc bit for block */
		if substr (mseg_hdr.alloc_bits, bit_off, 1) = "0"b /* block not in use */
		then do;
		     reason = "unprotected block";
		     go to BAD_SEG;
		end;
		else
		substr (mseg_hdr.alloc_bits, bit_off, 1) = "0"b; /* turn bit off */
		deletep = block_ptr;		/* remember block ptr to delete later */
	     end;

	     if ^ms_end then
		if block_ptr -> ms_block_hdr.f_offset = "0"b
		then do;				/* message block is last in message */
		     if found_ms_len ^= ms_len	/* found size doesn't agree with trailer */
		     then do;
			reason = "bad message length";
			go to BAD_SEG;
		     end;
		     else
		     ms_end = "1"b;			/* indicate end of message */
		end;

		else do;
		     block_ptr =			/* step the block pointer */
			ptr (block_ptr, fixed (block_ptr -> ms_block_hdr.f_offset, 18));
		end;

	     if (delete)				/* message is being deleted */
	     then do;
		copy_size = delete_size;		/* set size of copy mask */
		deletep -> bit_copy_mask = "0"b;	/* use mask to zero out block */
	     end;

	end;

/*  */
/* finish deleting message if requested */

	if (delete) then do;

	     if ms_count > 1			/* there will be a remaining message */
	     then do;

/* unthread the message */

		if (first) then do;			/* unthread first message */
		     mptr -> mseg_hdr.first_ms_offset =
			bit (fixed (next_offset, 18), 18); /* reset header offset to new first message */
		     next_tr_ptr -> ms_block_trailer.b_offset =
			"0"b;			/* reset new first message back pointer */
		end;

		if (last) then do;			/* unthread last message */
		     mptr -> mseg_hdr.last_ms_offset =
			bit (fixed (prev_offset, 18), 18); /* reset header offset to new last message */
		     prev_tr_ptr -> ms_block_trailer.f_offset =
			"0"b;			/* reset new last message forward pointer */
		end;

		if (^first) then if (^last) then do;	/* unthread mid message */
			prev_tr_ptr -> ms_block_trailer.f_offset =
			     bit (fixed (next_offset, 18), 18); /* reset forward offset of previous message */
			next_tr_ptr -> ms_block_trailer.b_offset =
			     bit (fixed (prev_offset, 18), 18); /* reset backward offset of next message */
		     end;

	     end;

	     else					/* no messages left */
	     mseg_hdr.first_ms_offset,		/* zero out hdr pointers */
		mseg_hdr.last_ms_offset = "0"b;

/* rethread the hash bucket */
	     if prev_in_bucket_ptr = null then
		hash_table.last_in_bucket (htx) = back_in_bucket_offset;
	     else prev_in_bucket_ptr -> ms_block_trailer.back_in_bucket = back_in_bucket_offset;

/* update header after deletion */

	     mptr -> mseg_hdr.space_left =		/* reset space left */
		mptr -> mseg_hdr.space_left + blocks_in_message;

	     ms_count = ms_count - 1;
	     mptr -> mseg_hdr.number_of_messages =	/* reset number of messages */
		fixed (ms_count);

	     mptr -> mseg_hdr.mip = "0"b;		/* turn off modification in progress bit */

	end;

	if read | incr_read
	then do;					/* fill in return argument structure */
	     arg_ptr = a_arg_ptr;			/* copy ptr to return_args structure */
	     return_args.ms_ptr = ret_ptr;		/* ptr to message */
	     return_args.ms_len = ms_len;		/* length of message */
	     return_args.sender_id = ms_sender_id;	/* person-project ID of message sender */
	     return_args.level = level;		/* validation level of message sender */
	     return_args.ms_id = ms_id;		/* message ID */
	     return_args.sender_authorization = authorization; /* authorization of message sender */
	     return_args.access_class = access_class;	/* access class of message */
	end;

FIN:

	a_code = code;
	return;

BAD_SEG:
	call mseg_error_v3_ (mptr, 0, proc_name, reason);
	code = error_table_$bad_segment;
	go to FIN;


     end mseg_util_v3_;




		    mseg_util_v4_.pl1               05/09/85  1152.2r w 05/06/85  1619.0      231840



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


mseg_util_v4_: proc;

/* Modified for version 3 message segments by J. Stern, 10/22/74 */
/* Modified to use mseg_error_ by J. Stern, 11/12/75 */
/* Modified for "o" operations to test only Person_id 12/18/79 S. Herbst */
/* Modified 3/77 by Charlie Davis for the installation of version 4 message segments */
/* Modified: February 1983 by G. Palter for privileged entries used by compacting */
/* Modified: 84-05-07 BIM for get_process_authorization_ instead of get_authorization_ */
/* Modified: August 1984 by G. Palter to fix message segment error #0004 -- If a user's access to a mailbox or message
      segment includes read (r) and own (o) but not delete (d) permission, mailbox_$delete_index,
      message_segment_$delete_index, and message_segment_$delete_file will return error_table_$no_message when asked to
      delete a message not created by the user.  Since, in this case, the user can determine which messages exist in the
      segment, these entrypoints should return error_table_$moderr to indicate that the user doesn't have permission to
      delete the message */


dcl (a_mptr,					/* pointer to the message segment */
     prev_tr_ptr,					/* pointer to previous message trailer */
     next_tr_ptr,					/* pointer to next message trailer */
     prev_in_bucket_ptr,				/* pointer to previous message in hash bucket */
     ms_ptr,					/* pointer to message wanted */
     ret_ptr init (null),
     deletep,					/* pointer to block to be zeroed out */
     a_arg_ptr,					/*  pointer to return_arg structure (argument) */
     arg_ptr,					/* pointer to return_arg structure (internal) */
     t_ptr,					/* scan pointer for returning message */
     a_area_ptr,					/* pointer to allocated area */
     a_ms_ptr,					/* pointer to updating message */
     area_ptr) ptr;

dcl (read init ("0"b),				/* ON for read or read and delete entry */
     incr_read init ("0"b),				/* ON for incremental read entry */
     delete init ("0"b),				/* ON for delete or read and delete entry */
     update init ("0"b),				/* ON for update entry */
     get_count init ("0"b),				/* ON for get_count entry */
     priv_entry init ("0"b),				/* ON for privileged read entrypoint */
     mseg_priv,					/* ON if calling process has privileged access */
     a_own,					/* ON if reading own message (argument) */
     own,						/* ON if reading own message (internal) */
     a_read_access,					/* ON if user has read access to the segment (argument) */
     read_access init ("0"b),				/* ON if user has read access to the segment (internal) */
     last,					/* ON if message is last in segment */
     first,					/* ON if message is first in segment */
     search_sw,					/* ON if message id not found for incremental reading */
     ms_end) bit (1) aligned;				/* ON when end of message is found */

dcl  back_in_bucket_offset bit (18) aligned;		/* offset of message one back in hash bucket */

dcl (tr_offset,					/* offset from beginning of block to trailer */
     ms_count,					/* number of messages in segment */
     a_count,					/* message count (argument) */
     count,					/* message count (internal) */
     prev_offset,					/* offset to previous message */
     next_offset,					/* offset to next message */
     block_size,					/* size of a message block */
     blocks_in_message,				/* number of blocks used for message */
     update_len,					/* size of update message */
     loc,
     bit_off) fixed bin (18);				/* location of allocation bit to be turned off */

dcl (
     copy_size,					/* size of bit copy mask */
     delete_size,					/* bit size of block to be zeroed out */
     a_ms_len,					/* length of message in block trailer */
     ms_len,
     found_ms_len					/* actual message size */
     ) fixed bin (24);

dcl (a_first_or_last,				/* ON if last message wanted (argument) */
     first_or_last) bit (1) aligned;			/* ON if last message wanted (internal) */

dcl (a_dir,					/* direction of incremental search */
     dir init ("00"b)) bit (2) aligned;

dcl (a_ms_id,					/* message ID (argument) */
     ms_id) bit (72) aligned;				/* message ID (internal) */

dcl (authorization,					/* authorization of calling process */
     access_class) bit (72) aligned;			/* access class of message segment */

dcl  privileges bit (36) aligned;			/* privileges of calling process */
dcl 1 based_priv unal based (addr (privileges)) like aim_template.privileges;

dcl (
     alloc_len,					/* length of allocation bit string */
     level,					/* user level: 0 = non-own entry, 1 = own entry (internal) */
     ms_word_len,					/* length of message in words */
     htx,						/* hash table index */
     id_len) fixed bin;				/* length of person-project portion of group id */

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35);

dcl (addr, addrel, bit, divide, fixed, index, length, null, ptr, rel, rtrim, size, substr) builtin;

dcl (
     area,
     cleanup
     ) condition;

dcl  area_array area (30) aligned based (area_ptr),	/* for allocating */
     ms_word_array (ms_word_len) fixed bin aligned based (ret_ptr);

dcl (caller_id,					/* id of caller */
     ms_sender_id) char (32);				/* id of message sender */

dcl  proc_name char (32);				/* procedure name */
dcl  reason char (40);				/* reason why operation failed */

dcl  bit_copy_mask bit (copy_size) based;		/* bit copy mask */

dcl  bits (copy_size) bit (1) based unaligned;		/* for resetting copy-to pointer */

dcl 1 return_args aligned based (arg_ptr),		/* return argument structure */
    2 ms_ptr ptr,					/* pointer to message */
    2 ms_len fixed bin (18),				/* length of message in bits */
    2 sender_id char (32),				/* person-project ID of message sender */
    2 level fixed bin,				/* validation level of sender */
    2 ms_id bit (72),				/* unique ID of message */
    2 sender_authorization bit (72),			/* access authorization of message sender */
    2 access_class bit (72);				/* message access class */

%include mseg_hdr_v4;
declare mptr pointer;

%include ms_block_hdr_v4;

%include ms_block_trailer_v4;

%include aim_template;

dcl  error_table_$bad_segment ext fixed bin (35);
dcl  error_table_$ai_restricted ext fixed bin (35);
dcl  error_table_$moderr fixed binary (35) external;
dcl  error_table_$no_message ext fixed bin (35);
dcl  error_table_$inconsistent ext fixed bin (35);
dcl  error_table_$bigarg ext fixed bin (35);
dcl  error_table_$noalloc ext fixed bin (35);

dcl  get_group_id_$tag_star entry() returns(char(32));
dcl  get_process_authorization_ ext entry returns (bit (72) aligned);
dcl  get_privileges_ ext entry returns (bit (36) aligned);
dcl  hcs_$get_access_class_seg ext entry (ptr, bit (72) aligned, fixed bin (35));
dcl  mseg_error_v4_ entry options (variable);
dcl  read_allowed_ ext entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  read_write_allowed_ ext entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

/*  */
read_priv: entry (a_mptr, a_area_ptr, a_first_or_last, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_v4_$read_priv";
	priv_entry = "1"b;
	go to R_COMMON;

read:	entry (a_mptr, a_area_ptr, a_first_or_last, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_v4_$read";
R_COMMON:	first_or_last = a_first_or_last;
	area_ptr = a_area_ptr;
	read = "1"b;
	go to COMMON;

delete:	entry (a_mptr, a_ms_id, a_own, a_read_access, a_code);

	proc_name = "mseg_util_v4_$delete";
	ms_id = a_ms_id;
	delete = "1"b;
	read_access = a_read_access;
	go to COMMON;

read_and_delete: entry (a_mptr, a_area_ptr, a_first_or_last, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_v4_$read_and_delete";
	first_or_last = a_first_or_last;
	area_ptr = a_area_ptr;
	read, delete = "1"b;
	go to COMMON;

incremental_read_priv: entry (a_mptr, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_v4_$incremental_read_priv";
	priv_entry = "1"b;
	go to IR_COMMON;

incremental_read: entry (a_mptr, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_own, a_code);

	proc_name = "mseg_util_v4_$incremental_read";
IR_COMMON: ms_id = a_ms_id;
	dir = a_dir;
	if dir = "11"b then do;			/* undefined */
	     code = error_table_$inconsistent;
	     go to FIN;
	end;
	area_ptr = a_area_ptr;
	incr_read = "1"b;
	go to COMMON;


update:	entry (a_mptr, a_ms_ptr, a_ms_len, a_ms_id, a_own, a_read_access, a_code);

	proc_name = "mseg_util_v4_$update";
	update = "1"b;
	ms_id = a_ms_id;
	read_access = a_read_access;
	go to COMMON;

get_count: entry (a_mptr, a_count, a_code);

	proc_name = "mseg_util_v4_$get_count";
	get_count = "1"b;
	own = "0"b;
	go to COMMON2;

/*  */

COMMON:
	own = a_own;

COMMON2:
	mptr = a_mptr;
	code = 0;
	search_sw = "0"b;

	ms_count =				/* get number of messages */
	     fixed (mptr -> mseg_hdr_v4.number_of_messages, 18);

	block_size = fixed (mptr -> mseg_hdr_v4.block_size, 18);	/* pick out block size from header */

	tr_offset = block_size - size (ms_block_trailer); /* calculate trailer offset */

/* See if first or last message wanted */

	if get_count then go to COUNT;		/* start counting with first message */

	if read then do;				/* read first or last message */
	     if first_or_last = "1"b			/* last message wanted */
	     then do;
		dir = "10"b;			/* prepare to scan backward */
LAST:		loc = fixed (mptr -> mseg_hdr_v4.last_ms_offset, 18); /* get offset of last message */
	     end;

	     else do;				/* first message wanted */
COUNT:		dir = "01"b;			/* prepare to scan forward */
FIRST:		loc = fixed (mptr -> mseg_hdr_v4.first_ms_offset, 18); /* get offset of first message */
	     end;
	     if delete then do;
		ms_ptr = ptr (mptr, loc);
		tr_ptr = addrel (ms_ptr, tr_offset);
		ms_id = tr_ptr -> ms_block_trailer.ms_id;
		go to THREAD;
	     end;
	end;

/* look up message ID in hash table */

	else do;					/* for incr read, update ; delete */
THREAD:	     htx = fixed (substr (ms_id, 64, 9));	/* hash table index = low 9 bits of message ID */
	     loc = fixed (mptr -> mseg_hdr_v4.hash_table.last_in_bucket (htx), 18); /* get loc of last message in bucket */
	     prev_in_bucket_ptr = null;		/* no previous message yet */

	     do while (loc ^= 0);			/* search bucket for matching message ID */
		ms_ptr = ptr (mptr, loc);		/* get ptr to first block of message */
		if ^ms_ptr -> ms_block_hdr.first_block	/* check if really first block */
		then do;
		     reason = "not first block in hash lookup";
		     go to BAD_SEG;
		end;
		tr_ptr = addrel (ms_ptr, tr_offset);	/* get trailer ptr */
		if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* check pattern */
		then do;
		     reason = "bad trailer pattern in hash lookup";
		     go to BAD_SEG;
		end;
		if tr_ptr -> ms_block_trailer.ms_id = ms_id /* found it */
		then go to FOUND_ID;
		prev_in_bucket_ptr = tr_ptr;		/* remember ptr to this message */
		loc = fixed (tr_ptr -> ms_block_trailer.back_in_bucket, 18); /* go back one in bucket */
	     end;

	     if incr_read then
		if dir ^= "00"b then do;		/* forward or backward incr read */
		     search_sw = "1"b;		/* search for next message even though this message is gone */
		     if dir = "10"b then go to LAST;	/* search for largest message id < ms_id */
		     else go to FIRST;		/* search for smallest message id > ms_id */
		end;

	     go to NO_MSG;				/* bucket exhausted */
FOUND_ID:
	end;


/* prepare to check access */

	authorization = get_process_authorization_ ();	/* get caller's authorization */
	privileges = get_privileges_ ();		/* get caller's privileges */
	mseg_priv = based_priv.ring1 | priv_entry;	/* get ring 1 privilege flag */
	if own					/* caller can only reference his own message */
	then do;
	     caller_id = get_group_id_$tag_star ();	/* get caller's group id */
	     if substr (caller_id, 1, 10) = "anonymous." then
		id_len = length (rtrim (caller_id)) - 1;	/* ignore .* tag for anonymous */
	     else id_len = index (caller_id, ".");		/* others: compare only Person_id */
	end;

/* get_count */

	if get_count
	then do;
	     if mseg_priv				/* caller has privileged access */
	     then do;
FULL_COUNT:	a_count = ms_count;			/* return full count */
		go to FIN;
	     end;
	     call hcs_$get_access_class_seg (mptr, access_class, code); /* get message seg access class */
	     if code ^= 0 then go to FIN;
	     if read_allowed_ (authorization, access_class) /* caller is authorized to see all messages */
	     then go to FULL_COUNT;			/* return full count */
	     count = 0;				/* initialize count */
	     go to READ;				/* get count of read-accessible messages */
	end;

/* incremental read */

	else if search_sw then go to READ;
	else if incr_read
	then do;
	     if own				/* must be caller's own message */
	     then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		then go to NO_MSG;			/* pretend it doesn't exist */
	     if ^mseg_priv				/* no special access privilege */
	     then if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read permit */
		then go to NO_MSG;			/* pretend it doesn't exist */

	     if dir = "10"b				/* previous message wanted */
	     then do;				/* increment message pointer */
		if tr_ptr -> ms_block_trailer.b_offset = "0"b
		then do;				/* error, no previous message */
		     if fixed (mptr -> mseg_hdr_v4.first_ms_offset, 18) ^= loc
		     then do;
			reason = "bad first offset";
			go to BAD_SEG;
		     end;
NO_MSG:		     code = error_table_$no_message;
		     go to FIN;
		end;
		loc = fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
		go to READ;
	     end;

	     else if dir = "01"b			/* next message wanted */
	     then do;				/* increment message pointer */
		if tr_ptr -> ms_block_trailer.f_offset = "0"b
		then do;				/* error, no next message */
		     if fixed (mptr -> mseg_hdr_v4.last_ms_offset, 18) ^= loc
		     then do;
			reason = "bad last offset";
			go to BAD_SEG;
		     end;
		     go to NO_MSG;
		end;
		loc = fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
		go to READ;
	     end;

	end;

/* read */

	else if read
	then do;
READ:	     do while (loc ^= 0);			/* scan for read-accessible message */
		ms_ptr = ptr (mptr, loc);		/* get ptr to first block of message */
		if ^ms_ptr -> ms_block_hdr.first_block	/* check if really first block */
		then do;
		     reason = "not first block";
		     go to BAD_SEG;
		end;
		tr_ptr = addrel (ms_ptr, tr_offset);	/* get trailer ptr */
		if tr_ptr -> ms_block_trailer.tr_pattern ^= trailer_pattern /* check pattern */
		then do;
		     reason = "bad trailer pattern";
		     go to BAD_SEG;
		end;
		if own				/* must be caller's own message */
		then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		     then go to NEXT;		/* skip it */
		if ^mseg_priv			/* no special access privileges */
		then do;
		     if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read permit */
		     then go to NEXT;		/* skip over this one */
		     if delete			/* read and delete requested */
		     then if ^read_write_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class)
			then go to AI_ERR;		/* cannot delete this message */
		end;
		if get_count			/* get_count entry */
		then count = count + 1;		/* increment count of read-accessible messages */
		else if search_sw
		then if dir = "01"b
		     then if substr (tr_ptr -> ms_block_trailer.ms_id, 19, 54) > substr (ms_id, 19, 54)
			then go to EXIT;		/* found the one we're searching for */
			else go to NEXT;
		     else if substr (tr_ptr -> ms_block_trailer.ms_id, 19, 54) < substr (ms_id, 19, 54)
		     then go to EXIT;		/* found it */
		     else go to NEXT;
		else go to EXIT;			/* found a message to read, exit loop */
NEXT:
		if dir = "01"b			/* scanning forward */
		then loc = fixed (tr_ptr -> ms_block_trailer.f_offset, 18); /* get loc of next message */
		else loc = fixed (tr_ptr -> ms_block_trailer.b_offset, 18); /* get loc of previous message */
	     end;

	     if get_count				/* we're finished counting */
	     then do;
		a_count = count;
		go to FIN;
	     end;
	     go to NO_MSG;				/* couldn't find anything to read */
EXIT:	end;

/* update or delete */

	else if update | delete
	then do;
	     if own				/* must be caller's own message */
	     then if substr (ms_block_trailer.sender_id, 1, id_len) ^= substr (caller_id, 1, id_len) /* not his own */
		then if read_access then do;		/* caller is allowed to know the message is present */
		     code = error_table_$moderr;
		     go to FIN;
		end;
		else go to NO_MSG;			/* pretend it doesn't exist */
	     if ^mseg_priv				/* no special access privilege */
	     then if ^read_write_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* no read-write permit */
		then if ^read_allowed_ (authorization, tr_ptr -> ms_block_trailer.access_class) /* not even read permit */
		     then go to NO_MSG;		/* pretend it doesn't exist */
		     else do;			/* caller has read permit, but not modify */
AI_ERR:			code = error_table_$ai_restricted;
			go to FIN;
		     end;
	end;

/* prepare to perform requested operation */

	ms_len = fixed (ms_block_trailer.ms_size, 24);	/* pick out message size */

	if update
	then do;
	     update_len = a_ms_len;
	     if update_len > ms_len			/* incorrect message size specified */
	     then do;
		code = error_table_$bigarg;		/* user message too big */
		go to FIN;
	     end;
	     t_ptr = a_ms_ptr;			/* initialize copy ptr */
	end;

	if delete
	then do;

	     if fixed (mptr -> mseg_hdr_v4.first_ms_offset, 18) = loc /* first message */
	     then first = "1"b;			/* set flag to remember */
	     else first = "0"b;
	     if fixed (mptr -> mseg_hdr_v4.last_ms_offset, 18) = loc /* last message */
	     then last = "1"b;			/* set flag to remember */
	     else last = "0"b;

	     if (^first)
	     then do;				/* not first message */
		prev_offset =			/* get offset to previous message */
		     fixed (tr_ptr -> ms_block_trailer.b_offset, 18);
		prev_tr_ptr =			/* make pointer to previous trailer */
		     ptr (mptr, prev_offset+tr_offset);
	     end;

	     if (^last)
	     then do;				/* not last message */
		next_offset =			/* get offset to next message */
		     fixed (tr_ptr -> ms_block_trailer.f_offset, 18);
		next_tr_ptr =			/* make pointer to next trailer */
		     ptr (mptr, next_offset+tr_offset);
	     end;

	     back_in_bucket_offset = tr_ptr -> ms_block_trailer.back_in_bucket;

	     delete_size = block_size * 36;		/* the block size in bits */
	     alloc_len = mptr -> mseg_hdr_v4.alloc_len;	/* a local copy of the number of allocation bits */

	end;

	if read | incr_read
	then do;
	     ms_sender_id = tr_ptr -> ms_block_trailer.sender_id; /* pick out senders' id */
	     level = fixed (ms_block_trailer.ring_no, 17); /* pick out validation level */
	     ms_id = tr_ptr -> ms_block_trailer.ms_id;	/* pick out message id */
	     authorization = tr_ptr -> ms_block_trailer.sender_authorization; /* pick out sender authorization */
	     access_class = tr_ptr -> ms_block_trailer.access_class; /* pick out message access class */

/* allocate an area for the returned message */

	     on cleanup begin;			/* establish cleanup handler to free allocated message */
		if ret_ptr ^= null			/* a message was allocated */
		then do;
		     free ms_word_array in (area_array); /* free it */
		     a_arg_ptr -> return_args.ms_ptr = null; /* and return null argument ptr */
		end;
	     end;

	     on area begin;
		code = error_table_$noalloc;
		go to FIN;
	     end;

	     ms_word_len = divide (ms_len+35, 36, 17, 0); /* compute word length from bit count */
	     allocate ms_word_array in (area_array) set (ret_ptr); /* allocate the area */
	     t_ptr = ret_ptr;			/* initialize scan pointer */
	end;

/*  */
/* chase the message thread */

	found_ms_len = 0;				/* initialize size of found message */

	blocks_in_message = 0;			/* initialize count */
	block_ptr = ms_ptr;				/* initialize block pointer */
	ms_end = "0"b;				/* initialize end of message flag */

	if delete					/* user is deleting a message */
	then mptr -> mseg_hdr_v4.mip = "1"b;			/* turn on mip bit */

	do while (^ms_end);

	     blocks_in_message =			/* increment message block count */
		blocks_in_message + 1;

	     found_ms_len = found_ms_len + fixed (ms_block_hdr.block_count, 24); /* increment message size */
	     if found_ms_len > ms_len			/* more message than block trailer specified */
	     then do;				/* error in message segment */
		reason = "message too long";
		go to BAD_SEG;
	     end;


	     if (read | incr_read | update)
	     then do;				/* return message for reading */
		copy_size =			/* set size of copy mask */
		     fixed (block_ptr -> ms_block_hdr.block_count, 24);
		if update then do;			/* updating message */
		     if found_ms_len > update_len then do; /* update only part of this block */
			copy_size = copy_size - (found_ms_len - update_len);
			ms_end = "1"b;
		     end;
		     addrel (block_ptr, size (ms_block_hdr)) -> bit_copy_mask
			= t_ptr -> bit_copy_mask;	/* overwrite */
		end;
		else				/* reading message */
		t_ptr -> bit_copy_mask =		/* copy message */
		     addrel (block_ptr, size (ms_block_hdr)) -> bit_copy_mask;
		t_ptr = addr (t_ptr -> bits (copy_size + 1)); /* increment copy ptr */
	     end;

	     if (delete)
	     then do;				/* user is deleting a message */
		bit_off = divide (fixed (rel (block_ptr), 18), block_size, 18, 0)+1; /* calculate alloc bit for block */
		if substr (mptr -> mseg_hdr_v4.alloc_bits, bit_off, 1) = "0"b /* block not in use */
		then do;
		     reason = "unprotected block";
		     go to BAD_SEG;
		end;
		else
		substr (mptr -> mseg_hdr_v4.alloc_bits, bit_off, 1) = "0"b; /* turn bit off */
		deletep = block_ptr;		/* remember block ptr to delete later */
	     end;

	     if ^ms_end then
		if block_ptr -> ms_block_hdr.f_offset = "0"b
		then do;				/* message block is last in message */
		     if found_ms_len ^= ms_len	/* found size doesn't agree with trailer */
		     then do;
			reason = "bad message length";
			go to BAD_SEG;
		     end;
		     else
		     ms_end = "1"b;			/* indicate end of message */
		end;

		else do;
		     block_ptr =			/* step the block pointer */
			ptr (block_ptr, fixed (block_ptr -> ms_block_hdr.f_offset, 18));
		end;

	     if (delete)				/* message is being deleted */
	     then do;
		copy_size = delete_size;		/* set size of copy mask */
		deletep -> bit_copy_mask = "0"b;	/* use mask to zero out block */
	     end;

	end;

/*  */
/* finish deleting message if requested */

	if (delete) then do;

	     if ms_count > 1			/* there will be a remaining message */
	     then do;

/* unthread the message */

		if (first) then do;			/* unthread first message */
		     mptr -> mseg_hdr_v4.first_ms_offset =
			bit (fixed (next_offset, 18), 18); /* reset header offset to new first message */
		     next_tr_ptr -> ms_block_trailer.b_offset =
			"0"b;			/* reset new first message back pointer */
		end;

		if (last) then do;			/* unthread last message */
		     mptr -> mseg_hdr_v4.last_ms_offset =
			bit (fixed (prev_offset, 18), 18); /* reset header offset to new last message */
		     prev_tr_ptr -> ms_block_trailer.f_offset =
			"0"b;			/* reset new last message forward pointer */
		end;

		if (^first) then if (^last) then do;	/* unthread mid message */
			prev_tr_ptr -> ms_block_trailer.f_offset =
			     bit (fixed (next_offset, 18), 18); /* reset forward offset of previous message */
			next_tr_ptr -> ms_block_trailer.b_offset =
			     bit (fixed (prev_offset, 18), 18); /* reset backward offset of next message */
		     end;

	     end;

	     else					/* no messages left */
	     mptr -> mseg_hdr_v4.first_ms_offset,		/* zero out hdr pointers */
		mptr -> mseg_hdr_v4.last_ms_offset = "0"b;

/* rethread the hash bucket */
	     if prev_in_bucket_ptr = null then
		mptr -> mseg_hdr_v4.hash_table.last_in_bucket (htx) = back_in_bucket_offset;
	     else prev_in_bucket_ptr -> ms_block_trailer.back_in_bucket = back_in_bucket_offset;

/* update header after deletion */

	     mptr -> mseg_hdr_v4.space_left =		/* reset space left */
		mptr -> mseg_hdr_v4.space_left + blocks_in_message;

	     ms_count = ms_count - 1;
	     mptr -> mseg_hdr_v4.number_of_messages =	/* reset number of messages */
		fixed (ms_count);

	     mptr -> mseg_hdr_v4.mip = "0"b;		/* turn off modification in progress bit */

	end;

	if read | incr_read
	then do;					/* fill in return argument structure */
	     arg_ptr = a_arg_ptr;			/* copy ptr to return_args structure */
	     return_args.ms_ptr = ret_ptr;		/* ptr to message */
	     return_args.ms_len = ms_len;		/* length of message */
	     return_args.sender_id = ms_sender_id;	/* person-project ID of message sender */
	     return_args.level = level;		/* validation level of message sender */
	     return_args.ms_id = ms_id;		/* message ID */
	     return_args.sender_authorization = authorization; /* authorization of message sender */
	     return_args.access_class = access_class;	/* access class of message */
	end;

FIN:

	a_code = code;
	return;

BAD_SEG:
	call mseg_error_v4_ (mptr, 0, proc_name, reason);
	code = error_table_$bad_segment;
	go to FIN;


     end mseg_util_v4_;




		    ptr_is_good_v2_.pl1             05/10/85  0857.4r w 05/06/85  1619.0       28818



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

ptr_is_good_v2_ : proc (a_test_ptr) returns (bit (1) aligned);

/* Adapted from the original version 2 ptr_is_good_ by J. Stern, 11/4/74 */

dcl (alloc_len internal static,			/* length of allocation bits */
     a_block_size,					/* given block size for salvager entry */
     block_size,					/* size of message block */
     hdr_alloc_len,					/* length of header allocation bits */
     i,						/* computation variable */
     message_begin,					/* first legal beginning loc for message */
     offset,					/* offset of given pointer */
     seg_size internal static) fixed bin (18);

dcl  code fixed bin (35);

dcl (a_test_ptr,					/* pointer to be validated (argument) */
     test_ptr) ptr;					/* pointer to be validated (internal) */

dcl (
     a_flag,					/* ON if pointer is valid (argument) */
     flag init ("0"b),
     salvager_entry init ("0"b)
     ) bit (1) aligned;				/* ON if pointer is valid (internal) */

dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35));

dcl (addr, divide, fixed, mod, ptr, rel) builtin;

% include mseg_hdr_v2;

/*  */


	go to COMMON;

ms_salvager_entry: entry (a_test_ptr, a_block_size) returns (bit (1) aligned);

	salvager_entry = "1"b;

COMMON:	

/* copy argument */

	test_ptr = a_test_ptr;

/* create offset from pointer */

	offset = fixed (rel (test_ptr), 18);

/* create message segment ptr */

	mptr = ptr (test_ptr, 0);

	if salvager_entry				/* get proper block size */
	then block_size = a_block_size;
	else
	block_size = mptr -> mseg_hdr_v2.block_size;

/* check block size, compute needed variables */

	if block_size <= 0
	then go to fin;

	call hcs_$get_max_length_seg (mptr, seg_size, code);
	if code ^= 0 then go to fin;
	alloc_len = divide (seg_size, block_size, 18, 0);

	i = divide (36* (fixed (rel (addr (mptr -> mseg_hdr_v2.hdr_ms_end)), 18) + 1)+alloc_len+35, 36, 18, 0);
	hdr_alloc_len = divide (i+block_size-1, block_size, 18, 0);

	message_begin = fixed (rel (addr (mptr -> mseg_hdr_v2.hdr_ms.hdr_ms_end)))+hdr_alloc_len+1;

/* validate message pointer */

	if offset >= message_begin			/* pointer is past header */
	then if offset <= seg_size - block_size		/* pointer is not off end of segment */
	then if mod (offset, block_size) = 0		/* pointer points to block boundary */
	then flag = "1"b;				/* pointer is o.k. */

fin:	a_flag = flag;				/* return test indicator */
	return (a_flag);

     end ptr_is_good_v2_;





		    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
