



		    mrds_builtin_.pl1               04/18/85  1429.4re  04/18/85  0906.3      386163



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

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

mrds_builtin_:
     proc;

/* DESCRIPTION:

   This  procedure  contains  entries  to  implement all MRDS and LINUS scalar
   builtin  functions.   No error codes are returned from this modules but two
   kinds  of  conditions  call  be  signaled  function_err and fatal_func_err.
   function_err  is  signaled  when  a  stringsize  condition  is  encountered
   fatal_func_err is signaled for all other errors detected.



   HISTORY:

   77-06-01 J. A. Weeldreyer: Initially written.

   77-07-01 R.  D.  Lackey: Modified to complete implemetation of mrds builtin
   functions.

   77-12-01 R. D. Lackey: Modified to correct round builtin.

   78-03-01 R. D. Lackey: Modified to correct size in concat descriptor.

   78-04-01 R. D. Lackey: Modified to add fatal_func_err condition.

   79-12-13  Davids:  Modified  rnd  to  take log10 (abs (in_val)) rather then
   log10 (in_val) in_val = 0 is a special case and returns 0.

   79-12-20  Davids:  Modified  value  of  CHAR_VAR_DESC  so  that it shows an
   unpacked  varying  char  desc.   Modified value of BIT_VAR_DESC so that its
   unpacked and really varying.

   79-12-21 Davids: Took the condition handling out of the substr function and
   explicitly  check for those things that can cause the stringrange condition
   to  be  signaled.   Also  modified the assignment of the lengths of varying
   character  and  bit  strings  in canon_bit and canon_char to use the actual
   length  not  the  declared  length.  The length of the return string in the
   reverse  function  is now taken from the descriptor pointed to by the third
   pointer in arg_list rather than the first.

   79-12-26  Davids: Modified canon_char so that the internal pointer pointing
   at a bit varying data type points to the length word.

   79-12-27 Davids: bnv in canon_bit is now based on a_ptr rather than b_ptr.

   80-01-01  Jim Gray : Modified to add calls to mu_data_class$xxxx_data_class
   so  that  packed  decimal  data types could be handled.  Also the structure
   rslt_cfld_59  had its float decimal(59) members changed to aligned, so that
   it  looks like a complex float decimal(59) aligned, which the new unaligned
   decimal would not imitate.

   80-01-07  Rickie  E.  Brinegar: Modified to make substr check of descriptor
   class types work properly.

   80-02-01 Jim Gray : Modified to make use of extensible non-freeing area for
   temp storage rather than system_free.

   81-08-14  Roger Lackey : Removed init and tidy_up internal procedures and
   replaced allocation in connoize procedures to use automatice variables for
   buffering instead of allocation.

   81-09-21 Davids: added a line of code to  all  entries  that  use
   arg_list to set the value of num_ptrs to prevent a subscriptrange
   condition from occuring.

   81-09-23 Davids: modified substr so that if the requested  length
   of  the  substring  would cause a reference beyond the end of the
   original string, the length of the substring returned is  shorted
   so  that  it  references  up  to  the last character (bit) of the
   original string.

   81-09-24 Davids: Removed all references to the variables  t1  and
   t2. These variables were being set but never referenced. It looks
   like a past change removed their usefullness but  they  were  not
   removed  at that time. Since they were declared fixed bin (5) and
   they were being set to the descriptor type which is fixed bin (6)
   unsigned  a size condition was possible and in fact was occurring
   in floor_info when used with a data type of  real  float  decimal
   unaligned.
*/

	return;					/* should never use mrds_builtin_ entry */

abs:
     entry;

/* This entry impliments the MRDS/LINUS "abs" builtin function.
   This is an arithmetic function, so only an arithmetic argument is accepted.
   If the argument is non-complex the input value is converted to float decimal (59)
   prior to calling the abs builtin function.
   The returned result is float decimal (59).
   The PL/I "abs" builtin is used to actually perform the function. */

	on size call fatal_func_error;
	on conversion call fatal_func_error;

/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	num_ptrs = 0;				/* to aviod a compiler warning */

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* Get the argument list pointer */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (2);		/* Points to place to store result */

	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (1),
	     arg_list.arg_des_ptr (3), fld_val_1);	/* Convert to
						   float decimal (59) */
(size, conversion):
	rslt_fld_59 = abs (fld_val_1);

	return;					/* End of abs entry */



abs_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "abs" builtin */
/* rslt_desc = 0 or float decimal (59) */

	if arg_descs.ndescs ^= 1 then
	     rslt_desc = "0"b;			/* Must have only one arg */

	else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1)))
	then rslt_desc = FLD59_DESC;

	else rslt_desc = "0"b;

	return;					/* End of abs info entry */

after:
     entry;

/* This entry implements the MRDS/LINUS "after" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.  If there is a
   mixture of character and bit arguments, an attempt is made to convert the bit
   argument to a character string.  The PL/I "after" builtin is used to actualy perform
   the function.  Returned result is either a bit or char varying string. */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = addrel (arg_list.arg_des_ptr (3), -1);	/* point to place to store result */

	r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 24);
						/* Max length of return string
						   can be no longer then length of input string (arg (1)) */

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4))
	     & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do;
						/* will canonize to bit var */
		call canon_bit (1, a1_ptr, a1_len);
		call canon_bit (2, a2_ptr, a2_len);
		rslt_bit_string = after (b1, b2);	/* do bit string after */
	     end;
	else do;					/* canonize to char. var. */
		call canon_char (1, a1_ptr, a1_len);
		call canon_char (2, a2_ptr, a2_len);
		rslt_char_string = after (c1, c2);	/* Do char string after */
	     end;



	return;					/* End of after entry */

after_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "after" builtin */
/* rslt_desc = 0   or BIT_VAR_DESC  or  CHAR_VAR_DESC */

	rslt_desc = arg_descs.desc (1);		/* Init to non-zero value */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* Exactly 2 arguments required */

	else /* Check for string args */
	     if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$string_data_class (addr (arg_descs.desc (2))))
	then rslt_desc = "0"b;

	if rslt_desc ^= "0"b then do;			/* Everything OK so set rslt_desc */

		rslt_desc = "0"b;			/* Zero all the bits in the rslt_desc */

		if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */
		     addr (arg_descs.desc (2)) -> descriptor.type then do;
			if addr (arg_descs.desc (1)) -> descriptor.type < 21 then
			     rslt_desc = BIT_VAR_DESC;/* Bit varying */
			else rslt_desc = CHAR_VAR_DESC; /* Char varying */
		     end;

		else /* String types are different */
		     rslt_desc = CHAR_VAR_DESC;	/* So make it char varying */

		addr (rslt_desc) -> descriptor.size =
		     addr (arg_descs.desc (1)) -> descriptor.size; /* Size can be no larger
						   then that of the input string */

	     end;

	return;					/*  End of after_info entry */

before:
     entry;

/* This entry implements the MRDS/LINUS "before" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.  If there is a
   mixture of character and bit arguments, an attempt is made to convert the bit
   argument to a character string.  The PL/I "before" builtin is used to actualy perform
   the function.  Returned result is either a bit or char varying string. */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = addrel (arg_list.arg_des_ptr (3), -1);	/* point to place to store result */

	r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 24);
						/* Max length of return string
						   can be no longer then length of input string (arg (1)) */

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4))
	     & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do;
						/* will canonize to bit var */
		call canon_bit (1, a1_ptr, a1_len);
		call canon_bit (2, a2_ptr, a2_len);
		rslt_bit_string = before (b1, b2);	/* do bit string before */
	     end;
	else do;					/* canonize to char. var. */
		call canon_char (1, a1_ptr, a1_len);
		call canon_char (2, a2_ptr, a2_len);
		rslt_char_string = before (c1, c2);	/* Do char string before */
	     end;


	return;					/* End of before entry */

before_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "before" builtin */
/* rslt_desc = 0  or  BIT_VAR_DESC  or  CHAR_VAR_DESC */

	rslt_desc = arg_descs.desc (1);		/* Init to non-zero value */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* Exactly 2 arguments required */

	else /* Check for string args */
	     if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$string_data_class (addr (arg_descs.desc (2))))
	then rslt_desc = "0"b;

	if rslt_desc ^= "0"b then do;			/* Everything OK so set rslt_desc */

		rslt_desc = "0"b;			/* Zero all the bits in the rslt_desc */

		if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */
		     addr (arg_descs.desc (2)) -> descriptor.type then do;

			if addr (arg_descs.desc (1)) -> descriptor.type < 21 then
			     rslt_desc = BIT_VAR_DESC;/* Bit varying */
			else rslt_desc = CHAR_VAR_DESC; /* Char varying */
		     end;

		else /* String types are different */
		     rslt_desc = CHAR_VAR_DESC;	/* So make it char varying */

		addr (rslt_desc) -> descriptor.size =
		     addr (arg_descs.desc (1)) -> descriptor.size; /* Size can be no larger
						   then that of the input string */

	     end;

	return;					/*  End of before_info entry */

ceil:
     entry;

/* This entry impliments the MRDS/LINUS "ceil" builtin function.
   This is an arithmetic function, so only an arithmetic argument is accepted.
   The argument is converted to float decimal (59)  prior to calling the ceil builtin function.
   The returned result is float decimal (59).
   The PL/i "ceil" builtin is used to actually perform the function. */

	on size call fatal_func_error;
	on conversion call fatal_func_error;
	call cu_$arg_list_ptr (al_ptr);		/* Get the argument list pointer */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (2);		/* Points to place to store result */

	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (1),
	     arg_list.arg_des_ptr (3), fld_val_1);	/* Convert to
						   float decimal (59) */
(size, conversion):
	rslt_fld_59 = ceil (fld_val_1);

	return;					/* End of ceil entry */



ceil_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "ceil" builtin */
/* rslt_desc = 0 or float decimal (59) */

	if arg_descs.ndescs ^= 1 then
	     rslt_desc = "0"b;			/* Must have only one arg */

	else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1)))
	then rslt_desc = FLD59_DESC;

	else rslt_desc = "0"b;

	return;					/* End of ceil info entry */

concat:
     entry;

/* This entry implements the MRDS/LINUS "concat" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.  If there is a
   mixture of character and bit arguments, an attempt is made to convert the bit
   argument to a character string.    Returned result is either a bit or char varying string. */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = addrel (arg_list.arg_des_ptr (3), -1);	/* point to place to store result */

	r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 26);
						/* Max length of return string */

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4))
	     & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do;
						/* will canonize to bit var */
		call canon_bit (1, a1_ptr, a1_len);
		call canon_bit (2, a2_ptr, a2_len);
		rslt_bit_string = b1 || b2;		/* do bit string concatination */
	     end;
	else do;					/* canonize to char. var. */
		call canon_char (1, a1_ptr, a1_len);
		call canon_char (2, a2_ptr, a2_len);
		rslt_char_string = c1 || c2;		/* Do char string concat */
	     end;


	return;					/* End of concat entry */


concat_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "concat" builtin */
/* rslt_desc = 0  or BIT_VAR_DESC  or  CHAR_VAR_DESC */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* Must have exactly two args */

	else /* Check for string args */
	     if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$string_data_class (addr (arg_descs.desc (2))))
	then rslt_desc = "0"b;

	else do;					/* If everything OK then build the descriptor */

		rslt_desc = "0"b;

		if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */
		     addr (arg_descs.desc (2)) -> descriptor.type then do;
			if addr (arg_descs.desc (1)) -> descriptor.type < 21 then
			     rslt_desc = BIT_VAR_DESC;/* Bit varying */
			else rslt_desc = CHAR_VAR_DESC; /* Char varying */
		     end;

		else /* String types are different */
		     rslt_desc = CHAR_VAR_DESC;	/* So make it char varying */


		s1 = fixed (string (addr (arg_descs.desc (1)) -> descriptor.size), 24);
		s2 = fixed (string (addr (arg_descs.desc (2)) -> descriptor.size), 24);

		desc_ptr = addr (rslt_desc);
		n = s1 + s2;			/* Max size = sum tow input sizes */
		string (descriptor.size) = bit (n);	/* New size = sum of two input sizes */

	     end;

	return;					/* End of concat_info entry */


floor:
     entry;

/* This entry impliments the MRDS/LINUS "floor" builtin function.
   This is an arithmetic function, only an arithmetic non-complex argument is accepted.
   The argument is converted to float decimal (59) prior to calling the floor builtin function.
   The returned result is a float decimal (59).
   The PL/I "floor" builtin is used to actually perform the function. */

	on size call fatal_func_error;
	on conversion call fatal_func_error;

	call cu_$arg_list_ptr (al_ptr);		/* Get the argument list pointer */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (2);		/* Points to place to store result */

	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (1),
	     arg_list.arg_des_ptr (3), fld_val_1);	/* Convert to
						   float decimal (59) */
(size, conversion):
	rslt_fld_59 = floor (fld_val_1);		/* Find the floor */

	return;					/* End of floor entry */



floor_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "floor" builtin */
/* rslt_desc = 0 or float decimal (59) */

	if arg_descs.ndescs ^= 1 then
	     rslt_desc = "0"b;			/* Must have only one arg */

	else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1)))
	then rslt_desc = FLD59_DESC;

	else rslt_desc = "0"b;

	return;					/* End of floor info entry */

index:
     entry;

/* This entry implements the MRDS/LINUS "index" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.  If there is a
   mixture of character and bit arguments, an attempt is made to convert the bit
   argument to a character string.  The PL/I "index" builtin is used to actualy perform
   the function.  Returned result is a fixed bin (24). */


	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (3);		/* point to place to store result */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4))
	     & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do;
						/* will canonize to bit var */
		call canon_bit (1, a1_ptr, a1_len);
		call canon_bit (2, a2_ptr, a2_len);
		rslt_bin = index (b1, b2);		/* do bit string index */
	     end;
	else do;					/* canonize to char. var. */
		call canon_char (1, a1_ptr, a1_len);
		call canon_char (2, a2_ptr, a2_len);
		rslt_bin = index (c1, c2);		/* Do char string index */
	     end;


	return;					/* end of index */





index_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "index" builtin */
/* rslt_desc = 0  or  FIXED_BIN_24 */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* need exactly 2 args */
	else /* check for string args */
	     if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$string_data_class (addr (arg_descs.desc (2))))
	then rslt_desc = "0"b;
	else rslt_desc = FIB24_DESC;			/* have 2 string args */

	return;					/* end of index info entry */

mod:
     entry;

/* This entry implements the MRDS/LINUS "mod" builtin function.
   This is an arithmetic function, so only arithmetic arguments are allowed.
   The input arguments are converted to float decimal (59) and the
   returned result is a float decimal (59).
   The PL/I "mod" builtin is used to actually perform the function. */

	on size call fatal_func_error;
	on conversion call fatal_func_error;

	call cu_$arg_list_ptr (al_ptr);		/* Get the argument list pointer */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (3);		/* Points to the place to store result */

	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (1),
	     arg_list.arg_des_ptr (4), fld_val_1);	/* Convert to
						   float decimal (59) */
	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (2),
	     arg_list.arg_des_ptr (5), fld_val_2);	/*  Convert second arg
						   to float decimal (59) */
(size, conversion):
	rslt_fld_59 = mod (fld_val_1, fld_val_2);	/* Do the mod function */

	return;					/* End of mod entry */



mod_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "mod" builtin
   rslt_desc = 0 or float_decimal (59) */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* Must have only two args */

	else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$convertible_data_class (addr (arg_descs.desc (2)))
						/* If both args can be converted */
	then rslt_desc = FLD59_DESC;

	else rslt_desc = "0"b;

	return;					/* End of mod_info entry */

reverse:
     entry;

/* This entry implements the MRDS/LINUS "reverse" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.
   The PL/I "reverse" builtin is used to actualy perform
   the function.  Returned result is a bit or char varying string. */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = addrel (arg_list.arg_des_ptr (2), -1);	/* point to place to store result */

	r_len = fixed (string (arg_list.arg_des_ptr (3) -> descriptor.size), 24);
						/* Max length of return string
						   can be no larger then input string */

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (3)) then do;
						/* String type is bit */
		call canon_bit (1, a1_ptr, a1_len);
		rslt_bit_string = reverse (b1);	/* do bit string reverse */
	     end;
	else do;					/* canonize to char. var. */
		call canon_char (1, a1_ptr, a1_len);
		rslt_char_string = reverse (c1);	/* Do char string reverse */
	     end;


	return;					/* End of reverse */




reverse_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "reverse" builtin */

	if arg_descs.ndescs ^= 1 then
	     rslt_desc = "0"b;			/* Can only accept one arg */

	else if ^mu_data_class$string_data_class (addr (arg_descs.desc (1))) then
	     rslt_desc = "0"b;			/* Got to be a
						   string of some kind */

	else do;					/* If everything OK then build the rslt desc */

		rslt_desc = "0"b;			/* Start with it all zeros */

		if addr (arg_descs.desc (1)) -> descriptor.type < 21 then
		     rslt_desc = BIT_VAR_DESC;	/* Bit varying */
		else rslt_desc = CHAR_VAR_DESC;	/* Char varying */

		addr (rslt_desc) -> descriptor.size =
		     addr (arg_descs.desc (1)) -> descriptor.size; /* size = input size */

	     end;

	return;					/* End of reverse_info entry */

round:
     entry;

/* This entry implements the MRDS/LINUS "round" builtin function.
   This is an arithmetic function so only arithmentic arguments are accepted.
   The input value is canonized to a float decimal (59) before rounding and the returned
   value is a float decimal (59). */

	on size call fatal_func_error;
	on conversion call fatal_func_error;

	call cu_$arg_list_ptr (al_ptr);
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (3);		/* Place to store result */

	call
	     conv_to_float_dec_59 (arg_list.arg_des_ptr (2),
	     arg_list.arg_des_ptr (5), q);

	if mu_data_class$complex_data_class (arg_list.arg_des_ptr (4)) then do;
						/* If input is complex */
		call
		     conv_to_complex_float_dec_59 (arg_list.arg_des_ptr (1),
		     arg_list.arg_des_ptr (4), cmplx_fld_59_val);
		call
		     rnd (real (cmplx_fld_59_val), q, arg_list.arg_des_ptr (4),
		     fld_val_1);			/* Round the real part */
		call
		     rnd (imag (cmplx_fld_59_val), q, arg_list.arg_des_ptr (4),
		     fld_val_2);			/* Round the imaginary part */
		rslt_cfld_59.real = fld_val_1;	/* Stuff the real and imag parts in returned result */
		rslt_cfld_59.imag = fld_val_2;
	     end;
	else do;					/* If input was not complex */
		call
		     conv_to_float_dec_59 (arg_list.arg_des_ptr (1),
		     arg_list.arg_des_ptr (4), fld_val_1);
		call rnd (fld_val_1, q, arg_list.arg_des_ptr (4), rslt_fld_59);
	     end;


	return;					/* End of round entry */


round_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "round" builtin
   rslt_desc = 0  or FLD59_DESC  */


	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* Must have only two args */

	else if mu_data_class$complex_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$convertible_data_class (addr (arg_descs.desc (2)))
	then rslt_desc = CFLD59_DESC;
	else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1)))
		& mu_data_class$convertible_data_class (addr (arg_descs.desc (2)))
						/* If both args can be converted */
	then rslt_desc = FLD59_DESC;

	else rslt_desc = "0"b;

	return;					/* End of round_info entry */

(size, conversion):
rnd:
     proc (in_val, q, type, r_val);

/* This procedure accepts a float decimal (59) input value and rounds it
   returning the result in r_val. The type indicates if the original input was fixed or float. */

	dcl     in_val		 float decimal (59);/* (INPUT) */
	dcl     q			 float decimal (59);/* (INPUT) */
	dcl     type		 ptr;		/* (INPUT) Descriptor pointer */
	dcl     r_val		 float decimal (59);/* (OUTPUT) */

	if abs (in_val) > 0.000001 then do;
		if mu_data_class$fixed_data_class (type) then
		     n = q;			/* If input type is fixed */
		else do;				/* Floating number */
			if sign (q) = -1. then
			     call fatal_func_error;
			n = q - (floor (log10 (abs (in_val)) + 1));
		     end;

		r_val = sign (in_val) * floor (abs (in_val) * 10.0 ** n + 0.5);
		r_val = divide (r_val, (10.0 ** n), 59);
	     end;
	else r_val = 0;

	return;

     end rnd;

search:
     entry;

/* This entry implements the MRDS/LINUS "search" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.  If there is a
   mixture of character and bit arguments, an attempt is made to convert the bit
   argument to a character string.  The PL/I "search" builtin is used to actualy perform
   the function.  The returned result will be a fixed bin (24).  */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (3);		/* point to place to store result */

	call canon_char (1, a1_ptr, a1_len);
	call canon_char (2, a2_ptr, a2_len);
	rslt_bin = search (c1, c2);			/* Do char string search */

	return;					/* End of search */



search_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "search" builtin */
/* rslt_desc = 0 or FIXED_BIN_24 */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* need exactly 2 args */
	else /* check for string args */
	     if ^mu_data_class$character_data_class (addr (arg_descs.desc (1))) |
		/* If arg types are not char */
		^mu_data_class$character_data_class (addr (arg_descs.desc (2)))
	then rslt_desc = "0"b;
	else rslt_desc = FIB24_DESC;			/* have 2 string args */

	return;					/* end of search info entry */

substr:
     entry;

/* This entry implements the MRDS/LINUS "substr" builtin function.  This function
   accepts either the two argument form "substr (string, starting_pos)" or the three
   argument form "substr (string, starting_pos, len)" of sub-string.
   If the input string is a bit string the returned value is a varying bit string.
   If the input string is a character string the returned value is a
   varying character string. Returned result is either bit varying or char varying string.
   The PL/I "substr" builtin is used to actually perform the function. */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* Get pointer to argument list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	nargs = arg_list.arg_count / 2;		/* Number of arguments passed */
						/* If nargs = 3   form is substr (string, starting_pos)
						   If nargs = 4   form is substr (string, starting_pos, len) */
	r_ptr = addrel (arg_list.arg_des_ptr (nargs), -1);/* Set return value pointer to last argument */
	r_len =
	     fixed (string (arg_list.arg_des_ptr (nargs + 1) -> descriptor.size),
	     24);					/* Max length of return string
						   can be no longer then length of input string (arg (1)) */

	if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then
	     /* String type is bit */
	     call canon_bit (1, a1_ptr, a1_len);	/* Canonize to bit. var. */
	else /* String type is character */
	     call canon_char (1, a1_ptr, a1_len);	/* Canonize to char. var. */

	call
	     conv_to_fixed_bin_24 (arg_list.arg_des_ptr (2),
	     arg_list.arg_des_ptr (nargs + 2), starting_pos); /* Convert
						   starting position to fixed bin (24,0) */

/* BEGIN CHANGE 81-09-23 ****************************** */

	if nargs = 4 then do;
		call conv_to_fixed_bin_24 /* Convert len to fixed bin (24, 0) */
		     (arg_list.arg_des_ptr (3),
		     arg_list.arg_des_ptr (nargs + 3), len);
		if len > a1_len - starting_pos + 1	/* if too many characters are */
		then len = a1_len - starting_pos + 1;	/* requested cut it down */
	     end;

/* END   CHANGE 81-09-23 ****************************** */

	else len = a1_len - starting_pos + 1;
	if starting_pos > a1_len | starting_pos < 1 | len < 1 then do;
		if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then
		     rslt_bit_string = ""b;
		else rslt_char_string = "";
	     end;
	else do;
		if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then
		     rslt_bit_string = substr (b1, starting_pos, len);
						/* Do the SUBSTR */
		else rslt_char_string = substr (c1, starting_pos, len);
						/* Do the SUBSTR */
	     end;

	return;					/* End of substr */

substr_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "substr" builtin */
/* rslt_desc = 0 or BIT_VAR_DESC or CHAR_VAR_DESC */

	rslt_desc = arg_descs.desc (1);		/* Initialize it to a non-zero value */

	if arg_descs.ndescs < 2 | arg_descs.ndescs > 3 then
	     rslt_desc = "0"b;			/* Wrong number of argsuments */

	else
	     do j = 2 to (arg_descs.ndescs);		/* Are the lengths valid for converstion? */
						/* descritors will be character unless argument */
						/* is result of another expression */
		if ^mu_data_class$real_data_class (addr (arg_descs.desc (j)))
		     & ^mu_data_class$string_data_class (addr (arg_descs.desc (j))) then
		     rslt_desc = "0"b;
	     end;

	if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1))))
						/* First arg must be a string */
	then rslt_desc = "0"b;

	if rslt_desc ^= "0"b then do;			/* If everything was ok then set the rslt desc */

		if addr (arg_descs.desc (1)) -> descriptor.type < 21 then
		     rslt_desc = BIT_VAR_DESC;	/* Bit varying */
		else rslt_desc = CHAR_VAR_DESC;	/* Char varying */

		addr (rslt_desc) -> descriptor.size =
		     addr (arg_descs.desc (1)) -> descriptor.size; /* Result cannot
						   be any larger then input string length */
	     end;

	return;					/* end of substr info entry */

verify:
     entry;

/* This entry implements the MRDS/LINUS "verify" builtin function.  This is
   a string function, so arithmetic arguments are not accepted.
   The PL/I "verify" builtin is used to actualy perform the function.
   Returned result is a fixed bin (24). */


/* BEGIN CHANGE 81-08-14 RDL ********************************************** */

	a1_ptr = addr (buffer1);
	a2_ptr = addr (buffer2);

/* END CHANGE 81-08-14 RDL ********************************************** */

	call cu_$arg_list_ptr (al_ptr);		/* get pointer to arg list */
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-21 */
	r_ptr = arg_list.arg_des_ptr (3);		/* point to place to store result */

	call canon_char (1, a1_ptr, a1_len);
	call canon_char (2, a2_ptr, a2_len);
	rslt_bin = verify (c1, c2);			/* Do char string verify */


	return;					/* End of verify */



verify_info:
     entry (ad_ptr, rslt_desc);

/* Info entry for the "verify" builtin */
/* rslt_desc = 0 or fixed bin (24) */

	if arg_descs.ndescs ^= 2 then
	     rslt_desc = "0"b;			/* need exactly 2 args */
	else /* check for string args */
	     if ^mu_data_class$character_data_class (addr (arg_descs.desc (1))) |
		/* If arg types are not char */
		^mu_data_class$character_data_class (addr (arg_descs.desc (2)))
	then rslt_desc = "0"b;

	else rslt_desc = FIB24_DESC;			/* have 2 string args */

	return;					/* end of verify info entry */

fatal_func_error:
     proc;

	signal fatal_func_err;

     end fatal_func_error;

canon_bit:
     proc (arg_index, b_ptr, b_len);

/* Procedure to canonize bit args into bit varying */

	dcl     arg_index		 fixed bin;
	dcl     b_len		 fixed bin (35);
	dcl     (
	        b_ptr,
	        a_ptr		 init (null),
	        d_ptr		 init (null)
	        )			 ptr;
	dcl     bnv		 bit (b_len) based (a_ptr);
	dcl     bv		 bit (b_len) var based (b_ptr);
	dcl     fb35		 fixed bin (35) based;

	a_ptr = arg_list.arg_des_ptr (arg_index);	/* pick up arg and desc ptrs */
	d_ptr = arg_list.arg_des_ptr (arg_index + arg_list.arg_count / 2);

	if d_ptr -> descriptor.type = BIT_VAR then do;	/* no conv., merely set ptrs */
		b_ptr = addrel (a_ptr, -1);		/* Include length field */
		b_len = b_ptr -> fb35;
	     end;
	else do;					/* must convert to var. */
		b_len = fixed (string (d_ptr -> descriptor.size));
		bv = bnv;				/* convert */
	     end;

     end canon_bit;

canon_char:
     proc (arg_index, c_ptr, c_len);

/* procedure to canonize character or bit string arguments into char. varying */

	dcl     arg_index		 fixed bin;
	dcl     c_len		 fixed bin (35);
	dcl     (
	        c_ptr,
	        a_ptr		 init (null),
	        d_ptr		 init (null)
	        )			 ptr;
	dcl     bnv		 bit (c_len) based (a_ptr);
	dcl     bv		 bit (c_len) var based (bv_ptr);
	dcl     bv_ptr		 ptr init (null);
	dcl     cnv		 char (c_len) based (a_ptr);
	dcl     cv		 char (c_len) var based (c_ptr);
	dcl     fb35		 fixed bin (35) based;

	a_ptr = arg_list.arg_des_ptr (arg_index);	/* pick up arg and desc ptrs */
	d_ptr = arg_list.arg_des_ptr (arg_index + arg_list.arg_count / 2);

	if d_ptr -> descriptor.type = CHAR_VAR then do;	/* already char var, merely set pointers */
		c_ptr = addrel (a_ptr, -1);		/* Include length field */
		c_len = c_ptr -> fb35;
	     end;
	else do;					/* must convert */
		c_len = fixed (string (d_ptr -> descriptor.size));
		if d_ptr -> descriptor.type = CHAR then
		     cv = cnv;
		else if d_ptr -> descriptor.type = BIT then
		     cv = char (bnv);
		else do;
			bv_ptr = addrel (a_ptr, -1);
			cv = char (bv);
		     end;
	     end;

     end canon_char;

(size, conversion):
conv_to_fixed_bin_24:
     proc (s_ptr, s_desc_ptr, val);

/* This procedure converts a non-complex value to
   a fixed binary (24,0) value returned as val. The input parameters are a pointer to
   the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr), and the
   returned value (val).
*/

/*	PARAMETERS	*/

	dcl     s_ptr		 ptr;		/* Pointer to the source item */
	dcl     s_desc_ptr		 ptr;		/* Pointer to the source item descriptor */
	dcl     val		 fixed bin (24, 0); /* Returned value */

/*	OTHERS	*/

	dcl     assign_
				 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     s_type		 fixed bin;	/* Source item type for assign_ */
	dcl     s_len		 fixed bin (35);	/* Source item length for assign_ */
	dcl     t_ptr		 ptr init (null);	/* Pointer to target item for assign_ */
	dcl     t_type		 fixed bin;	/* Target item type for assign_ */
	dcl     t_len		 fixed bin (35);	/* Target item lenth for assigh_ */

Start:
	t_ptr = addr (val);
	t_len = 24;				/* Scale = 0 precision = 24 */
	t_type = 2;				/* 2*M + P where M = 1 and P = 0 */

	s_type =
	     (2 * s_desc_ptr -> descriptor.type)
	     + fixed (s_desc_ptr -> descriptor.packed);
	s_len =
	     fixed (s_desc_ptr -> descriptor.size.scale || "000000"b
	     || s_desc_ptr -> descriptor.size.precision);

	call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len);

	return;

     end conv_to_fixed_bin_24;

(size, conversion):
conv_to_float_dec_59:
     proc (s_ptr, s_desc_ptr, val);

/* This procedure canonizes non-complex arithmetic values to float decimal (59).
   The input parameters are a pointer to the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr),
   and the returned value (val). */

/*	PARAMETERS	*/

	dcl     s_ptr		 ptr;		/* Pointer to the source item */
	dcl     s_desc_ptr		 ptr;		/* Pointer to the source item descriptor */
	dcl     val		 float decimal (59);/* Returned value */

/*	OTHERS	*/

	dcl     assign_
				 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     s_type		 fixed bin;	/* Source item type for assign_ */
	dcl     s_len		 fixed bin (35);	/* Source item length for assign_ */
	dcl     t_ptr		 ptr init (null);	/* Pointer to target item for assign_ */
	dcl     t_type		 fixed bin;	/* Target item type for assign_ */
	dcl     t_len		 fixed bin (35);	/* Target item lenth for assigh_ */

Start:
	t_ptr = addr (val);
	t_len = 59;
	t_type = 20;				/* 2*M + P where M = 10 and P = 0 */

	s_type =
	     (2 * s_desc_ptr -> descriptor.type)
	     + fixed (s_desc_ptr -> descriptor.packed);
	s_len =
	     fixed (s_desc_ptr -> descriptor.size.scale || "000000"b
	     || s_desc_ptr -> descriptor.size.precision);

	call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len);

	return;

     end conv_to_float_dec_59;

(size, conversion):
conv_to_complex_float_dec_59:
     proc (s_ptr, s_desc_ptr, val);

/* This procedure canonizes complex arithmetic values to complex float decimal (59).
   The input parameters are a pointer to the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr),
   and the returned value (val). */

/*	PARAMETERS	*/

	dcl     s_ptr		 ptr;		/* Pointer to the source item */
	dcl     s_desc_ptr		 ptr;		/* Pointer to the source item descriptor */
	dcl     val		 complex float decimal (59); /* Returned value */

/*	OTHERS	*/

	dcl     assign_
				 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     s_type		 fixed bin;	/* Source item type for assign_ */
	dcl     s_len		 fixed bin (35);	/* Source item length for assign_ */
	dcl     t_ptr		 ptr init (null);	/* Pointer to target item for assign_ */
	dcl     t_type		 fixed bin;	/* Target item type for assign_ */
	dcl     t_len		 fixed bin (35);	/* Target item lenth for assigh_ */

Start:
	t_ptr = addr (val);
	t_len = 59;
	t_type = 24;				/* 2*M + P where M = 12 and P = 0 */

	s_type =
	     (2 * s_desc_ptr -> descriptor.type)
	     + fixed (s_desc_ptr -> descriptor.packed);
	s_len =
	     fixed (s_desc_ptr -> descriptor.size.scale || "000000"b
	     || s_desc_ptr -> descriptor.size.precision);

	call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len);

	return;

     end conv_to_complex_float_dec_59;

%include mdbm_arg_list;
%page;
%include mdbm_descriptor;

	dcl     (
	        a1_ptr		 init (null),	/* arg pointers */
	        a2_ptr		 init (null),
	        r_ptr		 init (null),	/* pointer to function result */
	        ad_ptr				/* Input:  points to structure containing input descrips. */
	        )			 ptr;		/* pointer to work area */

	dcl     (
	        a1_len,				/* string lengths for args */
	        a2_len
	        )			 fixed bin (35);

	dcl     (
	        starting_pos,			/* Starting position for substr */
	        r_len,				/* Length of bit or char resultant string */
	        s1,
	        s2,
	        n,
	        len
	        )			 fixed bin (24);	/* Length or extent of substr */

	dcl     c1		 char (a1_len) var based (a1_ptr); /* canonized char args */
	dcl     c2		 char (a2_len) var based (a2_ptr);
	dcl     b1		 bit (a1_len) var based (a1_ptr); /* canonized bit args */
	dcl     b2		 bit (a2_len) var based (a2_ptr);
	dcl     (fld_val_1, fld_val_2, q) float decimal (59);
	dcl     rslt_desc		 bit (36) aligned;	/* Output: result descriptor */
	dcl     rslt_bin		 fixed bin (24) based (r_ptr); /* fixed bin results */
	dcl     rslt_bit_string	 bit (r_len) varying based (r_ptr); /* Bit string result */
	dcl     rslt_char_string	 char (r_len) varying based (r_ptr); /* Char string result */
	dcl     rslt_fld_59		 float decimal (59) based (r_ptr);
	dcl     1 rslt_cfld_59	 based (r_ptr),
		2 real		 float decimal (59) aligned,
		2 imag		 float decimal (59) aligned;

	dcl     alloc_array		 (mrds_data_$max_builtin_args) ptr
				 init ((mrds_data_$max_builtin_args) null); /* place to store pointers to allocated items */
	dcl     (nargs, j)		 fixed bin;


	dcl     1 arg_descs		 aligned based (ad_ptr), /* input descriptors for info entries */
		2 ndescs		 fixed bin,
		2 desc		 (0 refer (arg_descs.ndescs)) bit (36);



	dcl     FIB24_DESC		 bit (36) aligned int static options (constant)
				 init ("100000100000000000000000000000011000"b); /* Fixed bin (24) descriptor */
	dcl     CHAR_VAR_DESC	 bit (36) aligned int static options (constant)
				 init ("101011000000000000000000000000000000"b); /* Character varying descriptor */
	dcl     BIT_VAR_DESC	 bit (36) aligned int static options (constant)
				 init ("101010000000000000000000000000000000"b); /* Bit varying descriptor */
	dcl     FLD59_DESC		 bit (36) aligned int static options (constant)
				 init ("100101000000000000000000000000111011"b); /* Float decimal (59) descriptor */
	dcl     CFLD59_DESC		 bit (36) aligned int static options (constant)
				 init ("100110010000000000000000000000111011"b); /* Complex Float decimal (59) descriptor */

	dcl     cmplx_fld_59_val	 complex float decimal (59);

	dcl     (
	        CHAR		 init (21),
	        BIT		 init (19),
	        CHAR_VAR		 init (22),
	        BIT_VAR		 init (20)
	        )			 fixed bin (5) int static options (constant);

	dcl     (
	        mrds_data_$max_builtin_args,
	        mrds_data_$max_string_size
	        )			 fixed bin (35) ext;

	dcl     (conversion, size, fatal_func_err) condition;


	dcl     (abs, addr, addrel, after, before, bit, ceil, char, divide, fixed, floor,
	        imag, index, log10, mod, null, real, reverse, search, sign, string, substr,
	        verify)		 builtin;

	dcl     cu_$arg_list_ptr	 entry (ptr);


	dcl     (
	        mu_data_class$real_data_class,
	        mu_data_class$complex_data_class,
	        mu_data_class$fixed_data_class,
	        mu_data_class$string_data_class,
	        mu_data_class$convertible_data_class,
	        mu_data_class$bit_data_class,
	        mu_data_class$character_data_class
	        )			 entry (ptr) returns (bit (1) aligned); /* determines if descriptor pointed to
						   describes a data item in the class
						   that the entry point refers to */



	dcl     area_ptr		 ptr init (null ());
	dcl     (buffer1, buffer2)	 char (2 * mrds_data_$max_string_size + 4);



     end mrds_builtin_;




		    mrds_data_.cds                  08/01/88  1347.2rew 08/01/88  1300.0      109413



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



/* HISTORY COMMENTS:
  1) change(86-05-14,Dupuis), approve(86-08-08,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Added the "number_of_resultant_attributes" field to fix phx20301
     (mrds #154) and changed saved_res_version to rslt0003.
  2) change(86-06-01,Spitzer), approve(85-12-03,MCR7311),
     audit(86-08-29,Blair), install(86-10-16,MR12.0-1187):
     Add rmdb_info_directory.
  3) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-11-26,Dupuis),
     install(86-12-09,MR12.0-1237):
     Add the relation_blocking_factor so we have a consistent number of control
     intervals in all relations created.
  4) change(88-07-14,Hergert), approve(88-07-15,MCR7903),
     audit(88-07-15,Dupuis), install(88-08-01,MR12.2-1073):
     Added max_nested_expr for new parser.
                                                   END HISTORY COMMENTS */


mrds_data_: proc;

/* NOTES:

   This procedure creates the mrds_data_ database.
*/


/* HISTORY:

   78-09-01 J. A. Weeldreyer: Initially written.

   80-05-01 Jim Gray: Modified to delete unused data items,  and  to
   add comments.

   80-06-23 Jim Gray: Modified to change  max_string_size  to  4096,
   from  50000,  for  a more resonable maximum attribute size and to
   add max_line_size, to separate  the  function  of  the  two  data
   items.

   80-10-01 Lindsey Spratt: Changed the dsmd_version_number  from  4
   to 5.

   80-11-03 Jim Gray: Modified to add  temp_seg_name  item,  so  the
   routines  search, close, and delete_se have a common place to get
   this name used in managing the temp segs on a per opening basis.

   80-11-06 Jim Gray: Modified to add current_version_status  entry,
   so that display_mrds_dm can handle when not to display file info,
   and  mrds_rst_create_db  can  properly  init  the  version_status
   structure.

   80-11-07 Jim Gray: Modified to add  submodel_dir_name  entry,  so
   mrds and users will have a standard to refer to.

   80-12-09  Jim  Gray:  added  control_segment_name  which  is  now
   db.control  as  part  of the conversion from r-u to r-s-m-d scope
   modes.

   81-01-14 Rickie E. Brinegar: changed max_and_groups  from  10  to
   100.   This   should  only  affect  the  predicate  structure  in
   mrds_dsl_optimize. It will now allocate 100 pointers  instead  of
   10 pointers.

   81-03-20 Jim Gray: combined  mrds_data_  and  mdbm_data_  tables,
   also removed unused data items.

   81-03-26 Jim Gray : added max_vfile_wait_time to be used with the
   -share option at open time for the vfile attach descriptions.

   81-04-22 Jim Gray :  removed  max_db_open  as  part  of  removing
   module mrds_dm_open_table_mgr from mrds.


   81-04-24 Jim Gray : changed max_dbs value  from  64  to  128,  to
   allow  up to 128 simultaneous opening of databases. This will not
   up the 64 limit on version 3 databases.

   81-04-25 Jim Gray : changed  length  of  temp_seg_name  to  allow
   three  digits in the db_index part of the name, for getting up to
   128 openings.

   81-04-30 Jim Gray : changed max_relations  to  256,  as  part  of
   changing max rels that cmdb can create, and that are usable.

   81-05-19 Jim Gray : changed max_select_items, max_pred_nodes, and
   max_pred_ops  to  256,  to agree with change of max_attributes to
   256.

   81-07-02 Jim Gray : added  statistics  update  mrds  data  items,
   indicating  when  next  update is to be done in terms of relation
   references and real time. The update count value is set to number
   of possible tuple variables, so that max tup vars on one rel only
   causes one call to mu_get_rel_size for that relation. The  update
   time was set to five minutes initially.

   81-07-06 Jim Gray : added size of small relations to  be  updated
   once  per  S.E.  to reduce problems with large percentage changes
   for this case. Also reduced update count to 10, since things  are
   now  managed  on  an  S.E.  reference, rather than tuple variable
   reference manner.

   81-07-22 Jim Gray : added key_search_threshold for  the  strategy
   logic in mrds_dsl_gen_srch_prog.

   81-08-27  Davids:  changed  max_select_items,  max_pred_ops,  and
   max_pred_notes to 256 from 100.

   81-12-02 Davids: changed max_and_terms to 100 from 20.

   82-03-15 R. Lackey : Added valid_rel_and_attr_name_chars

   82-06-03 Mike Kubicar : Changed quiesce_wait (the default quiesce wait
   time to 0.  Default is now don't wait.

   83-02-14 R. Harvey : removed the following: file_id_len_pad, inv_thresh,
   key_search_threshold, max_children, max_kattr_len, max_vfile_wait_time.

   83-05-19 Davids: Added the saved_res_version element.

   83-10-24 Mike Kubicar : Added $max_tids_returned_per_call, the maximum
   number of tuple ids to return during calls to
   relation_manager_$get_tuple_ids.

   84-05-18 Bert Moberg : Changed lock_wait_time to 900

   84-09-07 John Hergert: Added caller_compile for dsl_$compile. Changed 
   saved_res_version to "rslt0001"

   85-04-08 Thanh Nguyen: Added max_safe_tids_returned_per_call with value 
   of one.

   85-04-14 Thanh Nguyen: Changed saved_res_version to "rslt0002".
*/

%include cds_args;


dcl 1 md aligned,					/* the values to go into mrds_data_ */
    2 caller_compile fixed bin (35) init (5),     	/* translate called by compile */
    2 caller_define_temp_rel fixed bin (35) init (4),	/* translate called by define_temp_rel */
    2 caller_delete fixed bin (35) init (1),		/* translate called by delete */
    2 caller_modify fixed bin (35) init (2),		/* translate called by modify */
    2 caller_retrieve fixed bin (35) init (3),		/* translate called by retrieve */
    2 cleanup_lock_wait fixed bin (35) init (120),	/* wait time to lock acs control segment in cleanup handlers */
    2 control_segment_name char (32) init ("db.control"),	/* name of database concurrency control segment */
    2 current_version fixed bin (35) init (4),		/* current database version */
    2 current_version_status fixed bin (35) init (8),	/* current version_status structure major number */
    2 dmd_version fixed bin (35) init (4),		/* version of model header structure */
    2 dsmd_version_number fixed bin (35) init (5),	/* version of submodel header structure */
    2 lit_string_size fixed bin (35) init (73728),	/* max length of a literal string */
    2 lock_wait fixed bin (35) init (900),		/* wait time to lock acs control segment */
    2 lock_wait_time fixed bin (35) init (900),		/* set_scope default wait time */
    2 max_and_groups fixed bin (35) init (100),		/* max "and_groups" allowed in s.e. pred tree */
    2 max_and_terms fixed bin (35) init (100),		/* max terms allowed in an and_group in pred tree */
    2 max_attributes fixed bin (35) init (256),		/* max attrs allowed per relation by CMDB */
    2 max_builtin_args fixed bin (35) init (4),		/* max number of arguments to a builtin function */
    2 max_data_length fixed bin (35) init (2000),		/* max temp rel record data length */
    2 max_dbs fixed bin (35) init (128),		/* number of database openings allowed */
    2 max_expr_items fixed bin (35) init (20),		/* stack depth for eval of s.e. expressions */
    2 max_expr_stack_size fixed bin (35) init (14),	/* stack depth for eval of s.e. expressions */
    2 max_id_len fixed bin (35) init (32),		/* max character length of a tuple variable name */
    2 max_key_len fixed bin (35) init (253),		/* max total chars from attrs making up key field in rels */
    2 max_line_size fixed bin (35) init (50000),		/* largest output line for cmdb listing */
    2 max_lit_string_size fixed bin (35) init (254),	/* max repeated string literal size */
    2 max_nested_expr fixed bin (35) init (5),		/* max number of expression that can be nested in a where clause */
    2 max_pred_depth fixed bin (35) init (30),		/* size of stack for conversion pred tree to disj. norm. form */
    2 max_pred_nodes fixed bin (35) init (256),		/* max number of pred tree tuple attr leaf nodes */
    2 max_pred_ops fixed bin (35) init (256),		/* max number of pred tree operator leaf nodes */
    2 max_relations fixed bin (35) init (256),		/* largest number of relations cmdb can create */
    2 max_select_items fixed bin (35) init (256),		/* s.e. select clause max item count */
    2 max_sets fixed bin (35) init (20),		/* s.e. max number of set operators */
    2 max_sf_args fixed bin (35) init (30),		/* max number of args for scalar function */
    2 max_string_size fixed bin (35) init (4096),		/* largest parsable token for cmdb */
    2 max_td_len fixed bin (35) init (10),		/* largest array space for token data */
    2 max_temp_rels fixed bin (35) init (20),		/* most simultaneous temp rels */
    2 max_tids_returned_per_call fixed bin (35) init (1000), /* Most tids returned in a call to relation_manager_$get_tuple_ids */
    2 max_safe_tids_returned_per_call fixed bin (35) init (1), /* Most tids returned in a call to relation_manager_$get_tuple_ids
      with a guaranty match for a select expression. */
    2 max_token_size fixed bin (35) init (65),		/* largest s.e. token length */
    2 max_tup_var fixed bin (35) init (20),		/* most s.e. tuple variables allowed */
    2 max_tuple_default fixed bin (35) init (1000),	/* blocked file relation -max_tuples option default */
    2 normal_mode fixed bin init (1),			/* normal data base access mode */
    2 number_of_resultant_attributes fixed bin init (500),  /* for refer extent of resultant_attributes_info structure */
    2 quiesce_mode fixed bin init (2),			/* quiesce data base access mode */
    2 quiesce_wait fixed bin (35) init (0),		/* wait time to quiesce files */
    2 relation_blocking_factor fixed bin init (255),        /* no. control intervals per segment */
    2 rmdb_info_directory char (168) init (">doc>ss>rmdb"),	/* directory containing rmdb info segs */
    2 saved_res_version char (8) init ("rslt0003"),         /* most up to date version of the resultant */
    2 statistics_update_count_interval fixed bin (35) init (10), /* number of rel ref times before statistics are next updated */
    2 statistics_update_time_interval fixed bin (71) init (300000000), /* real time til statistics next updated */
    2 statistics_update_small_rel_size fixed bin (35) init (100), /* max  size of rel to be updated every S.E. */
    2 submodel_dir_name char (16) init ("secure.submodels"), /* name of submodel_dir in new architecture */
    2 temp_seg_name char (23) init ("mrds_search_tidtemp.dbi"), /* common name for tid search temp segs */
    2 valid_id_chars char (128) varying
     init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-") , /* legal s.e. token characters */
    2 valid_rel_and_attr_name_chars char (128) varying
     init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-") ; /* Valid relation name character (Names can NOT begin with _ - or numeric) */

dcl 1 cdsa like cds_args;
dcl  code fixed bin (35);

dcl (addr,
     size,
     string,
     null) builtin;

dcl  create_data_segment_ entry (ptr, fixed bin (35));
dcl  com_err_ entry options (variable);

	cdsa.sections.p (1) = addr (md);		/* init. info for cds */
	cdsa.sections.len (1) = size (md);
	cdsa.sections.struct_name (1) = "md";
	cdsa.seg_name = "mrds_data_";
	cdsa.num_exclude_names = 0;
	cdsa.exclude_array_ptr = null;
	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0 then call com_err_ (code, "mrds_data_");
	return;

     end mrds_data_;




		    mrds_debug_.cds                 04/18/85  1429.4re  04/18/85  0906.4       30168



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

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



/* HISTORY:

   79-07-01 Jim Gray: Originially written.

   80-11-17 Rickie E. Brinegar: Call to com_err_ with a 0 error code
   changed to a call to ioa_.

*/


mrds_debug_ : procedure () ;

/* DESCRIPTION:

   this is the source to be used by the create_data_segment command
   to create the mrds_debug_ data segment object. to make additions
   or changes to the data segment, change the mrds_debug_structure
   declared in this pl1 program, then invoke cds with the pathname
   of this source.

*/

/* PARAMETERS:

   (input) changes to the mrds_debug_structure

   (output) a new mrds_debug_ data segment, after running
   the command create_data_segment on this source.

*/


/* CHANGE THIS STRUCTURE TO MAKE CHANGES IN MRDS_DEBUG_ */

declare 1 mrds_debug_structure,
        2 switch bit (9) unal dimension (400) init ((400) ((9) "0"b)) ; /* one 9 bit debug switch for each module in MRDS */



/* fill in the input structure to the subroutine
   call to create_data_segment_ */


	data.sections.p (1) = null () ;		/* no text section */
	data.sections.len (1) = 0 ;
	data.sections.struct_name = "NO_TEXT" ;
	data.sections.p (2) = addr (mrds_debug_structure) ; /* static section */
	data.sections.len (2) = size (mrds_debug_structure) ;
	data.sections.struct_name (2) = "mrds_debug_structure" ;
	data.seg_name = "mrds_debug_" ;
	data.num_exclude_names = 0 ;
	data.exclude_array_ptr = null () ;
	data.switches.defs_in_link = OFF ;
	data.switches.separate_static = OFF ;
	data.switches.have_text = OFF ;
	data.switches.have_static = ON ;
	data.switches.pad = OFF ;

/* make the call required by the create_data_segment command */

	call create_data_segment_ (addr (data), error_code) ;
	if error_code = 0 then
	     call ioa_ ("mrds_debug_ data segment created") ;
	else call com_err_ (error_code, "creating data segment for mrds_debug_") ;

	return ;


declare 1 data like cds_args ;			/* local version of create_data_segment_ input structure */
declare  create_data_segment_ entry (ptr, fixed bin (35)) ; /* subroutine for cds */
declare (addr, size) builtin ;


%include cds_args ;
%include mrds_debug_names ;

declare  com_err_ entry options (variable) ;		/* reports errors */
dcl  ioa_ entry options (variable);			/* other messages */
declare  error_code fixed bin (35) ;			/* error status encoding */
declare  ON bit (1) init ("1"b) ;			/* true value */
declare  OFF bit (1) init ("0"b) ;			/* false value */

     end ;




		    mrds_dm_authorization.pl1       03/08/88  1539.2rew 03/08/88  1530.1      148212



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



/****^  HISTORY COMMENTS:
  1) change(88-01-19,Blair), approve(88-02-26,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Add code to search a "mrds" search list for the db pathname.  SCP 6366.
  2) change(88-02-25,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Establish a local area for the search_path list in case we aren't
     passed an area_ptr.
                                                   END HISTORY COMMENTS */


mrds_dm_authorization: procedure (); return;		/* not a legal entry */

/* DESCRIPTION:

   This   routine   has    two    entries,    get_user_class,    and
   set_needed_access.  The  first determines whether the caller is a
   database administrator (has sma on the db dir) or a normal  user.
   The  second entry is used to give DBA's all access they will ever
   need for any operation against the database. An error is returned
   if the database is an unsupported version.

*/

/* PARAMETERS:

   database_path - - (input) char(*), the relative pathname  of  the
   database,  this can not be a submodel pathname, the suffix is not
   necessary.

   area_ptr - - (input) pointer, get entry only, a freeing  area  in
   which   to   allocate   the   structure  containing  the  desired
   information.

   structure_version - - (input) fixed  bin,  get  entry  only,  the
   desired  version  of  the structure, normaly the version given in
   the include file with the structure.

   mrds_authorization_ptr - - (output) pointer, get entry only,  the
   pointer  to the structure to be allocated in the callers area, as
   defined by the include file in mrds_authorization.incl.pl1

   error_code - - (output) fixed bin(35), the error status encoding,
   0 unless an error occurred.

*/
%page;
/* HISTORY:

   81-01-15 Jim Gray : Originally error_coded.

   81-04-17  Jim  Gray  :  made  modifications  to   implement   the
   mmi_$get_authorization  entry  point.  Improved path handling for
   this  and  the  mmi_$get_secured_state  routine  by  writing  the
   mrds_dm_check_path  routine. Added use of hcs_$status_ instead of
   hcs_$get_user_effmode.

   81-10-06 Davids: added a line to set the value of  star_entry_ptr
   to local_star_entry_ptr. This is so that references to star_names
   do not reference through a null pointer (star_names has an extent
   based   on   a   value   from   star_entries).   The   value   of
   star_entry_count was already being set correctly.

   83-01-21 Roger Lackey: Added  check for mrds_error_$no_model_access
   which is now returned from mrds_dm_check_path.

   83-05-31 Davids: Replaced reference to hcs_$add_acl_entries with a reference
   to object_type_$add_acl_entries. This was needed so that acls could be set
   on ring 2 dms files.

   83-06-07 Davids: Added a call to object_type_$validate before the call to
   the msf manager for setting acls on msfs. If validate returns a 0 code
   then object_type_$add_acl_entries will be called since it recognizes the
   msf and can set the acls correctly. Currently object_type_ wrorks for ring 2
   msf (dm files) but not regular ring 4 msfs.

   83-09-30 Mike Kubicar : Several significant changes.  Added an error routine
   to provide one convenient way of exiting this module.  This gets rid of the
   HORRIBLE nested if structure that used to be here.  This routine is now
   called when appropriate.  Also rewrote the force_dir_contents_acl procedure
   to use the fs_util_ subroutine instead of munging acls with hcs_.

*/
%page;
/* entry to determine if user is a DBA or peon */

get_user_class: get_authorization: entry (rel_db_path, area_ptr, structure_version, structure_ptr, error_code);

	error_code = 0;
	mrds_authorization_ptr = null ();

	call check_path ();
	if error_code = 0 then do;			/* check arguments other than database path */
		if area_ptr = null () then
		     error_code = error_table_$badcall;
		else do;
			unspec (my_area_info) = "0"b;
			my_area_info.version = 1;
			my_area_info.areap = area_ptr;

			call area_info_ (addr (my_area_info), error_code);
			if error_code ^= 0 then ;	/* couldn't get area info */
			else if my_area_info.no_freeing then
			     error_code = mrds_error_$not_freeing_area;
			else do;

				if structure_version ^= mrds_authorization_structure_version then
				     error_code = error_table_$unimplemented_version;
				else do;

					on area begin; /* in case allocate fails */
						error_code = error_table_$area_too_small;
						goto skip_allocate;
					     end;

					on cleanup begin;
						if mrds_authorization_ptr ^= null then do;
							free mrds_authorization_ptr -> mrds_authorization in (work_area);
							mrds_authorization_ptr = null ();
						     end;
					     end;

					allocate mrds_authorization set (mrds_authorization_ptr) in (work_area);
					revert area;

					call get_user_info (); /* fill in structure info */

skip_allocate:
				     end;

			     end;
		     end;
	     
	     end;

	structure_ptr = mrds_authorization_ptr;

	return;
%page;
/* entry to set any access a DBA might need */

set_needed_access: entry (rel_db_path, error_code);

	error_code = 0;
	call check_path ();
	if error_code = 0 then do;

		mrds_authorization_ptr = addr (local_mrds_authorization);
		call get_user_info ();
		if error_code ^= 0 then ;
		else if mrds_authorization.administrator then
		     call set_db_acls ();
		else error_code = error_table_$insufficient_access;

	     end;

	return;
%page;
check_path: procedure ();

/* routine to verify good database path
   by checking for a path with a .db suffix,
   being a directory containing a segment db_model,
   which should be for a version 4 database. */

dcl local_area area (2048);

          use_search_paths = "0"b;
	if search (rel_db_path, "<>") = 0 then do;
	     call search_paths_$get (MRDS_SEARCHLIST, sl_control_default, "", null (), addr(local_area),
		sl_info_version_1, mrds_search_list_ptr, error_code);
	     if error_code ^= 0 then return;
	     loop_idx = mrds_search_list_ptr -> sl_info.num_paths;
	     use_search_paths = "1"b;
	     end;
	else do;
	     call absolute_pathname_ (rel_db_path, abs_db_path, error_code);
	     if error_code ^= 0 then return;
	     loop_idx = 1;
	     end;

	error_code = 1;
	do idx = 1 to loop_idx while (error_code ^= 0);
	     if use_search_paths then abs_db_path = pathname_ (mrds_search_list_ptr -> sl_info.paths(idx).pathname, rel_db_path);
	     call mrds_dm_check_path (rtrim(abs_db_path), containing_dir, db_dir, new_found, error_code);

	     if error_code = error_table_$incorrect_access |
		error_code = mrds_error_$no_model_access then
		error_code = 0;		/* ignore access error */
	     end;                               /* no more search paths or we got a good one */

	if error_code = 0 & ^new_found then
	     error_code = mrds_error_$version_not_supported;

     end;
%page;
get_user_info: procedure ();

/* routine to determine class of user, DBA or peon */

	unspec (my_status_branch) = "0"b;		/* in case incorrect access => non-dba */

/* get access mode on db dir for caller */

	call hcs_$status_ (rtrim (containing_dir), rtrim (db_dir), chase_links,
	     addr (my_status_branch), addr (local_area), error_code);
	if error_code ^= 0 & error_code ^= error_table_$incorrect_access
	     & error_code ^= error_table_$no_s_permission then do; /* couldn't get access */
		free mrds_authorization_ptr -> mrds_authorization in (work_area);
		mrds_authorization_ptr = null ();
	     end;
	else do;

		error_code = 0;

		access_mode_overlay_ptr = addr (my_status_branch.mode);

		unspec (mrds_authorization) = "0"b;
		mrds_authorization.version = mrds_authorization_structure_version;

/* check for sma on db dir  */

		if access_mode_overlay.status & access_mode_overlay.modify & access_mode_overlay.append then do;

/* user is a DBA */
			mrds_authorization.administrator = "1"b;
			mrds_authorization.normal_user = "1"b;

		     end;
		else do;

/* user is a peon */

			mrds_authorization.administrator = "0"b;
			mrds_authorization.normal_user = "1"b;

		     end;

	     end;

     end;
%page;
set_db_acls: procedure ();

/* routine to set all access a DBA will ever need */

	acl_count = 1;
	allocate file_acl in (local_area);
	file_acl.version = GENERAL_ACL_VERSION_1;
	file_acl.count = acl_count;
	file_acl.entries (1).access_name = get_group_id_$tag_star ();
	file_acl.entries (1).mode = RW_ACCESS;
	file_acl.entries (1).status_code = 0;
	allocate dir_acl in (local_area);
	dir_acl.version = GENERAL_ACL_VERSION_1;
	dir_acl.count = acl_count;
	dir_acl.entries (1).access_name = get_group_id_$tag_star ();
	dir_acl.entries (1).mode = SMA_ACCESS;
	dir_acl.entries (1).status_code = 0;

/* call the recursive routine, that works on one directories contents at a time */

	abs_db_path = rtrim (containing_dir) || ">" || db_dir;

	call force_dir_contents_acls (rtrim (abs_db_path), file_acl_ptr,
	     dir_acl_ptr);

     end;
%page;
force_dir_contents_acls: procedure (abs_dir_path, facl_ptr, dacl_ptr);

/* get a list of all segs and dirs in this directory */

	call hcs_$star_ (abs_dir_path, "**", star_BRANCHES_ONLY,
	     addr (local_area), star_entry_count, star_entry_ptr,
	     star_names_ptr, code);
	if code = error_table_$nomatch
	then return;				/* Nothing to do */
	else if code ^= 0
	then call error (code);


/* set acls of rw and sma for each entry found */

	do local_index = 1 to star_entry_count;
	     current_name = star_names (star_entries.nindex (local_index));
	     call fs_util_$get_type (abs_dir_path, current_name, file_type,
		code);
	     if code ^= 0
	     then call error (code);
	     if file_type = FS_OBJECT_TYPE_DIRECTORY then do;
		     call fs_util_$add_acl_entries (abs_dir_path, current_name,
			dacl_ptr, code);
		     if code = error_table_$argerr
		     then call error (
			     dacl_ptr -> dir_acl.entries (1).status_code);
		     else if code ^= 0
		     then call error (code);

/* Now do everything in this directory too */

		     call force_dir_contents_acls ((rtrim (abs_dir_path)
			|| ">" || rtrim (current_name)), facl_ptr, dacl_ptr);
		end;
	     else do;
		     call fs_util_$add_acl_entries (abs_dir_path,
			current_name, facl_ptr, code);
		     if code = error_table_$argerr
		     then call error (facl_ptr
			     -> file_acl.entries (1).status_code);
		     else if code ^= 0
		     then call error (code);
		end;
	end;

	declare abs_dir_path	 char (*);	/* local copy of the directory name we are currently working on */
	declare code		 fixed bin (35);	/* Error code */
	declare current_name	 char (35);	/* Current name from starname call */
	declare dacl_ptr		 ptr;		/* Pointer to a general acl structure containing dir acls */
	declare facl_ptr		 ptr;		/* Same as above but for file acls */
	declare file_type		 char (32);	/* What kind of file system entity are we dealing with */
	declare fs_util_$add_acl_entries entry (char (*), char (*), ptr, fixed bin (35));
	declare fs_util_$get_type	 entry (char (*), char (*), char (*), fixed bin (35));
	declare local_index		 fixed bin;	/* local copy of index into list of entries */
%page;
%include star_structures;

     end;
%page;
error: proc (cd);

	dcl     cd		 fixed bin (35);

	error_code = cd;
	goto PROGRAM_EXIT;
     end error;


PROGRAM_EXIT:

%page;
          declare MRDS_SEARCHLIST        char (4) int static options (constant) init ("mrds");
	declare abs_db_path		 char (168);	/* absolute path to db */
          declare absolute_pathname_     entry (char(*), char(*), fixed bin(35));
	declare access_mode_overlay_ptr ptr;		/* points to access_mode */
	declare area		 condition;	/* if area to small for allocate */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area details */
	declare area_ptr		 ptr;		/* pointer to users area */
	declare chase_links		 fixed bin (1) init (1); /* find link target info */
	declare cleanup		 condition;	/* signaled upon quit/release */
	declare containing_dir	 char (168);	/* name of dir containing db */
	declare db_dir		 char (32);	/* entry name of db dir */
	declare 1 dir_acl		 like general_acl based (dir_acl_ptr); /* For setting dir acls */
	declare dir_acl_ptr		 ptr;		/* pointer to  directory acl structure */
	declare dont_chase_links	 fixed bin (1) init (0); /* get info about link, not target */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$area_too_small fixed bin (35) ext; /* for area condition */
	declare error_table_$argerr	 fixed bin (35) ext;/* returned if acl structure status code ^= 0 */
	declare error_table_$badcall	 fixed bin (35) ext;/* null pointer given */
	declare error_table_$incorrect_access fixed bin (35) ext; /* no access on dir, or entry */
	declare error_table_$insufficient_access fixed bin (35) ext; /* process doesn't have sufficient access */
	declare error_table_$no_s_permission fixed bin (35) ext; /* no "s" on containing dir */
	declare error_table_$nomatch	 fixed bin (35) ext;/* nothing found in directory */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* bad structure version */
	declare 1 file_acl		 like general_acl based (file_acl_ptr); /* For setting file acls */
	declare file_acl_ptr	 ptr;		/* Default pointer for above */
	declare get_group_id_$tag_star entry returns (char (32)); /* gets person.project.* */
	declare hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); /* gets list of star names */
	declare hcs_$status_	 entry (char (*), char (*), fixed bin (1),
				 ptr, ptr, fixed bin (35)); /* gets access mode */
          declare idx                    fixed bin;
	declare local_area		 area (5000);	/* space for star entries/names structures */
          declare loop_idx               fixed bin;
	declare mrds_dm_check_path	 entry (char (*), char (168), char (32), bit (1), fixed bin (35)); /* verifies db path */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attribute */
	declare mrds_error_$no_model_access fixed bin (35) ext static;
	declare mrds_error_$version_not_supported fixed bin (35) ext; /*  db doesn't have secured bit */
          declare mrds_search_list_ptr   ptr;
	declare new_found		 bit (1);		/* on => new version db arch */
          declare pathname_              entry (char(*), char(*)) returns(char(168));
	declare rel_db_path		 char (*);	/* input database path */
          declare search_paths_$get      entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35));
	declare structure_ptr	 ptr;		/* parameter version of mrds_authorization_ptr */
	declare structure_version	 fixed bin;	/* desired version of structure */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* alrgest segmetn size */
          declare use_search_paths       bit (1);
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr); /* overlay for users area */
	declare (addr, empty, null, rtrim, search, sum, unspec) builtin;
	declare 1 access_mode_overlay	 based (access_mode_overlay_ptr),
		2 unused		 bit (1) unal,
		2 status		 bit (1) unal,	/* status permission */
		2 unimplemented	 bit (1) unal,
		2 modify		 bit (1) unal,	/* modify permission */
		2 append		 bit (1) unal;	/* append permission */
	declare 1 local_mrds_authorization like mrds_authorization; /* for set_needed_access entryies use */
	declare 1 my_area_info	 like area_info;	/* local copy */
	declare 1 my_status_branch	 like status_branch.short; /* local copy */
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include copy_flags;
%page;
%include mrds_authorization;
%page;
%include mdbm_db_model;
%page;
%include sl_info;
%page;
%include sl_control_s;
%include status_structures;
%page;
%include suffix_info;
%page;
%include area_info;

     end mrds_dm_authorization;




		    mrds_dm_check_path.pl1          04/18/85  1429.4re  04/18/85  0906.4       67410



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

mrds_dm_check_path: check_path: procedure (I_in_path, O_containing_dir, O_db_dir_name, O_new_found, O_code);

/* DESCRIPTION:

   this routine takes a relative pathname, and determines if it is a
   old or new architecture MRDS database. It attempts to require the
   minimum of access to  do  this.  It  was  written  primarily  for
   mmi_$get_authorization and mmi_$get_secured_state.

*/

/* PARAMETERS:

   I_in_path - - (input) char(*), the relative or absolute path to  be
   examined. Suffixes are not required.

   O_containing_dir - - (output) char(*) the containing directory of
   the database

   O_db_dir_name - - (output) char(*), the entry  name,  with  suffix,  if
   any, of the database dir

   O_new_found - - (output) bit(1),  on  =>  this  is  a  new  version
   database architecture (created by MR8 or later MRDS)

   O_code - - (output) fixed bin(35), the  error  status  encoding  it
   will  be  error_table_$incorrect_access if the user has no access
   to the data model entry.

*/
%page;
/* HISTORY:

   83-01-25 Roger Lackey : Rewritten to use the following sequence:
   what is given for db_path
   if not found then try db_path with .db suffix

   83-01-27  Roger Lackey: Corrected check fo .db suffix

   83-02-01 Roger Lackey: Returns mrds_error_$no_database if no model is found.

   83-04-29 Davids: Extensive modifications for performance reasons.
   The db_path variable is set in the main procedure instead of the internal
   find_model procedure. This reduces the number of times the variable is set
   (and rtrim and concatenate are referenced) by half (2 instead of 4).
   The check_db_path internal procedure was eliminated (with its call to
   hcs_$status_minf and needed error handling). The existance of the
   db_dir is now checked by checking for the no_dir error returned from status
   when the check for the db_model segment is made There was always 1 call
   and if the input path did not contain a .db suffix and the db dir did there
   was another call. The call to the internal check_model procedure is made
   with just the code variable instead of the special model_code which is
   assigned to code if the model was found. A variable called db_dir_length
   was created instead of referencing the length builtin 3 times.
*/
%page;
/* mrds_dm_check_path: check_path: procedure (I_in_path, O_containing_dir, O_db_dir_name, O_new_found, O_code); */
	dcl     I_in_path		 char (*) parameter;
	dcl     O_code		 fixed bin (35) parameter;
	dcl     O_containing_dir	 char (*) parameter;
	dcl     O_db_dir_name	 char (*) parameter;
	dcl     O_new_found		 bit (1) parameter;

	O_containing_dir = "";
	O_db_dir_name = "";
	O_new_found = "0"b;
	O_code = 0;

	model_found = "0"b;

	db_dir = "";				/* Incase of error in expandpath */

	call expand_pathname_ (I_in_path, containing_dir, temp_db_dir, code);
	if code ^= 0
	then do;
		containing_dir = "";
		goto exit;
	     end;

	db_dir = rtrim (temp_db_dir);
	db_path = pathname_ (containing_dir, (db_dir));

	call check_model (model_found, code);

	if ^model_found				/* See if db_dir has .db suffix */
	then do;
		db_dir_length = length (db_dir);

		if db_dir_length < 30
		then do;
			if db_dir_length > 3
			then do;
				if substr (db_dir, db_dir_length - 2, 3) = ".db"
				then goto exit;
			     end;

			db_dir = db_dir || ".db";
			db_path = rtrim (db_path) || ".db";

			call check_model (model_found, code);
		     end;
	     end;

exit:	O_containing_dir = containing_dir;
	O_db_dir_name = db_dir;

	if model_found
	then do;
		if model_name = "db_model"
		then O_new_found = "1"b;
	     end;
	else do;					/* No database */
		code = mrds_error_$no_database;
		call expand_pathname_$add_suffix ((db_dir), "db", temp_dir_path, O_db_dir_name, dummy_code);
	     end;

	O_code = code;

	return;

%page;
/* * * * * * * * * * * * * * * * * *   check_model   * * * * * * * * * * *  */

check_model: proc (cm_model_found, cm_model_code);

	dcl     cm_model_code	 fixed bin (35) parameter;
	dcl     cm_model_found	 bit (1) aligned parameter;

	model_name = "db_model";
	call find_model (model_name, cm_model_found, cm_model_code);
	if cm_model_code ^= error_table_$no_dir & ^cm_model_found
	then do;
		model_name = "data_model";
		call find_model (model_name, cm_model_found, cm_model_code);
	     end;

     end check_model;
%page;
/* * * * * * * * * * * * * * *    find_model    * * * * * * * * * * * *   */

find_model: proc (name, fm_found, fm_code);

	dcl     name		 char (*) parameter;/* Model name to try */
	dcl     fm_found		 bit (1) parameter aligned; /* ON = Model found */
	dcl     fm_code		 fixed bin (35) parameter; /* Error code for this internal procedure */


	call hcs_$status_minf (db_path, model_name, no_chase, entry_type, bit_count, fm_code);
	if fm_code = 0
	then do;
		if model_name = "db_model"
		then do;
			if entry_type ^= SEGMENT
			then do;
				fm_code = error_table_$noentry;
				fm_found = "0"b;
			     end;
			else fm_found = "1"b;
		     end;
		else do;
			if entry_type ^= DIR | bit_count = 0
			then do;
				fm_code = error_table_$noentry;
				fm_found = "0"b;
			     end;
			else fm_found = "1"b;
		     end;
	     end;					/* END if fm_code = 0 then do */
	else if fm_code = error_table_$incorrect_access
	then do;
		fm_code = mrds_error_$no_model_access;
		fm_found = "1"b;
	     end;

     end find_model;

%page;
	dcl     bit_count		 fixed bin (24);	/* bit count of entry */
	dcl     code		 fixed bin (35);	/* error status encoding */
	dcl     containing_dir	 char (168);	/* containing dir of db */
	dcl     db_dir		 char (32) varying; /* db dir entry */
	dcl     db_dir_length	 fixed bin;	/* number of chars in db_dir */
	dcl     db_path		 char (168);
	dcl     DIR		 fixed bin init (2);/* entry = direcotry */
	dcl     dummy_code		 fixed bin (35);
	dcl     entry_type		 fixed bin (2);	/* type of entry found */
	dcl     error_table_$incorrect_access fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext;/* no entry found */
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     error_table_$no_dir	 fixed bin (35) ext;/* some dir in path doesnt exists */
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35)); /* gets abs containing dir, and entryname */
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); /* gets entry type */
	dcl     length		 builtin;
	dcl     model_name		 char (32);
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_access fixed bin (35) ext static;
	dcl     model_found		 bit (1) aligned;
	dcl     no_chase		 fixed bin (1) init (0) int static options (constant); /* don't chase links */
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     rtrim		 builtin;
	dcl     SEGMENT		 fixed bin init (1);/* entry = segment */
	dcl     substr		 builtin;
	dcl     temp_db_dir		 char (32);
	dcl     temp_dir_path	 char (168);

     end mrds_dm_check_path;




		    mrds_dm_close.pl1               10/16/86  1550.5r w 10/16/86  1145.0       72207



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

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


/* DESCRIPTION:

   This procedure closes a data model that  has  been  opened  by  a
   previous call to either the dmd_ or the mmi_ opening entry.

   There are three entries. mrds_dm_close for use by internal  mrds.
   close_dm  for  external use by dmd_. close_model for external use
   bu mmi_. The external entries check for the user be a DBA if  the
   database is secured.

*/

/* PARAMETERS:

   data_model_ptr - - (input) ptr, for the mrds_dm_close and close_dm entries,
   the pointer returned by a call to dmd_$open

   open_name - - (input) char(*), for the close_model entry,
   the open name used in the call to mmi_$open_model

   code - - (output) fixed bin (35), the error status encoding

*/

/* HISTORY:

   Modified by J. A. Weeldreyer to  add  abort  entry  --  November,
   1976.

   Modified by Oris Friesen to accomodate new version data bases  --
   October 1978

   Modified by R. Lackey June 1979 to ad mode to get_opening

   Modified by Jim Gray - - Feb. 1980, to call the  old  version  of
   close_dm,  if  the  data_model_ptr  points  to an iocb_ptr in the
   area_linker, since this means data_model vfile of the old version
   was used.

   81-02-12 Jim Gray : added  need  for  caller  to  be  DBA  if  db
   secured, and call made to external dmd_$close_dm which should not
   be used by mrds. internal mrds should only call rmds_dm_close.

   81-04-22 Jim Gray : added close_model entry for mmi_, and removed
   use   of   mrds_dm_open_table_mgr   to   remove   opening  number
   restrictions.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

/* BEGIN CHANGE 81-02-12 *********************************************** */

mrds_dm_close: procedure (data_model_ptr_a, code_a);

/* entry to be used by internal mrds calls */

	internal_call = "1"b;

	data_model_ptr = data_model_ptr_a;

	call common ();

	code_a = code;

	return;




close_dm: entry (data_model_ptr_b, code_b);

/* entry to be used by external dmd_ callers,
   user must be a DBA if db is secured */

	internal_call = "0"b;

	data_model_ptr = data_model_ptr_b;

	call common ();

	code_b = code;

	return;

/* END CHANGE 81-02-12 ******************************************** */

/* BEGIN CHANGE 81-04-22 ********************************************** */

close_model: entry (open_name, code_c);

/* this entry closes a model that has been opened by a call to
   mmi_$open_model, by disassociating the open name from the model pointer
   It uses the close_dm entry so that the user must be a DBA,
   if the database has been secured. */

	call mu_open_name_manager$get_model_pointer (open_name, model_type, model_ptr, code_c);
	if code_c = 0 then do;

		call close_dm (model_ptr, code_c);
		if code_c = 0 then do;

			call mu_open_name_manager$delete_open_name (open_name, code_c);

		     end;

	     end;

	return;

/* END CHANGE 81-04-22 *********************************************** */

common: procedure ();

	code = 0;
	call hcs_$fs_get_path_name (data_model_ptr, db_path, ldn, model_name, code);
	if code ^= 0 then goto exit;

/* check for user being a DBA if database is secured */

	if ^internal_call then
	     call secured_db_check ();

exit:	return;

     end;

/* BEGIN CHANGE 81-02-12 ********************************************* */

secured_db_check: procedure ();

/* routine to check for the database being is a secured state,
   and if so, that the user is a DBA, and thus may use the external entry */

	if code ^= 0 then ;
	else if internal_call then ;
	else do;

/* get the secured state of the dataabase */

		call mrds_dm_db_secured$get_secured_status (data_model_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then

		     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the secured state of database """, db_path, """.");

		else if ^database_state.secured then ;
		else do;

/* database secured, see if the user is a DBA */

			call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then

			     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				"Unable to get user class for database """, db_path, """.");

			else if mrds_authorization.administrator then ;
			else do;

/* not DBA on secured db, issue error */

				code = error_table_$insufficient_access;
				call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a ^a",
				     "The database """, db_path, """ has been secured,",
				     "so the caller must be a DBA to use direct model access.");

			     end;

		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr = null ();

     end;

/* END CHANGE 81-02-12 ************************************************ */

	declare NULL_OFFSET		 bit (18) init ((18)"1"b); /* mrds version of null offset */
	declare caller_name		 char (32) init ("mrds_dm_open"); /* name of calling routine */
	declare code		 fixed bin (35);	/* a standard Multics system status code */
	declare code_a		 fixed bin (35);	/* temp for mrds_dm_close entry */
	declare code_b		 fixed bin (35);	/* temp for close_dm entry */
	declare code_c		 fixed bin (35);	/* error code for the close_model entry */
	declare continue		 char (1) init ("c"); /* dont stop after print mesg */
	declare data_model_ptr	 ptr;		/* pointer to the data_model to be closed */
	declare data_model_ptr_a	 ptr;		/* temp for rmds_dm_close entry */
	declare data_model_ptr_b	 ptr;		/* temp for close_dm entry */
	declare db_path		 char (168);
	declare error_table_$insufficient_access fixed bin (35) ext; /* not DBA and db secured */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare info_ptr		 ptr init (null ());/* unused */
	declare internal_call	 bit (1);		/* on => called from mrds, not by dmd_ */
	declare ldn		 fixed bin;
	declare local_area		 area (1024);	/* space for db state, and user class info */
	declare mu_open_name_manager$delete_open_name entry (char (*), fixed bin (35)); /* disassociates open name */
	declare mu_open_name_manager$get_model_pointer entry (char (*), char (1), ptr, fixed bin (35)); /* gets model ptr from open name */
	declare model_name		 char (32);
	declare model_ptr		 ptr;
	declare model_type		 char (1);	/* type of opening */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if DBA */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare open_name		 char (*);	/* opening association name */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare (addr, empty, null, rtrim) builtin;

%include mdbm_db_model;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;

     end mrds_dm_close;




		    mrds_dm_create_db.pl1           04/18/85  1429.4rew 04/18/85  0906.4      106056



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

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

/* HISTORY:

   Originally written by Jim Gray - - February 1980

   81-09-17 Davids: deleted the  variable  last_ptr  which  was  the
   index  of  the last pointer in the argument list and replaced all
   references to last_ptr with num_ptrs. This stops a subscriptrange
   condition  from  occuring  when  referencing  the  argument  list
   arg_desc_ptr array.

   81-09-17 Davids: changed cmdb_list so that  it  is  based  rather
   than automatic. If its automatic the dimension of arg_desc_ptr is
   0 since num_ptrs is 0 at the  time  the  structure  is  allocated
   (procedure  is  entered). This causes a subscriptrange condition.
   After cmdb_list is allocated it is necessary to reset  the  value
   of  num_ptrs  to  its larger value (it was set to a smaller value
   becuase cmdb_list does not include the code argument) so that the
   descriptor pointer to the argument before code can be referenced.

   84-10-23 Benjamin: created tidy_up procedure and changed the cleanup handler
   to call it, removing the nonlocal goto that existed.
*/

mrds_dm_create_db: create_db: procedure ();

/* DESCRIPTION:
   this routine provides a subroutine interface to create_mrds_db.
   it should be declared entry options(variable), and arguments should be
   the same character string arguments as would be given at command level.
   it provides the same options and features, but is basically a
   go/no-go interface, returning the error code of the first error encountered.
   some error codes do not provide much detail, because CMDB was
   oriented toward a command level interface with detailed error messages.
   thus a listing should be asked for, to provide full information.
*/

/* PARAMETERS:
   source_path - - (input) char(*), the pathname of the create_mrds_db source,
   with or without the .cmdb suffix

   db_path - - (input) char(*), the pathname of the database to be created.
   the database directory name will get a .db suffix
   if this optional argument is not given, the path defaults to [wd]>source_entry
   with .db replacing the .cmdb suffix

   list_opt - - (input) char(*), if this value is "-list" or "-ls", then a listing
   is produced, with error messages, using the entry portion of source
   path, with cmdb relpaced by the list suffix. this argument is optional.

   storage_opt - - (input) char(*), if this value is "-temp_dir", the next argument
   is used for temporary working storage during the creation of the database.
   this will only be necessary if a record quota overflow occurs in the [pd]

   storage_path - - (input) char(*), the pathname of a directory
   with more quota the the [pd]. this arg must be present if storage_opt is, but both are optional.

   error_code - - (output) fixed bin(35), the error status encoding, 0 unless
   an error occured, in which case it the first error encountered.
*/
%page;
/* make sure we don't leave in an inconsistant state */

	arg_list_ptr = null ();
	num_ptrs, num_dims, nargs, error_code = 0;
	on cleanup call tidy_up;

/* get the callers argument list */

	call cu_$arg_list_ptr (arg_list_ptr);
	nargs = arg_list_ptr -> arg_list.desc_count / 2;
	if nargs = 0 then
	     error_code = error_table_$bad_arg;
	else do;
		if arg_list_ptr -> arg_list.code = SPECIAL then
		     desc_index = nargs + 1;
		else desc_index = nargs;
		num_ptrs = nargs + desc_index;	/* CHANGED 81-09-17 */

/* verify all but the error code are character arguments */

		i = 1;
		done = OFF;
		do while (^done);
		     if arg_list_ptr -> arg_list.arg_des_ptr (desc_index + i) -> descriptor.type ^=
			CHAR_NONVAR then do;
			     done = ON;
			     error_code = error_table_$bad_arg;
			end;
		     else if desc_index + i < num_ptrs - 1 then /* CHANGED 81-09-17 */
			i = i + 1;
		     else done = ON;
		end;
		if error_code ^= 0 then ;
		else do;
			if arg_list_ptr -> arg_list.arg_des_ptr (num_ptrs) -> descriptor_ovrly ^=
			     /* CHANGED 81-09- */
			     FIXED_BIN_35_DESC then
			     error_code = error_table_$bad_arg;
			else do;

/* the arguments have been verified as character and   fixed bin(35) for the error code, now build the arg list
   for the call to the command CMDB, that is the same, minus the error code  */

				num_ptrs = 2 * (nargs - 1);
				call make_cmdb_call ();
			     end;
		     end;
	     end;

/* clean up before leaving */

exit:
	call tidy_up;

	return;
%page;
tidy_up:  procedure ();

	if cmdb_list_ptr ^= null
	then free cmdb_list_ptr -> cmdb_list;

	if nargs <= 0 | arg_list_ptr = null () then ;
	else arg_list_ptr -> arg_list.arg_des_ptr (nargs) -> FB35_ovrly = error_code;

/* reset CMDB for command level use */

	call create_mrds_db$set_command_level ();

     end tidy_up;
%page;
make_cmdb_call: procedure ();

/* routine to build the CMDB arg list,
   and make the call to cmdb as a subroutine */

	allocate cmdb_list set (cmdb_list_ptr);

	num_ptrs = num_ptrs + 2;			/* set it back so that pointers in the
						   larger arg_list.arg_des_ptr array can be referenced */

	cmdb_list.desc_count, cmdb_list.arg_count = 2 * (nargs - 1);
	cmdb_list.code = NORMAL;
	cmdb_list.pad = 0;

	do j = 1 by 1 to nargs - 1;

	     cmdb_list.arg_des_ptr (j) =
		arg_list_ptr -> arg_list.arg_des_ptr (j); /* data pointers */
	     cmdb_list.arg_des_ptr (nargs - 1 + j) =
		arg_list_ptr -> arg_list.arg_des_ptr (desc_index + j); /* descriptor ptrs */

	end;

/* initialize condition information structure */

	my_cond_info.mc_ptr = null ();
	my_cond_info.version = 1;
	my_cond_info.condition_name = " ";
	my_cond_info.info_ptr = null ();
	my_cond_info.wc_ptr = null ();
	my_cond_info.loc_ptr = null ();
	my_cond_info.crawlout = "0"b;
	my_cond_info.pad1 = "0"b;
	my_cond_info.pad2 = "0"b;
	my_cond_info.user_loc_ptr = null ();
	my_cond_info.pad3 (*) = "0"b;

	condition_info_ptr = addr (my_cond_info);


/* set up to capture any command errors */

	first_time = ON;

	on command_error begin;

		if ^first_time then ;
		else do;

			first_time = OFF;

			stack_ptr = null ();	/* use most recent condition frame */

			my_cond_info.condition_name = "command_error";

			call find_condition_info_ (stack_ptr, condition_info_ptr, code);
			if code ^= 0 then
			     error_code = mrds_error_$rst_logic_error;
			else do;
				command_error_info_ptr = condition_info_ptr -> condition_info.info_ptr;
				if command_error_info_ptr = null () then
				     error_code = mrds_error_$rst_logic_error;
				else do;
					error_code = command_error_info_ptr -> command_error_info.status_code;
					if error_code = 0 then
					     error_code = mrds_error_$rst_logic_error;
					command_error_info_ptr -> command_error_info.print_sw = OFF; /* tell com_err_ to shut up */
				     end;

			     end;

		     end;

	     end;

/* set up the mrds_rst_error capture logic */

	on mrds_rst_error begin;

		if ^first_time then ;
		else do;

			first_time = OFF;

			stack_ptr = null ();	/* use most recent condition frame */

			my_cond_info.condition_name = "mrds_rst_error";

			call find_condition_info_ (stack_ptr, condition_info_ptr, code);
			if code ^= 0 then
			     error_code = mrds_error_$rst_logic_error;
			else do;
				mrds_error_cond_ptr = condition_info_ptr -> condition_info.info_ptr;
				if mrds_error_cond_ptr = null () then
				     error_code = mrds_error_$rst_logic_error;
				else do;
					error_code = mrds_error_cond_ptr -> mrds_error_condition_info.status_code;
					if error_code = 0 then
					     error_code = mrds_error_$rst_logic_error;
				     end;

			     end;

		     end;

	     end;

/* tell CMDB to set up for a subroutine call */

	call create_mrds_db$set_subroutine_level ();

/* make the call to the CMDB command */

	call cu_$generate_call (create_mrds_db, addr (cmdb_list));


	declare first_time		 bit (1);		/* on => capture this error, else ignore */
	declare 1 my_cond_info	 like condition_info; /* local version to be filled in by find_cond_info */

     end;
%page;
	declare addr		 builtin;
	declare null		 builtin;
	declare arg_list_ptr	 ptr;		/* points to argument list */
	declare 1 cmdb_list		 like arg_list based (cmdb_list_ptr); /* arg list for CMDB call */
	declare cmdb_list_ptr	 ptr init (null);	/* pointer to the cmdb_list structure */
	declare mrds_error_cond_ptr	 ptr;		/* points to mrds error condition info */
	declare mrds_rst_error	 condition;	/* signaled by mrds_rst_error, when subroutine interface */
	declare command_error	 condition;	/* signaled by com_err_ from CMDB */
	declare cleanup		 condition;	/* signaled upon quit/release */
	declare command_error_info_ptr ptr;		/* points to command_error_info */
	declare cu_$arg_list_ptr	 entry (ptr);	/* gets poinmter to arg list */
	declare nargs		 fixed bin;	/* number of arguments */
	declare SPECIAL		 fixed bin int static options (constant) init (8); /* => extra stack frame ptr */
	declare NORMAL		 fixed bin int static options (constant) init (4); /* => no extra ptrs */
	declare desc_index		 fixed bin;	/* offset to descriuptor pointers */
	declare (i, j)		 fixed bin;	/* loop indexes */
	declare done		 bit (1);		/* on => all char args checked */
	declare ON		 bit (1) int static options (constant) init ("1"b); /* true value */
	declare OFF		 bit (1) int static options (constant) init ("0"b); /* false value */
	declare CHAR_NONVAR		 fixed bin int static options (constant) init (21); /* character nonvarying data type */
	declare descriptor_ovrly	 bit (36) unal based; /* overlay for descriptor */
	declare cu_$generate_call	 entry (entry, ptr);/* makes call given arg list */
	declare create_mrds_db	 entry options (variable); /* CMDB command */
	declare stack_ptr		 ptr init (null ());/* null => most recent */
	declare find_condition_info_	 entry (ptr, ptr, fixed bin (35)); /* gets condition information */
	declare mrds_error_$rst_logic_error fixed bin (35) ext; /* bad program */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare code		 fixed bin (35);	/* local error code */
	declare create_mrds_db$set_command_level entry ();/* sets up for use as command */
	declare create_mrds_db$set_subroutine_level entry (); /* sets up for use as subroutine */
	declare FIXED_BIN_35_DESC	 bit (36) init ("100000100000000000000000000000100011"b) int static options (constant);
	declare error_table_$bad_arg	 fixed bin (35) ext;/* not options variable, character, or fixed bin(35) */
	declare FB35_ovrly		 fixed bin (35) based; /* overlay for assigning error code */
%page;
	declare 1 mrds_error_condition_info based aligned,
%include cond_info_structure;
	2 severity fixed bin,
	     2 severity_high fixed bin;

	declare 1 command_error_info	 aligned based,
%include cond_info_structure;
	2 name_ptr ptr,
	     2 name_lth fixed bin,
	     2 errmess_ptr ptr,
	     2 errmess_lth fixed bin,
	     2 max_errmess_lth fixed bin,
	     2 print_sw bit (1);
%page;
%include mdbm_arg_list;
%include mdbm_descriptor;
%include condition_info;


     end;




		    mrds_dm_db_secured.pl1          03/08/88  1539.2rew 03/08/88  1531.6      137691



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



/****^  HISTORY COMMENTS:
  1) change(88-01-18,Blair), approve(88-02-26,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Add code to use the mrds search list.  SCP 6366.
  2) change(88-02-25,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Create a local area for use by search_paths_$get.
                                                   END HISTORY COMMENTS */


mrds_dm_db_secured: procedure (); return;		/* not a legal entry */

/*
                   BEGIN_DESCRIPTION
   This routine has three entries that will either return the  state
   of  or  turn  the  secured  bit in the database model on/off. The
   entries   are   names   set_db_secured,   reset_db_secured,   and
   get_secured_status.  Changing the state requires that the user be
   a DBA. This secured bit interface will only work  for  version  4
   databases.  The  data  model  must  have been opened by a call to
   dmd_$open_dm.
                   END_DESCRIPTION
*/

/* PARAMETERS:
   data_model_ptr - - (input) pointer, the  pointer  the  data  base
   model  returned  from  a  call  to  dmd_$open_dm  for  the  given
   database. (all entries but get_secured_state)

   rel_db_path - - (input) char(*), the  relative  pathname  of  the
   database whose secured state is to be determined, with or without
   the suffix. This is for the get_secure_state entry only.

   area_ptr - - (input) pointer,  for  the  get  entry  only,  to  a
   freeing  area  of  at least 20 words, in which the database_state
   structure is to be allocated.

   structure_version - - (input) fixed bin, for the get entry  only,
   the desired version of the structure. Normaly, the version number
   given in the include file.

   database_state_ptr - - (output) pointer, for the get entry  only,
   a  pointer  to the mrds_database_state.incl.pl1 defined structure
   that has been allocated in the area supplied  by  the  user,  and
   with  the  requested  version.  this  routine  will  fill  in the
   database state parameters in the structure.

   error_code - - (output) fixed bin(35), the error status encoding,
   0 unless an error occurred.  */

/* HISTORY:

   Originally written by Jim Gray - - November 1980

   81-01-20 Jim Gray : changed from mrds_dm_set_db_secured, with two
   set/reset  entries,  into  mrds_dm_db_secured,  with  a third get
   entry, replacing mrds_dm_get_secured_status.  The  get  interface
   was  extended  from 1 bit, to an extensible structure. Calls were
   added to the new authorization (DBA) handling  routines,  instead
   of handling this logic internally.

   81-04-20 Jim Gray : added entry for  mmi_$get_secured_state  that
   uses  a db_path rether than a db_model pointer. Also added use of
   mrds_dm_check_path,  and  use   of   hcs_$status_   rather   than
   hcs_$get_user_effmode.

   83-02-24 Davids: explicitly declared variables that were declared by
   context or implication. Deleted declarations to variables that were
   never referenced.
*/

/* entry to set secured bit on */

set_db_secured: entry (data_model_ptr, error_code);

	dbm_ptr = data_model_ptr;
	secure_bit = "1"b;
	set_operation = "1"b;

	call common ();

	return;


/* entry to turn the secured bit off */

reset_db_secured: entry (data_model_ptr, error_code);

	dbm_ptr = data_model_ptr;
	secure_bit = "0"b;
	set_operation = "1"b;

	call common ();

	return;

/* entry to get database secured state info */

get_secured_status: entry (data_model_ptr, area_ptr, structure_version, database_state_ptr, error_code);

	dbm_ptr = data_model_ptr;
	set_operation = "0"b;
	database_state_ptr = null ();

	call common ();

	return;


/* entry to get secured db state, using path rather than model ptr */

get_secured_state: entry (rel_db_path, area_ptr, structure_version, database_state_ptr, error_code);

dcl gs_local_area area (2048);

	database_state_ptr = null ();			/* init */
	use_search_paths = "0"b;
	if search (rel_db_path, "<>") = 0 then do;
	     call search_paths_$get (MRDS_SEARCHLIST, sl_control_default, "", null (), addr(gs_local_area), sl_info_version_1, mrds_search_list_ptr, error_code);
	     if error_code ^= 0 then return;
	     loop_idx = mrds_search_list_ptr -> sl_info.num_paths;
	     use_search_paths = "1"b;
	     end;
	else do;
	     call absolute_pathname_ (rel_db_path, abs_path, error_code);
	     if error_code ^= 0 then return;
	     loop_idx = 1;
	     end;
	error_code = 1;
	do idx = 1 to loop_idx while (error_code ^= 0);
	     if use_search_paths then abs_path = pathname_ (mrds_search_list_ptr -> sl_info.paths(idx).pathname, rel_db_path);
	     call mrds_dm_check_path (abs_path, containing_dir, db_dir, new_found, error_code);
	     if error_code = error_table_$incorrect_access then
		error_code = 0;			/* ignore access problems for right now,
		     may need to set acl's for a DBA */
	     end;                                              /* end do */
	if error_code = 0 then do;
		if ^new_found then
		     error_code = mrds_error_$version_not_supported;
		else do;

			db_path = rtrim (containing_dir) || ">" || db_dir;
			dbm_ptr = null ();

			set_operation = "0"b;

			call common ();

		     end;
	     end;

	return;

common: procedure ();

/* initialize */

	error_code = 0;

/* check for a valid pointer to a version 4 database model */

	if dbm_ptr = null () & ^set_operation then
	     model_name = "db_model";			/* get_secured_state entry */
	else call hcs_$fs_get_path_name (dbm_ptr, db_path, ldn, model_name, error_code);
	if error_code ^= 0 then ;
	else if model_name ^= "db_model" then
	     error_code = mrds_error_$version_not_supported;
	else do;

/* determine action based on entry called */

		if set_operation then
		     call change_secured_state ();
		else call get_secured_info ();

	     end;

     end;

change_secured_state: procedure ();

/* check for correct access by DBA type, to set secured bit */

	call check_access ();			/* this will fail if user not dba */
	if error_code ^= 0 then ;
	else do;


/* change the secured bit in an indivisible operation */

		secure_word_ptr = addr (dbm_ptr -> db_model.consistant);
		old_secure_word = secure_word;
		unspec (new_secure_word) = secure_word;
		new_secure_word.mdbm_secured = secure_bit;

		changed = "0"b;
		do while (^changed);

		     changed = stacq (unspec (secure_word),
			unspec (new_secure_word), unspec (old_secure_word));

		end;

	     end;

     end;

check_access: procedure ();

/* check for correct access by DBA type, to set secured bit */

	DBA, set_ok, read_ok, unspec (my_status_branch) = "0"b; /* init */

/* check for access on the db_model segment */

	call hcs_$status_ (rtrim (db_path), rtrim (model_name), dont_chase_links,
	     addr (my_status_branch), addr (local_area), error_code);

	if error_code = 0 | error_code = error_table_$incorrect_access |
	     error_code = error_table_$no_s_permission then do;

		error_code = 0;

		access_mode_overlay_ptr = addr (my_status_branch.mode);

		if access_mode_overlay.read & access_mode_overlay.write then
		     set_ok = "1"b;
		if access_mode_overlay.read then
		     read_ok = "1"b;

/* find out if the user is a DBA */

		call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
		     mrds_authorization_structure_version, mrds_authorization_ptr, error_code);
		if error_code = 0 then
		     DBA = mrds_authorization.administrator;

	     end;

/* if an access violation occured, try to set access for the user.
   This will fail if the user is not a DBA. */

	if error_code = 0 then do;
		if DBA then do;
			if ((set_operation & ^set_ok) | (^set_operation & ^read_ok)) then
			     call mrds_dm_authorization$set_needed_access (rtrim (db_path), error_code);
		     end;
		else do;				/* non-DBA */
			if set_operation then
			     error_code = error_table_$insufficient_access;
			else if ^read_ok then /* no set operation */
			     error_code = mrds_error_$no_model_access;
		     end;

	     end;

     end;

get_secured_info: procedure ();

/* set access for a DBA if needed */

	call check_access ();
	if error_code = 0 then do;

/* we may need to get the model pointer for the get_secured_state entry */

		if dbm_ptr = null () then
		     call hcs_$initiate (rtrim (db_path), "db_model", "",
			0, 1, dbm_ptr, error_code);
		if dbm_ptr ^= null () then do;

			error_code = 0;

/* check on input parameters for correctness */

			if area_ptr = null () then
			     error_code = error_table_$badcall;
			else do;

				unspec (my_area_info) = "0"b;
				my_area_info.version = 1;
				my_area_info.areap = area_ptr;

				call area_info_ (addr (my_area_info), error_code);
				if error_code ^= 0 then ; /* couldn't get area info */
				else if my_area_info.no_freeing then
				     error_code = mrds_error_$not_freeing_area;
				else do;

					if structure_version ^= mrds_authorization_structure_version then
					     error_code = error_table_$unimplemented_version;
					else do;

/* set up for too small an area given */

						on area begin;
							error_code = error_table_$area_too_small;
							goto skip_allocate;
						     end;

						allocate database_state set (database_state_ptr) in (work_area);
						revert area;
						unspec (database_state) = "0"b; /* init */

/* fill in the structure info details */

						database_state.version = database_state_structure_version;
						database_state.secured = db_model.mdbm_secured;
						database_state.unsecured = ^(database_state.secured);
						database_state.mbz = "0"b;

skip_allocate:
					     end;
				     end;
			     end;
		     end;
	     end;
     end;

	declare DBA		 bit (1);		/* on => user is a DBA */
          declare MRDS_SEARCHLIST        char (4) int static options (constant) init ("mrds");
          declare abs_path               char (168);
          declare absolute_pathname_     entry (char(*), char(*), fixed bin(35));
	declare access_mode_overlay_ptr ptr;		/* points to mode bits */
	declare area		 condition;	/* not enough space left */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area specs */
	declare area_ptr		 ptr;		/* pointer to area for allocation of structure */
	declare changed		 bit (1);		/* on => change successfull */
	declare containing_dir	 char (168);	/* containing directory of database */
	declare data_model_ptr	 ptr;		/* pointer to database model */
	declare db_dir		 char (32);	/* directory name of database */
	declare db_path		 char (168);	/* pathname of database */
	declare dont_chase_links	 fixed bin (1) init (0); /* dont follow links */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$area_too_small fixed bin (35) ext; /* can't allocate structure */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$incorrect_access fixed bin (35) ext; /* no acl on dir or object */
	declare error_table_$insufficient_access fixed bin (35) ext; /* not sma on db_dir or rw on db_model */
	declare error_table_$no_s_permission fixed bin (35) ext; /* no "s" on containing dir */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* bad structure version */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); /* gets path from pointer */
	declare hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2),
				 ptr, fixed bin (35)); /* gets ptr to seg */
	declare hcs_$status_	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); /* gets access modes */
          declare idx                    fixed bin;         /* index to search path loop */
          declare loop_idx               fixed bin;         /* number of entries in search list */
	declare ldn		 fixed bin;	/* length of db dir name */
	declare local_area		 area (2048);	/* temp space for authorization structure */
	declare model_name		 char (32);	/* name of database model */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* detects DBA's */
	declare mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets all access DBA needs */
	declare mrds_dm_check_path	 entry (char (*), char (168), char (32), bit (1), fixed bin (35)); /* check for path to db */
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no "r" to db_model */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attr for area */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 database */
          declare mrds_search_list_ptr   pointer;
	declare new_found		 bit (1);		/* on => new version db arch */
	declare old_secure_word	 bit (36);	/* value before change is made */
          declare pathname_              entry (char(*), char(*)) returns(char(168));
	declare read_ok		 bit (1);		/* on => user has access to read state */
	declare rel_db_path		 char (*);	/* relative database path */
          declare search                 builtin;
          declare search_paths_$get      entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35));
	declare secure_bit		 bit (1);		/* on => secured */
	declare secure_word		 bit (36) aligned based (secure_word_ptr); /* bits to be change in model */
	declare secure_word_ptr	 ptr;		/* points to proper spot in model */
	declare set_ok		 bit (1);		/* on => user has access to write state */
	declare set_operation	 bit (1);		/* on => set or reset to be done */
	declare structure_version	 fixed bin;	/* desired version of output structure */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
          declare use_search_paths        bit (1);
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr); /* overlay for users area */
	declare (addr, empty, fixed, null, rel, rtrim, stacq, unspec) builtin;
	declare 1 access_mode_overlay	 unal based (access_mode_overlay_ptr), /* overlay for mode bits */
		2 pad1		 bit (1) unal,
		2 read		 bit (1) unal,
		2 exec		 bit (1) unal,
		2 write		 bit (1) unal,
		2 pad2		 bit (1) unal;
	declare 1 my_area_info	 like area_info;	/* local copy */
	declare 1 my_status_branch	 like status_branch;/* local copy */
	declare 1 new_secure_word	 aligned,		/* overlay for portion of db_model with secured bit */
		2 consistent	 bit (1) unal,
		2 mdbm_secured	 bit (1) unal,
		2 reserved	 bit (34) unal;

%include mrds_database_state;
%page;
%include sl_control_s;
%page;
%include sl_info;
%include status_structures;
%page;
%include mrds_authorization;
%page;
%include area_info;
%page;
%include mdbm_db_model;
%page;

     end;




		    mrds_dm_display.pl1             10/16/86  1550.5rew 10/16/86  1142.7      342738



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

/* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */

mrds_dm_display:
     proc (I_mrds_dm_display_info_ptr, O_err_msg, O_err_code);

/* BEGIN DESCRIPTION

   The purpose of this procedure is to display the db_model info.

   The output is through the iocb_ptr supplied in mrds_dm_display_info.

   END DESCRIPTION */


/****^  HISTORY COMMENTS:
  1) change(82-05-20,DWoodka), approve(), audit(), install():
     written.
  2) change(82-08-18,DWoodka), approve(), audit(), install():
     modified to remove bit offset and bit length numbers from the display
     and include the database type (page_file or vfile) for the DMS conversion.
  3) change(83-02-14,Davids), approve(), audit(), install():
     modified to use the new db_type_flags in the db_model structure instead
     of the old numeric db_type.
  4) change(83-02-28,Davids), approve(), audit(), install():
     Modified to indicate that Rollback is on/off instead of before journalling
     to keep it consistent with the rest of the user interface.
  5) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     modified to use crossreference file. display unreferenced objects.
     display crossreferences.
                                                   END HISTORY COMMENTS */


/*      PARAMETERS     */

dcl  I_mrds_dm_display_info_ptr ptr parameter;		/* Pointer to mrds_dm_display_info structure */
dcl  O_err_code fixed bin (35) parameter;		/* Error code */
dcl  O_err_msg char (*) parameter;			/* Text of error message */

%page;

/*      INITIALIZATION     */

	mrds_dm_display_info_ptr = I_mrds_dm_display_info_ptr;
						/* Init parameters */
	O_err_msg = "";
	O_err_code = 0;

	iocb_ptr = mrds_dm_display_info.output_iocb_ptr;	/* For faster reference */
	temp_file_iocb_ptr, second_temp_file_iocb_ptr = null;
						/* Used in tidy_up */
	dbm_ptr = mrds_dm_display_info.dbm_ptr;

	max_seg_size = sys_info$max_seg_size * 4;

	temp_seg_ptrs (*), fm_ptr = null;
	on cleanup call tidy_up;			/* Establish cleanup handler */

	if mrds_dm_display_info.version ^= MRDS_DM_DISPLAY_INFO_VERSION_1
	then call error (error_table_$unimplemented_version, "^/For mrds_dm_display_info.version");
%page;

/*    print header    */

	if mrds_dm_display_info.sw.header
	then call print_header;

/*    display cmdb format    */

	if mrds_dm_display_info.sw.cmdb
	then call mrds_dm_display_cmdb (mrds_dm_display_info_ptr, err_msg, code);

/*    display domains    */

	if mrds_dm_display_info.sw.domains
	then call print_domain_info;

/*    display attribute info    */

	if mrds_dm_display_info.sw.attribute
	then call print_attrib_info;

/*   display relation info     */

	if mrds_dm_display_info.sw.relation
	then call print_rel_info;

/*    display index info    */

	if mrds_dm_display_info.sw.index
	then call print_index_info;

/*    display domain crossreference    */

	if mrds_dm_display_info.sw.domain_xref
	then call print_xref (DOMAIN_KEY_HEAD, 1);

/*    display attribute crossreference    */

	if mrds_dm_display_info.sw.attribute_xref
	then call print_xref (ATTRIBUTE_KEY_HEAD, 2);

/*    display complete crossreference    */

	if mrds_dm_display_info.sw.all_xref
	then call print_complete_xref;

/*    display history info    */

	if mrds_dm_display_info.sw.history
	then call mrds_dm_display_history (mrds_dm_display_info_ptr, err_msg, code);

	call tidy_up;

exit:
	return;

%page;

print_rel_info:
     proc;

dcl  pii_object  char (32);

	if mrds_dm_display_info.sw.names_only
	then call ioa_$ioa_switch (iocb_ptr, "^/RELATION NAMES:");
	if rel_name_list_ptr = null
	then call print_all_relations;
	else do i = 1 to rel_name_list_ptr -> name_list.num_names;
	     pii_object = (rel_name_list_ptr -> name_list.name (i));
	     call print_object (pii_object);
	     end;

	call ioa_$ioa_switch (iocb_ptr, "");		/* add a line feed */

     end print_rel_info;
%page;



print_all_relations:
     proc;					/* called by print_rel_info */

dcl  par_object char (30);

	if db_model.num_rels < 1
	then do;
	     call ioa_$ioa_switch (iocb_ptr, "^2/There are no relations defined for the database^/^a",
		mrds_dm_display_info.db_path);
	     return;
	     end;
	else do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= NULL_OFFSET);	/* loop through all relations (files) */

	          par_object = file_info.file_name;
	          call print_object (par_object);
		end;
     end print_all_relations;



print_object:
	proc (po_object_of_print);

dcl   po_object_of_print char (*) parameter;
	
		file_model_name = rtrim (po_object_of_print) || ".m";
						/* get relation name */
		call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
		if fm_ptr = null
		then call error (mrds_error_$no_model_rel, "^/" || rtrim (rel_name_list_ptr -> name_list.name (i)));

		ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
						/* relation info ptr */
		if mrds_dm_display_info.sw.names_only
		then call ioa_$ioa_switch (iocb_ptr, "^a", rel_info.name);
						/* print relation name */
		else if mrds_dm_display_info.sw.default
		     then call print_rel_info_default;
		     else if mrds_dm_display_info.sw.long
			then call print_rel_info_long;
			else call print_rel_info_brief;

		call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));

	end print_object;
%page;

print_rel_info_brief:
print_rel_info_default:
     proc;					/* print relation info for default or brief switch */
						/* called by print_rel_info or print_all_relations */


	call ioa_$ioa_switch (iocb_ptr, "^2/RELATION: ^5x^32a", rel_info.name);
	if rel_info.num_attr > 1
	then plural = "S";
	else plural = "";

	printed_one_sw = "0"b;

	do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* get attribute info */
	     repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET);

	     if ^mrds_dm_display_info.sw.default
	     then /* Brief form */
		if ^printed_one_sw
		then do;
		     call ioa_$ioa_switch (iocb_ptr, "^/^3x^22a^a", "ATTRIBUTE" || plural || ":", attr_info.name);
		     printed_one_sw = "1"b;
		     end;
		else call ioa_$ioa_switch (iocb_ptr, "^25x^a", attr_info.name);
	     else do;				/* Default form */
		if ^printed_one_sw
		then do;
		     call ioa_$ioa_switch (iocb_ptr, "^/^3x^a", "ATTRIBUTE" || plural || ":");
		     printed_one_sw = "1"b;
		     end;

		if attr_info.key_attr
		then type = "Key";
		else type = "Data";

		if attr_info.index_attr
		then indx = "Index";
		else indx = "";

		untrimmed_dcl =
		     mdbm_util_$display_descriptor (
		     addr (pointer (dbm_ptr, attr_info.domain_ptr) -> domain_info.user_desc));
		dcl_trimmed = mdbm_util_$trim_descriptor (untrimmed_dcl);

		call ioa_$ioa_switch (iocb_ptr, "^6x^32a^2x^a^2x^a", attr_info.name, type, indx);
		call ioa_$ioa_switch (iocb_ptr, "^10x^a", dcl_trimmed);

		end;
	     end;
     end print_rel_info_brief;
%page;

print_rel_info_long:
     proc;					/* called by print_rel_info or print_all_relations */


	rel_long.rel_name = rel_info.name;
	rel_long.nattrs = rel_info.num_attr;

	call iox_$put_chars (iocb_ptr, addr (rel_long), length (string (rel_long)), code);
	if code ^= 0
	then call error (code, "");


	if rel_info.num_attr > 1
	then plural = "S";
	else plural = "";


	call ioa_$ioa_switch_nnl (iocb_ptr, "^2/^3x^a:", "ATTRIBUTE" || plural);

	do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* get attribute info */
	     repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET);

	     if attr_info.key_attr
	     then type = "Key";
	     else type = "Data";

	     if attr_info.index_attr
	     then indx = "Index";
	     else indx = "";

	     call ioa_$ioa_switch (iocb_ptr, "^2/^6xName:^7x^a", attr_info.name);
	     call ioa_$ioa_switch (iocb_ptr, "^6xType:^7x^a^2x^a", type, indx);

	     di_ptr = pointer (dbm_ptr, attr_info.domain_ptr);

	     call ioa_$ioa_switch (iocb_ptr, "^6xDomain_info:^/^12xname: ^a", domain_info.name);

	     call ioa_$ioa_switch_nnl (iocb_ptr, "^12xdcl:  ^a",
		mdbm_util_$display_descriptor (addr (domain_info.db_desc)));
	     if domain_info.check_path_ptr ^= NULL_OFFSET
	     then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-check_proc ^a",
		     get_path_entry (domain_info.check_path_ptr, "$"));

	     if domain_info.encd_path_ptr ^= NULL_OFFSET
	     then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-encode_proc ^a",
		     get_path_entry (domain_info.encd_path_ptr, "$"));

	     if domain_info.decd_path_ptr ^= NULL_OFFSET
	     then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_proc ^a",
		     get_path_entry (domain_info.decd_path_ptr, "$"));

	     if domain_info.db_desc ^= domain_info.user_desc
	     then /* It had a -decode_dcl */
		call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_dcl ^/^15x^a",
		     mdbm_util_$display_descriptor (addr (domain_info.user_desc)));
	     call ioa_$ioa_switch (iocb_ptr, "");	/* add a line feed */

	     end;

     end print_rel_info_long;

%page;

print_domain_info:
     proc;
	if db_model.domain_ptr = NULL_OFFSET
	then do;
	     call ioa_$ioa_switch (iocb_ptr, "^2/No domains exist for the database^/^a", mrds_dm_display_info.db_path);
	     return;
	     end;

	if mrds_dm_display_info.sw.names_only
	then call ioa_$ioa_switch (iocb_ptr, "^2/DOMAIN NAMES:");
	else do;
	     if db_model.num_domains > 1
	     then plural = "S";
	     else plural = "";
	     call ioa_$ioa_switch (iocb_ptr, "^2/DOMAIN" || plural || ":");
	     end;

	if dom_name_list_ptr = null
	then do;
	     printed_one_sw = "0"b;
	     do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) /* loop through all domains */
		repeat ptr (dbm_ptr, domain_info.fwd_thread) while (rel (di_ptr) ^= NULL_OFFSET);
		if (mrds_dm_display_info.sw.unreferenced_domains & domain_info.unreferenced)
		     | (^mrds_dm_display_info.sw.unreferenced_domains)
		then do;
		     if mrds_dm_display_info.sw.names_only
		     then call ioa_$ioa_switch (iocb_ptr, "^a", domain_info.name);
						/* print domain name */
		     else call print_domain;
		     printed_one_sw = "1"b;
		     end;
		end;
	     if ^printed_one_sw
	     then call ioa_$ioa_switch (iocb_ptr, "^2/No unreferenced domains exist for the database^/^a",
		     mrds_dm_display_info.db_path);
	     end;
	else do i = 1 to dom_name_list_ptr -> name_list.num_names;
		di_ptr = ptr (dbm_ptr, db_model.domain_ptr);

		do while (domain_info.name ^= dom_name_list_ptr -> name_list.name (i));
		     di_ptr = ptr (dbm_ptr, domain_info.fwd_thread);
		     if rel (di_ptr) = NULL_OFFSET
		     then call error (mrds_error_$no_model_dom,
			     "^/" || rtrim (dom_name_list_ptr -> name_list.name (i)));
		     end;


		if mrds_dm_display_info.sw.names_only
		then call ioa_$ioa_switch (iocb_ptr, "^a", domain_info.name);
						/* print domain name */
		else call print_domain;
		end;

	call ioa_$ioa_switch (iocb_ptr, "");		/* add a line feed */

     end print_domain_info;
%page;

print_domain:
     proc;					/* called by print_domain_info */

	long_desc_str = mdbm_util_$display_descriptor (addr (domain_info.db_desc));
	if mrds_dm_display_info.sw.long
	then do;
	     desc_str = long_desc_str;
	     call ioa_$ioa_switch_nnl (iocb_ptr, "^-^a^/^-^5x^a", domain_info.name, desc_str);
	     end;
	else do;
	     desc_str = mdbm_util_$trim_descriptor (long_desc_str);
	     call ioa_$ioa_switch_nnl (iocb_ptr, "^-^20a^1x^a", domain_info.name, desc_str);
	     end;

	if domain_info.check_path_ptr ^= NULL_OFFSET
	then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-check_proc ^a",
		get_path_entry (domain_info.check_path_ptr, "$"));

	if domain_info.encd_path_ptr ^= NULL_OFFSET
	then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-encode_proc ^a",
		get_path_entry (domain_info.encd_path_ptr, "$"));

	if domain_info.decd_path_ptr ^= NULL_OFFSET
	then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_proc ^a",
		get_path_entry (domain_info.decd_path_ptr, "$"));

	if domain_info.db_desc ^= domain_info.user_desc
	then call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_dcl ^/^15x^a",
		mdbm_util_$display_descriptor (addr (domain_info.user_desc)));

	call ioa_$ioa_switch (iocb_ptr, "");		/* add a line feed */
     end print_domain;
%page;

print_attrib_info:
     proc;

	if ^mrds_dm_display_info.sw.header
	then call build_db_attr_list;			/* if the attribute list is not already built */

          if (db_model.unreferenced_attribute_ptr = NULL_OFFSET & mrds_dm_display_info.unreferenced_attributes)
	     then do;
	     call ioa_$ioa_switch (iocb_ptr, "^2/No unreferenced attributes exist for the database^/^a", mrds_dm_display_info.db_path);
	     return;
	     end;
	if mrds_dm_display_info.sw.names_only
	then call ioa_$ioa_switch (iocb_ptr, "^2/ATTRIBUTE NAMES:");
	else do;
	     call ioa_$ioa_switch (iocb_ptr, "^/ATTRIBUTES:");
	     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^-^20a^1x^a^/", "NAME:", "DOMAIN:");
	     end;

	call iox_$position (temp_file_iocb_ptr, BOF, 0, code);
	if code ^= 0
	then call error (code, "Positioning temp file to BOF");

	if attr_name_list_ptr = null
	then if mrds_dm_display_info.sw.unreferenced_attributes
	     then do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
	          repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET);

	          if mrds_dm_display_info.sw.names_only
		then call ioa_$ioa_switch (iocb_ptr, "^a", unreferenced_attribute.name);
	          else do;
		     di_ptr = ptr (dbm_ptr, unreferenced_attribute.domain_ptr);
		     call ioa_$ioa_switch (iocb_ptr, "^-^20a^1x^a", unreferenced_attribute.name,
			domain_info.name);
		     end;
		end;				/* do ua_ptr */
	     
	     else do;
		seek_head_info.n = length (ATTRIBUTE_KEY_HEAD);
		seek_head_info.search_key = ATTRIBUTE_KEY_HEAD;

		call iox_$control (temp_file_iocb_ptr, "seek_head", addr (seek_head_info), code);
		if code = error_table_$no_record
		then code = error_table_$end_of_info;

		do while (code = 0);

		     call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
		     if code = 0
		     then if substr (key, 1, length (ATTRIBUTE_KEY_HEAD)) = ATTRIBUTE_KEY_HEAD
			then if mrds_dm_display_info.sw.names_only
			     then do;
				call ioa_$ioa_switch (iocb_ptr, "^a",
				     substr (key, length (ATTRIBUTE_KEY_HEAD) + 1));
				call iox_$position (temp_file_iocb_ptr, 0, 1, code);
				end;
			     else do;
				call iox_$read_record (temp_file_iocb_ptr, temp_seg_ptr, 8, (0), code);

				if (code = 0) | (code = error_table_$long_record)
				then do;
				     di_ptr = ptr (dbm_ptr, temp_seg_ptr -> crossref_info_record.offset);
				     call ioa_$ioa_switch (iocb_ptr, "^-^20a^1x^a",
					substr (key, length (ATTRIBUTE_KEY_HEAD) + 1),
					di_ptr -> domain_info.name);
				     code = 0;
				     end;
				else call error (code, "Reading attribute record from xref file for key: " || key);
				end;
			else code = error_table_$end_of_info;
		     end;

		if code ^= error_table_$end_of_info
		then call error (code, "Getting attribute names from temp file");
		end;

	else do i = 1 to attr_name_list_ptr -> name_list.num_names;
		key = ATTRIBUTE_KEY_HEAD || rtrim (attr_name_list_ptr -> name_list.name (i));
		call iox_$seek_key (temp_file_iocb_ptr, key, (0), code);
		if code ^= 0
		then call error (mrds_error_$no_model_attr, "^/" || rtrim (attr_name_list_ptr -> name_list.name (i)));

		if mrds_dm_display_info.sw.names_only
		then call ioa_$ioa_switch (iocb_ptr, "^a", attr_name_list_ptr -> name_list.name (i));
		else do;
		     call iox_$read_record (temp_file_iocb_ptr, temp_seg_ptr, 8, (0), code);
		     if (code = 0) | (code = error_table_$long_record)
		     then do;
			di_ptr = ptr (dbm_ptr, temp_seg_ptr -> crossref_info_record.offset);

			call ioa_$ioa_switch (iocb_ptr, "^-^20a^1x^a", attr_name_list_ptr -> name_list.name (i),
			     di_ptr -> domain_info.name);
			code = 0;           /* in case the code was long_record */
			end;
		     else call error (code, "Reading attribute record from xref file for key: " || key);
		     end;
		end;

	call ioa_$ioa_switch (iocb_ptr, "");	/* add a new_line */

	return;
     end print_attrib_info;

%page;

build_db_attr_list:
     proc;					/* called by print_header or print_attrib_info */

	if temp_file_iocb_ptr ^= null
	then return;

	temp_file_iocb_ptr = mrds_dm_display_info.xref_iocb_ptr;
	if temp_file_iocb_ptr = null
	then do;
	     call mu_db_xref$xref_build (mrds_dm_display_info.temp_dir_path, mrds_dm_display_info.db_path, dbm_ptr,
		mrds_dm_display_info.xref_name, mrds_dm_display_info.xref_iocb_ptr, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);

	     end;

	temp_file_iocb_ptr = mrds_dm_display_info.xref_iocb_ptr;
	temp_file_attach_name = mrds_dm_display_info.xref_name;

	call mu_temp_segments$get_temp_segment_path (mrds_dm_display_info.temp_dir_path, myname, temp_seg_ptr, code);
	if code ^= 0
	then call error (code, "Getting a temp segment in [pd].");

	return;
     end build_db_attr_list;

%page;
print_index_info:
     proc;

	if mrds_dm_display_info.sw.names_only
	then call ioa_$ioa_switch (iocb_ptr, "^/INDEXED RELATION NAMES:");

	if index_name_list_ptr = null
	then call print_all_indexes;
	else do i = 1 to index_name_list_ptr -> name_list.num_names;

		file_model_name = rtrim (index_name_list_ptr -> name_list.name (i)) || ".m";
						/* get index name */
		call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
		if fm_ptr = null
		then call error (mrds_error_$no_model_rel, "^/" || rtrim (index_name_list_ptr -> name_list.name (i)));

		ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
						/* relation info ptr */

		if ^rel_info.indexed
		then call ioa_$ioa_switch (iocb_ptr, "^/^3xThe relation ^a is not indexed^/", rel_info.name);

		else do;				/* if the relation is indexed */

		     if mrds_dm_display_info.sw.names_only
		     then call ioa_$ioa_switch (iocb_ptr, "^a", index_name_list_ptr -> name_list.name (i));
		     else do;
			call ioa_$ioa_switch (iocb_ptr, "^2/INDEXED RELATION: ^8x^32a",
			     index_name_list_ptr -> name_list.name (i));


			call ioa_$ioa_switch (iocb_ptr, "^/^3x^a", "INDEXED ATTRIBUTES:");


			do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* loop through attributes */
			     repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET);

			     if attr_info.index_attr
			     then call ioa_$ioa_switch (iocb_ptr, "^6x^a", attr_info.name);
			     end;
			end;
		     end;

		call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
		end;

	call ioa_$ioa_switch (iocb_ptr, "");		/* add line feed */

     end print_index_info;
%page;

print_all_indexes:
     proc;					/* called by print_index_info */

	if db_model.num_rels < 1
	then do;
	     call ioa_$ioa_switch (iocb_ptr, "^2/There are no relations defined for the database^/^a",
		mrds_dm_display_info.db_path);
	     return;
	     end;
	else do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= NULL_OFFSET);	/* loop through all relations (files) */

		file_model_name = rtrim (file_info.file_name) || ".m";
						/* get relation name */

		call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
		if fm_ptr = null
		then call error (code, "^/" || rtrim (db_path) || file_model_name);

		ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
						/* relation info Ptr */

		if rel_info.indexed
		then do;

		     if mrds_dm_display_info.sw.names_only
		     then call ioa_$ioa_switch (iocb_ptr, "^a", rel_info.name);
		     else do;
			call ioa_$ioa_switch (iocb_ptr, "^2/INDEXED RELATION: ^8x^32a", rel_info.name);


			call ioa_$ioa_switch (iocb_ptr, "^/^3x^a", "INDEXED ATTRIBUTES:");

			do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* loop through attributes */
			     repeat ptr (fm_ptr, attr_info.fwd_thread) while (rel (ai_ptr) ^= NULL_OFFSET);

			     if attr_info.index_attr
			     then call ioa_$ioa_switch (iocb_ptr, "^6x^a", attr_info.name);
			     end;

			end;

		     end;

		call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
		end;

     end print_all_indexes;

%page;
print_header:
     proc;


	call build_db_attr_list;
	call mu_db_xref$xref_statistics (temp_file_iocb_ptr, (0), total_attributes, (0), error_message, code);
	if code ^= 0
	then call error (code, error_message);

	if db_model.db_type_flags.vfile_type
	then call ioa_$ioa_switch (iocb_ptr, "DATA MODEL FOR VFILE DATA BASE  ^a", mrds_dm_display_info.db_path);
						/* Database path */
	else do;
	     call ioa_$ioa_switch (iocb_ptr, "DATA MODEL FOR DMFILE DATA BASE  ^a", mrds_dm_display_info.db_path);
						/* Database path */
	     if db_model.db_type_flags.transactions_needed
	     then do;
		call ioa_$ioa_switch (iocb_ptr, "^-Database requires transactions");
		call ioa_$ioa_switch (iocb_ptr, "^-   Rollback is    ^[on^;off^]", db_model.db_type_flags.rollback_on)
		     ;
		call ioa_$ioa_switch (iocb_ptr, "^-   Concurrency is ^[on^;off^]",
		     db_model.db_type_flags.concurrency_on);
		end;
	     else call ioa_$ioa_switch (iocb_ptr, "^-Database does not require transactions");
	     end;

	if db_model.mdbm_secured
	then call ioa_$ioa_switch (iocb_ptr, "Data base secured.");

	header_1.version_num = db_model.version;

	changer_ptr = pointer (dbm_ptr, db_model.changer_ptr);
						/* last on list = creator */

	do while (changer_ptr -> changer.next ^= NULL_OFFSET);
	     changer_ptr = pointer (dbm_ptr, changer_ptr -> changer.next);
	     end;

	header_1.creator = changer_ptr -> changer.id;

	call date_time_ ((changer_ptr -> changer.time), header_1.create_time);

	call iox_$put_chars (iocb_ptr, addr (header_1), length (string (header_1)), code);
	if code ^= 0
	then call error (code, "");

	if pointer (dbm_ptr, db_model.changer_ptr) -> changer.next ^= NULL_OFFSET
	then do;					/* If db_model has been changed */
	     header_2.changer = pointer (dbm_ptr, db_model.changer_ptr) -> changer.id;
	     call date_time_ ((pointer (dbm_ptr, db_model.changer_ptr) -> changer.time), header_2.change_time);
	     call iox_$put_chars (iocb_ptr, addr (header_2), length (string (header_2)), code);
	     if code ^= 0
	     then call error (code, "");

	     end;

	header_3.num_rels = db_model.num_rels;

	header_3.num_attrs = total_attributes;		/*  count all attributes */

	header_3.num_domains = db_model.num_domains;

	call iox_$put_chars (iocb_ptr, addr (header_3), length (string (header_3)), code);
	if code ^= 0
	then call error (code, "");

	call ioa_$ioa_switch (iocb_ptr, "");		/* Add a line feed */

     end print_header;


%page;
print_xref:
     proc (px_key_head, px_type);

dcl  px_key_head char (*) parameter;
dcl  px_loop fixed bin;
dcl  px_type fixed bin parameter;

	call build_db_attr_list;

	call iox_$position (temp_file_iocb_ptr, BOF, 0, code);
	if code ^= 0
	then call error (code, "Positioning temp file to BOF");

	seek_head_info.n = length (px_key_head);
	seek_head_info.search_key = px_key_head;

	call iox_$control (temp_file_iocb_ptr, "seek_head", addr (seek_head_info), code);
	if code ^= 0
	then if code = error_table_$no_record
	     then do;
		call ioa_$ioa_switch (iocb_ptr, "^2/No ^[domains^;attributes^] exist for the database.", px_type = 1);
		return;
		end;
	     else call error (code, "Seeking to first domain xref record");

	printed_one_sw = "0"b;
	call ioa_$ioa_switch (iocb_ptr, "^2/^[^20a^1x^;^s^]^20a^1x^[^20a^]^/", px_type = 1, "DOMAINS", "ATTRIBUTES",
	     px_type = 2, "RELATIONS");

	call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
	do while (code = 0);
	     if substr (key, 1, length (px_key_head)) = px_key_head
	     then do;
		key = substr (key, length (px_key_head) + 1);
		call iox_$read_record (temp_file_iocb_ptr, temp_seg_ptr, max_seg_size, (0), code);
		if code = 0
		then do;
		     if temp_seg_ptr -> crossref_info_record.count ^= 0
		     then do;
			do px_loop = 1 to temp_seg_ptr -> crossref_info_record.count;
			     call ioa_$ioa_switch (iocb_ptr, "^[^20a^;^20x^s^]^1x^a", px_loop = 1, key,
				temp_seg_ptr -> crossref_info_record.object (px_loop));
			     end;			/* do pdx_loop */

			printed_one_sw = "1"b;
			end;

		     call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
		     end;
		end;
	     else code = error_table_$end_of_info;
	     end;					/* do while code = 0 */

	if code ^= error_table_$end_of_info
	then call error (code, "Reading crossreference file.");

	if ^printed_one_sw
	then call ioa_$ioa_switch (iocb_ptr, "^2/No referenced ^[domains^;attributes^] exist for the database^/^a",
		px_type = 1, mrds_dm_display_info.db_path);

	return;

     end print_xref;
%page;
print_complete_xref:
     proc;

dcl  pcx_attribute_loop fixed bin;
dcl  pcx_attribute_name char (32);
dcl  pcx_domain_loop fixed bin;
dcl  pcx_domain_name char (32);
dcl  pcx_prev_attribute_name char (32);
dcl  pcx_prev_domain_name char (32);

	call build_db_attr_list;
	call attach_second_iocb;

	call iox_$position (temp_file_iocb_ptr, BOF, 0, code);
	if code ^= 0
	then call error (code, "Positioning temp file to BOF");

	printed_one_sw = "0"b;
	call ioa_$ioa_switch (iocb_ptr, "^2/^20a^x^20a^x^20a^/", "DOMAINS", "ATTRIBUTES", "RELATIONS");

/* Position first iocb to first domain key */
	seek_head_info.search_key = DOMAIN_KEY_HEAD;
	seek_head_info.n = length (DOMAIN_KEY_HEAD);

	call iox_$control (temp_file_iocb_ptr, "seek_head", addr (seek_head_info), code);
	if code ^= 0
	then if code = error_table_$no_record
	     then do;
		call ioa_$ioa_switch (iocb_ptr, "^2/No domains exist for the database.");
		return;
		end;
	     else call error (code, "Seeking to first domain xref record");

	call mu_temp_segments$get_temp_segment_path (mrds_dm_display_info.temp_dir_path, myname, temp_seg_ptrs (2),
	     code);
	if code ^= 0
	then call error (code, "Cannot get temp segment in [pd].");

	pcx_prev_domain_name, pcx_prev_attribute_name = "";

/*
   Produce the listing. This is done by reading the domain records from the
   temp_file_iocb_ptr file. These records contain list of attributes the domains
   are used in. Ignore unreferenced domains. Read the attribute record from the
   second_temp_file_iocb_ptr file. These records contain list of relations the
   attribute is used in. If no relations, display {Unreferenced} in the relation
   column; otherwise display the domain, attribute and list of relations.
*/

	call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
	do while (code = 0);
	     if substr (key, 1, length (DOMAIN_KEY_HEAD)) ^= DOMAIN_KEY_HEAD
	     then code = error_table_$end_of_info;
	     else do;
		call iox_$read_record (temp_file_iocb_ptr, temp_seg_ptr, max_seg_size, (0), code);
		if code = 0
		then do;
		     pcx_domain_name = substr (key, length (DOMAIN_KEY_HEAD) + 1);

/* ignore unreferenced domains by testing count of domain record. The first
   reference of a domain record is the generated attribute with the same name,
   so we skip that one. */
		     do pcx_domain_loop = 1 to temp_seg_ptr -> crossref_info_record.count;

/* make attribute record key. look for this record (has to be there according
   to the rules of building the xref file). */
			key = ATTRIBUTE_KEY_HEAD || temp_seg_ptr -> crossref_info_record.object (pcx_domain_loop);
			call iox_$seek_key (second_temp_file_iocb_ptr, key, (0), code);
			if code ^= 0
			then if (code = error_table_$no_record) & (temp_seg_ptr -> crossref_info_record.count = 1)
			     then do;		/* this is a generated attribute for a domain */
				temp_seg_ptrs (2) -> crossref_info_record.count = 0;
				pcx_attribute_name = pcx_domain_name;
				end;
			     else call error (code, "Searching crossreference for attribute list record: " || key);
			else do;			/* read the attribute record into the second temp segment */
			     call iox_$read_record (second_temp_file_iocb_ptr, temp_seg_ptrs (2), max_seg_size, (0),
				code);
			     if code ^= 0
			     then call error (code, "Reading crossreference for attribute list record: " || key);

			     pcx_attribute_name = temp_seg_ptr -> crossref_info_record.object (pcx_domain_loop);
			     end;

/* finally get to print something out. if the count of attribute record is zero,
   then the attribute isn't used in any relations. */
			if temp_seg_ptrs (2) -> crossref_info_record.count = 0
			then do;
			     call ioa_$ioa_switch (iocb_ptr, "^[^20x^s^;^20a^]^1x^[^20x^s^;^20a^]^1x{Unreferenced}", 
				pcx_domain_name = pcx_prev_domain_name, pcx_domain_name,
				pcx_attribute_name = pcx_prev_attribute_name, pcx_attribute_name);

			     pcx_prev_domain_name = pcx_domain_name;
			     pcx_prev_attribute_name = pcx_attribute_name;
			     printed_one_sw = "1"b;
			     end;

/* otherwise, display the xref line doing previous line name suppressions */
			else do pcx_attribute_loop = 1 to temp_seg_ptrs (2) -> crossref_info_record.count;
				call ioa_$ioa_switch (iocb_ptr, "^[^20x^s^;^20a^]^1x^[^20x^s^;^20a^]^1x^20a",
				     pcx_domain_name = pcx_prev_domain_name, pcx_domain_name,
				     pcx_attribute_name = pcx_prev_attribute_name, pcx_attribute_name,
				     temp_seg_ptrs (2) -> crossref_info_record.object (pcx_attribute_loop));

				pcx_prev_domain_name = pcx_domain_name;
				pcx_prev_attribute_name = pcx_attribute_name;
				printed_one_sw = "1"b;

				end;		/* do pcx_attribute_loop */
			end;			/* do pcx_domain_loop */
		     end;
		end;

/* the first file iocb should now be positioned to the next sequential record
   as a byproduct of reading the domain record. try to read the current
   record. */
	     if code = 0
	     then call iox_$read_key (temp_file_iocb_ptr, key, (0), code);

	     end;					/* do while code = 0 */

/* done reading all the domain records, or we encountered some kind of error
   reading the crossreference file. */
	if code ^= error_table_$end_of_info
	then call error (code, "Reading crossreference file.");

/* if we didn't print any lines, there must not have been any domains in the
   crossreference file. */
	if ^printed_one_sw
	then call ioa_$ioa_switch (iocb_ptr, "^/No referenced domains exist for the database.");

	return;
%page;
/*
   This internal subroutine attaches a second iocb to the same crossreference
   file that was previously built. Note that it must be opened in -share mode
   even though only the current process has the file opened.
*/

attach_second_iocb:
     proc;

dcl  asi_attach_desc char (256) varying;

	asi_attach_desc = "vfile_ " || rtrim (mrds_dm_display_info.temp_dir_path);
	asi_attach_desc = asi_attach_desc || ">";
	asi_attach_desc = asi_attach_desc || temp_file_attach_name;
	asi_attach_desc = asi_attach_desc || " -share";

	call iox_$attach_name (unique_chars_ ("0"b), second_temp_file_iocb_ptr, (asi_attach_desc), null, code);
	if code ^= 0
	then call error (code, (asi_attach_desc));

	call iox_$open (second_temp_file_iocb_ptr, Keyed_sequential_update, "0"b, code);
	if code ^= 0
	then call error (code, (asi_attach_desc));

	return;
     end attach_second_iocb;

     end print_complete_xref;
%page;
/*  * * * * * * * * * * * * * *      error     * * * * * * * * * * * * * *   */



error:
     proc (err_code, err_message);			/* Error procedure  */

dcl  err_code fixed bin (35);
dcl  err_message char (*);


	O_err_code = err_code;
	O_err_msg = err_message;
	call tidy_up;
	goto exit;

     end error;


%page;


/* * * * * * * * * * * * * * * *   tidy_up  * * * * * * * * * * * * * * *  */

tidy_up:
     proc;

	if second_temp_file_iocb_ptr ^= null
	then do;
	     call iox_$close (second_temp_file_iocb_ptr, (0));
	     call iox_$detach_iocb (second_temp_file_iocb_ptr, (0));
	     call iox_$destroy_iocb (second_temp_file_iocb_ptr, (0));
	     second_temp_file_iocb_ptr = null;
	     end;

	if temp_seg_ptr ^= null
	then call mu_temp_segments$free_all_temp_segments (myname, (0));

	if fm_ptr ^= null
	then call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));

	return;
     end tidy_up;
%page;
/*    * * * * * * * *     get_path_entry      * * * * * * * * * *           */

/* called by print_header, print_rel_info_long and print_domain */

get_path_entry:
     procedure (path_ptr, separator) returns (char (256));

dcl  path_ptr bit (18) unal parameter;			/* offset to struct in dbm_area */
dcl  separator char (1) parameter;			/* either ">" or "$" */

/* get the path - entry character string from the path_entry structure */

	path_entry_ptr = pointer (dbm_ptr, path_ptr);

	return (rtrim (path_entry.path) || separator || rtrim (path_entry.entry));

     end get_path_entry;
%page;

/*    DECLARATIONS    */

dcl  1 rel_long aligned,				/* Structure for relation -long */
       2 l1 char (19) unal init ("
RELATION NAME:   "),
       2 rel_name char (32) unal,
       2 l2 char (23) unal init ("
Number attributes:	 "),
       2 nattrs pic "zzzzzz9" unal;



dcl  1 header_1,					/* Data base header info */
       2 lf0 char (1) unal init ("
"),
       2 l1 char (22) unal init ("Version:"),
       2 version_num pic "zz9" unal,
       2 lf1 char (1) unal init ("
"),
       2 l2 char (21) unal init ("Created by: "),
       2 creator char (32) unal,
       2 lf2 char (1) unal init ("
"),
       2 l3 char (21) unal init ("Created on: "),
       2 create_time char (24) unal,
       2 lf3 char (1) unal init ("
");


dcl  1 header_2,					/*  second part of header */
       2 l1 char (21) unal init ("Changed by: "),
       2 changer char (32) unal,
       2 lf1 char (1) unal init ("
"),
       2 l2 char (21) unal init ("Changed on: "),
       2 change_time char (24) unal,
       2 lf2 char (1) unal init ("
");

dcl  1 header_3,					/* third part of header */
       2 lf0 char (1) unal init ("
"),
       2 l1 char (21) unal init ("Total Domains: "),
       2 num_domains pic "zzz9" unal,
       2 lf1 char (1) unal init ("
"),
       2 l2 char (21) unal init ("Total Attributes: "),
       2 num_attrs pic "zzz9" unal,
       2 lf2 char (1) unal init ("
"),
       2 l3 char (21) unal init ("Total Relations: "),
       2 num_rels pic "zzz9" unal,
       2 lf3 char (1) unal init ("
");
dcl  1 seek_head_info,
       2 relation_type fixed bin init (0),		/* head = search_key */
       2 n fixed bin,
       2 search_key char (256);

dcl  addr builtin;
dcl  BOF int static options (constant) init (-1);
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  dcl_trimmed char (80);
dcl  desc_str char (120) varying;
dcl  err_msg char (256);
dcl  error_message char (500);
dcl  error_table_$end_of_info fixed bin (35) ext static;
dcl  error_table_$long_record fixed bin(35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  file_model_name char (32);
dcl  fixed builtin;
dcl  i fixed bin;
dcl  indx char (5);
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  iocb_ptr ptr;
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$read_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
dcl  key char (256) varying;
dcl  length builtin;
dcl  long_desc_str char (120) varying;
dcl  max_seg_size fixed bin (21);
dcl  mdbm_util_$display_descriptor entry (ptr) returns (char (120) varying);
dcl  mdbm_util_$trim_descriptor entry (char (120) varying) returns (char (*));
dcl  mrds_dm_display_cmdb entry (ptr, char (*), fixed bin (35));
dcl  mrds_dm_display_history entry (ptr, char (*), fixed bin (35));
dcl  mrds_error_$no_model_attr fixed bin (35) ext static;
dcl  mrds_error_$no_model_dom fixed bin (35) ext static;
dcl  mrds_error_$no_model_rel fixed bin (35) ext static;
dcl  mu_db_xref$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mu_db_xref$xref_statistics entry (ptr, fixed bin, fixed bin, fixed bin, char (*), fixed bin (35));
dcl  mu_temp_segments$free_all_temp_segments entry (char (*), fixed bin (35));
dcl  mu_temp_segments$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  myname char (32) int static options (constant) init ("mrds_dm_display");
dcl  null builtin;
dcl  NULL_OFFSET int static bit (18) unal init ((18)"1"b) options (constant);
dcl  plural char (1) varying;
dcl  pointer builtin;
dcl  printed_one_sw bit (1);
dcl  ptr builtin;
dcl  rel builtin;
dcl  rtrim builtin;
dcl  second_temp_file_iocb_ptr ptr;
dcl  string builtin;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  temp_file_attach_name char (32);
dcl  temp_file_iocb_ptr ptr;
dcl  temp_seg_ptr ptr based (addr (temp_seg_ptrs (1)));
dcl  temp_seg_ptrs (2) ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  total_attributes fixed bin;
dcl  type char (4);
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  untrimmed_dcl char (120) varying;

%page;
%include access_mode_values;
%page;
%include iox_modes;
%page;
%include mrds_dm_display_info;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include rmdb_crossref_info;
%page;
%include terminate_file;

     end mrds_dm_display;





		    mrds_dm_display_cmdb.pl1        10/16/86  1550.5rew 10/16/86  1142.7      150831



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

mrds_dm_display_cmdb: proc (I_mrds_dm_display_info_ptr, O_err_msg, O_err_code);

/* The purpose of this procedure is to display the db_model info in the
   form of a cmdb source.  The output is through the iocb_ptr supplied in
   mrds_dm_display_info.
*/


/****^  HISTORY COMMENTS:
  1) change(82-05-15,Lackey), approve(), audit(), install():
     written.
  2) change(83-10-03,Benjamin), approve(), audit(), install():
     to put the attribute information handling inside a begin block to keep from
     truncating the line when there are a lot of attributes.
  3) change(85-12-07,Spitzer), approve(85-12-07,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     Don't put unreferenced domains in the cmdb output. Put in a check to see
     if there are any referenced domains in the database. Use crossreference
     file for list of attributes.
                                                   END HISTORY COMMENTS */


/*      PARAMETERS     */

	dcl     I_mrds_dm_display_info_ptr ptr parameter; /* Pointer to mrds_dm_display_info structure */
	dcl     O_err_msg		 char (*) parameter;/* Text of error message */
	dcl     O_err_code		 fixed bin (35) parameter; /* Erro code */

%page;
/* mrds_dm_display_cmdb:  proc (I_mrds_dm_display_info_ptr, O_err_msg, O_err_code); */

	mrds_dm_display_info_ptr = I_mrds_dm_display_info_ptr; /* Init parameters */
	O_err_msg = "";
	O_err_code = 0;

	iocb_ptr = mrds_dm_display_info.output_iocb_ptr;	/* For faster reference */
	temp_file_iocb_ptr = null;
	dbm_ptr = mrds_dm_display_info.dbm_ptr;
	rel_name_table_ptr = null;			/* Not allocated yet */
	number_indexed_rels = 0;			/* Number relations indexed */

	on cleanup call tidy_up;			/* Establish clenaup handler */


	if mrds_dm_display_info.version ^= MRDS_DM_DISPLAY_INFO_VERSION_1 then
	     call error (error_table_$unimplemented_version,
		"For mrds_dm_display_info.version");



/*   ****   Output the header   ***    */

	if mrds_dm_display_info.sw.long then do;	/* If long output header */

		call date_time_ (clock (), time_of_list);

		call
		     ioa_$ioa_switch (iocb_ptr,
		     "^/ /* Created from   ^a ^/^2-^a^-*/",
		     mrds_dm_display_info.db_path,
		     time_of_list);
	     end;
%page;
/*    **** Output domain section  ****    */

	if db_model.domain_ptr = NULL_OFFSET then do;
NO_DOMAINS:         call ioa_$ioa_switch (iocb_ptr,
		     "^2/No domains exist for the data base^/^a",
		     mrds_dm_display_info.db_path);
		return;
	     end;

	call ioa_$ioa_switch (iocb_ptr, "^/domain:");	/* Domain section */

	found_one = "1"b;
	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) /* Loop thru all domains */
	     repeat ptr (dbm_ptr, domain_info.fwd_thread)
	     while (rel (di_ptr) ^= NULL_OFFSET);

	     if ^domain_info.unreferenced then do;
		if found_one then found_one = "0"b;
		else call ioa_$ioa_switch (iocb_ptr, ",");
		long_desc_str = mdbm_util_$display_descriptor (addr (domain_info.db_desc));
		if mrds_dm_display_info.sw.long then do;
			desc_str = long_desc_str;
			call ioa_$ioa_switch_nnl (iocb_ptr, "^-^a^/^-^5x^a",
			     domain_info.name, long_desc_str);
		     end;
		else do;
			desc_str = mdbm_util_$trim_descriptor (long_desc_str);
			call ioa_$ioa_switch_nnl (iocb_ptr, "^-^20a^1x^a",
			     domain_info.name, desc_str);
		     end;

		if domain_info.check_path_ptr ^= NULL_OFFSET then
		     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-check_proc ^a",
			get_path_entry (domain_info.check_path_ptr, "$"));

		if domain_info.encd_path_ptr ^= NULL_OFFSET then
		     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-encode_proc ^a",
			get_path_entry (domain_info.encd_path_ptr, "$"));

		if domain_info.decd_path_ptr ^= NULL_OFFSET then
		     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_proc ^a",
			get_path_entry (domain_info.decd_path_ptr, "$"));

		if domain_info.db_desc ^= domain_info.user_desc then
		     /* It had a -decode_dcl */
		     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^15x-decode_dcl ^/^15x^a",
			mdbm_util_$display_descriptor (addr (domain_info.user_desc)));

		end;
	end;					/* End Domain section */
	if found_one then goto NO_DOMAINS;

	call ioa_$ioa_switch (iocb_ptr, ";");

	if db_model.num_rels > 0 then call build_db_attr_list; /* Build attribute list in vfile */
%page;
/*   *****        Output Attribute section if needed         ***        */

	if found_one then do;			/* If any attributes
						   exists with a name different
						   then its domain name */

		call ioa_$ioa_switch (iocb_ptr, "^2/attribute:"); /* Attribute section */

		call iox_$position (temp_file_iocb_ptr, BOF, 0, code);
		if code ^= 0 then call error (code, "Positioning temp file to BOF");

		printed_one_sw = "0"b;

		seek_head_info.seek_type = 0;
		seek_head_info.seek_key = ATTRIBUTE_KEY_HEAD;
		seek_head_info.n = length (ATTRIBUTE_KEY_HEAD);
		call iox_$control (temp_file_iocb_ptr, "seek_head", addr (seek_head_info), code);
		if code = error_table_$no_record then do;
		     call ioa_$ioa_switch (iocb_ptr, "^2/No attributes exist for the data base^/^a",
			mrds_dm_display_info.db_path);
		     return;
		     end;

		crossref_info_record_ptr = addr (domain_offset);
		do while (code = 0);

		     call iox_$read_key (temp_file_iocb_ptr, key, rec_len, code);
		     if code = 0 then
			if substr (key, 1, length (ATTRIBUTE_KEY_HEAD)) ^= ATTRIBUTE_KEY_HEAD then
			     code = error_table_$end_of_info;

		     if code = 0 then do;
			call iox_$read_record (temp_file_iocb_ptr,
			     crossref_info_record_ptr, 2, (0), code);
			if code = error_table_$long_record then
			     code = 0;
			if code = 0 then do;

			     di_ptr = ptr (dbm_ptr, domain_offset);
			     key = substr (key, length (ATTRIBUTE_KEY_HEAD) + 1);

			     if rtrim (domain_info.name) ^= key then do;

				     if printed_one_sw then
					call ioa_$ioa_switch (iocb_ptr, ","); /* Put comma at end of line */

				     call ioa_$ioa_switch_nnl (iocb_ptr, "^-^20a^1x^a",
					key, di_ptr -> domain_info.name);

				     printed_one_sw = "1"b;
				end;
			     end;
			end;

		end;				/* do while code = 0 */

		if code ^= error_table_$end_of_info then
		     call error (code, "Getting attribute names from temp fiel");

		call ioa_$ioa_switch (iocb_ptr, ";");	/* Put semicolon at end of line */
	     end;					/* End found one */
%page;
/*    *****     Output relation section       *****     */

	if db_model.num_rels < 1 then do;		/* No relation defined in db */
		call ioa_$ioa_switch (iocb_ptr,
		     "^2/There are no relations defined for the data base^/^a",
		     mrds_dm_display_info.db_path);
		return;
	     end;


	call ioa_$ioa_switch_nnl (iocb_ptr, "^2/relation:"); /* Relation section */

	do i = 1 to rel_name_table_ix;

	     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^-^20a^1x(", rel_name_table (i).rel_name);

	     fm_ptr = rel_name_table (i).file_model_ptr;
	     ri_ptr = rel_name_table (i).rel_info_ptr;

	     begin;

		dcl     attr_line		 char (rel_info.num_attr * 35) varying;

		attr_line = "";

		do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* Loop thru all attibutes getting the attr_name */
		     repeat ptr (fm_ptr, attr_info.fwd_thread)
		     while (rel (ai_ptr) ^= NULL_OFFSET);

		     attr_line = attr_line || rtrim (attr_info.name);

		     if attr_info.key_attr then attr_line = attr_line || "*";

		     if attr_info.fwd_thread = NULL_OFFSET then /* Last attr in rel */
			attr_line = attr_line || ")";
		     else attr_line = attr_line || "  ";

		end;

		if i = db_model.num_rels then /* Last relation */
		     call ioa_$ioa_switch_nnl (iocb_ptr, "^a;", attr_line);
		else call ioa_$ioa_switch_nnl (iocb_ptr, "^a,", attr_line);

	     end;					/* begin block */

	     line = "";
	end;
%page;
/*     *****     index section for output     ***** */

	if number_indexed_rels > 0 then do;		/* If any relations were indexed */

		call ioa_$ioa_switch_nnl (iocb_ptr, "^2/index:");

		number_indexed_rels_used = 0;

		do i = 1 to rel_name_table_ix;

		     if rel_name_table (i).indexed then do;

			     number_indexed_rels_used = number_indexed_rels_used + 1;

			     call ioa_$ioa_switch_nnl (iocb_ptr, "^/^-^20a^1x(", rel_name_table (i).rel_name);

			     fm_ptr = rel_name_table (i).file_model_ptr;
			     ri_ptr = rel_name_table (i).rel_info_ptr;
			     line = "";
			     one_found = "0"b;

			     do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) /* Loop thru all attibutes getting the attr_name */
				repeat ptr (fm_ptr, attr_info.fwd_thread)
				while (rel (ai_ptr) ^= NULL_OFFSET);

				if attr_info.index_attr then do;

					if one_found then line = line || "  ";
					line = line || rtrim (attr_info.name);

					one_found = "1"b;
				     end;
			     end;

			     if number_indexed_rels_used = number_indexed_rels then /* last one */
				call ioa_$ioa_switch_nnl (iocb_ptr, "^a);", line);
			     else call ioa_$ioa_switch_nnl (iocb_ptr, "^a),", line);

			     line = "";
			end;

		end;				/* End if rel_name_table.indexed */

	     end;					/* END if indexed_found */

	call ioa_$ioa_switch (iocb_ptr, "^/");		/* Add a couple if line feeds at the end */

	call tidy_up;

exit:	return;
%page;
/*  * * * * * * * * * * *  build_db_attr_list  * * * * * * * * * * * * * *   */


build_db_attr_list: proc;

/*
   This internal subroutine calls the subroutine to build the database
   crossreference file. It also checks to see if an attribute name exists that
   is different then a domain name, if so it sets the found_one bit. The
   rel_name_table is allocated and filled in as the relation info is
   encountered.
*/

	temp_file_iocb_ptr = mrds_dm_display_info.xref_iocb_ptr;
	if temp_file_iocb_ptr = null then do;
	     call mu_db_xref$xref_build (mrds_dm_display_info.temp_dir_path, mrds_dm_display_info.db_path, dbm_ptr,
		mrds_dm_display_info.xref_name, mrds_dm_display_info.xref_iocb_ptr, error_message, code);
	     if code ^= 0 then call error (code, error_message);

	     temp_file_iocb_ptr = mrds_dm_display_info.xref_iocb_ptr;
	     end;

/* Create the rel_name_table structure and initialize it */
	allocate rel_name_table in (wa) set (rel_name_table_ptr);
	rel_name_table (*).indexed = "0"b;		/* Init to off */
	rel_name_table_ix = 0;			/* To start with */
	rel_name_table (*).file_model_ptr = null;

	found_one = "0"b;				/* Just to be sure */

/*  Walk the file_info list to get relation info */
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) /* Loop thru all files (relations ) */
	     repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while (rel (fi_ptr) ^= NULL_OFFSET);

	     file_model_name = rtrim (file_info.file_name) || ".m";

	     call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
	     if fm_ptr = null then call error (code, rtrim (db_path) || ">" || file_model_name);

	     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);	/* Relation info ptr */
	     rel_name_table_ix = rel_name_table_ix + 1;	/* Next array index */
	     rel_name_table (rel_name_table_ix).rel_name = file_info.file_name; /* Save rel info */
	     rel_name_table (rel_name_table_ix).file_model_ptr = fm_ptr;
	     rel_name_table (rel_name_table_ix).rel_info_ptr = ri_ptr;
	     rel_name_table (rel_name_table_ix).indexed = rel_info.indexed;
	     if rel_name_table (rel_name_table_ix).indexed then
		number_indexed_rels = number_indexed_rels + 1; /* Keep count */

/*
   Look through all the attributes in each relation looking for an attribute
   that is based upon a domain with a different name. If we find one, set
   found_one on. This bit is later used to determine if the "attribute:"
   statement need to be emitted. We can stop looking after the first one
   is found, as we only have to find one.
*/
	     do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
		repeat ptr (fm_ptr, attr_info.fwd_thread)
		while (rel (ai_ptr) ^= NULL_OFFSET & ^found_one);

		di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
		if domain_info.name ^= attr_info.name
		then found_one = "1"b;
	     end;					/* END of all attrs */

	end;					/* END of all files (relations) */
						/* vfile_ now contains all unique attribute names as keys with domain offset as data */

     end build_db_attr_list;

%page;
/*  * * * * * * * * * * * * * *      error     * * * * * * * * * * * * * *   */



error: proc (err_code, err_message);			/* Error procedure  */

	dcl     err_code		 fixed bin (35);
	dcl     err_message		 char (*);


	O_err_code = err_code;
	O_err_msg = err_message;
	call tidy_up;
	goto exit;

     end error;





/* * * * * * * * * * * * * * * *   tidy_up  * * * * * * * * * * * * * * *  */

tidy_up: proc;

	if rel_name_table_ptr ^= null then do;
	     do i = 1 to rel_name_table_ix;
		call terminate_file_ (rel_name_table (i).file_model_ptr, 0, TERM_FILE_TERM, (0));
		end;
	     free rel_name_table;
	     end;

     end tidy_up;
%page;
/*    * * * * * * * *     get_path_entry      * * * * * * * * * *           */

get_path_entry: procedure (path_ptr, separator) returns (char (256));

	dcl     path_ptr		 bit (18) unal;	/* offset to struct in dbm_area */
	dcl     separator		 char (1);	/* either ">" or "$" */

/* get the path - entry character string from the path_entry structure */

	path_entry_ptr = ptr (dbm_ptr, path_ptr);

	return (rtrim (path_entry.path) || separator || rtrim (path_entry.entry));

     end get_path_entry;
%page;
	dcl     addr		 builtin;
	dcl     BOF		 int static options (constant) init (-1);
	dcl     cleanup		 condition;
	dcl     clock		 builtin;
	dcl     code		 fixed bin (35);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     desc_str		 char (120) varying;
	dcl     domain_offset	 bit (18) aligned;
	dcl     error_message	 char (500);
	dcl     error_table_$end_of_info fixed bin (35) ext static;
	dcl     error_table_$long_record fixed bin(35) ext static;
	dcl     error_table_$no_record fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     file_model_name	 char (32);
	dcl     fixed		 builtin;
	dcl     found_one		 bit (1);
	dcl     i			 fixed bin;
	dcl     initiate_file_	 entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl     ioa_$ioa_switch	 entry () options (variable);
	dcl     ioa_$ioa_switch_nnl	 entry () options (variable);
	dcl     iocb_ptr		 ptr;
	dcl     iox_$control	 entry (ptr, char(*), ptr, fixed bin(35));
	dcl     iox_$position	 entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
	dcl     iox_$read_key	 entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     key		 char (256) varying;
	dcl     length		 builtin;
	dcl     line		 char (500) varying;
	dcl     long_desc_str	 char (120) varying;
	dcl     mdbm_util_$display_descriptor entry (ptr) returns (char (120) varying);
	dcl     mdbm_util_$trim_descriptor entry (char (120) varying) returns (char (*));
	dcl     mu_db_xref$xref_build	 entry (char(*), char(*), ptr, char(*), ptr, char(*), fixed bin(35));
	dcl     null		 builtin;
	dcl     NULL_OFFSET		 int static bit (18) unal init ((18)"1"b) options (constant);
	dcl     number_indexed_rels	 fixed bin;
	dcl     number_indexed_rels_used fixed bin;
	dcl     one_found		 bit (1);
	dcl     printed_one_sw	 bit (1);
	dcl     ptr		 builtin;
	dcl     rec_len		 fixed bin (21);
	dcl     rel		 builtin;
	dcl     rel_name_table_ix	 fixed bin;
	dcl     rtrim		 builtin;
	dcl     substr		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     temp_file_iocb_ptr	 ptr;
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     time_of_list	 char (24);
	dcl     wa		 area based (mrds_dm_display_info.work_area_ptr);

	dcl     1 seek_head_info	 aligned,
	          2 seek_type	 fixed bin,
		2 n		 fixed bin,
		2 seek_key	 char (256);

	dcl     1 rel_name_table	 (db_model.num_rels) aligned based (rel_name_table_ptr),
		2 rel_name	 char (32),	/* Relation name of this relation */
		2 file_model_ptr	 ptr,		/* Pointer to file_model for this relation */
		2 rel_info_ptr	 ptr,		/* Pointer to rel_info for this relation */
		2 indexed		 bit (1);		/* On = this rel contains an indexed attr */

	dcl     rel_name_table_ptr	 ptr;		/* Pointer to rel_name_table */
%page;
%include access_mode_values;
%page;
%include mrds_dm_display_info;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include rmdb_crossref_info;
%page;
%include terminate_file;

     end mrds_dm_display_cmdb;





		    mrds_dm_display_history.pl1     10/16/86  1550.5rew 10/16/86  1142.7       54702



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

mrds_dm_display_history: proc (I_mrds_dm_display_info_ptr, O_err_msg, O_err_code);

/*	     BEGIN_DESCRIPTION

   The purpose of this procedure is to display the restrucutring history
   maintained in the db_model.  If the database has not been restructured it
   says so.  If the database has been restructured more then once the list of
   entries are displayed in reverse chronalogical order.

   .           END_DESCRIPTION     */


/****^  HISTORY COMMENTS:
  1) change(82-06-02,Lackey), approve(), audit(), install():
     written.
  2) change(82-07-14,Lackey), approve(), audit(), install():
     changed length of entry_dis.inv from 40 chars to 64 chars to eliminate
     a stringsize condition.
  3) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Add more operation strings.
                                                   END HISTORY COMMENTS */


/*     PARAMETERS	       */

	dcl     I_mrds_dm_display_info_ptr ptr parameter;
	dcl     O_err_code		 fixed bin (35) parameter;
	dcl     O_err_msg		 char (*) parameter;

	O_err_code, code = 0;
	O_err_msg = "";
	mrds_dm_display_info_ptr = I_mrds_dm_display_info_ptr;
	dbm_ptr = mrds_dm_display_info.dbm_ptr;
	iocb_ptr = mrds_dm_display_info.output_iocb_ptr;

	if mrds_dm_display_info.version ^= MRDS_DM_DISPLAY_INFO_VERSION_1 then do;
		O_err_msg = "For mrds_dm_display_info.version";
		O_err_code = error_table_$unimplemented_version;
	     end;


/* Check for no restructuring   */

	else if db_model.last_restructuring_history_offset = NULL_OFFSET then
	     call ioa_$ioa_switch (iocb_ptr,
		"^/Database has never been restructured.^/^a",
		mrds_dm_display_info.db_path);




/* Display list in reverse order   */

	else do;

		call ioa_$ioa_switch (iocb_ptr, "^/HISTORY:");

		do rmdb_history_entry_ptr = pointer (dbm_ptr, db_model.last_restructuring_history_offset)
		     repeat pointer (dbm_ptr, rmdb_history_entry.offset_to_previous_entry)
		     while (rel (rmdb_history_entry_ptr) ^= NULL_OFFSET);

		     entry_dis.id = rmdb_history_entry.user_id;
		     call date_time_ (rmdb_history_entry.date_time_restructured, entry_dis.dt);
		     entry_dis.op = OPERATION_NAME (rmdb_history_entry.operation);
		     if RELATION_OPERATIONS (rmdb_history_entry.operation) then
			rel_name = "RELATION:        ";
		     else rel_name = "";
		     if (ATTRIBUTE_OPERATIONS (rmdb_history_entry.operation) & ^(RELATION_OPERATIONS (rmdb_history_entry.operation))
			& ^(RENAME_OPERATIONS (rmdb_history_entry.operation)))
		     then rel_name = "DOMAIN:          ";
		     if RENAME_OPERATIONS (rmdb_history_entry.operation)
		     then rel_name = "OLD NAME:        ";
		     entry_dis.inv = rel_name || rmdb_history_entry.object_name;

		     call iox_$put_chars (iocb_ptr, addr (entry_dis),
			length (string (entry_dis)), code);
		     if code ^= 0 then do;
			     O_err_msg = "While doing a put chars";
			     O_err_code = code;
			     return;
			end;

		     if rmdb_history_entry.secondary_object_name ^= "" then do;
			     if (ATTRIBUTE_OPERATIONS (rmdb_history_entry.operation) & ^(RENAME_OPERATIONS (rmdb_history_entry.operation))) then
				attr_name = "ATTRIBUTE:";
			     else if RENAME_OPERATIONS (rmdb_history_entry.operation) then
				attr_name = "NEW NAME: ";
			     else attr_name = "";

			     call ioa_$ioa_switch (iocb_ptr, "^21x^a^39t^a",
				attr_name, rmdb_history_entry.secondary_object_name);
			end;

		end;

	     call ioa_$ioa_switch (iocb_ptr, "");		/* Add line feed at end */
	     end;


	return;

%page;
	dcl     addr		 builtin;
	dcl     attr_name		 char (32) varying;
	dcl     code		 fixed bin (35);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     ioa_$ioa_switch	 entry () options (variable);
	dcl     iocb_ptr		 ptr;
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     length		 builtin;
	dcl     NULL_OFFSET		 bit (18) int static options (constant) init ((18)"1"b);
	dcl     pointer		 builtin;
	dcl     rel		 builtin;
	dcl     rel_name		 char (32) varying;
	dcl     string		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

	dcl     1 entry_dis		 unaligned,	/* Entry display */
		2 l1		 char (22) init ("
Restructured by:"),
		2 id		 char (32),
		2 l2		 char (22) init ("
Restructured on:"),
		2 dt		 char (16),
		2 l3		 char (22) init ("
Operation:"),
		2 op		 char (32),
		2 l4		 char (22) init ("
Involving:"),
		2 inv		 char (64),
		2 nl		 char (1) init ("
");

/* NOTE:   The RELATION_OPERATIONS and OPERATION_NAME dimentions must be kept the same */

	dcl     RELATION_OPERATIONS	 (11) bit (1) int static options (constant) init (
				 "1"b, "1"b, "1"b, "1"b,
				 "0"b, "0"b, "0"b, "0"b,
				 "0"b, "0"b, "1"b);

	dcl     ATTRIBUTE_OPERATIONS	 (11) bit (1) int static options (constant) init (
				 "0"b, "0"b, "1"b, "1"b,
				 "1"b, "1"b, "0"b, "0"b,
				 "1"b, "0"b, "0"b);

          dcl     RENAME_OPERATIONS      (11) bit (1) int static options (constant) init (
                                         "0"b, "0"b, "0"b, "0"b,
                                         "0"b, "0"b, "0"b, "0"b,
                                         "1"b, "1"b, "1"b);
	dcl     OPERATION_NAME	 (11) char (32) int static options (constant) init (
	        "ADD RELATION",	"DELETE RELATION",
	        "ADD INDEX",	"DELETE INDEX",
	        "ADD ATTRIBUTE",	"DELETE ATTRIBUTE",
	        "ADD DOMAIN",	"DELETE DOMAIN",
	        "RENAME ATTRIBUTE",	"RENAME DOMAIN",
	        "RENAME RELATION");
%page;
%include mrds_dm_display_info;
%page;
%include rmdb_history_entry;
%page;
%include mdbm_db_model;

     end mrds_dm_display_history;




		    mrds_dm_get_attributes.pl1      10/16/86  1550.5r w 10/16/86  1143.7      162495



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

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


/* BEGIN DESCRIPTION:

   This routine  returns  info  about  the  attributes  of  a  given
   relation   in  the  database  model.  There  are  three  entries.
   mrd_dm_get_attributes is internal for use by mrds.  get_relations
   is external for use by dmd_, and get_model_attributes is external
   for use by mmi_. The external entries check for a non-dba  trying
   to use this interface on a secured db.
   
   END DESCRIPTION
*/

/* PARAMETERS:

   ======= get_model_attributes entry

   open_name - -  (input)  char(*),  the  opening  name  supplie  to
   mmi_$open_model

   relation_name - - (input) char(*), the relation  for  which  attr
   info is desired

   area_ptr - - (input) ptr, pointer to an area in which  to  return
   info

   structure_version - - (input) fixed bin,  the  desired  structure
   version

   mrds_db_model_rel_attrs_ptr -  -  (output)  ptr,  points  to  the
   attribute      information      in      the      structure     in
   mrd_db_model_rel_attrs.incl.pl1

   code - - (output) fixed bin(35), the error status encoding

   ======= get_attributes and mrds_dm_get_attributes entries

   data_model_ptr - - (input) ptr, pointer returned from a  call  to
   dmd_$open_dm

   relation_name - - (input) char(32), the relation for  which  attr
   info is desired

   area_ptr - - (input) ptr, points to an area in  which  to  return
   info

   rd_ptr - - (output) ptr, points to the rel_desc  structure  given
   in mrds_rel_desc.incl.pl1

   code - - (output) fixed bin(35), the error status encoding

*/

/* HISTORY:

   Modified by Oris Friesen to accomodate new version data bases  --
   October 1978

   Modified by Jim Gray - - Feb. 1980, to correctly determine  which
   version database data_model_ptr refers to.

   Modified by Jim Gray - - April 1980,  to  correctly  handle  case
   when unknown relation name is given.

   Modified by Jim Gray - - 80-9-23, to add entries for setting type
   of  descriptor,  user  or  db  view,  wanted in the returned info
   structure

   81-01-31 Jim Gray : added setting of needed access for DBA types,
   if access violation occurred.

   81-02-12 Jim Gray : added check  for  user  being  a  DBA  if  db
   secured,  and  external  dmd_  entry  called, this get_attributes
   entry should not be called by  mrds,  use  mrds_dm_get_attributes
   instead.

   81-04-23 Jim Gray : changed the method of  getting  the  relation
   model  pointer.  Now  the  assumption  is  made that there is one
   relation per file,  and  the  file  has  the  same  name  as  the
   relation.  This  was  done on the premise that blocked files will
   not be implemented.

   81-04-23 Jim Gray : added get_model_attributes entry for mmi_

   82-08-20 D. Woodka deleted reference to rel_desc.attributes.bit_offset
   for DMS conversion.

   82-11-24 Davids: modified to convert from rel_desc_v3 which is
   returned from the call to dmd_v1_$get_attributes to the new
   rel_desc structure.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

/* BEGIN CHANGE 81-02-12 ********************************************* */

mrds_dm_get_attributes: procedure (data_model_ptr_a, relation_name_a, area_ptr_a, rd_ptr_a, code_a);

/* entry to be used internally by mrds, no access checking */

	internal_call = "1"b;

	data_model_ptr = data_model_ptr_a;
	relation_name = relation_name_a;
	area_ptr = area_ptr_a;

	call common ();

	code_a = code;
	rd_ptr_a = rd_ptr;

	return;



get_attributes: entry (data_model_ptr_b, relation_name_b, area_ptr_b, rd_ptr_b, code_b);

/* entry to be used by external calls, not mrds,
   if the db is secured, then the caller must be a DBA */

	internal_call = "0"b;

	data_model_ptr = data_model_ptr_b;
	relation_name = relation_name_b;
	area_ptr = area_ptr_b;

	call common ();

	code_b = code;
	rd_ptr_b = rd_ptr;

	return;

/* END CHANGE 81-02-12 ************************************************ */

/* BEGIN CHANGE 81-04-23 B ***************************************** */

get_model_attributes: entry (open_name, relation_name_c, area_ptr_c, structure_version,
	mrds_db_model_rel_attrs_ptr, code_c);

/* this entry is used by the mmi_ interface.
   it calls get_attributes to handle both old and new version models,
   and to have secured database non-dba user checks made. */

	code_c = 0;
	mrds_db_model_rel_attrs_ptr = null ();

/* get a model pointer from the open name */

	call mu_open_name_manager$get_model_pointer (open_name, model_type, model_ptr, code_c);
	if code_c = 0 then do;

/* get the attribute information */

		call get_attributes (model_ptr, (relation_name_c), addr (local_area), rd_ptr_c, code_c);
		if code_c = 0 then do;

			rd_ptr = rd_ptr_c;
			area_ptr = area_ptr_c;

/* check the users arguments */

			if area_ptr = null () then
			     code_c = error_table_$badcall;
			else do;
				unspec (my_area_info) = "0"b;
				my_area_info.version = 1;
				my_area_info.areap = area_ptr;

				call area_info_ (addr (my_area_info), code_c);
				if code_c ^= 0 then ;
				else if my_area_info.no_freeing then
				     code_c = mrds_error_$not_freeing_area;
				else do;

					if structure_version ^= mrds_db_model_rel_attrs_structure_version then
					     code_c = error_table_$unimplemented_version;
					else do;


/* fill in the users attribute structure */

						on area begin;
							code_c = error_table_$area_too_small;
							goto skip_allocate;
						     end;

						on cleanup begin;
							if mrds_db_model_rel_attrs_ptr ^= null () then do;
								free mrds_db_model_rel_attrs in (return_area);
								mrds_db_model_rel_attrs_ptr = null ();
							     end;
						     end;

						mrds_db_model_rel_attrs_count_init = rel_desc.num_attr;
						allocate mrds_db_model_rel_attrs set (mrds_db_model_rel_attrs_ptr) in (return_area);
						revert area;

						unspec (mrds_db_model_rel_attrs) = "0"b;
						mrds_db_model_rel_attrs.version = mrds_db_model_rel_attrs_structure_version;
						mrds_db_model_rel_attrs.attribute_count = mrds_db_model_rel_attrs_count_init;

/* do all the attributes in this relation */

						do i = 1 to mrds_db_model_rel_attrs_count_init;

						     mrds_db_model_rel_attrs.attribute (i).name = rel_desc.attributes (i).attribute_name;
						     mrds_db_model_rel_attrs.attribute (i).domain = rel_desc.attributes (i).domain_name;
						     mrds_db_model_rel_attrs.attribute (i).user_data_type =
							rel_desc.attributes (i).descriptor;
						     if rel_desc.attributes (i).key_attr_order = 1 |
							rel_desc.attributes (i).inver_flag then
							mrds_db_model_rel_attrs.attribute (i).indexed = "1"b;

						end;

					     end;
				     end;
			     end;
		     end;
	     end;
skip_allocate:

	return;

/* END CHANGE 81-04-23 B ***************************************** */

/* entries to set wether the user or database view data type descriptor is to be returned */

set_user_view: entry ();
	user_data_type_wanted = "1"b;
	return;

set_db_view: entry ();
	user_data_type_wanted = "0"b;
	return;

common: procedure ();
	code = 0;
	rd_ptr = null;

/* check for which mrds version to call   based on which version of the model we have */

	call hcs_$fs_get_path_name (data_model_ptr, db_path, ldn, model_name, code);
	if code = 0 then do;

/* check for the database being secured, but the user not being a DBA */

		dbm_ptr = data_model_ptr;
		if ^internal_call then
		     call secured_db_check ();

/* BEGIN CHANGE 81-04-23 A ********************************************** */

		if code = 0 then do;

/* check for a good relation name given   this search assumes that there is one relation per file,
   and that the relation name is the same as the file name */

			on no_read_permission begin;
				code = mrds_error_$no_model_access;
				rd_ptr = null ();
				goto exit;
			     end;

			done, rel_found = "0"b;
			fi_ptr = ptr (dbm_ptr, db_model.file_ptr);
			do while (^done);
			     if relation_name = file_info.file_name then
				done, rel_found = "1"b;
			     else if file_info.fwd_ptr ^= NULL_OFS then
				fi_ptr = ptr (dbm_ptr, file_info.fwd_ptr);
			     else done = "1"b;
			end;
			if ^rel_found then
			     code = mrds_error_$no_model_rel;
			else do;


/* BEGIN CHANGE 81-01-31 ********************************************* */

				call hcs_$initiate (db_path, rtrim (file_info.file_name) || ".m", "", 0, 1, fm_ptr, code);
				if code = error_table_$moderr | code = error_table_$no_info then do;
					call mrds_dm_authorization$set_needed_access
					     (rtrim (db_path), code); /* fails if not DBA */
					if code ^= 0 then
					     code = mrds_error_$no_model_access;
					else call hcs_$initiate (db_path, rtrim (file_info.file_name) || ".m", "", 0, 1,
						fm_ptr, code);
				     end;

/* END CHANGE 81-01-31 *********************************************** */

/* get the attribute information */

				if fm_ptr ^= null () then do;
					code = 0;
					on cleanup begin;
						if rd_ptr ^= null () then do;
							free rel_desc in (return_area);
							rd_ptr = null ();
						     end;
					     end;

					ri_ptr = ptr (fm_ptr, file_model.rel_ptr); /* this assumes one relation per file */

/* END CHANGE 81-04-23 A ************************************************* */

					num_attr_alloc = rel_info.num_attr;
					allocate rel_desc in (return_area);
					unspec (rel_desc) = "0"b;
					rel_desc.num_attr = num_attr_alloc;
					rel_desc.key_length = rel_info.max_key_len;
					rel_desc.data_length = rel_info.max_data_len;
					rel_desc.num_keys = 0;
					rel_desc.inversion = rel_info.indexed;

/* go through all attributes in this relation */

					cnt = 1;
					do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
					     repeat ptr (fm_ptr, attr_info.fwd_thread)
					     while (rel (ai_ptr) ^= NULL_OFS);
					     rel_desc.attributes.attribute_name (cnt) = attr_info.name;
					     di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
					     rel_desc.attributes.domain_name (cnt) = domain_info.name;

					     rel_desc.attributes.bit_length (cnt) = bit (fixed (attr_info.bit_length, 18));
					     rel_desc.attributes.key_flag (cnt) = attr_info.key_attr;
					     rel_desc.attributes.inver_flag (cnt) = attr_info.index_attr;
					     rel_desc.attributes.key_attr_order (cnt) = attr_info.key_order;
					     if user_data_type_wanted | ^internal_call then
						rel_desc.attributes.descriptor (cnt) = domain_info.user_desc;
					     else rel_desc.attributes.descriptor (cnt) = domain_info.db_desc;
					     if attr_info.key_attr then rel_desc.num_keys = rel_desc.num_keys + 1;
					     cnt = cnt + 1;
					end;
				     end;
			     end;
		     end;
	     end;
exit:
	return;
     end;

/* BEGIN CHANGE 81-02-12 ********************************************* */

secured_db_check: procedure ();

/* routine to check for the database being is a secured state,
   and if so, that the user is a DBA, and thus may use the external entry */

	if code ^= 0 then ;
	else if internal_call then ;
	else do;

/* get the secured state of the dataabase */

		call mrds_dm_db_secured$get_secured_status (dbm_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then

		     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the secured state of database """, db_path, """.");

		else if ^database_state.secured then ;
		else do;

/* database secured, see if the user is a DBA */

			call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then

			     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				"Unable to get user class for database """, db_path, """.");

			else if mrds_authorization.administrator then ;
			else do;

/* not DBA on secured db, issue error */

				code = error_table_$insufficient_access;
				call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a ^a",
				     "The database """, db_path, """ has been secured,",
				     "so the caller must be a DBA to use direct model access.");

			     end;

		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr, dbm_ptr = null ();

     end;

/* END CHANGE 81-02-12 ************************************************ */

	declare NULL_OFS		 int static bit (18) unal init ("111111111111111111"b) options (constant);
	declare area		 condition;	/* if area too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area details */
	declare area_ptr		 ptr;		/* pointer to area in which information is returned */
	declare area_ptr_a		 ptr;		/* temp for mrds_dm_get_attributes entry */
	declare area_ptr_b		 ptr;		/* temp for get_attributes entry */
	declare area_ptr_c		 ptr;		/* temp for get_model_attributes entry */
	declare caller_name		 char (32) init ("dmd_$open_dm"); /* name of calling routine */
	declare cleanup		 condition;
	declare cnt		 fixed bin;
	declare code		 fixed bin (35);	/* a standard Multics system status code */
	declare code_a		 fixed bin (35);	/* temp for mrds_dm_get_attributes entry */
	declare code_b		 fixed bin (35);	/* temp for get_attributes entry */
	declare code_c		 fixed bin (35);	/* temp for get_model_attributes entry */
	declare continue		 char (1) init ("c"); /* dont stop after print mesg */
	declare data_model_ptr	 ptr;		/* pointer to data model to be searched (Input) */
	declare data_model_ptr_a	 ptr;		/* temp for mrds_dm_get_attributes entry */
	declare data_model_ptr_b	 ptr;		/* temp for get_attributes entry */
	declare db_path		 char (168);
	declare done		 bit (1);		/* on => get out of loop */
	declare error_table_$area_too_small fixed bin (35) ext; /* area not big enough */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$insufficient_access fixed bin (35) ext; /* not DBA and db secured */
	declare error_table_$moderr	 fixed bin (35) ext;/* incorrect access */
	declare error_table_$no_info	 fixed bin (35) ext;/* no db dir acl, and no rel model acl */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* unknown structure version */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	declare i			 fixed bin;	/* loop index */
	declare info_ptr		 ptr init (null ());/* unused */
	declare internal_call	 bit (1);		/* on => called from mrds, not by dmd_ */
	declare ldn		 fixed bin;
	declare local_area		 area (8192);	/* space for db state, and user class info */
	declare mu_open_name_manager$get_model_pointer entry (char (*), char (1), ptr, fixed bin (35)); /* gets ptr from name */
	declare model_name		 char (32);
	declare model_ptr		 ptr;
	declare model_type		 char (1);	/* type of model opening */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if DBA */
	declare mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets access for DBA types */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no r acl to model */
	declare mrds_error_$no_model_rel fixed bin (35) ext; /* rel name not known in model */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attr for area */
	declare no_read_permission	 condition;	/* no r acl to model */
	declare open_name		 char (*);	/* name associated with this model opening */
	declare rd_ptr_a		 ptr;		/* temp for mrds_dm_get_attributes entry */
	declare rd_ptr_b		 ptr;		/* temp for get_attributes entry */
	declare rd_ptr_c		 ptr;		/* temp for get_model_attributes entry */
	declare rel_found		 bit (1);		/* on => good rel name given */
	declare relation_name	 char (32);	/* name of relation for which attribute information is desired */
	declare relation_name_a	 char (32);	/* temp for mrds_dm_get_attributes entry */
	declare relation_name_b	 char (32);	/* temp for get_attributes entry */
	declare relation_name_c	 char (*);	/* temp for get_model_attributes entry */
	declare return_area		 area (sys_info$max_seg_size) based (area_ptr);
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare structure_version	 fixed bin;	/* desired structure version */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare sys_info$max_seg_size	 fixed bin (35) external;
	declare user_data_type_wanted	 bit (1) init ("0"b) int static; /* on => user descr, else db descr */
	declare (addr, bit, empty, fixed, null, ptr, rel, rtrim, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local copy */

%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mrds_rel_desc;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include area_info;
%page;
%include mrds_db_model_rel_attrs;
%page;
%include arg_list;

     end mrds_dm_get_attributes;




		    mrds_dm_get_header.pl1          10/16/86  1550.5r w 10/16/86  1145.0      137052



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

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



/*
                   BEGIN_DESCRIPTION
   this routine has three  entries,  get_header  for  use  by  dmd_,
   mrds_dm_get_header for use internally by mrds, and get_model_info
   for use by mmi_

   It's purpose is to return the version and creation infmoration on
   the database model.

   There are three entries. mrds_dm_get_header is for  internal  use
   by  mrds.  get_header is for external use by dmd_. get_model_info
   is for external use by mmi_. The external entries check  for  the
   user being a DBA if the database is secured.
                   END_DESCRIPTION
*/

/* PARAMETERS:

   ======= for the get_model_info entry

   open_name - - (input) char(*), the name given to mmi_$open_model

   area_ptr - - (input) ptr, points to a freeing area for  structure
   allocation

   structure_version - - (input) fixed bin, the desired  version  of
   the structure

   mrds_db_model_info_ptr - - (output) ptr, points to the  allocated
   structure in mrds_db_model_info.incl.pl1

   code - - (output) fixed bin(35), the error status encoding

   ======= for the mrds_dm_get_header and get_header entries

   data_model_ptr - - (input) ptr, the model pointer  returned  from
   dmd_$open_dm

   area_ptr - - (input) ptr, points to an area in which to  allocate
   the header information

   dmh_ptr  -  -  (output)  ptr,  points   to   the   structure   in
   mrds_dm_header.incl.pl1

   code - - (output) fixed bin(35), error status encoding

*/

/* HISTORY:

   Modified by Oris Friesen for new version data  bases  --  October
   1978

   Modified by Jim Gray - - Feb. 1980, to correctly determine  which
   version  database  data_model_ptr, we were being called with. Old
   versions  will  have  data_mode_ptr  =  to  an  iocb_ptr  in  the
   area_linker,  since  it  is  to  the  data_model  vfile  for that
   version.


   81-02-12 Jim Gray  :  changed  so  that  calls  to  the  external
   interface  dmd_$get_header  require  a  DBA  once the database is
   secured.  mrds_dm_get_header  entry  should  only  be  called  by
   internal mrds, and internal mrds should never call the get_header
   entry.

   81-04-22 Jim Gray : added get_model_info entry for mmi_

   83-02-18 Davids: Modified get_model_info entry by adding the label
   exit_get_model_info and changing the deeply nested structure to one
   which just goes to the exit increase of an error. Also added code
   for handling version2 structures and for differentiating between
   version 1 and version 2 structures. Added the declaration for version 1
   structures since the include file now has version 2.

   83-02-24 Davids: changed references to mrds_db_model_info_(V DM)FILE_TYPE
   to mrds_db_model_info_(v dm)file_type, and before_joural in the dmfile_attributes
   substructure of mrds_db_model_info to rollback.

   83-06-10 Roger Lackey : Added code to force version 3 database to be
   vfile_type database instead of trying to overlay the db_model to determine
   what type it is.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

/* BEGIN CHANGE 81-02-12 **************************************** */

mrds_dm_get_header: proc (data_model_ptr_a, area_ptr_a, dmh_ptr_a, code_a);

/* for internal mrds use */

	internal_call = "1"b;

	data_model_ptr = data_model_ptr_a;
	area_ptr = area_ptr_a;

	call common ();

	dmh_ptr_a = dmh_ptr;
	code_a = code;

	return;

get_header: entry (data_model_ptr_b, area_ptr_b, dmh_ptr_b, code_b);

/* for external use only, not by mrds, needs a DBA if db secured */

	internal_call = "0"b;

	data_model_ptr = data_model_ptr_b;
	area_ptr = area_ptr_b;

	call common ();

	dmh_ptr_b = dmh_ptr;
	code_b = code;

	return;

/* END CHANGE 81-02-12 ************************************************* */

/* BEGIN CHANGE 81-04-22 ************************************** */

get_model_info: entry (open_name, area_ptr_c, structure_version, mrds_db_model_info_ptr, code_c);

/* routine to get db creation info for the mmi_ interface.
   It uses the get_header entry to allow secured databases only
   have DBA's use this entry, and to handle old version databases
   in a common manner. */

/* initialize */

	code_c = 0;
	mrds_db_model_info_ptr = null ();

/* get the model pointer from the opening name */

	call mu_open_name_manager$get_model_pointer (open_name, model_type, model_ptr, code_c);
	if code_c ^= 0
	then goto exit_get_model_info;

/* get the header info for either an old or new database,
   not allowing a non-dba to mess with a secured database. */

	call get_header (model_ptr, addr (local_area), dmh_ptr_c, code_c);
	if code_c ^= 0
	then goto exit_get_model_info;

	dmh_ptr = dmh_ptr_c;
	area_ptr = area_ptr_c;

/* check the arguments */

	if area_ptr = null ()
	then do;
		code_c = error_table_$badcall;
		goto exit_get_model_info;
	     end;

	unspec (my_area_info) = "0"b;
	my_area_info.version = 1;
	my_area_info.areap = area_ptr;
	call area_info_ (addr (my_area_info), code_c);
	if code_c ^= 0
	then goto exit_get_model_info;

	if my_area_info.no_freeing
	then do;
		code_c = mrds_error_$not_freeing_area;
		goto exit_get_model_info;
	     end;

	if structure_version ^= 1 & structure_version ^= 2
	then do;
		code_c = error_table_$unimplemented_version;
		goto exit_get_model_info;
	     end;

/* good arguments, fill in the users structure */

	on area begin;
		code_c = error_table_$area_too_small;
		goto exit_get_model_info;
	     end;

	on cleanup begin;
		if mrds_db_model_info_ptr ^= null ()
		then do;
			if structure_version = 1
			then
			     free mrds_db_model_info_ptr -> mrds_db_model_info_1 in (return_area);
			else
			     free mrds_db_model_info_ptr -> mrds_db_model_info in (return_area);
			mrds_db_model_info_ptr = null ();
		     end;
	     end;

	if structure_version = 1
	then do;
		allocate mrds_db_model_info_1 set (mrds_db_model_info_ptr) in (return_area);
		unspec (mrds_db_model_info_1) = "0"b;
		mrds_db_model_info_1.version = 1;
		mrds_db_model_info_1.model_version = dm_header.dmd_version;
		mrds_db_model_info_1.creator_id = dm_header.creator_id;
		mrds_db_model_info_1.creation_time = dm_header.create_time;
	     end;
	else do;
		if dm_header.dmd_version = 3 then vfile_database_sw = "1"b;
		else vfile_database_sw = model_ptr -> db_model.vfile_type;

		allocate mrds_db_model_info set (mrds_db_model_info_ptr) in (return_area);
		unspec (mrds_db_model_info) = "0"b;
		mrds_db_model_info.version = 2;
		mrds_db_model_info.model_version = dm_header.dmd_version;
		mrds_db_model_info.creator_id = dm_header.creator_id;
		mrds_db_model_info.creation_time = dm_header.create_time;
		if vfile_database_sw
		then do;
			mrds_db_model_info.db_type = mrds_db_model_info_vfile_type;
			mrds_db_model_info.dmfile_attributes.protected = "0"b;
			mrds_db_model_info.dmfile_attributes.rollback = "0"b;
			mrds_db_model_info.dmfile_attributes.concurrency = "0"b;
		     end;
		else do;
			mrds_db_model_info.db_type = mrds_db_model_info_dmfile_type;
			mrds_db_model_info.dmfile_attributes.protected = model_ptr -> db_model.db_type_flags.transactions_needed;
			mrds_db_model_info.dmfile_attributes.rollback = model_ptr -> db_model.db_type_flags.rollback_on;
			mrds_db_model_info.dmfile_attributes.concurrency = model_ptr -> db_model.db_type_flags.concurrency_on;
		     end;
	     end;

exit_get_model_info:
	return;

/* END CHANGE 81-04-22 ************************************************* */

common: procedure ();

/* initialize */

	dmh_ptr = null;


	call hcs_$fs_get_path_name (data_model_ptr, db_path, ldn, model_name,
	     code);
	if code = 0 then do;

		dbm_ptr = data_model_ptr;

/* check for the user being a DBA, if the database is secured */

		if ^internal_call then
		     call secured_db_check ();

		if code = 0 then do;

/* fill in the database creation information */

			on cleanup begin;
				if dmh_ptr ^= null () then do;
					free dm_header in (return_area);
					dmh_ptr = null ();
				     end;
			     end;

			on no_read_permission begin;
				code = mrds_error_$no_model_access;
				dmh_ptr = null ();
				goto exit;
			     end;

			allocate dm_header in (return_area);
			unspec (dm_header) = "0"b;

			dm_header.dm_header_id = " "; /* this used to be 'dmd_head' */
			dm_header.dmd_version = db_model.version;

			changer_ptr = pointer (dbm_ptr, db_model.changer_ptr);
			do while (changer_ptr -> changer.next ^= NULL_OFFSET); /* creator is last on change list */
			     changer_ptr = pointer (dbm_ptr, changer_ptr -> changer.next);
			end;

			dm_header.creator_id = changer_ptr -> changer.id;
			dm_header.create_time = changer_ptr -> changer.time;

		     end;
	     end;
exit:

	return;

     end;

/* BEGIN CHANGE 81-02-12 ********************************************** */

secured_db_check: procedure ();

/* routine to check for the database being is a secured state,
   and if so, that the user is a DBA, and thus may use the external entry */

	if code ^= 0 then ;
	else if internal_call then ;
	else do;

/* get the secured state of the dataabase */

		call mrds_dm_db_secured$get_secured_status (dbm_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then

		     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the secured state of database """, db_path, """.");

		else if ^database_state.secured then ;
		else do;

/* database secured, see if the user is a DBA */

			call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then

			     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				"Unable to get user class for database """, db_path, """.");

			else if mrds_authorization.administrator then ;
			else do;

				code = error_table_$insufficient_access;

				call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a ^a",
				     "The database """, db_path, """ has been secured,",
				     "so the caller must be a DBA to use direct model access.");

			     end;

		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr, dbm_ptr = null ();

     end;

/* END CHANGE 81-02-12 ************************************************ */

	declare NULL_OFFSET		 bit (18) init ((18)"1"b);
	declare area		 condition;	/* if area too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area details */
	declare area_ptr		 ptr;		/* points to area in which informationb is returned */
	declare area_ptr_a		 ptr;		/* temp for mrd_dm_get_header entry */
	declare area_ptr_b		 ptr;		/* temp for get_header entry */
	declare area_ptr_c		 ptr;		/* temp for get_model_info entry */
	declare caller_name		 char (32) init ("dmd_$open_dm"); /* name of calling routine */
	declare cleanup		 condition;
	declare code		 fixed bin (35);	/* status return code */
	declare code_a		 fixed bin (35);	/* temp for mrds_dm_get_header entry */
	declare code_b		 fixed bin (35);	/* temp for get_header entry */
	declare code_c		 fixed bin (35);	/* temp for get_model_info entry */
	declare continue		 char (1) init ("c"); /* dont stop after print mesg */
	declare data_model_ptr	 ptr;		/* points to data model to be searched -- input */
	declare data_model_ptr_a	 ptr;		/* temp for mrds_dm_get_header entry */
	declare data_model_ptr_b	 ptr;		/* temp for get_header_entry */
	declare db_path		 char (168);
	declare dmh_ptr_a		 ptr;		/* temp for mrds_dm_get_header entry */
	declare dmh_ptr_b		 ptr;		/* temp for get_header entry */
	declare dmh_ptr_c		 ptr;		/* temp for get_model_info entry */
	declare error_table_$area_too_small fixed bin (35) ext; /* small area */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$insufficient_access fixed bin (35) ext; /* not DBA and db secured */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* bad struct version */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare info_ptr		 ptr init (null ());/* unused */
	declare internal_call	 bit (1);		/* on => called from mrds, not by dmd_ */
	declare ldn		 fixed bin;
	declare local_area		 area (1024);	/* space for db state, and user class info */
	declare mu_open_name_manager$get_model_pointer entry (char (*), char (1), ptr, fixed bin (35)); /* gets ptr from name */
	declare model_name		 char (32);
	declare model_ptr		 ptr;
	declare model_type		 char (1);	/* type of opening */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if DBA */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no r acl to model */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attr on area */
	declare no_read_permission	 condition;	/* no r acl to model */
	declare open_name		 char (*);	/* model opening name */
	declare return_area		 area (sys_info$max_seg_size) based (area_ptr);
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare structure_version	 fixed bin;	/* desired structure version */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare sys_info$max_seg_size	 fixed bin ext;
	declare vfile_database_sw	 bit (1) aligned;
	declare (addr, empty, fixed, rel, null, pointer, rtrim, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local copy */
	declare 1 mrds_db_model_info_1 aligned based (mrds_db_model_info_ptr),
						/* version 1 of this structure (now obsolete) */
		2 version		 fixed bin,	/* version number for this structure */
		2 model_version	 fixed bin,	/* the version number of the database model */
		2 creator_id	 char (32),	/* the person.project.tag of the database creator */
		2 creation_time	 fixed bin (71),	/* the convert date to binary form of the database creation time */
		2 mbz		 bit (36) unal;

%include mdbm_db_model;
%page;
%include mrds_dm_header;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include area_info;
%page;
%include mrds_db_model_info;

     end mrds_dm_get_header;




		    mrds_dm_get_relations.pl1       10/16/86  1550.5r w 10/16/86  1145.0      123966



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

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


/* DESCRIPTION:

   The routine returns the names of all  relations  defined  in  the
   database  model. There are 3 entries, mrds_dm_get_relations is an
   internal entry for use by  mrds,  get_relations  is  an  external
   entry  for  use  by  dmd_, and get_model_relations is an external
   entry for use by mmi_. The external entries make sure the user is
   a DBA if the database has been secured.

*/

/* PARAMETERS:

   ======= get_model_relations entry

   open_name - - (input) char(*), the open name supplied in the call
   to mmi_$open_model

   area_ptr - - (input) ptr, pointer to an area in which  to  return
   info

   structure_version - - (input) fixed bin,  the  desired  structure
   version

   mrd_db_model_relations_ptr - - (output) ptr, the pointer  to  the
   list of model relation names in mrd_db_model_relations.incl.pl1

   code - - (output) fixed bin (35), the error status encoding

   ======= mrds_dm_get_relations and get_relations entries

   data_model_ptr - - (input) ptr, the pointer returned from a  call
   to dmd_$open_dm

   area_ptr - - (input) ptr, points to an area in  which  to  return
   info

   mr_ptr - - (output) ptr, points to the relation names returned in
   mrds_model_relations.incl.pl1

   code - - (output) fixed bin (35), the error status encoding

*/

/* HISTORY :

   Modified by J. A. Weeldreyer to incorporate domain separation  --
   November, 1976.

   Modified by Oris Friesen to accomodate new version data bases  --
   October 1978

   Modified by Jim Gray  -  -  Feb.  1980,  to  correctly  determine
   whether  data_model_ptr  refers to an old or new version database
   model.

   80-12-30 Jim Gray : captured error  message  when  no  access  to
   model segment, and translated into meaningful mrds error code.

   81-01-31 Jim Gray : added setting of needed for DBA types, if  an
   access violation occurs.

   81-02-12  Jim  Gray  :  added  need  for  external   callers   to
   dmd_$get_relations  to be a DBA if db secured, this should not be
   called   internally   from   mrds,   mrds    should    use    the
   mrds_dm_get_relations entry.

   81-04-23 Jim Gray : changed method of  obtaining  relation  names
   from that of looking at all relation model segments, to using the
   file names as the relation names, and getting them all out of the
   db_model segment. This was done on the premise that blocked files
   are not to be implemented.

   81-04-23 Jim Gray : added get_model_relations entry for mmi_

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

/* BEGIN CHANGE 81-02-12 ********************************************* */

mrds_dm_get_relations: procedure (data_model_ptr_a, area_ptr_a, mr_ptr_a, code_a);

/* entry to be used internal by mrds, no access checking required */

	internal_call = "1"b;

	data_model_ptr = data_model_ptr_a;
	area_ptr = area_ptr_a;

	call common ();

	mr_ptr_a = mr_ptr;
	code_a = code;

	return;




get_relations: entry (data_model_ptr_b, area_ptr_b, mr_ptr_b, code_b);

/* this entry should only be called externally from dmd_, never by mrds */

	internal_call = "0"b;

	data_model_ptr = data_model_ptr_b;
	area_ptr = area_ptr_b;

	call common ();

	mr_ptr_b = mr_ptr;
	code_b = code;

	return;

/* END CHANGE 81-02-12 ****************************************** */

/* BEGIN CHANGE 81-04-23 B ********************************************* */

get_model_relations: entry (open_name, area_ptr_c, structure_version, mrds_db_model_relations_ptr, code_c);

/* this entry is for the mmi_ interface. it calls the get_relations
   entry to be able to handle both old and new version databases,
   and also to be able to detect non-dba's using a secured database. */

	code_c = 0;
	mrds_db_model_relations_ptr = null ();

/* get the model pointer from the opening name */

	call mu_open_name_manager$get_model_pointer (open_name, model_type, model_ptr, code_c);
	if code_c = 0 then do;

/* get the list of relation names from the old or new model */

		call get_relations (model_ptr, addr (local_area), mr_ptr_c, code_c);
		if code_c = 0 then do;

/* check the callers arguments */

			mr_ptr = mr_ptr_c;
			area_ptr = area_ptr_c;

			if area_ptr = null () then
			     code_c = error_table_$badcall;
			else do;
				unspec (my_area_info) = "0"b;
				my_area_info.version = 1;
				my_area_info.areap = area_ptr;

				call area_info_ (addr (my_area_info), code_c);
				if code_c ^= 0 then ;
				else if my_area_info.no_freeing then
				     code_c = mrds_error_$not_freeing_area;
				else do;

					if structure_version ^= mrds_db_model_relations_structure_version then
					     code_c = error_table_$unimplemented_version;
					else do;

/* fill in the users structure details */

						on area begin;
							code_c = error_table_$area_too_small;
							goto skip_allocate;
						     end;

						on cleanup begin;
							if mrds_db_model_relations_ptr ^= null () then do;
								free mrds_db_model_relations in (return_area);
								mrds_db_model_relations_ptr = null ();
							     end;
						     end;

						mrds_db_model_relations_count_init = model_relations.nrels;
						allocate mrds_db_model_relations set (mrds_db_model_relations_ptr) in (return_area);
						revert area;

						unspec (mrds_db_model_relations) = "0"b;
						mrds_db_model_relations.version = mrds_db_model_relations_structure_version;
						mrds_db_model_relations.relation_count = mrds_db_model_relations_count_init;

/* get all relation names */

						do i = 1 to mrds_db_model_relations_count_init;

						     mrds_db_model_relations.relation (i).name = model_relations.relation_name (i);

						end;

					     end;
				     end;
			     end;
		     end;
	     end;

skip_allocate:

	return;

/* END CHANGE 81-04-23 B ********************************************* */

common: procedure ();

/* check for which version of mrds to call,
   based on the version of the model being referenced */

	mr_ptr = null ();
	code = 0;

	call hcs_$fs_get_path_name (data_model_ptr, db_path, ldn, model_name, code);
	if code = 0 then do;

		dbm_ptr = data_model_ptr;

/* check for a non-DBA trying to use this interface
   on a secured database, which is not allowed */

		if ^internal_call then
		     call secured_db_check ();

/* get the relation names from the database model */

		if code = 0 then do;

/* BEGIN CHANGE 81-04-23 A ******************************************** */

			on cleanup begin;
				if mr_ptr ^= null then do;
					free model_relations in (return_area);
					mr_ptr = null ();
				     end;
			     end;

			on no_read_permission begin;
				code = mrds_error_$no_model_access;
				mr_ptr = null ();
				goto exit;
			     end;

			num_relations_alloc = db_model.num_rels;
			allocate model_relations in (return_area);
			unspec (model_relations) = "0"b;
			model_relations.nrels = num_relations_alloc;

			indx1 = 1;

			do fi_ptr = ptr (dbm_ptr, db_model.file_ptr)
			     repeat ptr (dbm_ptr, file_info.fwd_ptr)
			     while (rel (fi_ptr) ^= NULL_OFS);

/* get the relation name out of the db_model segment,
   by assuming that there is one relation per file,
   and the file name is the same as the relation name. */

			     model_relations.relation_name (indx1) = file_info.file_name;
			     indx1 = indx1 + 1;
			end;

/* END CHANGE 81-04-23 A ********************************************* */


		     end;
	     end;
exit:
	return;

     end;

/* BEGIN CHANGE 81-02-12 ********************************************* */

secured_db_check: procedure ();

/* routine to check for the database being is a secured state,
   and if so, that the user is a DBA, and thus may use the external entry */

	if code ^= 0 then ;
	else if internal_call then ;
	else do;

/* get the secured state of the dataabase */

		call mrds_dm_db_secured$get_secured_status (dbm_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then

		     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the secured state of database """, db_path, """.");

		else if ^database_state.secured then ;
		else do;

/* database secured, see if the user is a DBA */

			call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then

			     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				"Unable to get user class for database """, db_path, """.");

			else if mrds_authorization.administrator then ;
			else do;

/* not DBA on secured db, issue error */

				code = error_table_$insufficient_access;
				call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a ^a",
				     "The database """, db_path, """ has been secured,",
				     "so the caller must be a DBA to use direct model access.");

			     end;

		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr, dbm_ptr = null ();

     end;

/* END CHANGE 81-02-12 ************************************************ */

	declare NULL_OFS		 bit (18) unal int static init ("111111111111111111"b) options (constant);
	declare area		 condition;	/* if area too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area details */
	declare area_ptr		 ptr;		/* pointer to the area in which to return information */
	declare area_ptr_a		 ptr;		/* temp for mrds_dm_get_relations entry */
	declare area_ptr_b		 ptr;		/* temp for get_relations entry */
	declare area_ptr_c		 ptr;		/* temp for get_model_relations entry */
	declare caller_name		 char (32) init ("dmd_$open_dm"); /* name of calling routine */
	declare cleanup		 condition;
	declare code		 fixed bin (35);	/* a standard Multics system status code (Output) */
	declare code_a		 fixed bin (35);	/* temp for mrds_dm_get_relations entry */
	declare code_b		 fixed bin (35);	/* temp for get_relations entry */
	declare code_c		 fixed bin (35);	/* temp for get_model_relations entry */
	declare continue		 char (1) init ("c"); /* dont stop after print mesg */
	declare data_model_ptr	 ptr;		/* iocb pointer to the data model to be searched (Input) */
	declare data_model_ptr_a	 ptr;		/* temp for mrds_dm_get_relations entry */
	declare data_model_ptr_b	 ptr;		/* temp for get_relations entry */
	declare db_path		 char (168);
	declare error_table_$area_too_small fixed bin (35) ext; /* area not big enough */
	declare error_table_$badcall	 fixed bin (35) ext;/* area ptr null */
	declare error_table_$insufficient_access fixed bin (35) ext; /* not DBA and db secured */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* unknown structure version */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	declare i			 fixed bin;	/* loop index */
	declare indx1		 fixed bin;
	declare info_ptr		 ptr init (null ());/* unused */
	declare internal_call	 bit (1);		/* on => called from mrds, not by dmd_ */
	declare ldn		 fixed bin;
	declare local_area		 area (4096);	/* space for db state, and user class info */
	declare mu_open_name_manager$get_model_pointer entry (char (*), char (1), ptr, fixed bin (35)); /* gets ptr from name */
	declare model_name		 char (32);
	declare model_ptr		 ptr;
	declare model_type		 char (1);	/* type of model opening */
	declare mr_ptr_a		 ptr;		/* temp for mrds_dm_get_relations entry */
	declare mr_ptr_b		 ptr;		/* temp for get_relations entry */
	declare mr_ptr_c		 ptr;		/* temp for get_model_relations entry */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if DBA */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no r acl to model */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attr for area */
	declare no_read_permission	 condition;	/* no r acl on model */
	declare open_name		 char (*);	/* opening name associated with model opening */
	declare return_area		 area (sys_info$max_seg_size) based (area_ptr);
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare structure_version	 fixed bin;	/* desired version of structure */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare sys_info$max_seg_size	 fixed bin (35) external;
	declare (addr, empty, fixed, null, ptr, rel, rtrim, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local copy */

%include mrds_model_relations;
%page;
%include mdbm_db_model;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include mrds_db_model_relations;
%page;
%include area_info;

     end mrds_dm_get_relations;




		    mrds_dm_open.pl1                03/08/88  1539.2rew 03/08/88  1531.6      134586



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        * Copyright (c) 1976 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(88-01-19,Blair), approve(88-02-26,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Add code to find the db pathname using a "mrds" searchlist. SCP6366.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

   This procedure opens a data model for retrieval. A pointer to the
   opened   data   model  is  returned  if  no  errors  occur.  (for
   mrds_dm_open and open_dm) An opening name is associated with  the
   opening for the open_model entry.

   The mrds_dm_open entry is for use by internal mrds.  The  open_dm
   entry  is  for  external sue by dmd_. The open_model entry is for
   external use by mmi_. The external entries  check  for  the  user
   being  a  DBA  if  the  database  ius secured. A DBA will get any
   needed access set if an acces violation occurs.

*/

/* PARAMETERS:

   ======== open_model entry

   rel_path - - (input) char(*), the relative or  absolute  pathname
   of  the  database  whose  model  is  to  be  opened, no suffix is
   required.

   open_name - - (input) char(*), the opening name (arbitrary) to be
   assoicated  with  this  opening  of  the model, and to be used in
   subsequent mmi_ calls

   code - - (output) fixed bin(35), the error status encoding

   ======== mrds_dm_open and open_dm entries

   rel_path - - (input) char(168),  the  relative  pathname  of  the
   database  model  to  be  opened.  This  will be the pathname of a
   directory with a msf named "data_model" under it for old  version
   databases,  or  with  a segment named "db_model" under it for new
   version databases, with a ".db" suffix on the directory.

   mode - - (input) fixed bin, either 1 or 2, currently only mode  =
   2 for retrieval from a database model is supported.

   data_model_ptr - - (output) pointer, the database model  segment(
   or  msf)  pointer, that is returned upon a successfull opening of
   the data model.

   code - -  (output)  fixed  bin(35),  the  standard  error  status
   encoding, 0 unless an error occured.

*/

/* HISTORY:

   Written by RG Luebke October 1975

   Modified by J. A. Weeldreyer to change header -- December, 1976.

   Modified by O D Friesen to handle queued scope requests  --  July
   1977

   Modified by Oris Friesen to accomodate new version data bases  --
   October 1978


   Modified by Jim Gray - -  Jan.  1980,  to  disallow  opening  for
   creation.

   Rewritten by Jim Gray - - Feb. 1980,  to  correct  bad  logic  in
   determining  type and version of database, and to remove obsolute
   subroutine calls.

   Modified by Jim Gray - - June 1980, to change  Entry  not  found.
   error  message  to  the  no_database  error message, to make more
   sense to higher level routines.

   81-01-21 Jim Gray : modified to have access set for DBA types

   81-02-12 Jim Gray : modified to have the  open_dm  entry,  called
   only by dmd_, to require a DBA once the database is secured.

   81-04-22 Jim Gray : added  the  open_model  entry  for  the  mmi_
   interface.    Changed    path    checking    to   use   the   new
   mrds_dm_check_path routine, so that suffixes  would  be  handled,
   and access violation handling delayed for possible DBA setting of
   needed access. The mrds_dm_open_table_mgr usage  was  removed  to
   allow  the  new  open  name manager to provide the only number of
   opening restrictions.

   81-04-30 Jim Gray : added error_table_$no_info to codes  captured
   from  hcs_$initiate  of the db_model segment, for case where user
   has no acl to both db dir and db_model. This gets translated into
   mrds_error_$no_model_access.

   83-06-17 Davids: Replaced the generate_call to dmd_v1_$open_dm
   with an error code assignment (mrds_error_$version_3_db) to indicate that
   old version databases are no longer supported.

   83-06-21 Davids: Removed the rest of the overhead dealing with 
   old version database which is now never executed (except to decide
   not to execute it).
*/

/* BEGIN CHANGE 81-02-12 *********************************************** */

mrds_dm_open: procedure (rel_path_a, mode_a, data_model_ptr_a, code_a);

/* entry to be used internally by mrds code, no access restrictions */

	internal_call = "1"b;
	rel_path = rel_path_a;
	mode = mode_a;

	call common ();

	data_model_ptr_a = data_model_ptr;
	code_a = code;

	return;







open_dm: entry (rel_path_b, mode_b, data_model_ptr_b, code_b);

/* entry to be called only via dmd_, never by any mrds modules,
   to use this entry on a secured database, the user must be a DBA */

	internal_call = "0"b;
	rel_path = rel_path_b;
	mode = mode_b;

	call common ();

	if code = 0 then
	     call secured_db_check ();

	data_model_ptr_b = data_model_ptr;
	code_b = code;

	return;

/* END CHANGE 81-02-12 ********************************************* */

/* BEGIN CHANGE 81-04-22 ************************************************ */

open_model: entry (rel_path_c, open_name, code_c);

/* this entry is called from mmi_ for opening the model,
   it makes use of the open_dm entry to make sure the user
   is a DBA if the database is secured. */

	call open_dm ((rel_path_c), 2, model_ptr, code_c);
	if code_c = 0 then do;

/* opening successful, associate the model pointer with the open name */

		call mu_open_name_manager$define_open_name (open_name, "m" /* model opening type */, model_ptr, code_c);

	     end;

	return;

/* END CHANGE 81-04-22 ************************************************** */

common: procedure ();

/* initialize */

	dbm_ptr, data_model_ptr = null ();
	code = 0;

/* check the opening mode given */

	if mode < 1 | mode > 2 then
	     code = mrds_error_$invalid_opening_mode;

	else if mode = 1				/* indicates opening for creation */ then do;
		code = mrds_error_$invalid_opening_mode;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a",
		     "Opening database models for creation will not be allowed until a later release.");
	     end;

	else if mode = 2				/* open for retrieval */ then do;

/* BEGIN CHANGE 81-04-22 ************************************************ */

/* check on the path that was given to us, it may be
   to either an old or new architecture database, and for
   new databases, it may or may not have the .db suffix */

		use_search_paths = "0"b;
		if search (rel_path, "<>") = 0 then do;
		     call search_paths_$get (MRDS_SEARCHLIST, sl_control_default, "", null (), addr(local_area),
			sl_info_version_1, mrds_search_list_ptr, code);
		     loop_idx = mrds_search_list_ptr -> sl_info.num_paths;
		     use_search_paths = "1"b;
		     end;
		else do;
		     call absolute_pathname_ (rel_path, abs_path, code);
		     loop_idx = 1;
		     end;
		if code = 0 then do;
		     code = 1;
		     do idx = 1 to loop_idx while (code ^= 0);
			if use_search_paths then abs_path = pathname_ (mrds_search_list_ptr -> sl_info.paths(idx).pathname, rel_path);
			call mrds_dm_check_path (abs_path, containing_dir, db_dir, new_found, code);
			if code = error_table_$incorrect_access then
			     code = 0;	/* ignore access problems for right now,
					              may need to set acl's for a DBA */
			end;                          /* end do */
		     end;

		if code = 0 then do;
			if ^new_found		/* old architecture */
			then code = mrds_error_$version_3_db;
			else do;

/* now we need to get a pointer to the new architecture model segment */

				db_path = rtrim (containing_dir) || ">" || db_dir;

/* END CHANGE 81-04-22 ************************************************* */

/* BEGIN CHANGE 81-01-21 *********************************************** */

				call hcs_$initiate (db_path, "db_model", "", 0, 1, data_model_ptr, code);

				if code = error_table_$moderr |
				     code = error_table_$no_info then do; /* segment present */
					call mrds_dm_authorization$set_needed_access
					     (rtrim (db_path), code); /* if user DBA */

					if code ^= 0 then
					     code = mrds_error_$no_model_access; /* this used to be error_table_$moderr */
					else call hcs_$initiate (db_path, "db_model", "", 0, 0, data_model_ptr, code);
				     end;

/* END CHANGE 81-01-21 ********************************************** */

				if data_model_ptr ^= null then do;

					dbm_ptr = data_model_ptr;

					if db_model.version ^= 4 then
					     code = error_table_$unimplemented_version;
					else code = 0;


				     end;
			     end;
		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr, dbm_ptr = null ();

	return;

     end;

/* BEGIN CHANGE 81-02-12 ********************************************* */

secured_db_check: procedure ();

/* routine to check for the database being is a secured state,
   and if so, that the user is a DBA, and thus may use the external entry */

	if code ^= 0 then ;
	else if internal_call then ;
	else do;

/* get the secured state of the dataabase */

		call mrds_dm_db_secured$get_secured_status (dbm_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then

		     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the secured state of database """, db_path, """.");

		else if ^database_state.secured then ;
		else do;

/* database secured, see if the user is a DBA */

			call mrds_dm_authorization$get_user_class (rtrim (db_path), addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then

			     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				"Unable to get user class for database """, db_path, """.");

			else if mrds_authorization.administrator then ;
			else do;

/* not DBA on secured db, issue error */

				code = error_table_$insufficient_access;
				call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a ^a",
				     "The database """, db_path, """ has been secured,",
				     "so the caller must be a DBA to use direct model access.");

			     end;

		     end;

	     end;

	if code ^= 0 then
	     data_model_ptr, dbm_ptr = null ();

     end;

/* END CHANGE 81-02-12 ************************************************ */

          declare MRDS_SEARCHLIST        char (4) init ("mrds") int static options (constant);
          declare abs_path               char (168);
          declare absolute_pathname_     entry (char(*), char(*), fixed bin(35));
	declare caller_name		 char (32) init ("dmd_$open_dm"); /* name of calling routine */
	declare code		 fixed bin (35);	/* error return code (Output) */
	declare code_a		 fixed bin (35);	/* temp for mrds_dm_open entry */
	declare code_b		 fixed bin (35);	/* temp for open_dm entry */
	declare code_c		 fixed bin (35);	/* error code for open_model entry */
	declare containing_dir	 char (168);	/* dir over db */
	declare continue		 char (1) init ("c"); /* dont stop after print mesg */
	declare ctl_file		 char (32) init ("ctl_file");
	declare data_model_ptr	 ptr;		/* pointer to the opened data model (Output) */
	declare data_model_ptr_a	 ptr;		/* temp for mrds_dm_open entry */
	declare data_model_ptr_b	 ptr;		/* temp for open_dm entry */
	declare db_dir		 char (32);	/* db entry name */
	declare db_path		 char (168);
	declare error_table_$incorrect_access fixed bin (35) ext; /* no acl to db */
	declare error_table_$insufficient_access fixed bin (35) ext; /* not DBA and db secured */
	declare error_table_$moderr	 fixed bin (35) ext;/* no access */
	declare error_table_$no_info	 fixed bin (35) ext;/* no acl to db dir or db_model */
	declare error_table_$unimplemented_version fixed bin (35) external;
	declare hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
          declare idx                    fixed bin;
	declare info_ptr		 ptr init (null ());/* unused */
	declare internal_call	 bit (1);		/* on => called from mrds, not by dmd_ */
	declare local_area		 area (4096);	/* space for db state, user class info, and search list */
          declare loop_idx               fixed bin;
	declare mu_open_name_manager$define_open_name entry (char (*), char (1), ptr, fixed bin (35)); /* associates name with ptr */
	declare mode		 fixed bin;	/* mode of opening 1= creation 2= retrieval (Input) */
	declare mode_a		 fixed bin;	/* temp for mrds_dm_open entry */
	declare mode_b		 fixed bin;	/* temp for open_dm entry */
	declare model_ptr		 ptr;
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if DBA */
	declare mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets access needed, if DBA */
	declare mrds_dm_check_path	 entry (char (*), char (168), char (32), bit (1), fixed bin (35)); /* checks for legal db path */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare mrds_error_$invalid_opening_mode fixed bin (35) external;
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no r acl on db_model */
	declare mrds_error_$version_3_db fixed bin (35) ext;
          declare mrds_search_list_ptr   ptr;
	declare new_found		 bit (1);		/* on => new version architecture */
	declare open_name		 char (*);	/* user defined opening name */
          declare pathname_              entry (char(*), char(*)) returns(char(168));
	declare rel_path		 char (168);	/* pathname of data model  (Input) */
	declare rel_path_a		 char (168);	/* temp for mrds_dm_open entry */
	declare rel_path_b		 char (168);	/* temp for open_dm entry */
	declare rel_path_c		 char (*);	/* relative db path for open_model entry */
	declare return_value	 fixed bin (35) init (0); /* unused */
          declare search_paths_$get      entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35));
	declare sub_err_		 entry options (variable); /* reports errors */
	declare sys_info$max_seg_size	 fixed bin (35) ext;
          declare use_search_paths       bit (1);
	declare (addr, empty, fixed, null, rel, rtrim, search) builtin;

%include mdbm_db_model;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include sl_info;
%page;
%include sl_control_s;

     end mrds_dm_open;




		    mrds_dm_secured_submodel.pl1    04/18/85  1429.4re  04/18/85  0906.6       39078



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

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

/* HISTORY:

   Originally written by Jim Gray - - February 1981

*/

mrds_dm_secured_submodel: procedure (db_dir, sm_dir, sm_name) returns (bit (1));

/* DESCRIPTION:

   This routine determines whether a given submodel resides under the
   secure.submodels directory in the database.
   It requires the path to the database, the submodel containing dir,
   and the submodel name, returning either true or false.
   This routine was written because it is common code used in several places,
   and the same algorithm was desired.
   It is not meant to be used externally to mrds, so absolute
   pathnames are requried.

*/

/* PARAMETERS:

   db_dir - - (input) char(*), the absolute path of the database

   sm_dir - - (input) char(*), the absolute path of the containing dir
   for the submodel in question.

   sm_name - - (input) char(*), the entryname of the submodel in question

   returned - - (output) bit(1), on => secured submodel in secure.submodels directory
   underneath the database dir

*/

/* check for the submodel being properly under the db */

	real_sm_dir = rtrim (db_dir) || ">" || mrds_data_$submodel_dir_name;
	if get_uid (sm_dir, sm_name, chase_links) = /* get uids, submodel + where should be */
	     get_uid (real_sm_dir, sm_name, dont_chase_links) then
	     answer = "1"b;				/* secured submodel */
	else answer = "0"b;				/* not a secure submodel */

	return (answer);

get_uid: procedure (dir, entry, chase_sw) returns (bit (36));

/* routine to get the unique identifier of an entry,
   chasing links or not as chase_sw is set */

	allocate status_branch set (status_ptr) in (work_area); /* this area init only for submodels */

	call hcs_$status_long (dir, entry, chase_sw, status_ptr, addr (work_area), temp_code);

	if temp_code ^= 0 & temp_code ^= error_table_$no_s_permission then
	     entry_uid = bit (chase_sw);		/* return junk if we cant get uid */
	else if chase_sw = dont_chase_links & status_ptr -> status_branch.short.type = Link then
	     entry_uid = bit (chase_sw);
	else entry_uid = status_ptr -> status_branch.long.uid;

	return (entry_uid);



	declare entry_uid		 bit (36);	/* returned unique id of entry */
	declare temp_code		 fixed bin (35);	/* unused err code, only effects of error reported */
	declare dir		 char (*);	/* directory of entry */
	declare entry		 char (*);	/* entry portion */
	declare chase_sw		 fixed bin (1);	/* 0 => dont, 1 => do chase links */

     end;

	declare addr		 builtin;
	declare bit		 builtin;
	declare empty		 builtin;
	declare rtrim		 builtin;
	declare answer		 bit (1);		/* returned answer, on => secured submodel */
	declare hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); /* gets all info about entry */
	declare chase_links		 fixed bin (1) init (1); /*  1 => do chase links */
	declare dont_chase_links	 fixed bin (1) init (0); /* 0 => dont chase links */
	declare real_sm_dir		 char (168);	/* actual path to submodel dir from db */
	declare error_table_$no_s_permission fixed bin (35) ext; /* null access on dir */
	declare work_area		 area (2048);	/* space for status long info */
	declare db_dir		 char (*);	/* abs path to db */
	declare sm_dir		 char (*);	/* abs path to sm containing dir */
	declare sm_name		 char (*);	/* entryname of submodel */
	declare mrds_data_$submodel_dir_name char (16) char (16) ext; /* name of submodel directory */

%include status_structures;

     end;




		    mrds_dsm_close.pl1              04/18/85  1429.4re  04/18/85  0906.6       21924



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

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

mrds_dsm_close: proc (iocb_ptr, code);

/*
   The close_dsm  module  has  two  entry  points  for  closing  and
   detaching  data  submodels. The first, close, closes detaches and
   destroyes the iocb and  returns  any  errors.  The  second  entry
   point,  force,  closes  detaches  and destroyes the iocb with out
   returning any error codes.

   Known Bugs:

   Other Problems:

   HISTORY

   75-11-?? Lackey: written.

   81-02-02 Davids: added the call to iox_$destroy_iocb.
*/

/* PARAMETERS */

	dcl     iocb_ptr		 ptr;		/* (input) pointer to the iocb */
	dcl     code		 fixed bin (35);	/* (output) error code */

/* AUTOMATIC */

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

/* BUILTINS */

	dcl     null		 builtin;

/* ENTRIES */

	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$badcall	 fixed bin (35) external static;





	if iocb_ptr ^= null ()
	then do;
		call iox_$close (iocb_ptr, code);
		if code = 0
		then do;
			call iox_$detach_iocb (iocb_ptr, code);
			if code = 0
			then call iox_$destroy_iocb (iocb_ptr, code);
		     end;
	     end;
	else code = error_table_$badcall;

	return;

force: entry (iocb_ptr);

	if iocb_ptr ^= null ()
	then do;
		call iox_$close (iocb_ptr, a_code);
		call iox_$detach_iocb (iocb_ptr, a_code);
		call iox_$destroy_iocb (iocb_ptr, a_code);
	     end;

	return;

     end /* mrds_dsm_close */;




		    mrds_dsm_compute_access.pl1     04/18/85  1429.4re  04/18/85  0906.7      366021



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

mrds_dsm_compute_access: proc (p_caller_name, p_submodel_path, p_listing_iocb_ptr, p_data_model_ptr, p_code);

/*
   where:
   .   p_caller_name	char (*)		(input)
   .     name of the module calling this  routine,  used  for  error
   .     reporting
   .   p_submodel_path	char (*)		(input)
   .     path of submodel access bits are to be computed for
   .   p_listing_iocb_ptr     ptr                 (input)
   .     pointer to the listing iocb or null if no listing is  being
   .     produced
   .   p_data_model_ptr       ptr                 (input)
   .     pointer to the data_model used for verifing relation access
   .   p_code		fixed bin (35)	(output)
   .     stand error code

   Takes a  submodel  vfile  as  produced  by  create_mrds_dsm  (via
   mrds_dsm_parse,  et.al.)  and  fills  in  the  access bits in the
   relation records.

   The  processing  of  the  dsm   is   done   via   two   switches,
   relation_records_iocb_ptr  and  access_records_iocb_ptr. A select
   control order is done on the relation_records_iocb_ptr switch  to
   get  only the relation records. These are then processed one at a
   time.

   First calc_relation_access is called for  the  current  relation,
   then calc_attr_access is called for each attribute in the current
   relation. calc_relation_access and  calc_attr_access  operate  by
   looking  around  in  the  dsm for various kinds of access records
   which relate to the current object. The basic algorithm  is  that
   the  access  records  are  looked  for  in  decreasing  order  of
   specificity. Whenever an access record  is  found,  get_(relation
   attribute)_access  is  called  to decode the access mode names in
   the access record and set the appropriate bits in a bit string.

   The access_records_iocb_ptr switch is used by the calc_* routines
   so  that  their  poking  around  in the dsm won't through off the
   positioning of the walk through all of  relations.  Also,  having
   the  two  allows  the  use of a select order to find the relation
   records and use read_record to sequence through them  instead  of
   doing successive searches via get_key control orders.

   When all the relations and their attributes have  been  processed
   the access records are checked to be sure that they were all used
   at least once. If a record is not  used  it  is  assumed  that  a
   problem  exists  in  the  source  (possibly  a typo in the access
   specification statement or the relation statement) and  an  error
   is reported.

   Internal procedures do not return error codes. If an error occurs
   that  cannot  be  recovered from while in an internal procedure a
   call to program_logic_error is made which will report the  error,
   cleanup,   set  the  return  code,  and  do  a  non-local  go  to
   exit_compute_access to exit this routine. If an error occurs that
   can  be  recovered  from (semantic error based on incorrect cmdsm
   source) it is reported and the error code  set  (via  a  call  to
   report error) and processing is continued like it never happened.



   Known Bugs:

   Other Problems:
   
   HISTORY:

   79-11-30 Spratt: Written

   80-02-21 Spratt: to convert from  compute_dsm_access  command  to
   .        mrds_dsm_compute_access subroutine.

   80-12-05  Spratt:  the  p_caller_name  argument  added  to  allow
   .        reporting of errors as though the calling  program  were
   .        doing the reporting.

   .        The get_access routine was changed  to  have  its  input
   .        mode_name_array  argument  be  0  based so that it could
   .        catch "null" modes  properly  (now  declared  (0:*)  was
   .        declared (*)).

   .        Added the null mode for relations,  removed  the  status
   .        mode.

   .        Changed all error messages to have initial newlines.

   80-12-08 Spratt: Added a cleanup_handler routine, which is called
   .        before any return  and  on  the  cleanup  condition.  It
   .        primarily  ensures  that  the  iox_ switches against the
   .        submodel are closed and detached.

   .        Made the names of the dsm switches unique.

   .        Changed myname from internal static options(constant) to
   .        automatic, to allow it to be set.

   81-01-23 Davids: modified the calls to iox_$read_record  so  that
   .        they used as a buffer  size  sys_info$max_seg_size  *  4
   .        rather  than 261120 which aside from being a constant is
   .        just the number of words in a segment not the number  of
   .        bytes.

   81-05-01 Davids: reformated and remodulated - many, many changes.

   81-05-04 Davids: added checks for  unused  access  specifications
   .        and for continuing checking after the first  combination
   .        of  null  and non-null access is found. Also if an error
   .        is found it now returns a non-zero error code.

   81-05-11  Davids  added  the  parameter  p_listing_iocb_ptr   and
   .        changed report error  to  report  errors  via  ioa  over
   .        iox_$error_output   and   the  listing_iocb_ptr  if  its
   .        non-null.

   81-05-12     Davids:     changed     error_table_$bad_arg      to
   .        mrds_error_$inconsistent_submodel. The error  code  does
   .        not have to be all that informative since each error has
   .        an expanatory message associated with it.

   81-05-22 Davids:  added  a check to be sure that keys of the form
   .        model relation: are not used to read in access records.

   .        added  the  data_model_ptr to the parameter list and the
   .        internal procedure validate_relation_access

   81-05-27 Davids: changed the action for  a  non-zero  error  code
   .        returned      from       mrds_dm_get_attributes       in
   .        validate_relation_access      from     a     call     to
   .        program_logic_error to a simple return  statement.  this
   .        is  because  the  failure  of mrds_dm_get_attributes has
   .        already been reported in mrds_dsm_semantics.  processing
   .        continues  (both  here  and in semantics) so the maximum
   .        number of errors can be reported.

   81-09-17  Davids:  added  a  local_key_string  variable  to   the
   .        internal  procedure  verify_access_record_use  which  is
   .        char   (256)   non-varying.   this   is  because  substr
   .        (key_string, 1, 15) would cause a  stringsize  error  is
   .        key_string  was  not  at  least  15  characters long. by
   .        assigning key_string to local_key_string it  is  assured
   .        that  the  string will be long enough - just padded with
   .        blanks.

   83-06-13 Harvey: changed references to addrel (addr (REL_HEAD), 1)
   .        to  be  addrel (temp_ptr, 1)  instead.  This is due to  a
   .	  compiler bug (TR 15402).

*/

/* PARAMETER */

	dcl     p_caller_name	 char (*);	/* (input) name of the module calling this
						   routine - used for error reporting */
	dcl     p_submodel_path	 char (*);	/* (input) path of submodel - including the .dsm suffix */
	dcl     p_listing_iocb_ptr	 ptr;		/* (input) pointer to the listing iocb or */
						/* null if no listing is being produced */
	dcl     p_data_model_ptr	 ptr;		/* (input) pointer th the data_model, used
						   to verify that the specified relation access is ok */
	dcl     p_code		 fixed bin (35);	/* standard error code */

/* AUTOMATIC */

	dcl     access_record_len	 fixed bin (21);	/* length of the access record read */
	dcl     access_records_iocb_ptr ptr init (null ()); /* iocb pointer used to reference the
						   access records in the submodel */
	dcl     attr_idx		 fixed bin;	/* index of attributes within a relation */
	dcl     code		 fixed bin (35);	/* internal error code */
	dcl     have_sought_default_attribute_access bit (1) /* "1"b if default attribute access has been determined */
				 init ("0"b);
	dcl     have_sought_default_relation_access bit (1) /* "1"b if default relation access has been determined */
				 init ("0"b);
	dcl     info_ptr		 ptr init (null ());/* pointer to the hi_sl_info structure used for
						   setting up the subset of relation records */
	dcl     key_string		 char (256) varying;/* used for submodel record keys */
	dcl     last_rel_attr_access_sought_for char (32) varying; /* name of relation that the current
						   rel_attr_access is setup for */
	dcl     local_area_ptr	 ptr;		/* pointer to the local area */
	dcl     rel_rec_5_len	 fixed bin (21);	/* length of the rel_rec_5 record read */
	dcl     rel_rec_5_ptr	 ptr init (null ());/* pointer to the buffer used to store
						   rel_rec_5 records after reading */
	dcl     relation_name	 char (64) varying; /* name of relation access is currently being calculated for */
	dcl     relation_records_iocb_ptr ptr init (null ()); /* pointer to the iocb used to read the relation records */
	dcl     temp_ptr		 ptr;		/* becomes addr (REL_HEAD) */
	dcl     temp_seg_ptrs	 (3) ptr init (null (), null (), null ());
						/* pointers to three temporary segments
						   - set by get_temp_segments_ */
	dcl     01 default_attribute_access like attribute_access; /* the default attribute access */
	dcl     01 default_relation_access like relation_access; /* the default relation access */
	dcl     01 implicit_default_attribute_access /* default attribute access values used if the */
				 like attribute_access; /* cmdsm source does not specify any other values */
	dcl     01 implicit_default_relation_access /* default relation access values used if the */
				 like relation_access; /* cmdsm source does not specify any other values */
	dcl     01 rel_attr_access	 like attribute_access; /* default attribute access values for the current relation */

/* BASED */

	dcl     local_area		 area (sys_info$max_seg_size) based (local_area_ptr);
						/* area for allocations */

/* BUILTIN */

	dcl     addr		 builtin;
	dcl     addrel		 builtin;
	dcl     empty		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     substr		 builtin;
	dcl     unspec		 builtin;

/* CONDITION */

	dcl     cleanup		 condition;

/* ENTRY */

	dcl     get_temp_segments_	 entry (char (*), pointer dimension (*), fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$position	 entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
	dcl     iox_$read_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$rewrite_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     mrds_dm_get_attributes entry (ptr, char (32), ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_open$update_share entry (char (*), ptr, fixed bin (35));
	dcl     release_temp_segments_ entry (char (*), pointer dimension (*), fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$end_of_info fixed bin (35) external static; ;
	dcl     error_table_$no_record fixed bin (35) external static;
	dcl     mrds_error_$inconsistent_submodel fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (24) external static;

/*
   Set up initial values  for  variables  that  for  one  reason  or
   another cannot be set in the variable's declaration statement.
*/



	access_record_ptr = null;

	default_relation_access.null = "0"b;
	default_relation_access.append = "0"b;
	default_relation_access.delete = "0"b;
	default_relation_access.mbz1 = "0"b;

	default_attribute_access.null = "0"b;
	default_attribute_access.read = "0"b;
	default_attribute_access.modify = "0"b;
	default_attribute_access.mbz1 = "0"b;

	implicit_default_relation_access.null = "1"b;
	implicit_default_relation_access.append = "0"b;
	implicit_default_relation_access.delete = "0"b;
	implicit_default_relation_access.mbz1 = "0"b;

	implicit_default_attribute_access.null = "0"b;
	implicit_default_attribute_access.read = "1"b;
	implicit_default_attribute_access.modify = "0"b;
	implicit_default_attribute_access.mbz1 = "0"b;





/*
   Set up the cleanup condition handler.
*/

	on cleanup call cleanup_handler;





/*
   Set the return error code to zero - do not assume its input value was zero
*/

	p_code = 0;

/*
   Set up the switches for processing the submodel.

   The submodel must be opened twice  for  update_share.  The  first
   opening  (relation_records_iocb_ptr) is used to read the relation
   records and update their access information. The  second  opening
   (access_records_iocb_ptr)  is used to read the access records and
   change the used element to "1"b without  changing  the  "current"
   relation record.
*/


	call mrds_dsm_open$update_share (p_submodel_path, relation_records_iocb_ptr, code);
	if code ^= 0
	then do;
		call report_error (code, "^/Could not open ^a in shared update mode", "", "");
		call cleanup_handler;
		goto exit_compute_access;
	     end;



	call mrds_dsm_open$update_share (p_submodel_path, access_records_iocb_ptr, code);
	if code ^= 0
	then do;
		call report_error (code, "^/Could not open ^a in shared read mode", "", "");
		call cleanup_handler;
		goto exit_compute_access;
	     end;

/*
   Set up buffer space for reading the relation and access records,
   and an area for allocating things in.

   Three temporary segments are obtained from the temp segment pool.
   the   pointers   to  these  segments  will  be  assigned  to  the
   access_record_ptr,  the   rel_rec_5_ptr,  and the local_area_ptr.
   Since records in a vfile_ cannot be longer  than  1  segment  the
   buffer will always be adequate.
*/


	call get_temp_segments_ (p_caller_name, temp_seg_ptrs, code);
	if code ^= 0
	then do;
		call report_error (code, "^/Could not get temporary segment.", "", "");
		call cleanup_handler;
		goto exit_compute_access;
	     end;


	access_record_ptr = temp_seg_ptrs (1);
	rel_rec_5_ptr = temp_seg_ptrs (2);
	local_area_ptr = temp_seg_ptrs (3);
	local_area = empty ();

/*
   Create a subset consisting of only the relation records using the
   relation_records_iocb_ptr,  and setup to read the first record in
   the subset.



   A hi_sl_info structure is allocated in a small local  area.  This
   structure  is  used to build a subset of the records in the vfile
   which have keys greater than or equal to first_head and less than
   of equal to last_head, in this case only one pair of keys is used
   and the net effect is to select all records which have a key head
   equal  to  the  string  contained  in REL_HEAD, i.e. all relation
   records.
*/

	sl_array_limit = 1;
	allocate hi_sl_info in (local_area) set (info_ptr);
	hi_sl_info.version = sl_info_version_0;
	temp_ptr = addr (REL_HEAD);
	hi_sl_info.first_head.kptr = addrel (temp_ptr, 1);
	hi_sl_info.first_head.length = length (REL_HEAD);
	hi_sl_info.last_head.length = length (REL_HEAD);
	hi_sl_info.last_head.kptr = addrel (temp_ptr, 1);
	hi_sl_info.list_type = 1;
	hi_sl_info.status_only = "0"b;
	hi_sl_info.output_descriptors = "0"b;
	call iox_$control (relation_records_iocb_ptr, "select", info_ptr, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to select relation subset.", "", "");



/*
   Position to the beginning of the "relation" subset just created.
*/

	call iox_$position (relation_records_iocb_ptr, -1, 0, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to position to beginning of relation records subset.", "", "");



/*
   Read the first key of the "relation" subset. This  is  equivalent
   to getting the name of the first relation in the submodel.
*/

	call iox_$read_key (relation_records_iocb_ptr, key_string, rel_rec_5_len, code);
	if code ^= 0
	then call program_logic_error (code, "Could not read first key in relation subset.", "", "");

/*
   Walk through the "relation" subset, one relation at a  time.  For
   each  relation;  get its record (rel_rec_5), calculate the access
   for  the  relation,  calculate  the  access  for  each   of   its
   attributes, rewrite the record with the access bits set, and read
   the key of the next relation record. When all the  relations  and
   their  attributes  have  been processed check to be sure that all
   the access records have been used.
*/


	do while (code = 0);
	     call iox_$read_record (relation_records_iocb_ptr, rel_rec_5_ptr,
		(sys_info$max_seg_size * 4), rel_rec_5_len, code);
	     if code ^= 0
	     then call program_logic_error (code, "Unable to read record for key ^a.", key_string, "");



	     relation_name = substr (key_string, length (REL_HEAD) + 1);
	     call calc_relation_access (relation_name, addr (rel_rec_5_ptr -> rel_rec_5.access));


	     do attr_idx = 1 to rel_rec_5_ptr -> rel_rec_5.attr_num;
		call calc_attribute_access (relation_name, rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name,
		     addr (rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).access));
	     end;


	     call validate_relation_access;


	     call iox_$rewrite_record (relation_records_iocb_ptr, rel_rec_5_ptr, rel_rec_5_len, code);
	     if code ^= 0
	     then call program_logic_error (code, "Unable to rewrite relation record for relation ^a.", relation_name, "");



	     call iox_$read_key (relation_records_iocb_ptr, key_string, rel_rec_5_len, code);
	     if code ^= 0 & code ^= error_table_$end_of_info
	     then call program_logic_error (code, "Unable to  read a key from the relation subset.", "", "");
	end;


	call verify_access_record_use;



	call cleanup_handler;

exit_compute_access:
	return;					/* Effective end of compute_dsm_access. */

calc_relation_access: proc (a_rel_name, access_ptr);

/*
   This routine calculates a relation access and sets the results in
   the relation_access structure.

   Access records are searched for starting with the  most  specific
   (case  1) and continuing to the least specific (case3). The cases
   and the cmdsm statements that  generate  the  access  are  listed
   below.

   relation access: a_rel_name (specs)
   .   Sets a_rel_name's access.

   default relation access: (specs)
   .   Sets the relation access for all relations which  do  have  a
   .   relation access statement defining a specific access.

   .   If no default relation  access  statement  is  in  the  cmdsm
   .   source  than  those  relations  which  do not have a relation
   .   access statement seting a  specific  access  will  given  the
   .   implicit default relation access.

   Cases  2  and  3  are  done  in  the  get_default_relation_access
   routine.
*/

/* PARAMETERS */

	dcl     a_rel_name		 char (*) varying;
	dcl     access_ptr		 ptr;

/* AUTOMATIC */

	dcl     key_string		 char (256) varying;


	unspec (access_ptr -> relation_access) = "0"b;
	key_string = REL_ACCESS_HEAD || a_rel_name;


	call iox_$seek_key (access_records_iocb_ptr, key_string, access_record_len, code);
	if code = 0
	then call get_relation_access (key_string, access_ptr);
	else
	     if code = error_table_$no_record
	then do;
		if ^have_sought_default_relation_access
		then do;
			have_sought_default_relation_access = "1"b;
			call get_default_relation_access;
		     end;

		access_ptr -> relation_access = default_relation_access;
	     end;
	else call program_logic_error (code, "Unable to seek key ^a.", key_string, "");

	return;

     end calc_relation_access;

calc_attribute_access: proc (a_rel_name, a_attr_name, access_ptr);

/*
   This routine calculates an attributes access and sets the results
   in the attribute_access structure.

   Access records are searched for starting with the  most  specific
   (case  1)  and continuing through to the least specific (case 5).
   The cases and the cmdsm statements that generate the  access  are
   listed below.

   attribute access: a_attr_name in relation a_rel_name  (specs);
   .   Specifically sets the access of attribute a_attr_name for its
   .   occurence in the relation a_rel_name.

   attribute access: a_attr_name (specs);
   .   Sets the access of attribute a_attr_name for its occurance in
   .   any  relation  except where a_attr_name has an access defined
   .   by the above case.

   relation access: a_rel_name (specs) with attribute access (specs);
   .   Sets the access for every attribute  in  relation  a_rel_name
   .   except  for those attributes who have had an access specified
   .   by either of the above cases.

   default attribute access: (specs)
   .   Sets the attribute access of every attribute in the  submodel
   .   expect those attributes who have had an access defined by any
   .   of the above cases.

   .   If the default attribute access statement does not  exist  in
   .   the cmdsm source than all the attributes not covered by cases
   .   1, 2, or 3 are given an implicit default attribute access.

   Cases 3, 4, and 5 are done in the get_rel_attr_access routine.
*/

	dcl     a_rel_name		 char (*) varying;	/* name of attribute's relation */
	dcl     a_attr_name		 char (*) varying;	/* (input) name of attribute whose access is being computed */
	dcl     access_ptr		 ptr;		/* (input) pointer to attribute's access structure */

/* AUTOMATIC */

	dcl     key_string		 char (256) varying;/* key value of an access record */

	unspec (access_ptr -> attribute_access) = "0"b;
	key_string = ATTR_ACCESS_HEAD || a_attr_name || ATTR_REL_DELIMITER || a_rel_name;

	call iox_$seek_key (access_records_iocb_ptr, key_string, access_record_len, code);
	if code = 0
	then call get_attribute_access (key_string, access_ptr);
	else
	     if code ^= error_table_$no_record
	then call program_logic_error (code, "Could not seek for ^a", key_string, "");
	else do;
		key_string = ATTR_ACCESS_HEAD || a_attr_name;
		call iox_$seek_key (access_records_iocb_ptr, key_string, access_record_len, code);
		if code = 0
		then call get_attribute_access (key_string, access_ptr);
		else
		     if code ^= error_table_$no_record
		then call program_logic_error (code, "Could not seek for ^a", key_string, "");
		else do;
			if last_rel_attr_access_sought_for = a_rel_name
			then access_ptr -> attribute_access = rel_attr_access;
			else do;
				last_rel_attr_access_sought_for = a_rel_name;
				call get_rel_attr_access (a_rel_name, a_attr_name);
				access_ptr -> attribute_access = rel_attr_access;
			     end;
		     end;
	     end;

	return;

     end calc_attribute_access;

get_rel_attr_access: proc (a_rel_name, a_attr_name);

/*
   This routine determines the rel_attr_access. Every relation has a
   default  attribute  access which will be the attribute access set
   on attributes without an explicit access specifiction defined  in
   the  cmdsm source. This access is rel_attr_access. It first looks
   for a record explicitly stating  the  attribute  access  for  the
   current  relation, if its found the access is interpreted and the
   value of rel_attr_access set. If  the  error  code  no_record  is
   returned  it  means  that  the  cmdsm  source  did not contain an
   explicit statement seting the attribute access for  the  relation
   (relation    access    statement    using   the   with   option),
   rel_attr_access  is  therefore  set   to   the   value   of   the
   default_attribute_access. If the default attribute access has not
   yet been found it is determined before  rel_attr_access  is  set.
   Any  other  error code indicates an unexpected error so a program
   logic error is reported.
*/

/* PARAMETER */

	dcl     a_rel_name		 char (*) varying;	/* (input) the relation's name */
	dcl     a_attr_name		 char (*) varying;	/* (input) the attribute's name */




	call iox_$seek_key (access_records_iocb_ptr, REL_ATTR_ACCESS_HEAD || a_rel_name, access_record_len, code);
	if code = 0
	then call get_attribute_access ((REL_ATTR_ACCESS_HEAD), addr (rel_attr_access));
	else
	     if code = error_table_$no_record
	then do;
		if ^have_sought_default_attribute_access
		then do;
			have_sought_default_attribute_access = "1"b;
			call get_default_attribute_access;
		     end;

		rel_attr_access = default_attribute_access;
	     end;
	else call program_logic_error (code,
		"Could not determine access for ^a in relation ^a", a_attr_name, a_rel_name);

	return;

     end get_rel_attr_access;

get_default_attribute_access: proc;

/*
   This   routine   determines   the   default   attribute    access
   specifications.  It  first  looks  for a default attribute access
   specification record that was built  in  response  to  a  default
   attribute  access statement in the cmdsm source. If the record is
   found it interprets the contained access as the default attribute
   access. If the error code no_record is returned it means that the
   source did not contain a default attribute  access  statement  so
   the  default  is  set  to  the  system  defined  default which is
   recorded  in  implicit_default_attribute_access.  If  some  other
   error  code  is returned a drastic problem has occured - report a
   program logic error.
*/

	call iox_$seek_key (access_records_iocb_ptr, (DEF_ATTR_ACCESS_HEAD), access_record_len, code);
	if code = 0
	then call get_attribute_access ((DEF_ATTR_ACCESS_HEAD), addr (default_attribute_access));
	else
	     if code = error_table_$no_record
	then default_attribute_access = implicit_default_attribute_access;
	else call program_logic_error (code, "Could not determine the default attribute access", "", "");

	return;

     end get_default_attribute_access;

get_default_relation_access: proc;

/*
   This   routine   determines   the   default    relation    access
   specifications.  It  first  looks  for  a default relation access
   specification record that was built  in  response  to  a  default
   relation  access  statement in the cmdsm source. If the record is
   found it interprets the contained access as the default  relation
   access. If the error code no_record is returned it means that the
   source did not contain a default relation access statement so the
   default is set to the system defined default which is recorded in
   implicit_default_relation_access. If some  other  error  code  is
   returned  a  drastic problem has occured - report a program logic
   error.
*/

	call iox_$seek_key (access_records_iocb_ptr, (DEF_REL_ACCESS_HEAD), access_record_len, code);
	if code = 0
	then call get_relation_access ((DEF_REL_ACCESS_HEAD), addr (default_relation_access));
	else
	     if code = error_table_$no_record
	then default_relation_access = implicit_default_relation_access;
	else call program_logic_error (code, "Could not determine the default attribute access", "", "");

	return;

     end get_default_relation_access;

get_relation_access: proc (key_string, access_ptr);

/*
   This routine reads the current access record which was set up  by
   the  caller. It interprets the record looking for relation access
   modes   (null,   append_tuple,   delete_tuple)   and   sets   the
   corresponding  bits  in  the  relation  access  structure.  If an
   unrecognized access mode is found report a  program  logic  error
   since  only  legal modes should have been written into the access
   record. If a null access  is  specified  along  with  some  other
   access  the  cmdsm source has a semantic error - report the error
   and continue processing. After the record has been processed mark
   it as having been used.
*/

/* PARAMETER */

	dcl     key_string		 char (256) varying;/* (input) key of the relation access record to be read */
	dcl     access_ptr		 ptr;		/* (input) pointer to relation access storage for this relation */

/* AUTOMATIC */

	dcl     mode_idx		 fixed bin;	/* index of the access mode in the access record */





	unspec (access_ptr -> relation_access) = "0"b;

	call iox_$read_record (access_records_iocb_ptr, access_record_ptr,
	     (sys_info$max_seg_size * 4), access_record_len, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to read relation access record for key ^a.", key_string, "");

	do mode_idx = 1 to access_record.mode_num;
	     if access_record.modes (mode_idx) = "null"
	     then access_ptr -> relation_access.null = "1"b;
	     else
		if access_record.modes (mode_idx) = "append_tuple"
	     then access_ptr -> relation_access.append = "1"b;
	     else
		if access_record.modes (mode_idx) = "delete_tuple"
	     then access_ptr -> relation_access.delete = "1"b;
	     else call program_logic_error (mrds_error_$inconsistent_submodel,
		     "Unrecognized relation access mode ^a", access_record.modes (mode_idx), "");
	end;

	if access_ptr -> relation_access.null &
	     (access_ptr -> relation_access.append | access_ptr -> relation_access.delete)
	then call report_error (mrds_error_$inconsistent_submodel,
		"^/Null access given with other access modes for ^a", key_string, "");

	access_record_ptr -> access_record.used = "1"b;
	call iox_$rewrite_record (access_records_iocb_ptr, access_record_ptr, access_record_len, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to mark access record as being used, record key is: ^a",
		key_string, "");

	return;

     end get_relation_access;

get_attribute_access: proc (key_string, access_ptr);

/*
   This routine reads the current access record which was set up  by
   its caller. It interprets the record looking for attribute access
   modes (null, read, update) and sets the corresponding bits in the
   attribute_access  structure.  If  an  unrecognized access mode is
   found report a program logic error since only legal modes  should
   have  been  written  into  the access record. If a null access is
   specified with some other access the cmdsm source has a  semantic
   error - report the  error  and  continue  processing.  After  the
   record  has been processed mark it as having been used.
*/

/* PARAMETER */

	dcl     key_string		 char (256) varying;/* (input) key of the attribute access record to be read */
	dcl     access_ptr		 ptr;		/* (input) pointer to attribute access storage */

/* AUTOMATIC */

	dcl     mode_idx		 fixed bin;	/* index of the access mode in the access record */





	unspec (access_ptr -> attribute_access) = "0"b;

	call iox_$read_record (access_records_iocb_ptr, access_record_ptr,
	     (sys_info$max_seg_size * 4), access_record_len, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to read attribute access record for key ^a.", key_string, "");

	do mode_idx = 1 to access_record.mode_num;
	     if access_record.modes (mode_idx) = "null"
	     then access_ptr -> attribute_access.null = "1"b;
	     else
		if access_record.modes (mode_idx) = "read"
	     then access_ptr -> attribute_access.read = "1"b;
	     else
		if access_record.modes (mode_idx) = "update"
	     then access_ptr -> attribute_access.modify = "1"b;
	     else call program_logic_error (mrds_error_$inconsistent_submodel,
		     "Unrecognized attribute access mode ^a", access_record.modes (mode_idx), "");
	end;

	if access_ptr -> attribute_access.null &
	     (access_ptr -> attribute_access.read | access_ptr -> attribute_access.modify)
	then call report_error (mrds_error_$inconsistent_submodel,
		"^/Null access given with other access modes for ^a", key_string, "");

	access_record_ptr -> access_record.used = "1"b;
	call iox_$rewrite_record (access_records_iocb_ptr, access_record_ptr, access_record_len, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to mark access record as being used, record key is: ^a",
		key_string, "");

	return;

     end get_attribute_access;

validate_relation_access: proc;

/*
   This procedure validates that the relation  access  specified  is
   legal.  A submodel relation must be a full view of its base model
   relation before it  can  have  either  append  or  delete  access
   specified.  It is sufficient to check attribute numbers since the
   model/submodel mapping has been checked by mrds_dsm_semantics  so
   that  the only way the submodel relation can have the same number
   of attributes as the model relation is if each model attribute is
   used  to  define  1  submodel attribute. Also a submodel relation
   must have read access specified on all the key attributes of  the
   model  relation before append access can be specified. This is so
   that  multiple  stores   cannot   be   made   until   the   error
   tuple_not_found is returned - at which time the key values of the
   tuple are known.
*/


/* AUTOMATIC */

	dcl     dm_attr		 fixed bin;	/* index of a datamodel attribute */
	dcl     dsm_attr		 fixed bin;	/* index of a submodel attribute */
	dcl     done		 bit (1) unal;	/* used to terminate searching loop */

	call mrds_dm_get_attributes
	     (p_data_model_ptr,
	     (rel_rec_5_ptr -> rel_rec_5.rel_dm_name),
	     local_area_ptr,
	     rd_ptr,
	     code);
	if code ^= 0				/* the fact that no model relation exists has already been */
	then return;				/* reported in semantics */

	if (rel_rec_5_ptr -> rel_rec_5.access.append | rel_rec_5_ptr -> rel_rec_5.access.delete) &
	     rel_rec_5_ptr -> rel_rec_5.attr_num ^= rd_ptr -> rel_desc.num_attr
	then call report_error (mrds_error_$inconsistent_submodel,
		"^/^a may not have append and/or delete access specified since its not a full view of ^a",
		relation_name, rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
	else
	     if rel_rec_5_ptr -> rel_rec_5.access.append
	then do;
		do dm_attr = 1 to rd_ptr -> rel_desc.num_attr;
		     if rd_ptr -> rel_desc.attributes (dm_attr).key_flag
		     then do;
			     done = "0"b;
			     do dsm_attr = 1 to rel_rec_5_ptr -> rel_rec_5.attr_num while (^done);
				if rel_rec_5_ptr -> rel_rec_5.attr (dsm_attr).dm_name =
				     rd_ptr -> rel_desc.attributes (dm_attr).attribute_name
				then do;
					if ^rel_rec_5_ptr -> rel_rec_5.attr (dsm_attr).access.read
					then do;
						call report_error (mrds_error_$inconsistent_submodel,
						     "^/Relation ^a does not have read access on" ||
						     " all of the key attributes of its base relation ^a",
						     relation_name,
						     rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
						done = "1"b;
					     end;
					else done = "1"b;
				     end;
			     end;
			end;
		end;
	     end;


	return;

     end validate_relation_access;

verify_access_record_use: proc;

/*
   This procedure verifies that the access  records  have  all  been
   used.  If  a  record  is  not  used a message is output using the
   record's key as an identifier.

   A "current" position is first set up by going to the beginning of
   the  file  and then skipping the header record. All records after
   the header record are either access records or relation  records.
   The  key of the current record is read and if does not begin with
   the string "relation:" it is treated as an access  record  -  the
   associated record is read and the used field check. If the record
   is a relation record the "current" position must be advanced  one
   record, read_record does this authomatically.

   Records are read until a non-zero code  is  returned.  Any  error
   code other than end_of_info indicates that not all of the records
   were read and is a program logic error.
*/

	dcl     local_key_string	 char (256) init (""); /* non-varying version of key_string */
						/* so that substr can be done without worry about the varying length */


	call iox_$position (access_records_iocb_ptr, -1, 0, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to position to the first record to begin access verification",
		"", "");
	call iox_$position (access_records_iocb_ptr, 0, 1, code);
	if code ^= 0
	then call program_logic_error (code, "Unable to skip header record to begin access verification", "", "");

	do while (code = 0);
	     call iox_$read_key (access_records_iocb_ptr, key_string, access_record_len, code);

/* BEGIN CHANGE 81-09-17 */

	     local_key_string = key_string;
	     if code = 0 & substr (local_key_string, 1, 9) ^= "relation:" & substr (local_key_string, 1, 15) ^= "model relation:"

/* END   CHANGE 81-09-17 */

	     then do;
		     call iox_$read_record (access_records_iocb_ptr, access_record_ptr, (sys_info$max_seg_size * 4),
			access_record_len, code);
		     if code = 0
		     then do;
			     if ^access_record_ptr -> access_record.used
			     then call report_error (mrds_error_$inconsistent_submodel,
				     "^/Access specification: ^a was never used", key_string, "");
			end;
		end;
	     else do;
		     call iox_$position (access_records_iocb_ptr, 0, 1, code);
		     if code ^= 0 & code ^= error_table_$end_of_info
		     then call program_logic_error (code, "Unable to skip a relation record during access verification",
			     "", "");
		end;
	end;
	if code ^= error_table_$end_of_info
	then call program_logic_error (code, "Unable to verify access record usage", "", "");

	return;

     end verify_access_record_use;

program_logic_error: proc (icode, message, arg1, arg2);

/*
   This  routine  calls  report_error  to  report  the  error  after
   concatinating  the  phrase "^/PROGRAM LOGIC ERROR^/" to the input
   message, it then calls cleanup_handler to release  the  temporary
   segments  and  close  the submodel, it then sets the value of the
   return  error  code  and  then   does   a   non-local   goto   to
   exit_compute_access.

   NOTE this routine does NOT return it does  a  non-local  goto  to
   exit_compute_access.
*/


/* PARAMETERS */

	dcl     icode		 fixed bin (35);	/* (input) error code */
	dcl     message		 char (*);	/* (input) error message */
	dcl     arg1		 char (*) varying;	/* (input) first error message argument */
	dcl     arg2		 char (*) varying;	/* (input) second error message argument */





	call report_error (icode, "^/PROGRAM LOGIC ERROR^/" || message, arg1, arg2);

	call cleanup_handler;

	p_code = icode;

	goto exit_compute_access;

     end;						/* report_error */

report_error: proc (icode, message, arg1, arg2);

/*
   This routine reports errors via the iox_$error_output switch  and
   the  lsiting_iocb switch (providing it is non-null). It also sets
   the value of the output error code
*/



/* PARAMETERS */

	dcl     icode		 fixed bin (35);	/* (input) error code) */
	dcl     message		 char (*);	/* (input) error message */
	dcl     arg1		 char (*) varying;	/* (input) first argument to error message */
	dcl     arg2		 char (*) varying;	/* (input) second argument to error message */

/* AUTOMATIC */

	dcl     long_message	 char (100) aligned;/* long message associated with the error code */
	dcl     short_message	 char (8) aligned;	/* short message associated with the error code */

/* ENTRIES */

	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     ioa_$ioa_switch	 entry options (variable);

/* EXTERNAL */

	dcl     iox_$error_output	 ptr external static;



	call convert_status_code_ (icode, short_message, long_message);
	call ioa_$ioa_switch (iox_$error_output, long_message || message || "^/", arg1, arg2);

	if p_listing_iocb_ptr ^= null ()
	then call ioa_$ioa_switch (p_listing_iocb_ptr, long_message || message || "^/", arg1, arg2);


	p_code = icode;

	return;

     end report_error;

cleanup_handler: proc;

/*
   This procedure releases the two temporary segments and closes the
   two openings of the submodel - after checking to be sure that the
   temporary segments have been set up and the submodel opened  (pts
   ^= null).

   The error code returned by release_temp_segments_  is  ignored  -
   there  is  nothing  that  can be done anyway, and the submodel is
   closed using an entry that does not return an error code.
*/





	if temp_seg_ptrs (1) ^= null
	then call release_temp_segments_ (p_caller_name, temp_seg_ptrs, code);

	if access_records_iocb_ptr ^= null
	then call mrds_dsm_close$force (access_records_iocb_ptr);

	if relation_records_iocb_ptr ^= null
	then call mrds_dsm_close$force (relation_records_iocb_ptr);


     end cleanup_handler;

%include mrds_dsm_access_record;
%page;
%include mrds_dsm_head_strings;
%page;
%include mrds_dsm_rel_rec_5;
%page;
%include mrds_rel_desc;
%page;
%include select_info;


     end;						/* End of compute_dsm_access. */





		    mrds_dsm_define_temp.pl1        04/18/85  1429.4re  04/18/85  0906.7       59067



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

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

mrds_dsm_define_temp: proc (dsm_pn, iocb_ptr, a_code);

/*
   The function of the define_dsm module is to prepare  a  temporary
   data  submodel to accept relation definitions. If dsm_pn is null,
   the path is set to a unique entry in the process  directory.  The
   file  is  attached  to  a  unique switchname for direct_output. A
   temporary header record is written which  contains  the  submodel
   version  and  a  string  identifing the header record. A complete
   header record cannot be written because the number  of  relations
   is  not  yet  known.  The  temporary  record is needed because it
   contains the submodel version.

   Known Bugs:

   Other Problems:
   
   HISTORY:

   75-11-?? Lackey: written

   76-12-?? Lackey: added creator_id to the header record

   80-11-24 Spratt: Use the pathname specified  in  temp_dsm_pn,  if
   .        it's non-null. Enforce the requirement that the dsm  not
   .        exist prior to "definition."

   81-02-24 Davids: reformated the header and declaration  sections.
   .        removed the iox_modes include file. reformated the  code
   .        and   renamed   some   variables,   also   changed  some
   .        declarations. the header record now written has null  or
   .        0  values  in  elements  not  used  rather than just not
   .        setting them.

   81-02-25 Davids: changed the temp_dsm_pn parameter to dsm_pn  and
   .        added the internal variable  internal_dsm_pn.  this  was
   .        needed  so  that  if  the path parameter was "" we could
   .        generate a path that was in the  process  directory.  we
   .        could  not merely just change the parameters value since
   .        it was an input parameter, also it  was  a  zero  length
   .        string whose value we could not change.

   81-06-02   Davids:   changed   mrds_dsm_header_str.incl.pl1    to
   .        mrds_dsm_header;
*/

/* PARAMETERS */

	dcl     dsm_pn		 char (*);	/* (input) path of the dsm segment */
	dcl     iocb_ptr		 ptr;		/* (output) iocb pointer to the dsm segment */
	dcl     a_code		 fixed bin (35);	/* (output) standard error code */

/* AUTOMATIC */

	dcl     atd		 char (178) init (""); /* attach description for attachment to the dsm segment */
	dcl     bit_count		 fixed bin (24);	/* bit count of dsm segment, if it already exists */
	dcl     code		 fixed bin (35);	/* internal error code */
	dcl     dsm_dir		 char (168);	/* directory containing the dsm segment */
	dcl     dsm_entry		 char (32);	/* entry name of the dsm segment */
	dcl     01 header_str	 like mrds_dsm_header; /* automatic version of the header record */
	dcl     internal_dsm_pn	 char (168);	/* a working copy of the dsm_path */
	dcl     key		 char (256) varying;/* key for the header record */
	dcl     record_length	 fixed bin (21);	/* size of header srecord in bytes */
	dcl     type		 fixed bin (2);	/* type of dsm entry, if it already exists */

/* BASED */

%include mrds_dsm_header;

/* BUILTIN */

	dcl     addr		 builtin;
	dcl     low		 builtin;
	dcl     null		 builtin;
	dcl     size		 builtin;
	dcl     substr		 builtin;

/* CONSTANTS */

	dcl     KEYED_SEQUENTIAL_UPDATE fixed bin init (10) internal static options (constant);

/* ENTRIES */

	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_pdir_		 entry returns (char (168));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/* EXTERNAL */

	dcl     error_table_$namedup	 external static fixed bin (35);
	dcl     error_table_$no_record external static fixed bin (35);
	dcl     error_table_$noentry	 external static fixed bin (35);
	dcl     mrds_data_$dsmd_version_number external static fixed bin;

	if dsm_pn = ""
	then internal_dsm_pn = substr (get_pdir_ (), 1, 32) || ">" || unique_chars_ ("0"b) || "temp_.dsm";
	else internal_dsm_pn = dsm_pn;


	call expand_pathname_ (internal_dsm_pn, dsm_dir, dsm_entry, a_code);
	if a_code ^= 0
	then goto exit;

	call hcs_$status_minf (dsm_dir, dsm_entry, 1, type, bit_count, a_code);
	if a_code = 0
	then do;
		a_code = error_table_$namedup;
		goto exit;
	     end;
	else
	     if a_code ^= error_table_$noentry
	then goto exit;

	atd = "vfile_ " || internal_dsm_pn;
	call iox_$attach_name ((unique_chars_ ("0"b) || ".dsm"), iocb_ptr, atd, null (), a_code);
	if a_code ^= 0
	then goto exit;

	call iox_$open (iocb_ptr, KEYED_SEQUENTIAL_UPDATE, "0"b, a_code);
	if a_code ^= 0
	then do;
		call iox_$detach_iocb (iocb_ptr, code);
		call iox_$destroy_iocb (iocb_ptr, code);
		goto exit;
	     end;



	key = low (32);
	call iox_$seek_key (iocb_ptr, key, record_length, a_code);
	if a_code = error_table_$no_record
	then do;
		header_str.dsm_generator_version = mrds_data_$dsmd_version_number;
		header_str.date_time_generated = 0;
		header_str.database_pn = "";
		header_str.name = "data_submodel_header";
		header_str.num_of_relations = 0;
		header_str.creator_id = "";

		record_length = size (header_str) * 4;
		call iox_$write_record (iocb_ptr, addr (header_str), record_length, a_code);
	     end;

exit:
	return;

     end /* mrds_dsm_define_temp */;




		    mrds_dsm_determine_auth_sec.pl1 04/18/85  1429.4re  04/18/85  0906.7       75888



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

mrds_dsm_determine_auth_sec: proc (db_path, dsm_dirname, dsm_entryname) returns (bit (1) unal);

/*
   This module determines the security state of the database and the
   authorization  to  that  database  for the caller. It returns the
   value true ("1"b) if either the database is in an unsecure  state
   or  the database is in a secure state and the caller is a DBA for
   that database, for any other condition it returns  false  ("0"b).
   If  for some reason the database cannot be opened or its security
   state cannot be determined the database will be assumed to be  in
   a  secure  state an a warning will be sent via sub_err_ that this
   assumption is being made. If the caller's authorization cannot be
   determined  it  will  be  assumed to be that of a normal user (as
   opposed to a DBA) and again a warning will be sent  via  sub_err_
   that  this  assuption  is  being made. Old version databases will
   always have the value true returned.

   where:

   db_path: (input) char  (*)  relative  or  absolute  path  to  the
   .   database
   dsm_dirname: (input) char (*) absolute  path  to  the  submodel's
   .   containing directory
   dsm_entryname: (input) char (*) entry name of the submodel - must
   .   include the dsm suffix.
   return_value: (output) bit (1) unal true if the database  is  not
   .   secure or the database is secure and the caller is a DBA else
   .   false.

   Known Bugs:

   Other problems:

   HISTORY:

   81-04-27 Davids: originally coded;
   83-01-24 Roger Lackey :  Changed the length of SECURE_DATABASE_MESSAGE 
                            and NOT_ADMINISTRATOR_MESSAGE to accommodate long 
		        directory pathnames in error messages.
		        Also added undefine variables.

   83-09-28 Paul Benjamin:  Backed out change of 83-01-24 as meaningless.
*/

/* PARAMETERS */

	dcl     db_path		 char (*);	/* (input) absolute or relative path to the database */
	dcl     dsm_dirname		 char (*);	/* (input) absolute path to the submodel's containing directory */
	dcl     dsm_entryname	 char (*);	/* (input) entry name of the submodel
						   - must conatin the dsm suffix */

/* AUTOMATIC */

	dcl     db_ptr		 ptr init (null ());/* pointer to the database's data model */
	dcl     internal_error	 fixed bin (35);	/* standard error code */
	dcl     local_area		 area (50);	/* area for small allocations */

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     empty		 builtin;
	dcl     null		 builtin;


/* CONDITIONS */

	dcl     cleanup		 condition;

/* CONSTANT */

	dcl     SECURE_DATABASE_MESSAGE char (150) internal static options (constant)
				 init ("^/ASSUMING DATABASE IS SECURE^/Could not open the database ^a^/refered to by ^a>^a");
	dcl     NOT_ADMINISTRATOR_MESSAGE char (150) internal static options (constant)
				 init ("^/ASSUMING YOU ARE NOT A DATABASE ADMINISTRATOR^/Could not " ||
				 "determine your authorization to the database ^a^/refered to by ^a>^a");

/* EXTERNAL */

	dcl     mrds_error_$version_not_supported fixed bin (35) external static;

/* ENTRIES */

	dcl     mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35));

%include mrds_authorization;
%page;
%include mrds_database_state;

	on cleanup
	     begin;
		if db_ptr ^= null ()
		then call mrds_dm_close (db_ptr, internal_error);
	     end;

/*
   Open the database  to  determine  its  securitry  state.  If  the
   database  cannot  be  opened  no  information  about the database
   version or security state of the database can be obtained so  for
   security  reasons  it  must be assummed that the database is in a
   secure state. A message indicating this assumption is set to  the
   user.
   */

	call mrds_dm_open ((db_path), 2, db_ptr, internal_error);
	if internal_error ^= 0
	then do;
		call report_error (internal_error, SECURE_DATABASE_MESSAGE,
		     db_path, dsm_dirname, dsm_entryname);
		allocate database_state in (local_area) set (database_state_ptr);
		database_state.secured = "1"b;
	     end;
	else do;

/*
   With the database successfully open a check may be  made  on  its
   security state. If the error mrds_error_$version_not_supported is
   returned it means that the database is a version  that  does  not
   have  a  security  attribute,  the  database  will  be flaged (in
   database_state.secured) as  unsecured.  If  any  other  error  is
   returned it is assumed that the database has a security attribute
   but its value could not  be  determined.  The  database  will  be
   flaged  as secure and a message about the assumption will be sent
   to the user.
*/

		call mrds_dm_db_secured$get_secured_status (db_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, internal_error);
		if internal_error ^= 0
		then do;
			allocate database_state in (local_area) set (database_state_ptr);
			if internal_error = mrds_error_$version_not_supported
			then database_state.secured = "0"b;
			else do;
				call report_error (internal_error, SECURE_DATABASE_MESSAGE,
				     db_path, dsm_dirname, dsm_entryname);
				database_state.secured = "1"b;
			     end;
		     end;
		call mrds_dm_close (db_ptr, internal_error); /* no reason to keep the db open */
	     end;

/*
   If    the     error     returned     by     get_user_clase     is
   mrds_error_$version_not_supported it means that the database does
   have use the DBA concept. For these databases all users have  the
   functionality of a DBA and an authorization of administrator will
   be set. For any other error it will be asummed that the  database
   does use the DBA concept but that the authorization of the caller
   cannot be determined, for security reasons it  must  be  assummed
   that  the  caller  is  not an administrator. A warning about this
   assumption will be sent to the user.
*/

	call mrds_dm_authorization$get_user_class (db_path, addr (local_area),
	     mrds_authorization_structure_version, mrds_authorization_ptr, internal_error);
	if internal_error ^= 0
	then do;
		allocate mrds_authorization in (local_area) set (mrds_authorization_ptr);
		if internal_error = mrds_error_$version_not_supported
		then mrds_authorization.administrator = "1"b;
		else do;
			call report_error (internal_error, NOT_ADMINISTRATOR_MESSAGE,
			     db_path, dsm_dirname, dsm_entryname);
			mrds_authorization.administrator = "0"b;
		     end;
	     end;

	return (^database_state.secured | (database_state.secured & mrds_authorization.administrator));

report_error: proc (icode, message, arg1, arg2, arg3);

/*
   This routine is used to report errors via the sub_err_ condition.
   sub_err_ is called with the continue switch set so that after the
   sub_err_ condition has been  acted  on  by  the  system  and  the
   message  is printed control is returned to the entry which called
   report_error. All this assumes that the user has not set  up  his
   own  sub_err_  handler  - if he has he can return control to this
   module or not as well as printing the message or not.
*/


/* PARAMETERS */

	dcl     icode		 fixed bin (35);	/* (input) error code */
	dcl     message		 char (*);	/* (input) error message */
	dcl     arg1		 char (*);	/* (input) first argument to the error message */
	dcl     arg2		 char (*);	/* (input) second argument to the error message */
	dcl     arg3		 char (*);	/* (input) third argument to the error message */

/* AUTOMATIC */

	dcl     retval		 fixed bin (35);	/* not used but needed as a parameter by sub_err_ */

/* ENTRIES */

	dcl     sub_err_		 entry options (variable);




	call sub_err_ (icode, "mrds_dsm_determine_auth_sec", "c", null (), retval, message, arg1, arg2, arg3);

	return;

     end;						/* report_error */

     end;						/* determine_security_authorization */





		    mrds_dsm_dmdsm.pl1              04/18/85  1429.4re  04/18/85  0906.8      157266



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


mrds_dsm_dmdsm: proc (mrds_dsm_display_info_ptr, code);

/* DESCRIPTION:

   This  is the basic subroutine for displaying the submodel.  It is called by
   both display_mrds_dsm and create_mrds_dsm.



   PARAMETERS:

   mrds_dsm_display_info_ptr:  pointer  to the mrds_dsm_display_info structure
   containted in mrds_dsm_display_info.incl.pl1.  This variable is declared in
   the afore mentioned include file.

   code: the standard system return code.




   HISTORY:

   81-05-22 Rickie E. Brinegar: Initially Written.

   81-06-02   Davids:   changed   the   mrds_dsm_headr_str   include  file  to
   mrds_dsm_header.

   81-06-09    Rickie    E.     Brinegar:    modified    to    make   use   of
   mrds_dsm_display_info.submodel_secured when displaying the long format.

   81-06-11  Rickie  E.  Brinegar: Modified to incorporate audit changes which
   include:
   1) trapping the sub_error_ condition.
   2)    Just    printing    a    message    and    then    continuing    when
   error_table_$no_record is returned by mrds_dsm_read_relation.

*/

%include mrds_dm_header;
%page;
%include mrds_dsm_display_info;
%page;
%include mrds_dsm_entry_dcls;
%page;
%include mrds_dsm_header;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_rel_desc;

/* AUTOMATIC */

	dcl     (attr_index,			/* submodel attribute index */
	        dm_attr_index,			/* data model attribute index */
	        rel_index)		 fixed bin;	/* relation index */

	dcl     (data_model_ptr	 init (null),	/* To model that this submodel is for */
	        hd_ptr		 init (null),	/* To header information */
	        wa_ptr		 init (null)) ptr;	/* To temp segment */

	dcl     date_time_str	 char (25);	/* for date_time conversions */

/* BASED */

	dcl     work_area		 area (sys_info$max_seg_size) based (wa_ptr);

/* BUILTIN */

	dcl     (addr,
	        empty,
	        null)		 builtin;

/* CONDITION */

	dcl     (cleanup,
	        sub_error_)		 condition;

/* CONSTANT */

	dcl     READ_MODE		 init (2) fixed bin internal static options (constant);

/* ENTRY */

	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dm_get_attributes entry entry (ptr, char (32), ptr, ptr, fixed bin (35));
	dcl     mrds_dm_get_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     mu_display_descriptor	 entry (ptr) returns (char (120) varying);
	dcl     mu_trim_descriptor	 entry (char (120) varying) returns (char (*));
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));

/* EXTERNAL */

	dcl     (error_table_$no_record,
	        sys_info$max_seg_size) fixed bin (35) ext;

	dcl     (iox_$error_output,
	        iox_$user_output)	 ptr ext;

/* PARAMETER */

	dcl     code		 fixed bin (35);	/* INPUT: Standard return code */


/* ****************************************************************************
   INITIALIZATION
   **************************************************************************** */

	on cleanup call finish;

	call get_temp_segment_ ("mrds_dsm_dmdsm", wa_ptr, code);
	if code ^= 0 then
	     go to exit;

	work_area = empty;

/* ****************************************************************************
   Get the list of relations to be displayed.
   **************************************************************************** */

	mrds_dsm_relation_names_ptr = mrds_dsm_display_info.rel_names_array_ptr;

	if mrds_dsm_relation_names_ptr = null then do;
		call mrds_dsm_get_relation_names (wa_ptr, mrds_dsm_relation_names_ptr, mrds_dsm_display_info.submodel_iocb_ptr,
		     code);
		if code ^= 0 then
		     go to exit;
	     end;

/* ****************************************************************************
   Print the display. This code is maintained in the alphabetical order of the
   value of mrds_dsm_display_info.format
   **************************************************************************** */

	on sub_error_ ;
	if mrds_dsm_display_info.format = "b" then /* if brief format */
	     call brief_format;
	else
	     if mrds_dsm_display_info.format = "c" then do; /* if cmdsm format */
		call mrds_dsm_read_header (wa_ptr, hd_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);
		if code ^= 0 then
		     go to exit;
		call cmdsm_format;
	     end;
	else
	     if mrds_dsm_display_info.format = "l" then do; /* if long format */
		call mrds_dsm_read_header (wa_ptr, hd_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);
		if code ^= 0 then
		     go to exit;
		call long_format;
	     end;
	else
	     if mrds_dsm_display_info.format = "r" then /* if rel_name format */
	     call rel_name_format;

/* ****************************************************************************
   All done
   **************************************************************************** */

exit:	call finish;
	return;					/* Normal end for mrds_dsm_dmdsm. */

brief_format: proc;

/* ****************************************************************************
   Display relation names, attribute names and, possibly, their respective
   access information
   **************************************************************************** */

	do rel_index = 1 to mrds_dsm_relation_names.nrels;/* get the submodel relation info */
	     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (rel_index), wa_ptr,
		relation_block_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);

	     if code = 0 then do;
		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
						/* display the relation info */
			"^/^[^[a^]^[d^]^[n^]^5t^a^;^3s^5t^a^]",
			mrds_dsm_display_info.access,
			relation_block.rel_access.append,
			relation_block.rel_access.delete,
			relation_block.rel_access.null,
			relation_block.dsm_rel_name);

		     do attr_index = 1 to relation_block.no_rb_attributes; /* display this relations
						   attribute info */
			call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
			     "^[^[r^]^[m^]^[n^]^8t^a^;^3s^8t^a^]",
			     mrds_dsm_display_info.access,
			     relation_block.attribute_info (attr_index).attr_access.read,
			     relation_block.attribute_info (attr_index).attr_access.modify,
			     relation_block.attribute_info (attr_index).attr_access.null,
			     relation_block.attribute_info (attr_index).dsm_attr_name);
		     end;

		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "");
		end;
	     else
		if code = error_table_$no_record then
		call relation_not_in_submodel;
	     else
		go to exit;
	end;
     end brief_format;

cmdsm_format: proc;

/* ****************************************************************************
   Display the submodel information in a format that may be used to create a new
   submodel.
   **************************************************************************** */

	call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "^//*" ||
	     /* Print the header information */
	     "^/created from:^2x^a" ||
	     "^/^9xfor:^2x^a" ||
	     "^/^10xby:^2xdisplay_mrds_dsm -cmdsm^/*/^/",
	     mrds_dsm_display_info.submodel_pathname,
	     hd_ptr -> mrds_dsm_header.database_pn);

	do rel_index = 1 to mrds_dsm_relation_names.nrels;/* get the relation information */

	     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (rel_index), wa_ptr,
		relation_block_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);

	     if code = 0 then do;
		     if mrds_dsm_display_info.access then /* print the relation access info */
			call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
			     "relation access:^4x^a^x(^[append_tuple^[^x^]^;^s^]^[delete_tuple^[^x^]^;^s^]^[null^]);^/",
			     mrds_dsm_relation_names.relation (rel_index),
			     relation_block.rel_access.append,
			     (relation_block.rel_access.delete | relation_block.rel_access.null),
			     relation_block.rel_access.delete,
			     relation_block.rel_access.null,
			     relation_block.rel_access.null);

		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
						/* Print the relation info */
			"relation:^11x^a^x=^x^a",
			relation_block.dsm_rel_name, relation_block.dm_rel_name);

		     do attr_index = 1 to relation_block.no_rb_attributes; /* print the attribute info
						   (except access info) */

			call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
			     "^30t^[(^;^x^]^a^x=^x^a^[);^/^]",
			     (attr_index = 1),
			     relation_block.attribute_info (attr_index).dsm_attr_name,
			     relation_block.attribute_info (attr_index).dm_attr_name,
			     (attr_index = relation_block.no_rb_attributes));
		     end;

		     if mrds_dsm_display_info.access then /* print the attribute access info */

			do attr_index = 1 to relation_block.no_rb_attributes;

			     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
				"^[attribute access:^3x^;^21t^]^a^xin^x^a^x(^[read_attr^[^x^]^;^s^]" ||
				"^[delete_tuple^[^x^]^;^s^]^[null^])^[;^;,^]",
				(attr_index = 1),
				relation_block.attribute_info (attr_index).dsm_attr_name,
				relation_block.dsm_rel_name,
				relation_block.attribute_info (attr_index).attr_access.read,
				(relation_block.attribute_info (attr_index).attr_access.modify |
				relation_block.attribute_info (attr_index).attr_access.null),
				relation_block.attribute_info (attr_index).attr_access.modify,
				relation_block.attribute_info (attr_index).attr_access.null,
				relation_block.attribute_info (attr_index).attr_access.null,
				(attr_index = relation_block.no_rb_attributes));
			end;

		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "^[^;^//*^x^74(*^)^x*/^/^]",
						/* print the relation seperation comment line */
			(rel_index = mrds_dsm_relation_names.nrels));
		end;
	     else
		if code = error_table_$no_record then
		call relation_not_in_submodel;
	     else
		go to exit;
	end;

     end cmdsm_format;

long_format: proc;

/* ****************************************************************************
   Display everthing known about the submodel
   **************************************************************************** */

	call mrds_dm_open (hd_ptr -> mrds_dsm_header.database_pn, READ_MODE, data_model_ptr, code);
	if code ^= 0 then
	     go to exit;

/* Display header information */
	call date_time_ (hd_ptr -> mrds_dsm_header.date_time_generated, date_time_str);

	call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, /* display submodel header */
	     "^/Submodel path:^6x^a" ||
	     "^/^6xVersion:^6x^d" ||
	     "^/^3xCreated by:^6x^a" ||
	     "^/^3xCreated on:^6x^a" ||
	     "^/",
	     mrds_dsm_display_info.submodel_pathname,
	     hd_ptr -> mrds_dsm_header.dsm_generator_version,
	     hd_ptr -> mrds_dsm_header.creator_id,
	     date_time_str);

	call mrds_dm_get_header (data_model_ptr, wa_ptr, dmh_ptr, code); /* display model header info */
	if code ^= 0 then
	     go to exit;

	call date_time_ (dm_header.create_time, date_time_str);

	call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
	     "Database path:^6x^a" ||
	     "^/^6xVersion:^6x^d" ||
	     "^/^3xCreated by:^6x^a" ||
	     "^/^3xCreated on:^6x^a" ||
	     "^/",
	     hd_ptr -> mrds_dsm_header.database_pn,
	     dm_header.dmd_version,
	     dm_header.creator_id,
	     date_time_str);

	do rel_index = 1 to mrds_dsm_relation_names.nrels;/* Display each relation in the list */

	     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (rel_index), wa_ptr,
		relation_block_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);

	     if code = 0 then do;
		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
			"^/Submodel Relation Name:^6x^a" ||
			"^[^/^12xModel Name:^6x^a^;^s^]" ||
			"^[^/^16xAccess:^6x^[append_tuple ^]^[delete_tuple ^]^[null ^]^;^3s^]",
			relation_block.dsm_rel_name,
			(mrds_dsm_display_info.administrator | ^mrds_dsm_display_info.db_secured),
			relation_block.dm_rel_name,
			mrds_dsm_display_info.access,
			relation_block.rel_access.append, relation_block.rel_access.delete, relation_block.rel_access.null);

		     call mrds_dm_get_attributes (data_model_ptr, relation_block.dm_rel_name, wa_ptr,
			rd_ptr, code);		/* get datamodel attribute info */
		     if code ^= 0 then
			go to exit;

		     do attr_index = 1 to relation_block.no_rb_attributes; /* display each of this
						   realtions attributes' info */

			dm_attr_index = 1;		/* get data model attribute index */
			do while (dm_attr_index ^> rel_desc.num_attr &
			     rel_desc.attributes (dm_attr_index).attribute_name ^=
			     relation_block.attribute_info (attr_index).dm_attr_name);
			     dm_attr_index = dm_attr_index + 1;
			end;

			call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
			     "^/^9xSubmodel Attribute name:^6x^a" ||
			     "^[^/^22xModel Name:^6x^a^;^s^]" ||
			     "^[^/^26xAccess:^6x^[read_attr ^]^[modify_attr ^]^[null ^]^;^3s^]" ||
			     "^[^/^23xData Type:^6x^a" ||
			     "^[^/^39x^[Key ^]^[Index ^]^;^2s^]^;^4s^]",
			     relation_block.attribute_info (attr_index).dsm_attr_name,
			     (mrds_dsm_display_info.administrator | ^mrds_dsm_display_info.db_secured),
			     relation_block.attribute_info (attr_index).dm_attr_name,
			     mrds_dsm_display_info.access,
			     relation_block.attribute_info (attr_index).read, relation_block.attribute_info (attr_index).modify,
			     relation_block.attribute_info (attr_index).null,
			     (mrds_dsm_display_info.administrator | mrds_dsm_display_info.submodel_secured |
			     ^mrds_dsm_display_info.db_secured),
			     mu_trim_descriptor (mu_display_descriptor (addr (rel_desc.attributes (dm_attr_index).descriptor))),
			     (rel_desc.attributes (dm_attr_index).key_flag | rel_desc.attributes (dm_attr_index).inver_flag),
			     (rel_desc.attributes (dm_attr_index).key_flag & (mrds_dsm_display_info.administrator
			     | ^mrds_dsm_display_info.db_secured)),
			     (rel_desc.attributes (dm_attr_index).inver_flag
			     | (rel_desc.attributes (dm_attr_index).key_flag
			     & rel_desc.attributes (dm_attr_index).key_attr_order = 1
			     & mrds_dsm_display_info.db_secured & ^mrds_dsm_display_info.administrator)));

		     end;

		     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "");
		end;
	     else
		if code = error_table_$no_record then
		call relation_not_in_submodel;
	     else
		go to exit;
	end;

     end long_format;

rel_name_format: proc;

/* ****************************************************************************
   Display relation names and access
   **************************************************************************** */
	call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "");

	do rel_index = 1 to mrds_dsm_relation_names.nrels;

	     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (rel_index), wa_ptr,
		relation_block_ptr, mrds_dsm_display_info.submodel_iocb_ptr, code);

	     if code = 0 then
		call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr,
		     "^[^[a^]^[d^]^[n^]^5t^a^;^3s^5t^a^]",
		     mrds_dsm_display_info.access,
		     relation_block.rel_access.append,
		     relation_block.rel_access.delete,
		     relation_block.rel_access.null,
		     relation_block.dsm_rel_name);
	     else
		if code = error_table_$no_record then
		call relation_not_in_submodel;
	     else
		go to exit;
	end;

	call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "");

     end rel_name_format;

finish:
     proc;

/* ****************************************************************************
   Clean up anything left laying around
   **************************************************************************** */

	if data_model_ptr ^= null then
	     call mrds_dm_close (data_model_ptr, code);

	if wa_ptr ^= null then do;
		if hd_ptr ^= null then
		     free hd_ptr -> mrds_dsm_header;

		if mrds_dsm_display_info.rel_names_array_ptr = null & mrds_dsm_relation_names_ptr ^= null then
		     free mrds_dsm_relation_names;
		call release_temp_segment_ ("mrds_dsm_dmdsm", wa_ptr, code);
	     end;

     end finish;

relation_not_in_submodel:
     proc;

/* ****************************************************************************
   Display a message telling that the current relation is not in the submodel
   **************************************************************************** */

	call ioa_$ioa_switch (iox_$error_output, "Relation ^a is not in submodel ^a",
	     mrds_dsm_relation_names.relation (rel_index),
	     mrds_dsm_display_info.submodel_pathname);

	if mrds_dsm_display_info.output_iocb_ptr ^= iox_$user_output then
	     call ioa_$ioa_switch (mrds_dsm_display_info.output_iocb_ptr, "Relation ^a is not in submodel ^a",
		mrds_dsm_relation_names.relation (rel_index),
		mrds_dsm_display_info.submodel_pathname);

     end relation_not_in_submodel;

     end mrds_dsm_dmdsm;




		    mrds_dsm_dsmd.pl1               04/18/85  1429.4re  04/18/85  0906.8      125532



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

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

mrds_dsm_dsmd: proc;

/* DESCRIPTION:

   This  routine  is  obsolete,  it   is   maintained   to   provide
   compatability with MR8.0 and earlier releases.

   Known Bugs:

   Other Problems:
   
   HISTORY

   76-12-01 Weeldreyer: Modified to add get_dsm_relations entry

   80-08-01 Spratt:  Changed  calls  to  module  names  from  dsmd_
   .         entries, and add ext iocb_ptr for submodels

   80-11-07 Gray:  Added  sub_err_  additional  detail  for  when  a
   .        submodel points to a database, that no longer exists  in
   .        the same place

   80-12-31 Davids: added the entry get_dsm_file_rels. This entry is
   .        basicly a stub so that linus can  open  via  a  submodel
   .        without having to be changed.
   .
   .        Added the description, Known Bugs,  and  Other  Problems
   .        sections and reformated the history section.

   81-01-05  Davids:  changed   the   name   of   this   module   to
   .        mrds_dsm_dsmd_ so that we could write a transfer  vector
   .        called dsmd_ so that we would be consistant with how the
   .        rest of mrds works.

   .        added the internal  variable  a_code  to  the  procedure
   .        cleanup_handler  so  that  it  does not return incorrect
   .        values of code back to the user.

   81-01-20 Davids: removed  the  call  to  mrds_dsm_validate_header
   .        since mrds_dsm_read_header now validates the  header  as
   .        it reads it.

   81-01-22 Davids: changed mrds_dsm_open_read to mrds_dsm_open$read

   81-01-26  Davids:  changed  the  name  from   mrds_dsm_dsmd_   to
   .        mrds_dsm_dsmd

   .        deleted    the    unused    entry    points    get_mode,
   .        get_submodel_pn, validate_rel, and validate_rel_close.

   .        modified the open_dsm_read entry to remove code that was
   .        needed to support the operation of validate_rel.

   .        modified  the  declaration  section  to  remove   unused
   .        declarations, including several include files.

   81-01-27 Davids: implemented an internal working area based on  a
   .        temp segment gotten at open time.

   .        implemented   the   entries   get_dsm_header_record_ptr,
   .        get_relation_block_ptr,  and get_dsm_relation_names_ptr.
   .        these entries are for mrds code use only and will not be
   .        documented in the manual.

   .        implemented   the   mapping   from   the  relation_block
   .        structure  to the mrds_dsm_relation_str structure in the
   .        get_relation entry.

   81-01-29    Davids:    implemented    the    mapping   from   the
   .        mrds_dsm_relation_names       structure      to      the
   .        dsm_display_rels   structure  in  the  dsm_get_relations
   .        entry

   81-01-30 Davids: implemented the header_info, relation_data,  and
   .        attribute_data entries.

   .        alphabetized entries.

   81-02-03 Davids: The open entry point was checking to see if  the
   .        submodel was already open before it  tried  to  open  it
   .        rather than checking to see that no submodel was open. I
   .        introduced this bug was changing from the  mode  to  the
   .        submodel_already_open variable.

   81-02-04   Davids:   Removed    the    entries    attribute_data,
   .        get_dsm_header_record_ptr,   get_dsm_relation_names_ptr,
   .        get_relation_block_ptr,  header_info, and relation_data.
   .        These entries will be  moved  into  a  new  mrds_dsm_dsi
   .        module.

   81-02-05 Davids: The force_close_dsm was removed since it was not
   .        documented and is not used by internal mrds code.

   81-05-21  Rickie  E.  Brinegar:  Modified  to  use  the   changed
   .        mrds_dsm_relation_names.incl.pl1      which      changed
   .        dsm_relation_names to mrds_dsm_relation_names.

   81-06-01 Davids: Modified so that the header  structure  returned
   .        from the mrds_dsm_read_header call  is  translated  into
   .        the  structure  to  be  returned to the user rather than
   .        just passing the pointer back. At  the  moment  the  two
   .        structures  are  the same but that may not always be the
   .        case.

   81-06-08    Davids:    Made    the    close_dsm    entry     call
   .        mrds_dsm_close$force rather than mrds_dsm_close

   .        removed checks for and processing of long  relation  and
   .        attribute    names    in   the   get_dsm_relations   and
   .        get_relation entries (long names are not possible).

   .        Made security sensitive, i.e. if the database  that  the
   .        submodel  references  is  secure and the caller is not a
   .        DBA the model names  passed  back  by  get_relation  are
   .        spaces.
*/

/* PARAMETER */

	dcl     area_ptr		 ptr;		/* (input) pointer to area to allocate structures */
	dcl     code		 fixed bin (35);	/* (output) error code */
	dcl     display_rels_ptr	 ptr;		/* (output) pointer to the dsm_display_rels str */
	dcl     dsm_file_name	 char (*);	/* (input) file whose relations are to be returned */
	dcl     mrds_dsm_header_ptr	 ptr init (null ());/* pointer to the mrds_dsm_header str */
	dcl     dsm_relation_name	 char (*);	/* (input) relation whose relation data is to be returned */
	dcl     header_record_ptr	 ptr;		/* (output) pointer to the dsm_header_record str */
	dcl     rstr_ptr		 ptr;		/* (output) pointer to the dsm_relation_str structure */
	dcl     submodel_pn		 char (*);	/* (input) path to submodel */

/* AUTOMATIC */

	dcl     a_code		 fixed bin (35);	/* internal error code */
	dcl     db_path		 char (168);	/* path to the submodels database */
	dcl     i			 fixed bin;	/* loop index */
	dcl     temp_sm_pn		 char (168);	/* absolute path of submodel */

/* BASED */

	dcl     area		 area (sys_info$max_seg_size) based (area_ptr); /* space to allocate structures whose pointers
						   will be returned to the caller */
	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);
						/* space to allocate structures for internal use */

/* BUILTIN */

	dcl     empty		 builtin;
	dcl     null		 builtin;

/* CONDITION */

	dcl     cleanup		 condition;

/* CONSTANT */

	dcl     DSM_SUFFIX		 char (32) varying internal static options (constant) init ("dsm");

/* ENTRY */

	dcl     absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), pointer, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_determine_auth_sec entry (char (*), char (*), char (*)) returns (bit (1));
	dcl     mrds_dsm_get_relation_names entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_read_header$db_path entry (ptr, char (168), fixed bin (35));
	dcl     mrds_dsm_read_relation entry (char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     release_temp_segment_	 entry (char (*), pointer, fixed bin (35));

/* EXTERNAL */

	dcl     mrds_error_$incorrect_dsmd_seq fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* INTERNAL */

	dcl     iocb_ptr		 internal static ptr init (null);
	dcl     mask_model_info	 bit (1) unaligned internal static init ("0"b);
	dcl     submodel_already_open	 bit (1) internal static init ("0"b);
	dcl     work_area_ptr	 ptr internal static init (null ());

%include mrds_dsm_display_rels;
%page;
%include mrds_dsm_header;
%page;
%include mrds_dsm_header_str;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dsm_rel_str;
%page;
%include mrds_dsm_rel_block;

close_dsm: entry (code);

	if submodel_already_open
	then do;
		call mrds_dsm_close$force (iocb_ptr);
		submodel_already_open = "0"b;
		call release_temp_segment_ ("mrds_dsm_dsmd", work_area_ptr, a_code);
		work_area_ptr = null ();
		mask_model_info = "0"b;
	     end;
	else code = mrds_error_$incorrect_dsmd_seq;

	return;

get_dsm_file_rels: entry (dsm_file_name, area_ptr, display_rels_ptr, code);

/*
   For internal mrds use only. Not to be documented in any user manual.

   Because each file has only 1 relation in it and the file name  is
   the  same  as  the  relation name there is no reason to query the
   submodel about anything.
*/

	if submodel_already_open
	then do;
		nrels_alloc = 1;
		allocate dsm_display_rels in (area);
		display_rels_ptr = drel_ptr;
		dsm_display_rels.relation = dsm_file_name;
		code = 0;
	     end;
	else do;
		code = mrds_error_$incorrect_dsmd_seq;
		display_rels_ptr = null ();
	     end;

	return;

get_dsm_header: entry (area_ptr, header_record_ptr, code);




	header_record_ptr = null ();
	code = 0;
	if ^submodel_already_open
	then code = mrds_error_$incorrect_dsmd_seq;
	else do;
		call mrds_dsm_read_header (work_area_ptr, mrds_dsm_header_ptr, iocb_ptr, code);
		if code = 0
		then do;
			allocate dsm_header_record in (area) set (header_record_ptr);
			header_record_ptr -> dsm_header_record.dsm_generator_version =
			     mrds_dsm_header_ptr -> mrds_dsm_header.dsm_generator_version;
			header_record_ptr -> dsm_header_record.date_time_generated =
			     mrds_dsm_header_ptr -> mrds_dsm_header.date_time_generated;
			header_record_ptr -> dsm_header_record.database_pn =
			     mrds_dsm_header_ptr -> mrds_dsm_header.database_pn;
			header_record_ptr -> dsm_header_record.name =
			     mrds_dsm_header_ptr -> mrds_dsm_header.name;
			header_record_ptr -> dsm_header_record.num_of_relations =
			     mrds_dsm_header_ptr -> mrds_dsm_header.num_of_relations;
			header_record_ptr -> dsm_header_record.creator_id =
			     mrds_dsm_header_ptr -> mrds_dsm_header.creator_id;

			free mrds_dsm_header_ptr -> mrds_dsm_header;
		     end;
	     end;

	return;

get_dsm_relations: entry (area_ptr, display_rels_ptr, code);

	if submodel_already_open
	then do;
		call mrds_dsm_get_relation_names (work_area_ptr, mrds_dsm_relation_names_ptr, iocb_ptr, code);
		if code = 0
		then do;
			nrels_alloc = mrds_dsm_relation_names.nrels;
			allocate dsm_display_rels in (area);
			do i = 1 to nrels_alloc;
			     dsm_display_rels.relation (i) = mrds_dsm_relation_names.relation (i);
			end;
		     end;

		if mrds_dsm_relation_names_ptr ^= null ()
		then free mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names;
	     end;
	else code = mrds_error_$incorrect_dsmd_seq;

	if code = 0
	then display_rels_ptr = drel_ptr;
	else display_rels_ptr = null ();

	return;

get_relation: entry (dsm_relation_name, area_ptr, rstr_ptr, code);

	if submodel_already_open
	then do;
		call mrds_dsm_read_relation (dsm_relation_name, work_area_ptr, relation_block_ptr, iocb_ptr, code);
		if code = 0
		then do;
			dsm_num_attr_alloc = relation_block.no_rb_attributes;
			allocate dsm_relation_str in (area) set (rstr_ptr);
			rstr_ptr -> dsm_relation_str.key.submodel_rel_name = relation_block.dsm_rel_name;
			if mask_model_info
			then rstr_ptr -> dsm_relation_str.record.model_rel_name = "";
			else rstr_ptr -> dsm_relation_str.record.model_rel_name = relation_block.dm_rel_name;
			do i = 1 to rstr_ptr -> dsm_relation_str.no_attributes;
			     rstr_ptr -> dsm_relation_str.record.attribute_info (i).submodel_att_name =
				relation_block.attribute_info (i).dsm_attr_name;
			     if mask_model_info
			     then rstr_ptr -> dsm_relation_str.record.attribute_info (i).model_att_name = "";
			     else rstr_ptr -> dsm_relation_str.record.attribute_info (i).model_att_name =
				     relation_block.attribute_info (i).dm_attr_name;
			end;
		     end;

		if relation_block_ptr ^= null ()
		then free relation_block_ptr -> relation_block;

	     end;
	else code = mrds_error_$incorrect_dsmd_seq;

	return;

open_dsm_read: entry (submodel_pn, code);

	if submodel_already_open
	then code = mrds_error_$incorrect_dsmd_seq;
	else do;
		on condition (cleanup) call cleanup_handler;
		call absolute_pathname_$add_suffix (submodel_pn, (DSM_SUFFIX), temp_sm_pn, code);
		if code ^= 0
		then do;
			call cleanup_handler;
			return;
		     end;

		call mrds_dsm_open$read (temp_sm_pn, iocb_ptr, code);
		if code ^= 0
		then do;
			call cleanup_handler;
			return;
		     end;

		submodel_already_open = "1"b;

		call get_temp_segment_ ("mrds_dsm_dsmd", work_area_ptr, code);
		if code ^= 0
		then do;
			call cleanup_handler;
			return;
		     end;
		work_area = empty;

		call mrds_dsm_read_header$db_path (iocb_ptr, db_path, code);
		if code ^= 0
		then do;
			call cleanup_handler;
			return;
		     end;
		else mask_model_info = ^mrds_dsm_determine_auth_sec (db_path, temp_sm_pn, "");

	     end;

	return;

cleanup_handler: proc;

	if iocb_ptr ^= null
	then call mrds_dsm_close$force (iocb_ptr);
	submodel_already_open = "0"b;
	if work_area_ptr ^= null ()
	then call release_temp_segment_ ("mrds_dsm_dsmd", work_area_ptr, a_code);
	work_area_ptr = null ();
	iocb_ptr = null;
	mask_model_info = "0"b;
	return;
     end cleanup_handler;

     end /* mrds_dsm_dsmd */;




		    mrds_dsm_get_relation_names.pl1 04/18/85  1429.4re  04/18/85  0906.9      100089



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

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

mrds_dsm_get_relation_names: proc (p_area_ptr, p_dsm_relation_names_ptr, p_iocb_ptr, p_code);

/* DESCRIPTION:

   This routine loads a mrds_dsm_relation_names structure  with  the
   number and names of the relations in the submodel.

   It is assumed that p_area_ptr points to  a  non-freeing  area  so
   that   if   an  error  occurs  after  mrds_dsm_relation_names  is
   allocated    it    is    not    freed     even     though     the
   p_dsm_relation_names_ptr is set to null.

   The number_of_rels entry returns only the number of relations.

   Known bugs:

   Other problems:

   HISTORY

   80-12-24 Davids: This routine has been modified from  an  eariler
   .        version which had no  header  or  history  section.  The
   .        biggest changes were handling of version 4 submodels and
   .        a call to sub_err_ to explan any errors.

   81-01-06 Davids: Removed inline code to read the submodel  header
   .        record   and   replaced    it    with    a    call    to
   .        mrds_dsm_get_version.  added  the declarations for those
   .        iox_  entries  used  and  removed  the   include   files
   .        mrds_dsm_header_str and iox_dcls.

   81-01-09 Davids: changed  the  call  to  mrds_dsm_get_version  to
   .        mrds_dsm_read_header$version.

   81-01-12  Davids:   changed   mrds_dsm_display_rels.incl.pl1   to
   .         mrds_dsm_relation_names.incl.pl1

   81-01-13 Davids: modified so that for  version  1  submodels  the
   .        first part of the key head range is \001  and  the  last
   .        part  is  \177.  The reason why the select must still be
   .        done is that i need the number of relation to  know  how
   .        much space to allocate.

   81-01-28 Davids:  changed drel_ptr to mrds_dsm_relation_names_ptr
   .        and  nrels_alloc  to mrds_dsm_relation_names_nrels_alloc
   .        to      correspond      to      changes      in      the
   .        mrds_mrds_dsm_relation_names include file.

   81-02-19 Davids: added the number_of_rels  entry.  this  required
   .        building the internal procedure set_up_subset and having
   .        error_exit (renamed to cleanup) return rather than doing
   .        a goto error_return.

   81-02-20   Davids:   renamed    the    cleanup    procedure    to
   .        in_case_of_error.  also  added  a  call  to  the  finish
   .        procedure  in the number_of_rels entry. without the call
   .        the subset was never being reset.

   81-02-23 Davids: the number_of_rels entry now sets  the  variable
   .        code so there can be correct error reporting.

   81-05-20  Rickie  E.  Brinegar:  changed   all   referecnces   to
   .        dsm_relation_names  to  mrds_dsm_relation_names  due  to
   .        changed include file.

   81-06-09 Davids: It was discovered that the file key for  version
   .        4 submodels contained the model relation  name  and  not
   .        the  submodel  relation  name.  Processing  to  get  the
   .        relation names for version 4 submodels  was  changed  to
   .        set  up  a  subset containing both the relation and file
   .        records. Processing to load the  mrds_dsm_relation_names
   .        structure was change to ignore keys with file prefix.
*/

/* PARAMETER */

	dcl     p_area_ptr		 ptr;		/* (input) area to allocate mrds_dsm_relation_names structure in */
	dcl     p_dsm_relation_names_ptr ptr;		/* (output) pointer to the mrds_dsm_relation_names structure */
	dcl     p_iocb_ptr		 ptr;		/* (input) pointer to submodel iocb */
	dcl     p_code		 fixed bin (35);	/* (output) error code */

/* AUTOMATIC */

	dcl     answer		 fixed bin;	/* return value for the number_of_rels entry */
	dcl     code		 fixed bin (35);	/* local error code */
	dcl     idx		 fixed bin;	/* loop index */
	dcl     info_ptr		 ptr init (null ());/* pointer to the select set structure */
	dcl     key		 char (256) varying;/* submodel record key */
	dcl     f_key_header	 char (256) varying;/* defines start of range for leading part of relation record key
						   = REL_HEAD for version 5
						   = "file:" for version 4
						   = "\001" for version 1 */
	dcl     l_key_header	 char (256) varying;/* defines end of range for leading part of relation record key
						   = REL_HEAD
						   = "file:"
						   = "\177" */
	dcl     message		 char (100);	/* error message returned from set_up_subset */
	dcl     rec_len		 fixed bin (21);	/* length of a submodel record */
	dcl     version		 fixed bin;	/* submodel version */

/* BASED */

	dcl     area		 area (sys_info$max_seg_size) based (p_area_ptr);
						/* assumed to be a non-freeing area */

/* BUILTIN */

	dcl     addr		 builtin;
	dcl     addrel		 builtin;
	dcl     after		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     substr		 builtin;

/* CONSTANT */

	dcl     BOF		 fixed bin init (-1) internal static options (constant);
						/* used to indicate the beginning of the file */

/* ENTRIES */

	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$position	 entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
	dcl     iox_$read_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     mrds_dsm_read_header$version entry (ptr, fixed bin, fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$end_of_info fixed bin (35) external static;
	dcl     mrds_error_$version_not_supported fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (19) ext;

%include select_info;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dsm_head_strings;

	call set_up_subset (code, message);
	if code ^= 0
	then do;
		call in_case_of_error (message);
		goto error_return;
	     end;

	call iox_$position (p_iocb_ptr, BOF, 0, code);
	if code ^= 0
	then do;
		call in_case_of_error ("Problem while trying to position to the first relation record");
		goto error_return;
	     end;

	call iox_$read_key (p_iocb_ptr, key, rec_len, code); /* read submodel and load mrds_dsm_relation_names str */
	if code ^= 0
	then do;
		call in_case_of_error ("Problem while trying to read the key of the first relation record");
		goto error_return;
	     end;

	if version ^= 4
	then mrds_dsm_relation_names_nrels_alloc = hi_sl_info.count;
	else mrds_dsm_relation_names_nrels_alloc = hi_sl_info.count / 2;
						/* both relation and file records are selected for version 4 */
	allocate mrds_dsm_relation_names in (area);

	do idx = 1 by 1 while (code = 0);
	     if version < 4
	     then mrds_dsm_relation_names.relation (idx) = key;
	     else
		if version > 4
	     then mrds_dsm_relation_names.relation (idx) = after (key, f_key_header);
	     else
		if version = 4
	     then do;
		     if substr (key, 1, 5) = "file:"
		     then idx = idx - 1;
		     else mrds_dsm_relation_names.relation (idx) = key;
		end;

	     call iox_$position (p_iocb_ptr, 0, 1, code);
	     if code = 0
	     then call iox_$read_key (p_iocb_ptr, key, rec_len, code);
	end;
	if code ^= error_table_$end_of_info
	then do;
		call in_case_of_error ("Problem while reading the keys of subsequent relation records");
		goto error_return;
	     end;



	p_dsm_relation_names_ptr = mrds_dsm_relation_names_ptr;
	p_code = 0;
	call finish;
	return;

error_return:
	p_code = code;
	p_dsm_relation_names_ptr = null ();
	return;

number_of_rels: entry (p_iocb_ptr, p_code) returns (fixed bin);

	call set_up_subset (p_code, message);
	if p_code = 0
	then do;
		if version ^= 4
		then answer = hi_sl_info.count;
		else answer = hi_sl_info.count / 2;
		call finish;
	     end;
	else do;
		code = p_code;
		call in_case_of_error (message);
		answer = 0;
	     end;

	return (answer);

set_up_subset: proc (l_code, l_message);

/* PARAMETERS */

	dcl     l_code		 fixed bin (35);	/* (output) local error code */
	dcl     l_message		 char (*);	/* (output) local error message */




	call mrds_dsm_read_header$version (p_iocb_ptr, version, l_code);
	if l_code ^= 0
	then l_message = "Could not get the submodel version";
	else
	     if version = 5				/* set key_header based on version */
	then do;
		f_key_header = REL_HEAD;
		l_key_header = REL_HEAD;
	     end;
	else
	     if version = 4
	then do;
		f_key_header = "A";			/* file and relation records */
		l_key_header = "z";
	     end;
	else
	     if version = 1
	then do;
		f_key_header = "";			/* \001 */
		l_key_header = "";			/* \177 */
	     end;
	else do;
		l_code = mrds_error_$version_not_supported;
		l_message = "Unrecognized version of submodel";
	     end;




	if l_code = 0
	then do;
		sl_array_limit = 1;			/* build the select info str */
		allocate hi_sl_info set (info_ptr);
		hi_sl_info.version = sl_info_version_0;
		hi_sl_info.list_type = 1;
		hi_sl_info.interval (1).first_head.length = length (f_key_header);
		hi_sl_info.interval (1).first_head.kptr = addrel (addr (f_key_header), 1);
		hi_sl_info.interval (1).last_head.length = length (l_key_header);
		hi_sl_info.interval (1).last_head.kptr = addrel (addr (l_key_header), 1);



		call iox_$control (p_iocb_ptr, "select", info_ptr, l_code); /* select the relation records */
		if l_code ^= 0
		then l_message = "Problem while selecting submodel's relations";
	     end;

	return;

     end /* set_up_subset */;

finish: proc;

/*
   This procedure resets the subset number in the submodel vfile  so
   that  the next vfile access looks at the entire vfile rather than
   just the relation record subset.
*/

	dcl     f_code		 fixed bin (35);	/* local error code */


	if info_ptr ^= null
	then do;
		if hi_sl_info.subset_no > 0
		then do;
			hi_sl_info.list_type = 0;
			hi_sl_info.subset_no = 0;
			call iox_$control (p_iocb_ptr, "select", info_ptr, f_code);
		     end;
		free info_ptr -> hi_sl_info;
	     end;
     end;						/*  finish */

in_case_of_error: proc (message);

/* PARAMETERS */

	dcl     message		 char (*);	/* (input) error message */

/* AUITOMATIC */

	dcl     retval		 fixed bin (35);

/* ENTRIES */

	dcl     sub_err_		 entry options (variable);



	call finish;

	call sub_err_ (code, "mrds_dsm_get_relation_names", "c", null (), retval, message);

	return;

     end /* in_case_of_error */;

     end;						/*  mrds_dsm_get_relation_names */




		    mrds_dsm_msmi.pl1               03/08/88  1539.2rew 03/08/88  1530.1      319041



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(88-01-18,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Use "mrds" searchlist to find submodel.  SCP 6366.
                                                   END HISTORY COMMENTS */


mrds_dsm_msmi: msmi_: proc;

/* DESCRIPTION:

   This module implements the msmi_ interface of MRDS. It  allows  a
   user  to  determine the data model mapping and access permissions
   that are defined in a MRDS submodel as  well  as  certain  things
   about  the submodel itself. At the same time it protects a secure
   database by not returning model information to anyone but DBAs.

   Before a submodel can be referenced it must be "readied" via  the
   open_submodel  entry.  When  the submodel is not longer needed it
   should be "closed" via the close_submodel entry.

   Entries:

   .   mrds_dsm_msmi:
   .        should never be called.

   .   close_submodel:
   .        closes the submodel file to further output, removes  the
   .        opening_name from the open name name list, and frees the
   .        open_info structure.

   .   get_attribute_data:
   .        loads the mrds_dsm_attribute_data  structure  with  data
   .        about the attributes in the specified relation.

   .   get_relation_data:
   .        loads the  mrds_dsm_relation_data  structure  with  data
   .        about all the relations in the submodel view.

   .   get_submodel_info:
   .        loads the mrds_dsm_submodel_info structure with  general
   .        information about the submodel.

   .   open_submodel:
   .        sets up a submodel so the other entries  can  use  it  -
   .        opens  the  submodel  vfile  for reading, determines the
   .        security state of the database and the authorization  of
   .        the  caller  and  associates  an  opening_name  with  an
   .        allocated structure containing information needed by the
   .        rest  of  the  entries.  Also  the  first call sets up a
   .        temporary segment to  be  used  as  a  work  area.  This
   .        segment  remains  associated  with mrds_dsm_msmi for the
   .        life of the process.


   This   module   is   not   recursive    because    the    entries
   get_attribute_data  and  get_relation_data  use vfile subsets and
   cannot be recursive. It was decieded to make  the  entire  module
   non-recursive  instead of just parts of it to avoid complex rules
   when decieding what sequences could or could  not  be  recursive,
   i.e  a  call  to get_attribute_data cannot be interrupted to call
   get_relation_data but can be interrupted to call open_submodel.

   Known Bugs:

   Other Problems:

   .   The temp segment used to hold the msmi_area should go into  a
   .   lower  ring  so  that  the  open_info.return_model_stuff  bit
   .   cannot be twiddled.



   HISTORY:

   81-04-06 Davids: Coded.

   81-05-21  Rickie  E.  Brinegar:  Modified  to  use  the   changed
   .        mrds_dsm_relation_names.incl.pl1      which      changed
   .        dsm_relation_names to mrds_dsm_relation_names.

   81-06-01   Davids:   changed   mrds_dsm_header_str.incl.pl1    to
   .        mrds_dsm_header.incl.pl1
*/

/* PARAMETERS */

	dcl     attribute_data_ptr	 ptr;		/* (output) pointer to the attribute_data structure */
	dcl     code		 fixed bin (35);	/* (output) error code */
	dcl     dsm_path		 char (*);	/* (input) path relative or absolute to the submodel */
	dcl     opening_name	 char (*);	/* (input) unique identifing name for this opening */
	dcl     relation_data_ptr	 ptr;		/* (output) pointer to the relation_data structure */
	dcl     relation_name	 char (*);	/* (input) name of relation, used in get_attribute_data */
	dcl     str_version		 fixed bin;	/* (input) version of the submodel_info str
						   to be allocated and returned */
	dcl     submodel_info_ptr	 ptr;		/* (output) pointer to the submodel_info structure */
	dcl     users_area_ptr	 ptr;		/* (input) points to a freeing area */

/* AUTOMATIC */

	dcl     db_path		 char (168);	/* absolute path to the database that the submodel refers to */
	dcl     dsm_dirname		 char (168);	/* absolute path of the submodel's containing directory */
	dcl     dsm_entryname	 char (32);	/* entry name of the submodel */
	dcl     mrds_dsm_header_ptr	 ptr;		/* points to a copy of the submodels header record */
	dcl     dsm_iocb_ptr	 ptr;		/* pointer to the submodel's iocb */
	dcl     dsm_path_absolute	 char (168);	/* absolute path to the entry specified
						   by the parameter dsm_path */
	dcl     i			 fixed bin;	/* loop index */
	dcl     ignore_arg_char1	 char (1);	/* output argument returned from a call - never used */
	dcl     ignore_error	 fixed bin (35);	/* an error code that will be ignored */
	dcl     internal_error	 fixed bin (35) init (0); /* so as not to use the parameter code */
	dcl     local_area		 area (50);	/* local area for temporary allocations */
	dcl     01 local_area_info	 like area_info;	/* local copy of the area_info structure */
	dcl     name_not_deleted	 bit (1) unal;	/* indicates that the opening_name has not yet been
						   deleted from the open_name_manager - used in close_submodel */
	dcl     open_info_ptr	 ptr;		/* points to an open_info structure */
	dcl     open_info_ptr2	 ptr;		/* a copy of the open_info_ptr - used in close_submodel */

/* BASED */

	dcl     01 open_info	 based (open_info_ptr),
		02 iocb		 ptr,		/* pointer to this openings submodels iocb */
		02 return_model_stuff bit (1),	/* if true model info will be returned */
		02 dsm_path	 char (168);	/* absolute path of the submodel used
						   in the opening (may be a link) */
	dcl     msmi_area		 area (sys_info$max_seg_size) based (msmi_area_ptr);
						/* area for big allocations and
						   static stuff (open_info structures) */
	dcl     users_area		 area based (users_area_ptr); /* freeing area that the user has set up */

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     empty		 builtin;
	dcl     null		 builtin;
	dcl     rtrim		 builtin;
          dcl     search                 builtin;		  
	dcl     unspec		 builtin;

/* CONDITIONS */

	dcl     area		 condition;
	dcl     cleanup		 condition;

/* CONSTANTS */

	dcl     DSM_SUFFIX		 char (3) init ("dsm") internal static options (constant);
          dcl     MRDS_SEARCHLIST        char (4) init ("mrds") internal static options (constant);
/* EXTERNAL STATIC */

	dcl     error_table_$area_too_small fixed bin (35) external static;
	dcl     error_table_$badcall	 fixed bin (35) external static;
	dcl     error_table_$no_record fixed bin (35) external static;
	dcl     error_table_$unimplemented_version fixed bin (35) external static;
	dcl     mrds_error_$not_freeing_area fixed bin (35) external static;
	dcl     mrds_error_$recursion_error fixed bin (35) external static;
	dcl     mrds_error_$unknown_relation_name fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* INTERNAL STATIC */

	dcl     executing		 bit (1) unal init ("0"b) internal static; /* true while code is being executed - prevents recursion */
	dcl     msmi_area_ptr	 ptr init (null ()) internal static; /* points to a temporary segment in the pdir, set on the process's
						   first call to the open_submodel entry point.
						   Remains set for the life of the process */

/* ENTRIES */

	dcl     area_info_		 entry (ptr, fixed bin (35));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), pointer, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_determine_auth_sec entry (char (*), char (*), char (*)) returns (bit (1));
	dcl     mrds_dsm_open$read_share entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_read_header$db_path entry (ptr, char (168), fixed bin (35));
	dcl     mrds_dsm_read_relation entry (char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_get_relation_names entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mu_open_name_manager$define_open_name entry (char (*), char (1), ptr, fixed bin (35));
	dcl     mu_open_name_manager$delete_open_name entry (char (*), fixed bin (35));
	dcl     mu_open_name_manager$get_model_pointer entry (char (*), char (1), ptr, fixed bin (35));

%include area_info;
%page;
%include mrds_dsm_attribute_data;
%page;
%include mrds_dsm_header;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_relation_data;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dsm_submodel_info;

/* MAIN ENTRY POINT */

	call report_error (error_table_$badcall,
	     "The entry point mrds_dsm_msmi$mrds_dsm_msmi (msmi_$msmi_) should never be called", "", "", "");

	return;

close_submodel: entry (opening_name, code);

/*
   where:
   .   opening_name: (input) unique identifing name for this opening
   .   code: (output) error code

   This entry "closes" a submodel so that it may not  be  referenced
   by  any  of  the  other  entry  points.  This entails closing the
   submodel  vfile  to  further  output,  freeing   the   associated
   open_info  structure  and  deleting  the  opening_name  from  the
   open_name manager - this will also allow the opening_name  to  be
   used again.

   All   of   the   work   is   actually   done   by   the   routine
   cleanup_close_submodel.

   The variables open_info_ptr2 and  name_not_deleted  are  used  as
   switches  to be sure that the submodel is "closed" and to prevent
   errors from trying to  do  things  twice.  There  are  of  course
   windows where the operation has been performed but the switch not
   yet set, these windows are as small as possible.
*/

	code = 0;					/* initialize output variables */

	if executing				/* This module cannot be recursive */
	then internal_error = mrds_error_$recursion_error;
	else do;
		open_info_ptr = null ();		/* initialize working variables */
		open_info_ptr2 = null ();
		name_not_deleted = "1"b;

		on cleanup call cleanup_close_submodel; /* setup the cleanup condition handler */
		executing = "1"b;			/* and set flag to prevent recursion */

		call cleanup_close_submodel;		/* do the actual work */
		code = internal_error;		/* set output parameters */
	     end;					/* executing flag is reset in cleanup_close_submodel */

	return;

get_attribute_data: entry (opening_name, relation_name, users_area_ptr, str_version, attribute_data_ptr, code);

/*
   where:
   .   opening_name: (input) unique indetifing name for a opening
   .   relation_name: (input) name of relation whose attribute  data
   .        is wanted
   .   users_area_ptr: (input) pointer to a freeing area set  up  by
   .        the caller
   .   str_version: (input) version of  the  mrds_dsm_attribute_data
   .        structure expected to be allocated.
   .   attribute_data_ptr:    (output)      pointer      to      the
   .        mrds_dsm_attribute_data structure which was allocated
   .   code: (output) error code.

   This entry point returns a pointer to the mrds_dsm_attribute_data
   structure,  which  contains information about the attributes in a
   specific submodel relation. If the submodel refers  to  a  secure
   database  and the caller is not a DBA the names of the attributes
   in the model will be returned as spaces.

   The structure is allocated in  a  freeing  area  set  up  by  the
   caller who is responsible for freeing it.
*/



	code = 0;					/* initialize output variables */
	attribute_data_ptr = null ();

	if executing				/* This module cannot be recursive */
	then internal_error = mrds_error_$recursion_error;
	else do;
		mrds_dsm_attribute_data_ptr = null ();	/* initialize working variables */
		relation_block_ptr = null ();

		on cleanup call cleanup_get_attribute_data; /* setup the cleanup condition handler */
		executing = "1"b;			/* and set flag to prevent recursion */

		call verify_input_parameters (opening_name, /* verify some of the input */
		     users_area_ptr, str_version,	/* parameters and get the open_info pointer */
		     mrds_dsm_attribute_data_structure_version,
		     open_info_ptr, internal_error);
		if internal_error ^= 0
		then goto exit_get_attribute_data;

		call mrds_dsm_read_relation (relation_name, /* get the relation and attribute */
		     msmi_area_ptr, relation_block_ptr, /* data for the specified relation */
		     open_info.iocb, internal_error);
		if internal_error ^= 0
		then do;
			if internal_error = error_table_$no_record
			then internal_error = mrds_error_$unknown_relation_name;
			goto exit_get_attribute_data;
		     end;

		on area /* trap the area condition while */
		     begin;			/* allocating in the user's area */
			internal_error = error_table_$area_too_small;
			goto exit_get_attribute_data;
		     end;
		mrds_dsm_attribute_data_num_atts =
		     relation_block.no_rb_attributes;
		allocate mrds_dsm_attribute_data
		     in (users_area) set (mrds_dsm_attribute_data_ptr);
		revert area;

		unspec (mrds_dsm_attribute_data) = "0"b;/* initialize the allocated structure */
		mrds_dsm_attribute_data.number_of_attributes =
		     mrds_dsm_attribute_data_num_atts;
		mrds_dsm_attribute_data.version =
		     mrds_dsm_attribute_data_structure_version;

		do i = 1 to mrds_dsm_attribute_data_num_atts; /* load the structure */

		     mrds_dsm_attribute_data.attributes (i).submodel_attribute_name =
			relation_block.attribute_info (i).dsm_attr_name;
						/* supress model names if the caller is not a DBA */
		     if open_info.return_model_stuff	/* and the database is secure */
		     then mrds_dsm_attribute_data.attributes (i).model_attribute_name =
			     relation_block.attribute_info (i).dm_attr_name;
		     else mrds_dsm_attribute_data.attributes (i).model_attribute_name = " ";

		     mrds_dsm_attribute_data.attributes (i).read_access =
			relation_block.attribute_info (i).attr_access.read;
		     mrds_dsm_attribute_data.attributes (i).modify_access =
			relation_block.attribute_info (i).attr_access.modify;
		     mrds_dsm_attribute_data.attributes (i).null_access =
			relation_block.attribute_info (i).attr_access.null;
		     mrds_dsm_attribute_data.attributes (i).mbz1 = "0"b;
		end;

		free relation_block_ptr -> relation_block;

		attribute_data_ptr = mrds_dsm_attribute_data_ptr;

exit_get_attribute_data:
		code = internal_error;
		executing = "0"b;			/* no longer executing */

	     end;

	return;

get_relation_data: entry (opening_name, users_area_ptr, str_version, relation_data_ptr, code);

/*
   where:
   .   opening_name: (input) unique indetifing name for a opening
   .   users_area_ptr: (input) pointer to a freeing area set  up  by
   .        the caller
   .   str_version: (input) version  of  the  mrds_dsm_relation_data
   .        structure expected to be allocated.
   .   relation_data_ptr:     (output)      pointer      to      the
   .        mrds_dsm_relation_data structure which was allocated
   .   code: (output) error code.

   This entry point returns a pointer to the  mrds_dsm_relation_data
   structure  which  contains information about all of the relations
   in a submodel view. If the submodel refers to a  secure  database
   and  the  caller  is not a DBA then the names of the relations in
   the model are returned as blanks.

   The structure is allocated in  a  freeing  area  set  up  by  the
   caller who is responsible for freeing it.
*/



	code = 0;					/* initiate output variables */
	relation_data_ptr = null ();

	if executing				/* This module cannot be recursive */
	then internal_error = mrds_error_$recursion_error;
	else do;
		mrds_dsm_relation_data_ptr = null ();	/* initialize working variables */
		mrds_dsm_relation_names_ptr = null ();
		relation_block_ptr = null ();

		on cleanup call cleanup_get_relation_data; /* setup cleanup condition handler */
		executing = "1"b;			/* and set flag to prevent recursion */

		call verify_input_parameters (opening_name, /* verify the input parameters */
		     users_area_ptr, str_version,	/* and get the open_info pointer */
		     mrds_dsm_relation_data_structure_version,
		     open_info_ptr, internal_error);
		if internal_error ^= 0
		then goto exit_get_relation_data;

		call mrds_dsm_get_relation_names /* get a list of all the */
		     (msmi_area_ptr, mrds_dsm_relation_names_ptr, /* relations in the submodel */
		     open_info.iocb, internal_error);
		if internal_error ^= 0
		then do;
			call report_error (internal_error, /* this error should never occur */
			     "PROGRAM LOGIC ERROR^/Could not get the list of submodel relation names",
			     "", "", "");
			goto exit_get_relation_data;
		     end;

		on area /* trap the area condition while */
		     begin;			/* allocating in the user's area */
			internal_error = error_table_$area_too_small;
			goto exit_get_relation_data;
		     end;
		mrds_dsm_relation_data_num_rels = mrds_dsm_relation_names.nrels;
		allocate mrds_dsm_relation_data in (users_area) set (mrds_dsm_relation_data_ptr);
		revert area;

		unspec (mrds_dsm_relation_data) = "0"b; /* initialize the allocated structure */
		mrds_dsm_relation_data.number_of_relations =
		     mrds_dsm_relation_data_num_rels;
		mrds_dsm_relation_data.version =
		     mrds_dsm_relation_data_structure_version;

		do i = 1 to mrds_dsm_relation_names.nrels; /* load the structure */

		     call mrds_dsm_read_relation /* get relation and attribute data */
			(mrds_dsm_relation_names.relation (i), /* ingore attribute data */
			msmi_area_ptr, relation_block_ptr,
			open_info.iocb, internal_error);
		     if internal_error ^= 0
		     then do;
			     call report_error (internal_error, /* this error should never occur */
				"PROGRAM LOGIC ERROR^/Could not read the relation record for relation ^a",
				mrds_dsm_relation_names.relation (i), "", "");
			     goto exit_get_relation_data;
			end;

		     mrds_dsm_relation_data.relations (i).submodel_relation_name = mrds_dsm_relation_names.relation (i);
						/* surpress model names if the caller is not a DBA */
		     if open_info.return_model_stuff	/* and the database is secure */
		     then mrds_dsm_relation_data.relations (i).model_relation_name = relation_block.dm_rel_name;
		     else mrds_dsm_relation_data.relations (i).model_relation_name = " ";

		     mrds_dsm_relation_data.relations (i).append_access = relation_block.rel_access.append;
		     mrds_dsm_relation_data.relations (i).delete_access = relation_block.rel_access.delete;
		     mrds_dsm_relation_data.relations (i).null_access = relation_block.rel_access.null;
		     mrds_dsm_relation_data.relations (i).mbz1 = "0"b;

		     free relation_block_ptr -> relation_block;
		end;

		free mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names;

		relation_data_ptr = mrds_dsm_relation_data_ptr;

exit_get_relation_data:
		code = internal_error;
		executing = "0"b;			/* no longer executing */

	     end;

	return;

get_submodel_info: entry (opening_name, users_area_ptr, str_version, submodel_info_ptr, code);

/*
   where:
   .   opening_name: (input) unique indetifing name for a opening
   .   users_area_ptr: (input) pointer to a freeing area set  up  by
   .        the caller
   .   str_version: (input) version  of  the  mrds_dsm_relation_data
   .        structure expected to be allocated.
   .   relation_data_ptr:     (output)      pointer      to      the
   .        mrds_dsm_relation_data structure which was allocated
   .   code: (output) error code.

   This entry point returns a pointer to the  mrds_dsm_submodel_info
   structure  which  contains general information about the submodel
   associated with the opening_name.

   The structure is allocated in  a  freeing  area  set  up  by  the
   caller who is resp}onsible for freeing it.
*/


	code = 0;					/* initialize output variables */
	submodel_info_ptr = null ();

	if executing				/* This module cannot be recursive */
	then internal_error = mrds_error_$recursion_error;
	else do;
		mrds_dsm_submodel_info_ptr = null ();	/* initialize working variables */
		mrds_dsm_header_ptr = null ();

		on cleanup call cleanup_get_submodel_info; /* setup the cleanup condition handler */
		executing = "1"b;			/* and set flag to prevent recursion */

		call verify_input_parameters (opening_name, /* verify the input parameters */
		     users_area_ptr, str_version,	/* and get the open_info pointer */
		     mrds_dsm_submodel_info_structure_version,
		     open_info_ptr, internal_error);
		if internal_error ^= 0
		then goto exit_get_submodel_info;

		call mrds_dsm_read_header (msmi_area_ptr, /* get the info in the submodel header */
		     mrds_dsm_header_ptr, open_info.iocb,
		     internal_error);
		if internal_error ^= 0
		then do;
			call report_error (internal_error, /* this error should never occur */
			     "PROGRAM LOGIC ERROR^/Could not read the submodel header record",
			     "", "", "");
			goto exit_get_submodel_info;
		     end;

		on area /* trap the area condition while */
		     begin;			/* allocating in the user's area */
			internal_error = error_table_$area_too_small;
			goto exit_get_submodel_info;
		     end;
		allocate mrds_dsm_submodel_info in (users_area) set (mrds_dsm_submodel_info_ptr);
		revert area;

		unspec (mrds_dsm_submodel_info) = "0"b; /* initialize the allocated structure */
		mrds_dsm_submodel_info.version =
		     mrds_dsm_submodel_info_structure_version;
						/* load the structure */
		mrds_dsm_submodel_info.submodel_version =
		     mrds_dsm_header_ptr -> mrds_dsm_header.dsm_generator_version;
		mrds_dsm_submodel_info.database_path =
		     mrds_dsm_header_ptr -> mrds_dsm_header.database_pn;
		mrds_dsm_submodel_info.submodel_path =
		     open_info.dsm_path;
		mrds_dsm_submodel_info.date_time_created =
		     mrds_dsm_header_ptr -> mrds_dsm_header.date_time_generated;
		mrds_dsm_submodel_info.creator_id =
		     mrds_dsm_header_ptr -> mrds_dsm_header.creator_id;

		free mrds_dsm_header_ptr -> mrds_dsm_header;

		submodel_info_ptr = mrds_dsm_submodel_info_ptr;

exit_get_submodel_info:
		code = internal_error;
		executing = "0"b;			/* no longer executing */

	     end;

	return;

open_submodel: entry (opening_name, dsm_path, code);

/*
   where:
   .   opening_name: (input) unique identifing name for a opening
   .   dsm_path: (input) path relative or absolute to the submodel.
   .   code: (output) error code

   This entry point prepares a submodel so that it may be referenced
   by  the  other  entry  points  in  this module, it associates the
   opened submodel with the opening_name.

   It opens  the  submodel  for  shared  reading.  and  sets  up  an
   association  between  the  users unique identifier (opening_name)
   and the opening information (open_info). This opening information
   is  a  pointer to the submodels iocb and an indication of whether
   model information may be returned (only if the  database  is  not
   secure  or  if the database is secure and the user is a DBA), the
   submodel path is also saved.

   The open_info structure is allocated in a  temporary  segment  in
   the  process  directory.  This temporary segment is set up on the
   process's first call to this entry point and  remains  associated
   with this module for the life of the process.
*/
dcl       suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35));
dcl       search_paths_$find_dir entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35));

	code = 0;					/* initialize output variables */

	if executing				/* this module cannot be recursive */
	then internal_error = mrds_error_$recursion_error;
	else do;
		dsm_iocb_ptr = null ();
		open_info_ptr = null ();

		on cleanup call cleanup_open_submodel;	/* setup the cleanup condition handler */
		executing = "1"b;			/* and set flag to prevent recursion */

		if msmi_area_ptr = null ()		/* if the msmi_area has not yet been set up - set it up */
		then do;
			call get_temp_segment_ ("mrds_dsm_msmi", msmi_area_ptr, internal_error);
			if internal_error ^= 0
			then do;
				call report_error (internal_error,
				     "Could not get a temp segment to hold opening information", "", "", "");
				goto exit_open_submodel;
			     end;
			else msmi_area_ptr -> msmi_area = empty (); /* define an empty area in the segment */
		     end;

		if search (dsm_path, "<>") = 0 then do;
		     call suffixed_name_$make (dsm_path, DSM_SUFFIX, dsm_entryname, internal_error);
		     if internal_error ^= 0 
			then goto exit_open_submodel;
		     call search_paths_$find_dir (MRDS_SEARCHLIST, null(), dsm_entryname, "", dsm_dirname, internal_error);
		     if internal_error ^= 0 
			then goto exit_open_submodel;
		     end;
		else do;
		     call expand_pathname_$add_suffix (dsm_path, /* add .dsm to the input path if its not */
			DSM_SUFFIX, dsm_dirname,		/* already there and expand it to get the */
			dsm_entryname, internal_error);	/* absolute path of the directory and entry name */
		     if internal_error ^= 0
			then goto exit_open_submodel;
		     end;
		dsm_path_absolute = rtrim (dsm_dirname) ||
		     ">" || dsm_entryname;
		call mrds_dsm_open$read_share /* open the submodel, allowing multiple readers */
		     (dsm_path_absolute, dsm_iocb_ptr, internal_error);
		if internal_error ^= 0
		then goto exit_open_submodel;

		call mrds_dsm_read_header$db_path /* get the absolute path of the db */
		     (dsm_iocb_ptr, db_path, internal_error); /* that the submodel is defined for */
		if internal_error ^= 0
		then do;
			call report_error (internal_error, /* this error should never occur */
			     "PROGRAM LOGIC ERROR^/Could not read submodel ^a>^a's" ||
			     " header to get the database path", dsm_dirname, dsm_entryname, "");
			call mrds_dsm_close$force (dsm_iocb_ptr);
			goto exit_open_submodel;
		     end;

		allocate open_info in (msmi_area) /* allocate the open_info structure */
		     set (open_info_ptr);		/* to store */
		open_info.iocb = dsm_iocb_ptr;	/* submodel iocb pointer */
		open_info.dsm_path = dsm_path_absolute; /* input submodel path and */
		open_info.return_model_stuff = /* whether to return model info or not */
		     mrds_dsm_determine_auth_sec (db_path,
		     dsm_dirname, dsm_entryname);

		call mu_open_name_manager$define_open_name (opening_name, /* assocate the opening_name */
		     "s", open_info_ptr, internal_error); /* with the open_info structure */
		if internal_error ^= 0		/* in case of error free the open_info structure */
		then free open_info_ptr -> open_info;

exit_open_submodel:
		code = internal_error;
		executing = "0"b;			/* no longer executing */
	     end;

	return;

cleanup_close_submodel: proc;

/*
   This procedure  "closes"  a  submodel,  that  is  it  closes  the
   submodel  vfile  to further output, frees the open_info structure
   and deletes the opening_name from the  name  list.  Because  this
   routine  is  also  a  cleanup  handler  and the goal is to always
   "close" the submodel special switches are set and tested.

   .        open_info_ptr: if not null then a call to
   .        get_model_ptr has been successfully made.

   .        open_info_ptr2:  if  not  null  then  the
   .        open_info  structure  has  not  yet  been
   .        freed.

   .        name_not_deleted: if "1"b then a call  to
   .        delete_name has not yet been made.
*/

	internal_error = 0;
	if open_info_ptr = null ()			/* if the open_info_ptr has not yet been obtained - get it */
	then do;
		call mu_open_name_manager$get_model_pointer (opening_name, ignore_arg_char1,
		     open_info_ptr, internal_error);
		open_info_ptr2 = open_info_ptr;
	     end;

	if internal_error = 0			/* if open_info_ptr was obtained without error */
	then do;
		if name_not_deleted			/* and the name has not yet been deleted */
		then do;				/* from the open_name list - delete it */
			call mu_open_name_manager$delete_open_name
			     (opening_name, internal_error);
			name_not_deleted = "0"b;
			if internal_error ^= 0	/* You should always be able to delete a */
			then do;			/* name which can get a model pointer */
				call report_error (internal_error, "PROGRAM LOGIC ERROR^/Could not delete" ||
				     " the opening name ^a the submodel HAS been closed but you cannot use" ||
				     " the opening name over again", opening_name, "", "");
				internal_error = 0;
			     end;
		     end;

		if open_info_ptr2 ^= null ()		/* free an allocated open_info structure */
		then do;
			call mrds_dsm_close$force /* close the submodel - without generating errors */
			     (open_info.iocb);
			free open_info_ptr2 -> open_info; /* and free the structure */
		     end;
	     end;

	executing = "0"b;

     end /* cleanup_close_submodel */;

cleanup_get_attribute_data: proc;

/*
   This procedure cleansup allocated structures in the event that  a
   cleanup    condition    is    signaled    while   executing   the
   get_attribute_data entry. It also resets  the  executing  bit  to
   allow the module to be recalled.
*/



	if relation_block_ptr ^= null ()		/* free an allocated relation_block structure */
	then free relation_block_ptr -> relation_block;

	if mrds_dsm_attribute_data_ptr ^= null ()	/* free an allocated mrds_dsm_attribute_data structure */
	then free mrds_dsm_attribute_data_ptr -> mrds_dsm_attribute_data;

	executing = "0"b;				/* allow the module to be recalled */

     end /* cleanup_get_attribute_data */;

cleanup_get_relation_data: proc;

/*
   This procedure cleansup allocated structures in the event that  a
   cleanup    condition    is    signaled    while   executing   the
   get_relation_data entry. It also resets the executing bit so that
   the moduled can be called again.
*/




	if mrds_dsm_relation_data_ptr ^= null ()	/* free an allocated mrds_dsm_relation_data structure */
	then free mrds_dsm_relation_data_ptr -> mrds_dsm_relation_data;

	if mrds_dsm_relation_names_ptr ^= null ()	/* free an allocated mrds_dsm_relation_names structure */
	then free mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names;

	if relation_block_ptr ^= null ()		/* free an allocated relation_block structure */
	then free relation_block_ptr -> relation_block;

	executing = "0"b;				/* allow the module to be called again */

     end /* cleanup_get_relation_data */;

cleanup_get_submodel_info: proc;

/*
   This procedure cleansup allocated structures in the event that  a
   cleanup    condition    is    signaled    while   executing   the
   get_submodel_info entry. It also resets the executing bit so  the
   module can be recalled.
*/



	if mrds_dsm_header_ptr ^= null ()		/* free an allocated mrds_dsm_header structure */
	then free mrds_dsm_header_ptr -> mrds_dsm_header;

	if mrds_dsm_submodel_info_ptr ^= null ()	/* free an allocated mrds_dsm_submodel structure */
	then free mrds_dsm_submodel_info_ptr -> mrds_dsm_submodel_info;

	executing = "0"b;				/* allow the module to be called again */

     end;						/* cleanup_get_submodel_info */

cleanup_open_submodel: proc;

/*
   This procedure cleansup  allocated  structures  and  closes  open
   files  in  the  event  that a cleanup condition is signaled while
   executing the open_submodel entry. It also resets  the  executing
   bit so the model can be recalled.
*/



	if dsm_iocb_ptr ^= null ()			/* if the submodel has been opened close it */
	then call mrds_dsm_close$force (dsm_iocb_ptr);

	if open_info_ptr ^= null ()
	then do;
		call mu_open_name_manager$delete_open_name /* the name may not have been added yet */
		     (opening_name, ignore_error);	/* so ignore any errors */
		free open_info_ptr -> open_info;	/* free an allocated open_info structure */
	     end;

	executing = "0"b;				/* allow the module to be recalled */

     end /* cleanup_open_submodel */;

verify_input_parameters: proc (opening_name, users_area_ptr, str_version, version_limit, open_info_ptr, icode);

/*
   This routine is used to verify the input parameters:

   .   opening_name: to be sure that  the  name  is  associated
   .        with a submodel opening

   .   users_area_ptr: to be sure that it points to  a  freeing
   .        area

   .   str_version: to be sure that the  requested  version  of
   .        the structure can be allocated  (assumes  that  all
   .        versions  of  the structure <= version_limit can be
   .        allocated

   the routine also returns the pointer to a open_info  structure  -
   provided that all the parameters are ok.
*/


/* PARAMETERS */

	dcl     opening_name	 char (*);	/* (input) name identifing the opening */
	dcl     users_area_ptr	 ptr;		/* (input) pointer to users area */
	dcl     str_version		 fixed bin;	/* (input) str version requested by user */
	dcl     version_limit	 fixed bin;	/* (input) maximum str version obtainable */
	dcl     open_info_ptr	 ptr;		/* (output) open_info associated with opening_name */
	dcl     icode		 fixed bin (35);	/* (output) error icode */


	icode = 0;

	call mu_open_name_manager$get_model_pointer /* get the open_info associated with the opening_name */
	     (opening_name, ignore_arg_char1, open_info_ptr, icode);
	if icode = 0
	then do;
		if users_area_ptr = null ()		/* check to be sure that the area */
		then icode = error_table_$badcall;	/* is a freeing area */
		else do;
			unspec (local_area_info) = "0"b;
			local_area_info.version = 1;
			local_area_info.areap = users_area_ptr;
			call area_info_ (addr (local_area_info), icode);
			if icode = 0
			then do;
				if local_area_info.no_freeing
				then icode = mrds_error_$not_freeing_area;
			     end;
		     end;
		if icode = 0
		then do;
			if (str_version > version_limit) | /* make sure that the requested */
			     (str_version < 0)	/* structure can be allocated */
			then icode =
				error_table_$unimplemented_version;
		     end;
	     end;

	return;

     end /* verify_input_parameters */;

report_error: proc (icode, message, arg1, arg2, arg3);

/*
   This routine is used to report errors via the sub_err_ condition.
   sub_err_ is called with the continue switch set so that after the
   sub_err_ condition has been  acted  on  by  the  system  and  the
   message  is printed control is returned to the entry which called
   report_error. All this assumes that the user has not set  up  his
   own  sub_err_  handler  - if he has he can return control to this
   module or not as well as printing the message or not.
*/


/* PARAMETERS */

	dcl     icode		 fixed bin (35);	/* (input) error code */
	dcl     message		 char (*);	/* (input) error message */
	dcl     arg1		 char (*);	/* (input) first argument to error message */
	dcl     arg2		 char (*);	/* (input) second argument to error message */
	dcl     arg3		 char (*);	/* (input) third argument to error message */

/* AUTOMATIC */

	dcl     retval		 fixed bin (35);

/* ENTRIES */

	dcl     sub_err_		 entry options (variable);



	call sub_err_ (icode, "mrds_dsm_msmi", "c", null (), retval, message, arg1, arg2, arg3);

	return;

     end /* report_error */;

     end /* mrds_dsm_msmi */;




		    mrds_dsm_open.pl1               04/18/85  1429.4re  04/18/85  0906.9       42147



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

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

mrds_dsm_open: proc (submodel_pn, iocb_ptr, code);

/*
   This routine opens a submodel for  either  read,  update,  shared
   read,  or  shared  update depending on the entry used. it returns
   either a zero error code and a pointer to the submodel iocb or  a
   non-zero  error  code  and a null iocb pointer. The prinary entry
   point mrds_dsm_open should never be called. The file  is  checked
   to  be  sure  its a valid submodel after opening and if its not a
   valid  submodel  the  file  is  closed   and   the   error   code
   mrds_error_$not_dsm  is  returned.  If  for  any  reason the file
   cannot be varified it is also closed and an error code returned.

   Known Bugs:

   Other Problems:

   HISTORY

   81-01-22 Davids: written.

   81-01-30 Davids: modified to verify that the  file  is  really  a
   .        submodel by calling mrds_dsm_read_header$version, If the
   .        error code returned is zero its a submodel.

   81-04-24 Davids: added the update_share entry point.

   83-06-17 Davids: Modified to return mrds_error_$version_1_dsm if the
   submodel being opened is a version 1 submodel. A version 1 submodel
   will not be opened
*/

/* PARAMETERS */

	dcl     submodel_pn		 char (*);	/* (input) path to submodel to be opened */
	dcl     iocb_ptr		 ptr;		/* (output) pointer to submodel iocb */
	dcl     code		 fixed bin (35);	/* (output) error code */

/* AUTOMATIC */

	dcl     atd		 char (200) init (""); /* attach description */
	dcl     mode		 fixed bin;	/* opening mode */

/* BUILTIN */

	dcl     null		 builtin;
	dcl     rtrim		 builtin;

/* EXTERNAL */

	dcl     error_table_$badcall	 fixed bin (35) ext static;

	iocb_ptr = null ();
	code = error_table_$badcall;
	return;






read: entry (submodel_pn, iocb_ptr, code);

	atd = "vfile_ " || submodel_pn;
	mode = 8;
	call common;
	return;





update: entry (submodel_pn, iocb_ptr, code);

	atd = "vfile_ " || submodel_pn;
	mode = 10;
	call common;
	return;





read_share: entry (submodel_pn, iocb_ptr, code);

	atd = "vfile_ " || rtrim (submodel_pn) || " -share";
	mode = 8;
	call common;
	return;





update_share: entry (submodel_pn, iocb_ptr, code);

	atd = "vfile_ " || rtrim (submodel_pn) || " -share";
	mode = 10;
	call common;
	return;

common: proc;

/* AUTOMATIC */

	dcl     a_code		 fixed bin (35);	/* internal error code */
	dcl     version		 fixed bin;	/* used as an output parameter to read_header,
						   nothing is done with the returned value */

/* EXTERNAL */

	dcl     mrds_error_$version_1_dsm fixed bin (35) ext static;

/* ENTRIES */

	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     mrds_dsm_read_header$version entry (ptr, fixed bin, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));





	call iox_$attach_name (unique_chars_ ("0"b), iocb_ptr, atd, null (), code);
	if code ^= 0
	then iocb_ptr = null ();
	else do;
		call iox_$open (iocb_ptr, mode, "0"b, code);
		if code ^= 0
		then do;
			call iox_$detach_iocb (iocb_ptr, a_code);
			call iox_$destroy_iocb (iocb_ptr, a_code);
			iocb_ptr = null ();
		     end;
		else do;
			call mrds_dsm_read_header$version (iocb_ptr, version, code);
			if code = 0 & version = 1
			then code = mrds_error_$version_1_dsm;
			if code ^= 0
			then do;
				call iox_$close (iocb_ptr, a_code);
				call iox_$detach_iocb (iocb_ptr, a_code);
				call iox_$destroy_iocb (iocb_ptr, a_code);
			     end;
		     end;
	     end;

	return;

     end /* common */;

     end /* mrds_dsm_open */;





		    mrds_dsm_parse.pl1              04/18/85  1429.4re  04/18/85  0906.9      330984



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

mrds_dsm_parse: proc (p_mrds_dsm_parse_info_ptr, p_code);

/*
   HISTORY

   ??-??-?? Spratt: written

   81-05-07   Davids:    modified    to    set    the    value    of
   .        mrds_dsm_semantics_info.data_model_ptr, which  was  just
   .        added to the structure.

   .        started this history section.

   81-05-08 Davids: added the phrase "PROGRAM LOGIC  ERROR"  to  the
   .        message output by sub_err_ in the event that the version
   .        of mrds_dsm_parse_info is wrong.

   .        added a call to ioa_ in report_mdb_error to  send  error
   .        messages   to   the  listing,  if  one  is  being  built
   .        (listing_iocb_ptr ^= null ());

   81-05-15      Davids:      added       the       setting       of
   .        mrds_dsm_parse_info.highest_severity_(scanner semantics)
   .        after     each     call    to    mrds_dsm_scanner    and
   .        mrds_dsm_semantics.  also  removed   some   unreferenced
   .        variable declarations.

   81-05-20 Davids: fixed a bug in how the address of shared  tables
   .        was determined in next_term, DPDA.v1 was being used when
   .        it should have been DPDA.v2.
*/

/* PARAMETER */

	dcl     p_mrds_dsm_parse_info_ptr ptr;
	dcl     p_code		 fixed bin (35);

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     debug_sw		 bit (1) aligned;
	dcl     db_look		 pic "99" defined (db_data.type) pos (3);
	dcl     1 db_data,
		2 flag		 char (1),	/* * means stacked */
		2 state		 pic "zzz9",
		2 fil1		 char (2),
		2 type		 char (6),
		2 data		 char (100);
	dcl     ls_top		 fixed bin (24);	/* location of top of lexical stack */
	dcl     altn		 fixed bin (24);	/* APPLY alternative number */
	dcl     current_state	 fixed bin (24);	/* number of current state */
	dcl     test_symbol		 fixed bin (24);	/* encoding of current symbol */
	dcl     current_table	 fixed bin (24);	/* number of current table */
	dcl     i			 fixed bin (24);	/* temp */
	dcl     la_ct		 fixed bin (24);	/* number of terminals in look-ahead stack */
	dcl     la_get		 fixed bin (24);	/* location in look_ahead stack to get next symbol */
	dcl     la_need		 fixed bin (24);	/* number of look-ahead symbols needed */
	dcl     la_put		 fixed bin (24);	/* location in look_ahead stack to put next symbol */
	dcl     an		 fixed bin (24);
	dcl     la_use		 fixed bin (24);	/* location in look-ahead stack to test with */
	dcl     (m, n)		 fixed bin (24);
	dcl     next_state		 fixed bin (24);	/* number of next state */
	dcl     nil_sym		 fixed bin (24);
	dcl     nil		 fixed bin (24);
	dcl     nil_flag		 bit (1);
	dcl     ps_top		 fixed bin (24);	/* location of top of parse stack */
	dcl     recov_msg		 char (150) var;
	dcl     rulen		 fixed bin (24);	/* APPLY rule number */
	dcl     t			 fixed bin (24);
	declare token_cnt		 fixed binary (24); /* number of tokens used */
	declare error_mark		 fixed binary (24); /* point to get past before another local correction allowed */
	dcl     work_area_ptr	 ptr;
	declare message		 char (128) varying;/* message with details of error */
	declare message_length	 fixed binary;	/* length of returned error message */

/* BASED */

	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);

/* BUILTIN */

	dcl     (
	        abs,
	        addr,
	        copy,
	        fixed,
	        hbound,
	        lbound,
	        length,
	        ltrim,
	        min,
	        max,
	        mod,
	        null,
	        sign,
	        string,
	        substr
	        )			 builtin;

/* CONDITION */

	dcl     cleanup		 condition;

/* CONSTANT */

	dcl     MYNAME		 char (14) internal static options (constant) init ("mrds_dsm_parse");
	declare end_of_input_msg	 char (18) internal static options (constant) init (" --END_OF_INPUT-- ");
						/* EOI message */
	dcl     DDop		 (-1:2) char (4) int static options (constant) init ("LOOK", "FINI", "READ", "ERR");

/* ENTRY */

	dcl     sub_err_		 entry options (variable);
	declare ioa_$rs		 entry options (variable);
	dcl     ioa_$ioa_switch	 entry options (variable);
						/* routine to return string */
	dcl     mrds_dsm_scanner$init	 entry (ptr, fixed bin (35));

	dcl     mrds_dsm_scanner	 entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     mrds_dsm_semantics	 entry (ptr, fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_$ioa_switch_nnl	 entry options (variable);

/* EXTERNAL */

	dcl     error_table_$unimplemented_version fixed bin (35) ext;
	dcl     iox_$user_output	 ptr ext static;
	declare sys_info$max_seg_size	 fixed binary (35) external; /* largest segment size */

	mrds_dsm_parse_info_ptr = p_mrds_dsm_parse_info_ptr;
	on cleanup call finish;
	if mrds_dsm_parse_info.version ^= MRDS_DSM_PARSE_INFO_VERSION_1
	then call sub_err_ (error_table_$unimplemented_version, MYNAME, "s", null, (0),
		"PROGRAM LOGIC ERROR^/The wrong version of mrds_dsm_parse_info was used.");


/* the call to sub_err_ will never return */

	p_struct_ptr = null;
	mrds_dsm_scanner_info_ptr = null;
	mrds_dsm_semantics_info_ptr = null;
	lex_stack_ptr = null;
	cur_lex_top_ptr = null;

	p_code = 0;
	work_area_ptr = mrds_dsm_parse_info.work_area_ptr;

	allocate lex_stack in (work_area);
	allocate p_struct in (work_area);
	allocate cur_lex_top in (work_area);

	allocate mrds_dsm_semantics_info in (work_area);
	mrds_dsm_semantics_info.version = MRDS_DSM_SEMANTICS_INFO_VERSION_1;
	mrds_dsm_semantics_info.debug_semantics = mrds_dsm_parse_info.debug_semantics;
	mrds_dsm_semantics_info.work_area_ptr = mrds_dsm_parse_info.work_area_ptr;
	mrds_dsm_semantics_info.submodel_iocb_ptr = mrds_dsm_parse_info.submodel_iocb_ptr;
	mrds_dsm_semantics_info.error_iocb_ptr = mrds_dsm_parse_info.error_iocb_ptr;
	mrds_dsm_semantics_info.listing_iocb_ptr = mrds_dsm_parse_info.listing_iocb_ptr;
	mrds_dsm_semantics_info.data_model_ptr = mrds_dsm_parse_info.data_model_ptr;
	mrds_dsm_semantics_info.highest_severity = 0;

	allocate mrds_dsm_scanner_info in (work_area);
	mrds_dsm_scanner_info.version = MRDS_DSM_SCANNER_INFO_VERSION_1;
	mrds_dsm_scanner_info.debug_scanner = mrds_dsm_parse_info.debug_scanner;
	mrds_dsm_scanner_info.source_ptr = mrds_dsm_parse_info.source_ptr;
	mrds_dsm_scanner_info.source_length = mrds_dsm_parse_info.source_length;
	mrds_dsm_scanner_info.error_iocb_ptr = mrds_dsm_parse_info.error_iocb_ptr;
	mrds_dsm_scanner_info.listing_iocb_ptr = mrds_dsm_parse_info.listing_iocb_ptr;
	mrds_dsm_scanner_info.work_area_ptr = mrds_dsm_parse_info.work_area_ptr;
	mrds_dsm_scanner_info.highest_severity = 0;

	call mrds_dsm_scanner$init (mrds_dsm_scanner_info_ptr, code);

	current_state = 1;
	debug_sw = mrds_dsm_parse_info.debug_parse;
	nil_sym = -1;				/* set nil_sym non-existant */
	nil_flag = "0"b;				/* Initially not in skip error recovery */
	ls_top, ps_top = 0;
	la_put, la_get = 1;
	la_ct = 0;
	token_cnt = 0;
	error_mark = -1;

/* Begin parsing loop. */

	do while (current_state ^= 0);

	     current_table = current_state;
	     string (db_data) = "";
	     db_data.state = current_state;

	     goto CASE (DPDA.v1 (current_table));

CASE (3):
	     current_table = DPDA.v2 (current_table);
CASE (1):
	     la_use = mod (la_get + la_need - 1, -lbound (lex_stack, 1)) + 1;
	     if (la_need >= -lbound (lex_stack, 1) - 1)
	     then do;
		     call too_many (-lbound (lex_stack, 1), "lookahead");
		     call finish_mdp;
		     return;
		end;
	     la_need = la_need + 1;
	     call read_look (p_code);
	     if p_code ^= 0
	     then do;
		     call finish_mdp;
		     return;
		end;
	     goto NEXT;

CASE (10):					/* Shared read */
	     current_table = DPDA.v2 (current_table);

CASE (9):						/* Read. */
	     db_data.type = "READ";
	     la_need = 1;
	     la_use = la_get;
	     call read_look (p_code);
	     if p_code ^= 0
	     then do;
		     call finish_mdp;
		     return;
		end;
	     goto NEXT;

CASE (2):						/* Stack and Shared read */
	     current_table = DPDA.v2 (current_table);

CASE (0):						/* Stack and Read. */
	     db_data.type = "READ";
	     db_data.flag = "*";
	     la_need = 1;
	     la_use = la_get;
	     if (ps_top >= hbound (parse_stack, 1))
	     then do;
		     call too_many (hbound (parse_stack, 1), "parse");
		     call finish_mdp;
		     return;
		end;
	     ps_top = ps_top + 1;			/* Top of  parsing stack. */
	     parse_stack (ps_top) = current_state;	/* Stack the current state. */
	     cur_lex_top (ps_top) = ls_top;		/* save current lex top (for recovery) */
	     call read_look (p_code);
	     if p_code ^= 0
	     then do;
		     call finish_mdp;
		     return;
		end;
	     goto NEXT;

CASE (6):						/* Apply Shared */
	     current_table = DPDA.v2 (current_state + 3);
CASE (4):						/* Apply state. */
CASE (5):						/* Apply single */
	     la_need = 1;
	     rulen = DPDA.v1 (current_state + 2);
	     altn = DPDA.v2 (current_state + 2);
	     if debug_sw
	     then do;
		     db_data.type = "APLY";
		     db_data.data = "(";
		     call ioa_$ioa_switch_nnl (iox_$user_output, "^a^i ^i)", string (db_data), rulen, altn);
		end;

	     if (rulen > 0) & mrds_dsm_parse_info.highest_severity < 3
	     then do;
		     call mrds_dsm_semantics (mrds_dsm_semantics_info_ptr, rulen, altn, lex_stack_ptr, ls_top, code);
		     mrds_dsm_parse_info.highest_severity_semantics =
			max (mrds_dsm_parse_info.highest_severity_semantics,
			mrds_dsm_semantics_info.highest_severity);
		     if code ^= 0
		     then do;
			     p_code = code;
			     call finish_mdp;
			     return;
			end;
		end;

	     if debug_sw
	     then do;
		     call ioa_$ioa_switch_nnl (iox_$user_output, "^-pd=^i ld=^i(", DPDA.v1 (current_state + 1),
			DPDA.v2 (current_state + 1));
		     do t = ps_top to ps_top - DPDA.v1 (current_state + 1) + 1 by -1;
			call ioa_$ioa_switch_nnl (iox_$user_output, " ^d", parse_stack (t));
		     end;
		     call ioa_$ioa_switch_nnl (iox_$user_output, ")^/");
		end;

	     if DPDA.v1 (current_state + 1) = -1
	     then if (ps_top >= hbound (parse_stack, 1))
		then do;
			call too_many (hbound (parse_stack, 1), "parse");
			call finish_mdp;
			return;
		     end;
		else parse_stack (ps_top + 1) = current_state;

	     ps_top = ps_top - DPDA.v1 (current_state + 1);
	     ls_top = ls_top - DPDA.v2 (current_state + 1);

	     if ps_top <= 0
	     then do;
		     call report_mdp_error (4, PARSE_FAILURE, "The parse stack is empty.");
		     call finish_mdp;
		     return;
		end;

	     do i = current_table + 4 to current_table + DPDA.v2 (current_table)
		while (DPDA.v1 (i) ^= parse_stack (ps_top));
	     end;

	     if i > current_table + DPDA.v2 (current_table)
	     then current_state = DPDA.v2 (current_table + 3);
	     else current_state = DPDA.v2 (i);
NEXT:
	end;					/* End of parse loop. */

	return;					/* Effective end of mrds_dsm_parse. */

read_look:
     proc (p_code);

	dcl     p_code		 fixed bin (35);

	p_code = 0;

	do while (la_ct < la_need);
	     call mrds_dsm_scanner (mrds_dsm_scanner_info_ptr, addr (lex_stack), -la_put, code);
	     mrds_dsm_parse_info.highest_severity_scanner =
		max (mrds_dsm_parse_info.highest_severity_scanner,
		mrds_dsm_scanner_info.highest_severity);
	     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct + 1;
	end;

	test_symbol = lex_stack.symbol (-la_use);
	m = 0;
	nil = 0;
	an = test_symbol - 1;			/* The current table of the Deterministic Push-Down Automata(DPDA) must be
						   looped through, looking for an entry whose v1 equals the test_symbol.
						   Since the v1 column in the tables of the DPDA are arranged in ascending numberic
						   order, the search can be terminated when a v1>=test_symbol is found.
						   If a match is found, the next_state is set to the v2 of the matching entry and
						   got_symbol is called.
						   If a match is not found, an error condition has occurred and must be dealt
						   with appropriately.
						   */

	do i = current_table + 1 to current_table + DPDA.v2 (current_table) while (an < test_symbol);
	     n = DPDA.v1 (i);
	     if n < 0
	     then an = -n;
	     else an = n;
	     if an < test_symbol
	     then if n < 0
		then m = i;
		else if n = nil_sym
		then nil = i;
	end;

	if an = test_symbol
	then do;
		next_state = DPDA.v2 (i - 1);
		call got_symbol (p_code);
		if p_code ^= 0
		then return;
	     end;
	else do;
		if an > test_symbol
		then do i = 1 to current_table + DPDA.v2 (current_table);
			if abs (DPDA.v1 (i)) = nil_sym
			then nil = i;
		     end;

		if (m > 0)
		then do;
			next_state = DPDA.v2 (m);
			call got_symbol (p_code);
		     end;

		else if nil_flag & nil > 0
		then do;				/* If skip recovery has just occurred
						   and there is a nil symbol
						   transition take the transition
						   and back up to the nil
						   symbol in the lookahead
						   stack. */
			next_state = DPDA.v2 (nil);
			la_get = mod (la_get - 2, -lbound (lex_stack, 1)) + 1;
			la_ct = la_ct + 1;
			test_symbol = nil_sym;
			call got_symbol (p_code);
		     end;

		else if token_cnt > error_mark
		then do;
			if local_recovered (p_code)
			then do;
				call read_look (p_code);
				if p_code ^= 0
				then return;
			     end;
			else if p_code ^= 0
			then return;
			else if skip_recovered (p_code)
			then call report_mdp_error (3, PARSE_ERROR_RECOVERY, (recov_msg));
			else if p_code ^= 0
			then return;
			else do;
				if debug_sw
				then call ioa_$ioa_switch_nnl (iox_$user_output, " ^4i  ", current_state);
				call ioa_$rs ("^a ^d ^a ^a", message, message_length, "Line",
				     lex_stack (-la_get).line, "symbol", getermc (test_symbol, la_get));
				call report_mdp_error (2, PARSE_NO_RECOVERY, (message));
				p_code = PARSE_NO_RECOVERY;
			     end;
		     end;

		else if skip_recovered (p_code)
		then call report_mdp_error (3, PARSE_ERROR_RECOVERY, (recov_msg));
		else if p_code ^= 0
		then return;
		else do;
			if debug_sw
			then call ioa_$ioa_switch_nnl (iox_$user_output, " ^4i  ", current_state);
			call ioa_$rs ("^a ^d ^a ^a", message, message_length, "Line", lex_stack (-la_get).line,
			     "symbol", getermc (test_symbol, la_get));
			call report_mdp_error (2, PARSE_NO_RECOVERY, (message));
			p_code = PARSE_NO_RECOVERY;
		     end;
	     end;					/* End of (an ^= ts) case. */
	return;					/* Effective end of read_look. */

got_symbol:
     proc (p_code);
	dcl     p_code		 fixed bin (35);
	p_code = 0;
	nil_flag = "0"b;				/* If skip error recovery was
						   in progress, it is now
						   complete. */
	if debug_sw
	then do;
		if (next_state < 0)
		then do;				/* is this a look-ahead state? */
			db_data.type = "LK01";
			db_look = la_need;
			db_data.data = geterm (test_symbol, 0);
						/* display only terminal "name" on look-ahead */
			db_data.flag = " ";
		     end;
		else do;
			db_data.data = getermc (test_symbol, la_get);
						/* display terminal "name" and data, if available */
		     end;
		call ioa_$ioa_switch_nnl (iox_$user_output, "^a^/", string (db_data));
	     end;
	current_state = next_state;
	if (current_state < 0)
	then do;					/* Transition is a look-ahead state. */
		current_state = -current_state;
	     end;
	else do;
		if (ls_top >= hbound (lex_stack, 1))
		then do;
			call too_many (hbound (lex_stack, 1), "lexical");
			p_code = LEX_TOO_MANY;
			return;
		     end;
		ls_top = ls_top + 1;
		lex_stack (ls_top) = lex_stack (-la_get);
		la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
		la_ct = la_ct - 1;
		token_cnt = token_cnt + 1;
	     end;

     end;						/* End of got_symbol. */

skip_recovered:
     proc (p_code) returns (bit (1));

/* *
   Skip recovery requires that the user difine one or more  recovery
   terminal symbols by means of the

   -recover <nil> st1 st2 ...

   control  included  in  the  lrk  source.   st1  st2 etc. are skip
   terminals.  They are terminals which can  end  statements.   They
   cause  a  table  to  be built for skip recovery.  This table is a
   list of read or lookahead states which can follow the reading  of
   a skip terminal. These states correspond to the beginnings of new
   statements.

   Skip  recovery  is  done  when  an  error  has occurred and local
   recovery (if used) was not successful.  Basically what it does is
   to skip forward in the source by calling  the  scanner  until  it
   encounters  one  of  the skip terminals.  It then tries to find a
   state which followed a previous occurrence of the found terminal.
   If one is found it adjusts the lexical and parse stacks and  then
   procedes.

   Effectively  a  bad "statement" has been discarded.  In this case
   "statement" means an input string bounded by two  identical  skip
   terminals  (such  as  ";"  for  example)  including  the boundary
   terminal on  the  right.   If  the  language  is  such  that  the
   discarded  statement  is optional (syntactically) the rest of the
   input can be checked for syntax errors.

   When a bad "statement" is discarded the parser  is  restarted  in
   the  state  in  which it began to process that statement.  If the
   next input symbol encountered is not acceptable  to  this  state,
   the  parser  makes  a last attempt at error recovery by replacing
   the bad "statement" with the <nil> symbol defined by the -recover
   control if used.

   The <nil> symbol is one which the scanner must NEvER  return.  It
   is  needed  because some languages do not allow all statements to
   occur at every point.  This means that when you back  up  to  the
   last  statement  beginning  point, you may not be allowed to have
   the statement you find next.  As an example, take  this  grammar:
   <g>  ::= <i> | <g> <i> !
   <i>  ::= <a> | <b> !
   <a>  ::= a ; <rd> !
   <rd> ::= r ; | <rd> r ; !
   <b>  ::= b ; <sd> !
   <sd> ::= s ; | <sd> s ; !
   
   Then  suppose  that  you  intended to have an input like line (1)
   below, but instead you got (2):

   (1)  a ; r ; r ; b ; s ; s ; s ; a ; r ; r ; r ;
   (2)  a ; r ; r ; b ; s ; s ; s   a ; r ; r ; r ;

   Suppose that the grammar had specified
   -recover <nil> ;
   and local recovery  is  not  used.   When  the  "s"  "a"  ";"  is
   encountered,  skip  recovery  will discard it as a bad statement.
   But this then means that it will miss the fact that it should  be
   entering  the  <a>  rule.   It  will  then get to the "r" but the
   parser will have restarted in a state which can  read  either  an
   "a",  "b",  or  "s".   So  it  will  have to skip again.  In this
   example, skipping will occur, one statement at a time, until  EOI
   is reached.  This means that no syntax checking is done in all of
   the "r" s which are skipped.  This is not highly desireable.

   However, if you add a rule like this:

   <a>  ::= <nil> <rd> !
   then  the  generated <nil> from skip recovery will allow the <rd>
   to be correctly parsed, reducing  the  number  of  useless  error
   messages by quite a bit, usually.

   These <nil> rules can help parse thru misplaced statements during
   error  recovery,  but  will  never  accept these statements under
   normal circumstances.  The semantics on these <nil> rules  should then report an error.
   */

	dcl     p_code		 fixed bin (35);
	dcl     (i, ii)		 fixed bin (24);
	dcl     (j, jj)		 fixed bin (24);
	dcl     c			 fixed bin (24);
	dcl     dec4		 pic "zzz9";


	p_code = 0;
	if (hbound (skip_v1, 1) <= 0)
	then return ("0"b);				/* no skip table */
	error_mark = 0;
	current_table = 1;
	recov_msg = "Unuseable ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	recov_msg = recov_msg || " on line ";
	dec4 = lex_stack (-la_get).line;
	recov_msg = recov_msg || ltrim (dec4);
	recov_msg = recov_msg || ",  Skipped to ";

	nil_sym = skip_v1 (2);			/* SKIP table */
	c = 1;
	do while (c ^= 0);
	     if (la_ct < 1)
	     then do;				/* if look-ahead stack is empty, get a symbol */
		     call mrds_dsm_scanner (mrds_dsm_scanner_info_ptr, addr (lex_stack), -la_put, p_code);
		     mrds_dsm_parse_info.highest_severity_scanner =
			max (mrds_dsm_parse_info.highest_severity_scanner,
			mrds_dsm_scanner_info.highest_severity);
		     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
		     la_ct = 1;
		end;
	     c = lex_stack.symbol (-la_get);
	     do i = current_table + 2 to current_table + skip_v2 (current_table);
						/* SKIP table */
		if (skip_v1 (i) = c)
		then do;				/* SKIP table */
			jj = skip_v2 (i);		/* SKIP table */
			do j = ps_top to 1 by -1;
			     do ii = jj + 1 to jj + skip_v2 (jj);
						/* SKIP table */
				if (skip_v1 (ii) = parse_stack (j))
				then do;		/* SKIP table */
					ps_top = j - 1;
					ls_top = cur_lex_top (j);
					current_state = skip_v2 (ii);
						/* SKIP table */
					recov_msg = recov_msg || geterm (c, 0);
					recov_msg = recov_msg || " on line ";
					dec4 = lex_stack (-la_get).line;
					recov_msg = recov_msg || ltrim (dec4) || " " || copy ("!*!", 26);
					lex_stack (-la_get).symlen = 0;
						/* generate a nil symbol into the look-ahead stack */
					lex_stack (-la_get).symbol = nil_sym;
					la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
						/* Advance past nil symbol.
						   It will not be used unless
						   the next symbol cannot be read. */
					la_ct = la_ct - 1;
					nil_flag = "1"b;
					return ("1"b);
				     end;
			     end;
			end;
		     end;
	     end;
	     la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct - 1;
	end;
	recov_msg = recov_msg || end_of_input_msg || copy ("!*!", 26);
	current_state = 0;
	return ("1"b);
     end;						/* End of skip_recovered. */

geterm:
     proc (idx, ids) returns (char (100) var);

	dcl     (idx, ids)		 fixed bin (24);
	dcl     temp		 char (100) var;
	dcl     c_str		 char (20000) based;

	temp = "";
get_rest:
	if (ids > 0)
	then if (lex_stack (-ids).symlen > 0)
	     then do;
		     temp = temp || """";
		     temp = temp || substr (lex_stack (-ids).symptr -> c_str, 1, min (50, lex_stack (-ids).symlen));
		     temp = temp || """";
		     return (temp);
		end;
	if (idx = 0)
	then temp = end_of_input_msg;
	else temp = substr (string (TC), TL.fc (idx), TL.ln (idx));
	return (temp);
getermc:
     entry (idx, ids) returns (char (100) var);

	if (idx = 0)
	then temp = end_of_input_msg;
	else temp = substr (string (TC), TL.fc (idx), TL.ln (idx));
	temp = temp || " ";
	goto get_rest;
     end;						/* End of get_term and get_termc. */

local_recovered:
     proc (p_code) returns (bit (1));

/*
   "    this procedure implements the LRK local error recovery (using
   "    the  DPDA  table).  This  is  done by using the current (bad)
   "    symbol and the next input symbol. All  possible  parses  from
   "    this state are examined. These trial parses proceed until the
   "    next read or lookahead state is encountered. The trial parses
   "    are true simulations of what  can  happen,  apply  states are
   "    chosen according to the simulated top of parse stack.

   "    Given:
   "         B is the current symbol (bad)
   "         N is the next input symbol
   "         C is the current state
   "         R is a "next" read state
   "    These are the conditions which can exist.
   "         C( N )    R( B N )    -kind-
   "            0         1 0    symbol leading to R is missing
   "            0         0 1    B is a wrong symbol
   "            1         1 0    B and N reversed in input
   "            1         0 x    B is an extra symbol in the input
   "            0         0 0    recovery fails

   "    The recovery tries to find  a  useable  combination.  If  one
   "    exists,  the  search  does  not  stop.  If  a  second  one is
   "    encountered, the search stops, a message is  generated  which
   "    says the choice is not unique, and then the first combination
   "    is used.

   "    The local recovery shcheme was altered in  Sept  1977  by  Al
   "    Kepner  to  allow  local  recovery from errors encountered by
   "    look-ahead states.  Preveously  only  errors  encountered  by
   "    read states could be handled.  The error correction scheme is
   "    still the same heuristic described above.
   "
   "    Some  complexity has been added to procedure next_term.  Note
   "    the new variables la_get2 and la_use2.  These  are  necessary
   "    to  handle  the  case  where  an  error  is  encountered by a
   "    look-ahead state and the next state found is not a look-ahead
   "    state.  In this case the next  read  state  encountered  will
   "    correspond  to the "bad" symbol or a symbol to the left of it
   "    (depending on how many look-ahead states preceded the error).
   "    The goal is to  find  the  read  or  look-ahead  state  which
   "    corresponds  to  the  input  symbol to the right of the "bad"
   "    symbol.  The goal is recognized by the condition  "la_use2  =
   "    la_next".   Until  this  goal  is reached look-ahead and read
   "    states are simply passed through using the  look-ahead  stack
   "    to find the appropriate next state.
   */

	p_code = 0;
	if (test_symbol < 0)
	then do;
		call ioa_$rs ("^a ^d ^a", message, message_length, "Line", lex_stack (-la_get).line,
		     "Negative terminal; cannot recover");

		call report_mdp_error (2, PARSE_NO_RECOVERY, (message));
		return ("0"b);
	     end;
	error_mark = token_cnt + la_need;
	do while (la_ct < la_need + 1);

	     call mrds_dsm_scanner (mrds_dsm_scanner_info_ptr, addr (lex_stack), -la_put, p_code);
	     mrds_dsm_parse_info.highest_severity_scanner =
		max (mrds_dsm_parse_info.highest_severity_scanner,
		mrds_dsm_scanner_info.highest_severity);
	     if p_code ^= 0
	     then return ("0"b);

	     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct + 1;
	end;
	if hbound (skip_v1, 1) > 0
	then nil_sym = skip_v1 (2);			/* SKIP table */
	else nil_sym = -1;
	la_next = mod (la_use, -lbound (lex_stack, 1)) + 1;
	next_symbol = lex_stack (-la_next).symbol;
	dcl     string		 builtin;
	string (sws) = "0"b;
	transit = -1;
	combinations = 0;
	depth = 0;
	if debug_sw
	then call dump_la;
	do i = current_table + 1 to current_table + DPDA.v2 (current_table) while (combinations < 2);
	     alt_symbol = abs (DPDA.v1 (i));
	     if alt_symbol = nil_sym
	     then go to try_again;
	     if debug_sw
	     then call ioa_$ioa_switch_nnl (iox_$user_output, "#^4i ^4a ^i ^a^/", current_state, DDop (sign (DPDA.v2 (i))),
		     alt_symbol, geterm (alt_symbol, 0));
	     string (cycle) = "0"b;
	     if combinations < 2
	     then do;
		     call next_term ((ps_top), (DPDA.v2 (i)), p_code);
		     if p_code ^= 0
		     then return ("0"b);
		end;
try_again:
	end;
	recov_msg = "";
	if (transit = -1)
	then return ("0"b);
	goto case (fixed (string (sws)));

case (0):						/* can't resolve it */
	return ("0"b);

case (3):
case (7):						/* cannot occur */
	signal condition (logic_error);
	dcl     logic_error		 condition;

case (1):						/* B is wrong symbol */
	recov_msg = recov_msg || geterm (transit, 0);
	recov_msg = recov_msg || " used in place of erroneous ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	goto set_symbol;

case (2):						/* symbol leading to R is missing */
	recov_msg = recov_msg || "Missing ";
	recov_msg = recov_msg || geterm (transit, 0);
	recov_msg = recov_msg || " is assumed before ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	la_ct = la_ct + 1;
	lex_stack (-la_put) = lex_stack (-la_next);
	lex_stack (-la_next) = lex_stack (-la_use);
	la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
set_symbol:
	lex_stack (-la_use).token_num = 0;		/* flag as phoney token for semantics */
	la_next = la_use;
	lex_stack (-la_next).symptr = addr (default_symbol);
	lex_stack (-la_next).symlen = length (default_symbol);
	lex_stack (-la_next).line = lex_stack (-(mod (la_put - 2, -lbound (lex_stack, 1)) + 1)).line;
	lex_stack (-la_next).symbol = transit;
	goto done;

case (4):
case (5):						/* B is an extra symbol */
	recov_msg = recov_msg || "Extraneous ";
	recov_msg = recov_msg || geterm (test_symbol, la_use);
	recov_msg = recov_msg || " ignored before ";
	recov_msg = recov_msg || geterm (next_symbol, la_next);
	la_ct = la_ct - 1;
	la_put = mod (la_put - 2, -lbound (lex_stack, 1)) + 1;
						/* Back up one in look-ahead stack. */
	lex_stack (-la_use) = lex_stack (-la_next);
	goto done;

case (6):						/* B and N reversed */
	recov_msg = recov_msg || geterm (test_symbol, la_use);
	recov_msg = recov_msg || " and ";
	recov_msg = recov_msg || geterm (next_symbol, la_next);
	recov_msg = recov_msg || " are reversed.";
	lex_stack (ls_top + 1) = lex_stack (-la_use);
	lex_stack (-la_use) = lex_stack (-la_next);
	lex_stack (-la_next) = lex_stack (ls_top + 1);
done:
	if combinations <= 1
	then ;
	else recov_msg = recov_msg || copy (" ", 30) || "(choose first of many possibilities)";
	call ioa_$rs ("^a ^d ^a", message, message_length, "Line", mrds_dsm_scanner_info.line_number, recov_msg);

	call report_mdp_error (1, PARSE_ERROR_RECOVERY, (message));
	if debug_sw
	then call dump_la;
	return ("1"b);				/* recovery completed */

	dcl     1 sws,
		2 CNf		 bit (1) unal,	/* current state contains next symbol */
		2 RBNf		 bit (2) unal;	/* next read matches bad or next symbol */
	dcl     combinations	 fixed bin (24);	/* useable combinations found so far */
	dcl     transit		 fixed bin (24);	/* found alternate symbol to use from current state */
	dcl     la_next		 fixed bin (24);	/* temporary "next" look-ahead position */
	dcl     alt_symbol		 fixed bin (24);	/* current alternate symbol */
	dcl     cycle		 (4000) bit (1) unal;
	dcl     default_symbol	 char (13) int static init ("ERROR_SYMBOL_");
	dcl     next_symbol		 fixed bin (24);
	dcl     p_code		 fixed bin (35);
	dcl     depth		 fixed bin (24);

dump_la:
     proc;

	dcl     ii		 fixed bin (24);
	if debug_sw
	then do;
		ii = la_get;
		do while (ii ^= la_put);
		     call ioa_$ioa_switch_nnl (iox_$user_output, "#la(-^i) ^3i""^a""^/", ii, lex_stack (-ii).symbol,
			geterm (lex_stack (-ii).symbol, 0));
		     ii = mod (ii, -lbound (lex_stack, 1)) + 1;
		end;
	     end;
     end dump_la;					/*  */
next_term:
     proc (top, next_state, p_code);
	dcl     p_code		 fixed bin (35);

	p_code = 0;

	look_ahead = (next_state < 0);
	if look_ahead
	then do;
		la_use2 = la_use;
		la_get2 = la_get;
	     end;
	else la_use2, la_get2 = mod (la_get, -lbound (lex_stack, 1)) + 1;
	depth = depth + 5;
	do i = 1 to ps_top;
	     parse_stack2 (i) = parse_stack (i);
	end;
NEXT:
	if (next_state = 0)
	then do;
		transit = 0;
		depth = depth - 5;
		go to done;
	     end;
	next_state = abs (next_state);
	cur_st = next_state;
	if DPDA.v1 (cur_st) = 0 | DPDA.v1 (cur_st) = 2
	then do;					/* Stack state? */
		if top >= hbound (parse_stack, 1)
		then do;
			call too_many (hbound (parse_stack, 1), "parse");
			p_code = PARSE_TOO_MANY;
			return;
		     end;
		top = top + 1;
		parse_stack (top) = cur_st;
	     end;
	goto CASE (DPDA.v1 (cur_st));
CASE (2):						/* Stack and Shared read */
CASE (3):						/* Shared look */
CASE (10):					/* Shared read */
	cur_st = DPDA.v2 (cur_st);
CASE (0):						/* Stack and Read. */
CASE (1):						/* Look. */
CASE (9):						/* Read. */
	if DPDA.v1 (cur_st) = 1
	then la_use2 = mod (la_use2, -lbound (lex_stack, 1)) + 1;
	else la_use2 = la_get2;
	if la_use2 = la_next
	then do;
		if debug_sw
		then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i READ^/", depth, next_state);
		rep = 0;
		do s = test_symbol, next_symbol while (next_symbol ^= alt_symbol);
		     rep = rep + 1;
		     do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (combinations < 2);
			if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= s)) | (DPDA.v1 (i) = s)
			then do;
				if debug_sw
				then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx(^i)^i^/", depth, rep, s);
				if (combinations = 0)
				then do;
					combinations = 1;
					transit = alt_symbol;
					if (rep = 1)
					then RBNf = "10"b;
					else RBNf = "01"b;
				     end;
				else combinations = 2;
			     end;
		     end;
		end;
		if (next_symbol = alt_symbol)
		then do;
			if (combinations = 0)
			then do;
				CNf = "1"b;
				do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st);
				     if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= test_symbol))
					| DPDA.v1 (i) = test_symbol
				     then RBNf = "10"b;
				end;
				transit = alt_symbol;
				combinations = 1;
			     end;
			else combinations = 2;
		     end;
done:
		depth = depth - 5;
		do i = 1 to ps_top;
		     parse_stack (i) = parse_stack2 (i);
		end;
		return;
	     end;
	else do;
		if la_use2 = la_use			/* la_use points to the bad input symbol. */
		then s = alt_symbol;		/* We are considering an alternate symbol. */
		else s = lex_stack (-la_use2).symbol;
		marked = 0;
		do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (abs (DPDA.v1 (i)) <= s);
		     if abs (DPDA.v1 (i)) = s
		     then go to found;
		     else if DPDA.v1 (i) < 0
		     then marked = i;
		end;
		if marked ^= 0
		then i = marked;
		else go to done;
found:
		next_state = DPDA.v2 (i);
		if next_state >= 0
		then la_get2 = mod (la_get2, -lbound (lex_stack, 1)) + 1;
		go to NEXT;
	     end;
CASE (4):						/* Apply state. */
CASE (5):						/* Apply single */
CASE (6):						/* Apply Shared */
	if debug_sw
	then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i APLY^/", depth, next_state);
	if DPDA.v1 (cur_st + 1) = -1
	then do;
		if (top >= hbound (parse_stack, 1))
		then do;
			call too_many (hbound (parse_stack, 1), "parse");
			p_code = PARSE_TOO_MANY;
			return;
		     end;
		parse_stack (top + 1) = cur_st;
	     end;
	top = top - DPDA.v1 (cur_st + 1);
	if (DPDA.v1 (cur_st) = 6)
	then cur_st = DPDA.v2 (cur_st + 3);
	if top > 0
	then do i = cur_st + 4 to cur_st + DPDA.v2 (cur_st);
		if (DPDA.v1 (i) = parse_stack (top))
		then do;
			next_state = DPDA.v2 (i);
			goto NEXT;
		     end;
	     end;
	else return;
	next_state = DPDA.v2 (cur_st + 3);
	goto NEXT;




	dcl     top		 fixed bin (24);	/* top of parse stack for this invocation */
	dcl     next_state		 fixed bin (24);	/* branch to follow */
	dcl     cur_st		 fixed bin (24);	/* current state for this recursion */
	dcl     rep		 fixed bin (24);
	dcl     s			 fixed bin (24);
	dcl     look_ahead		 bit (1);
	dcl     i			 fixed bin (24);
	dcl     la_get2		 fixed bin (24);
	dcl     la_use2		 fixed bin (24);
	dcl     marked		 fixed bin (24);
     end;						/* End of next_term. */
     end;						/* End of  local_recovered. */

     end;						/* End of read_look. */

too_many:
     proc (x, t);
	p6 = x;
	call ioa_$rs ("^a", message, message_length, "Exceeded " || p6 || " entries of lrk " || t || " stack.");
	call report_mdp_error (4, INTERNAL_STACK_OVERFLOW, (message));
	return;

/* *	variables for too_many:	*/
	dcl     p6		 pic "zzzzz9";
	dcl     t			 char (*) parm;
	dcl     x			 fixed bin (24) parm;
     end;						/* End of too_many. */

finish_mdp:
     proc;
	if lex_stack_ptr ^= null
	then free lex_stack in (work_area);
	if mrds_dsm_scanner_info_ptr ^= null
	then free mrds_dsm_scanner_info in (work_area);
	if mrds_dsm_semantics_info_ptr ^= null
	then free mrds_dsm_semantics_info in (work_area);
     end;						/* End of finish_mdp. */

report_mdp_error: proc (p_severity, p_internal_error_code, p_message);

	dcl     p_severity		 fixed bin (35);
	dcl     p_internal_error_code	 fixed bin (35);
	dcl     p_message		 char (*);

	mrds_dsm_parse_info.highest_severity = max (p_severity, mrds_dsm_parse_info.highest_severity);

	call ioa_$ioa_switch (mrds_dsm_parse_info.error_iocb_ptr, "Severity ^d, ^a^/^a", p_severity,
	     MRDS_DSM_ERROR_MESSAGE (p_internal_error_code), p_message);

	if mrds_dsm_parse_info.listing_iocb_ptr ^= null ()
	then call ioa_$ioa_switch (mrds_dsm_parse_info.listing_iocb_ptr, "Severity ^d, ^a^/^a", p_severity,
		MRDS_DSM_ERROR_MESSAGE (p_internal_error_code), p_message);

     end;						/* End of report_mdp_error. */

finish: proc;

	if p_struct_ptr ^= null
	then free p_struct;
	if lex_stack_ptr ^= null
	then free lex_stack;
	if mrds_dsm_semantics_info_ptr ^= null
	then free mrds_dsm_semantics_info;
	if mrds_dsm_scanner_info_ptr ^= null
	then free mrds_dsm_scanner_info;
     end;						/* End of finish. */

%include mrds_dsm_parse_stack;
%page;
%include mrds_dsm_parse_info;
%page;
%include mrds_dsm_sem_info;
%page;
%include mrds_dsm_scan_info;
%page;
%include mrds_dsm_error_info;
%page;
%include mrds_dsm_parse_table;
%page;
%include mrds_dsm_skip_table;
%page;
%include mrds_dsm_terminals;

     end;						/* End of mrds_dsm_parse. */




		    mrds_dsm_parse_table.alm        04/18/85  1429.4re  04/18/85  0906.9      240732



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

	equ	STRD,0
	equ	LOOK,1
	equ	STRDS,2
	equ	LOOKS,3
	equ	APLY,4
	equ	APLY1,5
	equ	APLYS,6
	equ	SKIP,7
	equ	ADJUST,8
	equ	NSRD,9
	equ	NSRDS,10
	equ	T0,0
	equ	ST0,0
"
"
" DPDA table
DPDA:	zero	0,DPDAs
	segdef	DPDA
"
" STATE 1
	equ	ST1,*-DPDA
	zero	STRD,LN1
	zero	8,ST70	"relation
	zero	9,ST77	"attribute
	zero	11,ST85	"rel_acc
	zero	12,ST92	"attr_acc
	zero	13,ST100	"default
	equ	LN1,*-DPDA-ST1-1
"
" STATE 7
	equ	ST7,*-DPDA
	zero	STRD,LN7
	zero	3,ST106	":
	equ	LN7,*-DPDA-ST7-1
"
" STATE 9
	equ	ST9,*-DPDA
	zero	STRD,LN9
	zero	8,ST70	"relation
	zero	9,ST77	"attribute
	zero	11,ST85	"rel_acc
	zero	12,ST92	"attr_acc
	equ	LN9,*-DPDA-ST9-1
"
" STATE 14
	equ	ST14,*-DPDA
	zero	APLY,LN14
	zero	0,0   pd ld
	zero	22,2   rule/alt
	zero	22,ST32 prod/val
	zero	ST782,ST789
	equ	LN14,*-DPDA-ST14-1
"
" STATE 19
	equ	ST19,*-DPDA
	zero	APLY1,LN19
	zero	0,0   pd ld
	zero	21,2   rule/alt
	zero	21,ST34 prod/val
	equ	LN19,*-DPDA-ST19-1
"
" STATE 23
	equ	ST23,*-DPDA
	zero	STRD,LN23
	zero	10,ST148	"access
	equ	LN23,*-DPDA-ST23-1
"
" STATE 25
	equ	ST25,*-DPDA
	zero	NSRD,LN25
	zero	3,-ST802	":
	zero	10,-ST800	"access
	equ	LN25,*-DPDA-ST25-1
"
" STATE 28
	equ	ST28,*-DPDA
	zero	STRD,LN28
	zero	3,ST160	":
	equ	LN28,*-DPDA-ST28-1
"
" STATE 30
	equ	ST30,*-DPDA
	zero	STRD,LN30
	zero	3,ST170	":
	equ	LN30,*-DPDA-ST30-1
"
" STATE 32
	equ	ST32,*-DPDA
	zero	STRD,LN32
	zero	3,ST180	":
	equ	LN32,*-DPDA-ST32-1
"
" STATE 34
	equ	ST34,*-DPDA
	zero	STRD,LN34
	zero	3,ST181	":
	equ	LN34,*-DPDA-ST34-1
"
" STATE 36
	equ	ST36,*-DPDA
	zero	APLY,LN36
	zero	0,0   pd ld
	zero	3,4   rule/alt
	zero	3,ST57 prod/val
	zero	ST806,ST182
	equ	LN36,*-DPDA-ST36-1
"
" STATE 41
	equ	ST41,*-DPDA
	zero	APLYS,LN41
	zero	0,0   pd ld
	zero	3,5   rule/alt
	zero	3,ST36 prod/val
	equ	LN41,*-DPDA-ST41-1
"
" STATE 45
	equ	ST45,*-DPDA
	zero	APLYS,LN45
	zero	0,0   pd ld
	zero	3,3   rule/alt
	zero	3,ST36 prod/val
	equ	LN45,*-DPDA-ST45-1
"
" STATE 49
	equ	ST49,*-DPDA
	zero	APLYS,LN49
	zero	0,0   pd ld
	zero	3,2   rule/alt
	zero	3,ST36 prod/val
	equ	LN49,*-DPDA-ST49-1
"
" STATE 53
	equ	ST53,*-DPDA
	zero	APLYS,LN53
	zero	0,0   pd ld
	zero	3,1   rule/alt
	zero	3,ST36 prod/val
	equ	LN53,*-DPDA-ST53-1
"
" STATE 57
	equ	ST57,*-DPDA
	zero	APLY1,LN57
	zero	0,0   pd ld
	zero	2,2   rule/alt
	zero	2,ST61 prod/val
	equ	LN57,*-DPDA-ST57-1
"
" STATE 61
	equ	ST61,*-DPDA
	zero	NSRD,LN61
	zero	0,-ST807	"EOI
	zero	8,-ST806	"relation
	zero	9,-ST806	"attribute
	zero	11,-ST806	"rel_acc
	zero	12,-ST806	"attr_acc
	zero	13,-ST806	"default
	equ	LN61,*-DPDA-ST61-1
"
" STATE 68
	equ	ST68,*-DPDA
	zero	STRD,LN68
	zero	0,ST0	"EOI
	equ	LN68,*-DPDA-ST68-1
"
" STATE 70
	equ	ST70,*-DPDA
	zero	APLY,LN70
	zero	0,0   pd ld
	zero	31,1   rule/alt
	zero	31,ST284 prod/val
	zero	ST1,ST25
	zero	ST9,ST142
	zero	ST806,ST25
	equ	LN70,*-DPDA-ST70-1
"
" STATE 77
	equ	ST77,*-DPDA
	zero	APLY,LN77
	zero	0,0   pd ld
	zero	32,1   rule/alt
	zero	32,ST280 prod/val
	zero	ST1,ST23
	zero	ST9,ST140
	zero	ST782,ST23
	zero	ST806,ST23
	equ	LN77,*-DPDA-ST77-1
"
" STATE 85
	equ	ST85,*-DPDA
	zero	APLY,LN85
	zero	0,0   pd ld
	zero	34,1   rule/alt
	zero	34,ST272 prod/val
	zero	ST1,ST19
	zero	ST9,ST136
	zero	ST806,ST19
	equ	LN85,*-DPDA-ST85-1
"
" STATE 92
	equ	ST92,*-DPDA
	zero	APLY,LN92
	zero	0,0   pd ld
	zero	35,1   rule/alt
	zero	35,ST268 prod/val
	zero	ST1,ST14
	zero	ST9,ST132
	zero	ST782,ST14
	zero	ST806,ST14
	equ	LN92,*-DPDA-ST92-1
"
" STATE 100
	equ	ST100,*-DPDA
	zero	APLY,LN100
	zero	0,0   pd ld
	zero	36,1   rule/alt
	zero	36,ST264 prod/val
	zero	ST1,ST9
	zero	ST806,ST9
	equ	LN100,*-DPDA-ST100-1
"
" STATE 106
	equ	ST106,*-DPDA
	zero	STRD,LN106
	zero	1,ST326	"<identifier>
	zero	8,ST70	"relation
	zero	9,ST77	"attribute
	zero	10,ST148	"access
	zero	11,ST85	"rel_acc
	zero	12,ST92	"attr_acc
	zero	13,ST100	"default
	zero	14,ST330	"in
	zero	15,ST335	"with
	zero	16,ST340	"delete
	zero	17,ST348	"append
	zero	18,ST356	"tuple
	zero	19,ST362	"attr
	zero	20,ST368	"d
	zero	21,ST376	"a
	zero	22,ST384	"delete_tuple
	zero	23,ST392	"append_tuple
	zero	24,ST400	"read
	zero	25,ST410	"read_attr
	zero	26,ST420	"modify
	zero	27,ST430	"modify_attr
	zero	28,ST440	"null
	zero	29,ST454	"n
	zero	30,ST468	"r
	zero	31,ST478	"m
	equ	LN106,*-DPDA-ST106-1
"
" STATE 132
	equ	ST132,*-DPDA
	zero	APLY1,LN132
	zero	1,1   pd ld
	zero	23,2   rule/alt
	zero	23,ST30 prod/val
	equ	LN132,*-DPDA-ST132-1
"
" STATE 136
	equ	ST136,*-DPDA
	zero	APLY1,LN136
	zero	1,1   pd ld
	zero	24,2   rule/alt
	zero	24,ST28 prod/val
	equ	LN136,*-DPDA-ST136-1
"
" STATE 140
	equ	ST140,*-DPDA
	zero	STRD,LN140
	zero	10,ST148	"access
	equ	LN140,*-DPDA-ST140-1
"
" STATE 142
	equ	ST142,*-DPDA
	zero	STRD,LN142
	zero	10,ST148	"access
	equ	LN142,*-DPDA-ST142-1
"
" STATE 144
	equ	ST144,*-DPDA
	zero	APLYS,LN144
	zero	1,1   pd ld
	zero	22,1   rule/alt
	zero	22,ST14 prod/val
	equ	LN144,*-DPDA-ST144-1
"
" STATE 148
	equ	ST148,*-DPDA
	zero	APLY,LN148
	zero	0,0   pd ld
	zero	33,1   rule/alt
	zero	33,ST276 prod/val
	zero	ST23,ST144
	zero	ST140,ST488
	zero	ST142,ST492
	zero	ST800,ST156
	equ	LN148,*-DPDA-ST148-1
"
" STATE 156
	equ	ST156,*-DPDA
	zero	APLY1,LN156
	zero	1,1   pd ld
	zero	21,1   rule/alt
	zero	21,ST34 prod/val
	equ	LN156,*-DPDA-ST156-1
"
" STATE 160
	equ	ST160,*-DPDA
	zero	STRD,LN160
	zero	5,ST550	"(
	zero	16,ST340	"delete
	zero	17,ST348	"append
	zero	20,ST368	"d
	zero	21,ST376	"a
	zero	22,ST384	"delete_tuple
	zero	23,ST392	"append_tuple
	zero	28,ST440	"null
	zero	29,ST454	"n
	equ	LN160,*-DPDA-ST160-1
"
" STATE 170
	equ	ST170,*-DPDA
	zero	STRD,LN170
	zero	5,ST603	"(
	zero	24,ST400	"read
	zero	25,ST410	"read_attr
	zero	26,ST420	"modify
	zero	27,ST430	"modify_attr
	zero	28,ST440	"null
	zero	29,ST454	"n
	zero	30,ST468	"r
	zero	31,ST478	"m
	equ	LN170,*-DPDA-ST170-1
"
" STATE 180
	equ	ST180,*-DPDA
	zero	STRDS,ST106

"
" STATE 181
	equ	ST181,*-DPDA
	zero	STRDS,ST106

"
" STATE 182
	equ	ST182,*-DPDA
	zero	APLY1,LN182
	zero	1,1   pd ld
	zero	2,1   rule/alt
	zero	2,ST61 prod/val
	equ	LN182,*-DPDA-ST182-1
"
" STATE 186
	equ	ST186,*-DPDA
	zero	APLY,LN186
	zero	0,0   pd ld
	zero	30,23   rule/alt
	zero	30,ST288 prod/val
	zero	ST180,ST612
	zero	ST181,ST622
	zero	ST631,ST683
	zero	ST670,ST736
	zero	ST676,ST612
	zero	ST682,ST622
	equ	LN186,*-DPDA-ST186-1
"
" STATE 196
	equ	ST196,*-DPDA
	zero	APLYS,LN196
	zero	0,0   pd ld
	zero	30,20   rule/alt
	zero	30,ST186 prod/val
	equ	LN196,*-DPDA-ST196-1
"
" STATE 200
	equ	ST200,*-DPDA
	zero	APLYS,LN200
	zero	0,0   pd ld
	zero	30,25   rule/alt
	zero	30,ST186 prod/val
	equ	LN200,*-DPDA-ST200-1
"
" STATE 204
	equ	ST204,*-DPDA
	zero	APLYS,LN204
	zero	0,0   pd ld
	zero	30,24   rule/alt
	zero	30,ST186 prod/val
	equ	LN204,*-DPDA-ST204-1
"
" STATE 208
	equ	ST208,*-DPDA
	zero	APLYS,LN208
	zero	0,0   pd ld
	zero	30,22   rule/alt
	zero	30,ST186 prod/val
	equ	LN208,*-DPDA-ST208-1
"
" STATE 212
	equ	ST212,*-DPDA
	zero	APLYS,LN212
	zero	0,0   pd ld
	zero	30,21   rule/alt
	zero	30,ST186 prod/val
	equ	LN212,*-DPDA-ST212-1
"
" STATE 216
	equ	ST216,*-DPDA
	zero	APLYS,LN216
	zero	0,0   pd ld
	zero	30,19   rule/alt
	zero	30,ST186 prod/val
	equ	LN216,*-DPDA-ST216-1
"
" STATE 220
	equ	ST220,*-DPDA
	zero	APLYS,LN220
	zero	0,0   pd ld
	zero	30,18   rule/alt
	zero	30,ST186 prod/val
	equ	LN220,*-DPDA-ST220-1
"
" STATE 224
	equ	ST224,*-DPDA
	zero	APLYS,LN224
	zero	0,0   pd ld
	zero	30,17   rule/alt
	zero	30,ST186 prod/val
	equ	LN224,*-DPDA-ST224-1
"
" STATE 228
	equ	ST228,*-DPDA
	zero	APLYS,LN228
	zero	0,0   pd ld
	zero	30,16   rule/alt
	zero	30,ST186 prod/val
	equ	LN228,*-DPDA-ST228-1
"
" STATE 232
	equ	ST232,*-DPDA
	zero	APLYS,LN232
	zero	0,0   pd ld
	zero	30,15   rule/alt
	zero	30,ST186 prod/val
	equ	LN232,*-DPDA-ST232-1
"
" STATE 236
	equ	ST236,*-DPDA
	zero	APLYS,LN236
	zero	0,0   pd ld
	zero	30,14   rule/alt
	zero	30,ST186 prod/val
	equ	LN236,*-DPDA-ST236-1
"
" STATE 240
	equ	ST240,*-DPDA
	zero	APLYS,LN240
	zero	0,0   pd ld
	zero	30,13   rule/alt
	zero	30,ST186 prod/val
	equ	LN240,*-DPDA-ST240-1
"
" STATE 244
	equ	ST244,*-DPDA
	zero	APLYS,LN244
	zero	0,0   pd ld
	zero	30,12   rule/alt
	zero	30,ST186 prod/val
	equ	LN244,*-DPDA-ST244-1
"
" STATE 248
	equ	ST248,*-DPDA
	zero	APLYS,LN248
	zero	0,0   pd ld
	zero	30,11   rule/alt
	zero	30,ST186 prod/val
	equ	LN248,*-DPDA-ST248-1
"
" STATE 252
	equ	ST252,*-DPDA
	zero	APLYS,LN252
	zero	0,0   pd ld
	zero	30,10   rule/alt
	zero	30,ST186 prod/val
	equ	LN252,*-DPDA-ST252-1
"
" STATE 256
	equ	ST256,*-DPDA
	zero	APLYS,LN256
	zero	0,0   pd ld
	zero	30,9   rule/alt
	zero	30,ST186 prod/val
	equ	LN256,*-DPDA-ST256-1
"
" STATE 260
	equ	ST260,*-DPDA
	zero	APLYS,LN260
	zero	0,0   pd ld
	zero	30,8   rule/alt
	zero	30,ST186 prod/val
	equ	LN260,*-DPDA-ST260-1
"
" STATE 264
	equ	ST264,*-DPDA
	zero	APLYS,LN264
	zero	0,0   pd ld
	zero	30,7   rule/alt
	zero	30,ST186 prod/val
	equ	LN264,*-DPDA-ST264-1
"
" STATE 268
	equ	ST268,*-DPDA
	zero	APLYS,LN268
	zero	0,0   pd ld
	zero	30,5   rule/alt
	zero	30,ST186 prod/val
	equ	LN268,*-DPDA-ST268-1
"
" STATE 272
	equ	ST272,*-DPDA
	zero	APLYS,LN272
	zero	0,0   pd ld
	zero	30,6   rule/alt
	zero	30,ST186 prod/val
	equ	LN272,*-DPDA-ST272-1
"
" STATE 276
	equ	ST276,*-DPDA
	zero	APLYS,LN276
	zero	0,0   pd ld
	zero	30,4   rule/alt
	zero	30,ST186 prod/val
	equ	LN276,*-DPDA-ST276-1
"
" STATE 280
	equ	ST280,*-DPDA
	zero	APLYS,LN280
	zero	0,0   pd ld
	zero	30,3   rule/alt
	zero	30,ST186 prod/val
	equ	LN280,*-DPDA-ST280-1
"
" STATE 284
	equ	ST284,*-DPDA
	zero	APLYS,LN284
	zero	0,0   pd ld
	zero	30,2   rule/alt
	zero	30,ST186 prod/val
	equ	LN284,*-DPDA-ST284-1
"
" STATE 288
	equ	ST288,*-DPDA
	zero	NSRD,LN288
	zero	1,-ST813	"<identifier>
	zero	5,-ST813	"(
	zero	6,-ST813	")
	zero	7,-ST811	"=
	zero	8,-ST813	"relation
	zero	9,-ST813	"attribute
	zero	10,-ST813	"access
	zero	11,-ST813	"rel_acc
	zero	12,-ST813	"attr_acc
	zero	13,-ST813	"default
	zero	14,-ST813	"in
	zero	15,-ST813	"with
	zero	16,-ST813	"delete
	zero	17,-ST813	"append
	zero	18,-ST813	"tuple
	zero	19,-ST813	"attr
	zero	20,-ST813	"d
	zero	21,-ST813	"a
	zero	22,-ST813	"delete_tuple
	zero	23,-ST813	"append_tuple
	zero	24,-ST813	"read
	zero	25,-ST813	"read_attr
	zero	26,-ST813	"modify
	zero	27,-ST813	"modify_attr
	zero	28,-ST813	"null
	zero	29,-ST813	"n
	zero	30,-ST813	"r
	zero	31,-ST813	"m
	equ	LN288,*-DPDA-ST288-1
"
" STATE 317
	equ	ST317,*-DPDA
	zero	STRD,LN317
	zero	5,ST632	"(
	equ	LN317,*-DPDA-ST317-1
"
" STATE 319
	equ	ST319,*-DPDA
	zero	APLY1,LN319
	zero	0,0   pd ld
	zero	5,2   rule/alt
	zero	5,ST323 prod/val
	equ	LN319,*-DPDA-ST319-1
"
" STATE 323
	equ	ST323,*-DPDA
	zero	STRD,LN323
	zero	2,ST633	".
	zero	4,ST637	",
	equ	LN323,*-DPDA-ST323-1
"
" STATE 326
	equ	ST326,*-DPDA
	zero	APLYS,LN326
	zero	0,0   pd ld
	zero	30,1   rule/alt
	zero	30,ST186 prod/val
	equ	LN326,*-DPDA-ST326-1
"
" STATE 330
	equ	ST330,*-DPDA
	zero	APLY,LN330
	zero	0,0   pd ld
	zero	38,1   rule/alt
	zero	38,ST260 prod/val
	zero	ST612,ST670
	equ	LN330,*-DPDA-ST330-1
"
" STATE 335
	equ	ST335,*-DPDA
	zero	APLY,LN335
	zero	0,0   pd ld
	zero	39,1   rule/alt
	zero	39,ST256 prod/val
	zero	ST817,ST782
	equ	LN335,*-DPDA-ST335-1
"
" STATE 340
	equ	ST340,*-DPDA
	zero	APLY,LN340
	zero	0,0   pd ld
	zero	40,1   rule/alt
	zero	40,ST252 prod/val
	zero	ST160,ST526
	zero	ST550,ST526
	zero	ST650,ST526
	zero	ST677,ST526
	equ	LN340,*-DPDA-ST340-1
"
" STATE 348
	equ	ST348,*-DPDA
	zero	APLY,LN348
	zero	0,0   pd ld
	zero	41,1   rule/alt
	zero	41,ST248 prod/val
	zero	ST160,ST524
	zero	ST550,ST524
	zero	ST650,ST524
	zero	ST677,ST524
	equ	LN348,*-DPDA-ST348-1
"
" STATE 356
	equ	ST356,*-DPDA
	zero	APLY,LN356
	zero	0,0   pd ld
	zero	42,1   rule/alt
	zero	42,ST244 prod/val
	zero	ST524,ST638
	zero	ST526,ST642
	equ	LN356,*-DPDA-ST356-1
"
" STATE 362
	equ	ST362,*-DPDA
	zero	APLY,LN362
	zero	0,0   pd ld
	zero	43,1   rule/alt
	zero	43,ST240 prod/val
	zero	ST571,ST654
	zero	ST577,ST658
	equ	LN362,*-DPDA-ST362-1
"
" STATE 368
	equ	ST368,*-DPDA
	zero	APLY,LN368
	zero	0,0   pd ld
	zero	44,1   rule/alt
	zero	44,ST236 prod/val
	zero	ST160,ST520
	zero	ST550,ST520
	zero	ST650,ST520
	zero	ST677,ST520
	equ	LN368,*-DPDA-ST368-1
"
" STATE 376
	equ	ST376,*-DPDA
	zero	APLY,LN376
	zero	0,0   pd ld
	zero	45,1   rule/alt
	zero	45,ST232 prod/val
	zero	ST160,ST516
	zero	ST550,ST516
	zero	ST650,ST516
	zero	ST677,ST516
	equ	LN376,*-DPDA-ST376-1
"
" STATE 384
	equ	ST384,*-DPDA
	zero	APLY,LN384
	zero	0,0   pd ld
	zero	46,1   rule/alt
	zero	46,ST228 prod/val
	zero	ST160,ST512
	zero	ST550,ST512
	zero	ST650,ST512
	zero	ST677,ST512
	equ	LN384,*-DPDA-ST384-1
"
" STATE 392
	equ	ST392,*-DPDA
	zero	APLY,LN392
	zero	0,0   pd ld
	zero	47,1   rule/alt
	zero	47,ST224 prod/val
	zero	ST160,ST508
	zero	ST550,ST508
	zero	ST650,ST508
	zero	ST677,ST508
	equ	LN392,*-DPDA-ST392-1
"
" STATE 400
	equ	ST400,*-DPDA
	zero	APLY,LN400
	zero	0,0   pd ld
	zero	48,1   rule/alt
	zero	48,ST220 prod/val
	zero	ST170,ST577
	zero	ST603,ST577
	zero	ST666,ST577
	zero	ST671,ST577
	zero	ST769,ST577
	zero	ST791,ST577
	equ	LN400,*-DPDA-ST400-1
"
" STATE 410
	equ	ST410,*-DPDA
	zero	APLY,LN410
	zero	0,0   pd ld
	zero	49,1   rule/alt
	zero	49,ST216 prod/val
	zero	ST170,ST573
	zero	ST603,ST573
	zero	ST666,ST573
	zero	ST671,ST573
	zero	ST769,ST573
	zero	ST791,ST573
	equ	LN410,*-DPDA-ST410-1
"
" STATE 420
	equ	ST420,*-DPDA
	zero	APLY,LN420
	zero	0,0   pd ld
	zero	50,1   rule/alt
	zero	50,ST212 prod/val
	zero	ST170,ST571
	zero	ST603,ST571
	zero	ST666,ST571
	zero	ST671,ST571
	zero	ST769,ST571
	zero	ST791,ST571
	equ	LN420,*-DPDA-ST420-1
"
" STATE 430
	equ	ST430,*-DPDA
	zero	APLY,LN430
	zero	0,0   pd ld
	zero	51,1   rule/alt
	zero	51,ST208 prod/val
	zero	ST170,ST567
	zero	ST603,ST567
	zero	ST666,ST567
	zero	ST671,ST567
	zero	ST769,ST567
	zero	ST791,ST567
	equ	LN430,*-DPDA-ST430-1
"
" STATE 440
	equ	ST440,*-DPDA
	zero	APLY,LN440
	zero	0,0   pd ld
	zero	52,1   rule/alt
	zero	52,ST204 prod/val
	zero	ST160,ST504
	zero	ST170,ST504
	zero	ST550,ST504
	zero	ST603,ST504
	zero	ST650,ST504
	zero	ST666,ST504
	zero	ST671,ST504
	zero	ST677,ST504
	zero	ST769,ST504
	zero	ST791,ST504
	equ	LN440,*-DPDA-ST440-1
"
" STATE 454
	equ	ST454,*-DPDA
	zero	APLY,LN454
	zero	0,0   pd ld
	zero	53,1   rule/alt
	zero	53,ST200 prod/val
	zero	ST160,ST496
	zero	ST170,ST496
	zero	ST550,ST496
	zero	ST603,ST496
	zero	ST650,ST496
	zero	ST666,ST496
	zero	ST671,ST496
	zero	ST677,ST496
	zero	ST769,ST496
	zero	ST791,ST496
	equ	LN454,*-DPDA-ST454-1
"
" STATE 468
	equ	ST468,*-DPDA
	zero	APLY,LN468
	zero	0,0   pd ld
	zero	54,1   rule/alt
	zero	54,ST196 prod/val
	zero	ST170,ST563
	zero	ST603,ST563
	zero	ST666,ST563
	zero	ST671,ST563
	zero	ST769,ST563
	zero	ST791,ST563
	equ	LN468,*-DPDA-ST468-1
"
" STATE 478
	equ	ST478,*-DPDA
	zero	APLY,LN478
	zero	0,0   pd ld
	zero	55,1   rule/alt
	zero	55,ST186 prod/val
	zero	ST170,ST559
	zero	ST603,ST559
	zero	ST666,ST559
	zero	ST671,ST559
	zero	ST769,ST559
	zero	ST791,ST559
	equ	LN478,*-DPDA-ST478-1
"
" STATE 488
	equ	ST488,*-DPDA
	zero	APLY1,LN488
	zero	2,2   pd ld
	zero	23,1   rule/alt
	zero	23,ST30 prod/val
	equ	LN488,*-DPDA-ST488-1
"
" STATE 492
	equ	ST492,*-DPDA
	zero	APLY1,LN492
	zero	2,2   pd ld
	zero	24,1   rule/alt
	zero	24,ST28 prod/val
	equ	LN492,*-DPDA-ST492-1
"
" STATE 496
	equ	ST496,*-DPDA
	zero	APLY,LN496
	zero	0,0   pd ld
	zero	29,2   rule/alt
	zero	29,ST579 prod/val
	zero	ST160,ST528
	zero	ST550,ST528
	zero	ST650,ST528
	zero	ST677,ST528
	equ	LN496,*-DPDA-ST496-1
"
" STATE 504
	equ	ST504,*-DPDA
	zero	APLYS,LN504
	zero	0,0   pd ld
	zero	29,1   rule/alt
	zero	29,ST496 prod/val
	equ	LN504,*-DPDA-ST504-1
"
" STATE 508
	equ	ST508,*-DPDA
	zero	APLY1,LN508
	zero	0,0   pd ld
	zero	26,3   rule/alt
	zero	26,ST533 prod/val
	equ	LN508,*-DPDA-ST508-1
"
" STATE 512
	equ	ST512,*-DPDA
	zero	APLY1,LN512
	zero	0,0   pd ld
	zero	25,3   rule/alt
	zero	25,ST537 prod/val
	equ	LN512,*-DPDA-ST512-1
"
" STATE 516
	equ	ST516,*-DPDA
	zero	APLY1,LN516
	zero	0,0   pd ld
	zero	26,2   rule/alt
	zero	26,ST533 prod/val
	equ	LN516,*-DPDA-ST516-1
"
" STATE 520
	equ	ST520,*-DPDA
	zero	APLY1,LN520
	zero	0,0   pd ld
	zero	25,2   rule/alt
	zero	25,ST537 prod/val
	equ	LN520,*-DPDA-ST520-1
"
" STATE 524
	equ	ST524,*-DPDA
	zero	STRD,LN524
	zero	18,ST356	"tuple
	equ	LN524,*-DPDA-ST524-1
"
" STATE 526
	equ	ST526,*-DPDA
	zero	STRD,LN526
	zero	18,ST356	"tuple
	equ	LN526,*-DPDA-ST526-1
"
" STATE 528
	equ	ST528,*-DPDA
	zero	APLY,LN528
	zero	0,0   pd ld
	zero	13,2   rule/alt
	zero	13,ST541 prod/val
	zero	ST650,ST724
	equ	LN528,*-DPDA-ST528-1
"
" STATE 533
	equ	ST533,*-DPDA
	zero	APLYS,LN533
	zero	0,0   pd ld
	zero	13,3   rule/alt
	zero	13,ST528 prod/val
	equ	LN533,*-DPDA-ST533-1
"
" STATE 537
	equ	ST537,*-DPDA
	zero	APLYS,LN537
	zero	0,0   pd ld
	zero	13,1   rule/alt
	zero	13,ST528 prod/val
	equ	LN537,*-DPDA-ST537-1
"
" STATE 541
	equ	ST541,*-DPDA
	zero	APLY,LN541
	zero	0,0   pd ld
	zero	12,2   rule/alt
	zero	12,ST547 prod/val
	zero	ST550,ST651
	zero	ST677,ST745
	equ	LN541,*-DPDA-ST541-1
"
" STATE 547
	equ	ST547,*-DPDA
	zero	STRD,LN547
	zero	2,ST646	".
	zero	4,ST650	",
	equ	LN547,*-DPDA-ST547-1
"
" STATE 550
	equ	ST550,*-DPDA
	zero	STRD,LN550
	zero	16,ST340	"delete
	zero	17,ST348	"append
	zero	20,ST368	"d
	zero	21,ST376	"a
	zero	22,ST384	"delete_tuple
	zero	23,ST392	"append_tuple
	zero	28,ST440	"null
	zero	29,ST454	"n
	equ	LN550,*-DPDA-ST550-1
"
" STATE 559
	equ	ST559,*-DPDA
	zero	APLY1,LN559
	zero	0,0   pd ld
	zero	28,3   rule/alt
	zero	28,ST584 prod/val
	equ	LN559,*-DPDA-ST559-1
"
" STATE 563
	equ	ST563,*-DPDA
	zero	APLY1,LN563
	zero	0,0   pd ld
	zero	27,3   rule/alt
	zero	27,ST588 prod/val
	equ	LN563,*-DPDA-ST563-1
"
" STATE 567
	equ	ST567,*-DPDA
	zero	APLY1,LN567
	zero	0,0   pd ld
	zero	28,2   rule/alt
	zero	28,ST584 prod/val
	equ	LN567,*-DPDA-ST567-1
"
" STATE 571
	equ	ST571,*-DPDA
	zero	STRD,LN571
	zero	19,ST362	"attr
	equ	LN571,*-DPDA-ST571-1
"
" STATE 573
	equ	ST573,*-DPDA
	zero	APLY1,LN573
	zero	0,0   pd ld
	zero	27,2   rule/alt
	zero	27,ST588 prod/val
	equ	LN573,*-DPDA-ST573-1
"
" STATE 577
	equ	ST577,*-DPDA
	zero	STRD,LN577
	zero	19,ST362	"attr
	equ	LN577,*-DPDA-ST577-1
"
" STATE 579
	equ	ST579,*-DPDA
	zero	APLY,LN579
	zero	0,0   pd ld
	zero	18,2   rule/alt
	zero	18,ST592 prod/val
	zero	ST666,ST730
	equ	LN579,*-DPDA-ST579-1
"
" STATE 584
	equ	ST584,*-DPDA
	zero	APLYS,LN584
	zero	0,0   pd ld
	zero	18,3   rule/alt
	zero	18,ST579 prod/val
	equ	LN584,*-DPDA-ST584-1
"
" STATE 588
	equ	ST588,*-DPDA
	zero	APLYS,LN588
	zero	0,0   pd ld
	zero	18,1   rule/alt
	zero	18,ST579 prod/val
	equ	LN588,*-DPDA-ST588-1
"
" STATE 592
	equ	ST592,*-DPDA
	zero	APLY,LN592
	zero	0,0   pd ld
	zero	17,2   rule/alt
	zero	17,ST600 prod/val
	zero	ST603,ST667
	zero	ST671,ST738
	zero	ST769,ST779
	zero	ST791,ST792
	equ	LN592,*-DPDA-ST592-1
"
" STATE 600
	equ	ST600,*-DPDA
	zero	STRD,LN600
	zero	2,ST662	".
	zero	4,ST666	",
	equ	LN600,*-DPDA-ST600-1
"
" STATE 603
	equ	ST603,*-DPDA
	zero	STRD,LN603
	zero	24,ST400	"read
	zero	25,ST410	"read_attr
	zero	26,ST420	"modify
	zero	27,ST430	"modify_attr
	zero	28,ST440	"null
	zero	29,ST454	"n
	zero	30,ST468	"r
	zero	31,ST478	"m
	equ	LN603,*-DPDA-ST603-1
"
" STATE 612
	equ	ST612,*-DPDA
	zero	STRD,LN612
	zero	5,ST671	"(
	zero	14,ST330	"in
	equ	LN612,*-DPDA-ST612-1
"
" STATE 615
	equ	ST615,*-DPDA
	zero	APLY1,LN615
	zero	0,0   pd ld
	zero	15,2   rule/alt
	zero	15,ST619 prod/val
	equ	LN615,*-DPDA-ST615-1
"
" STATE 619
	equ	ST619,*-DPDA
	zero	STRD,LN619
	zero	2,ST672	".
	zero	4,ST676	",
	equ	LN619,*-DPDA-ST619-1
"
" STATE 622
	equ	ST622,*-DPDA
	zero	STRD,LN622
	zero	5,ST677	"(
	equ	LN622,*-DPDA-ST622-1
"
" STATE 624
	equ	ST624,*-DPDA
	zero	APLY1,LN624
	zero	0,0   pd ld
	zero	10,2   rule/alt
	zero	10,ST628 prod/val
	equ	LN624,*-DPDA-ST624-1
"
" STATE 628
	equ	ST628,*-DPDA
	zero	STRD,LN628
	zero	2,ST678	".
	zero	4,ST682	",
	equ	LN628,*-DPDA-ST628-1
"
" STATE 631
	equ	ST631,*-DPDA
	zero	STRDS,ST106

"
" STATE 632
	equ	ST632,*-DPDA
	zero	STRDS,ST106

"
" STATE 633
	equ	ST633,*-DPDA
	zero	APLY1,LN633
	zero	3,3   pd ld
	zero	4,1   rule/alt
	zero	4,ST53 prod/val
	equ	LN633,*-DPDA-ST633-1
"
" STATE 637
	equ	ST637,*-DPDA
	zero	STRDS,ST106

"
" STATE 638
	equ	ST638,*-DPDA
	zero	APLY1,LN638
	zero	1,1   pd ld
	zero	26,1   rule/alt
	zero	26,ST533 prod/val
	equ	LN638,*-DPDA-ST638-1
"
" STATE 642
	equ	ST642,*-DPDA
	zero	APLY1,LN642
	zero	1,1   pd ld
	zero	25,1   rule/alt
	zero	25,ST537 prod/val
	equ	LN642,*-DPDA-ST642-1
"
" STATE 646
	equ	ST646,*-DPDA
	zero	APLY1,LN646
	zero	3,3   pd ld
	zero	20,1   rule/alt
	zero	20,ST36 prod/val
	equ	LN646,*-DPDA-ST646-1
"
" STATE 650
	equ	ST650,*-DPDA
	zero	STRDS,ST550

"
" STATE 651
	equ	ST651,*-DPDA
	zero	STRD,LN651
	zero	4,ST650	",
	zero	6,ST728	")
	equ	LN651,*-DPDA-ST651-1
"
" STATE 654
	equ	ST654,*-DPDA
	zero	APLY1,LN654
	zero	1,1   pd ld
	zero	28,1   rule/alt
	zero	28,ST584 prod/val
	equ	LN654,*-DPDA-ST654-1
"
" STATE 658
	equ	ST658,*-DPDA
	zero	APLY1,LN658
	zero	1,1   pd ld
	zero	27,1   rule/alt
	zero	27,ST588 prod/val
	equ	LN658,*-DPDA-ST658-1
"
" STATE 662
	equ	ST662,*-DPDA
	zero	APLY1,LN662
	zero	3,3   pd ld
	zero	19,1   rule/alt
	zero	19,ST41 prod/val
	equ	LN662,*-DPDA-ST662-1
"
" STATE 666
	equ	ST666,*-DPDA
	zero	STRDS,ST603

"
" STATE 667
	equ	ST667,*-DPDA
	zero	STRD,LN667
	zero	4,ST666	",
	zero	6,ST734	")
	equ	LN667,*-DPDA-ST667-1
"
" STATE 670
	equ	ST670,*-DPDA
	zero	STRDS,ST106

"
" STATE 671
	equ	ST671,*-DPDA
	zero	STRDS,ST603

"
" STATE 672
	equ	ST672,*-DPDA
	zero	APLY1,LN672
	zero	3,3   pd ld
	zero	14,1   rule/alt
	zero	14,ST45 prod/val
	equ	LN672,*-DPDA-ST672-1
"
" STATE 676
	equ	ST676,*-DPDA
	zero	STRDS,ST106

"
" STATE 677
	equ	ST677,*-DPDA
	zero	STRDS,ST550

"
" STATE 678
	equ	ST678,*-DPDA
	zero	APLY1,LN678
	zero	3,3   pd ld
	zero	9,1   rule/alt
	zero	9,ST49 prod/val
	equ	LN678,*-DPDA-ST678-1
"
" STATE 682
	equ	ST682,*-DPDA
	zero	STRDS,ST106

"
" STATE 683
	equ	ST683,*-DPDA
	zero	APLY,LN683
	zero	2,2   pd ld
	zero	8,1   rule/alt
	zero	8,ST317 prod/val
	zero	ST632,ST689
	zero	ST693,ST752
	equ	LN683,*-DPDA-ST683-1
"
" STATE 689
	equ	ST689,*-DPDA
	zero	APLY1,LN689
	zero	0,0   pd ld
	zero	7,2   rule/alt
	zero	7,ST693 prod/val
	equ	LN689,*-DPDA-ST689-1
"
" STATE 693
	equ	ST693,*-DPDA
	zero	STRD,LN693
	zero	1,ST326	"<identifier>
	zero	6,ST756	")
	zero	8,ST70	"relation
	zero	9,ST77	"attribute
	zero	10,ST148	"access
	zero	11,ST85	"rel_acc
	zero	12,ST92	"attr_acc
	zero	13,ST100	"default
	zero	14,ST330	"in
	zero	15,ST335	"with
	zero	16,ST340	"delete
	zero	17,ST348	"append
	zero	18,ST356	"tuple
	zero	19,ST362	"attr
	zero	20,ST368	"d
	zero	21,ST376	"a
	zero	22,ST384	"delete_tuple
	zero	23,ST392	"append_tuple
	zero	24,ST400	"read
	zero	25,ST410	"read_attr
	zero	26,ST420	"modify
	zero	27,ST430	"modify_attr
	zero	28,ST440	"null
	zero	29,ST454	"n
	zero	30,ST468	"r
	zero	31,ST478	"m
	equ	LN693,*-DPDA-ST693-1
"
" STATE 720
	equ	ST720,*-DPDA
	zero	APLY1,LN720
	zero	2,2   pd ld
	zero	5,1   rule/alt
	zero	5,ST323 prod/val
	equ	LN720,*-DPDA-ST720-1
"
" STATE 724
	equ	ST724,*-DPDA
	zero	APLYS,LN724
	zero	2,2   pd ld
	zero	12,1   rule/alt
	zero	12,ST541 prod/val
	equ	LN724,*-DPDA-ST724-1
"
" STATE 728
	equ	ST728,*-DPDA
	zero	STRD,LN728
	zero	2,ST761	".
	equ	LN728,*-DPDA-ST728-1
"
" STATE 730
	equ	ST730,*-DPDA
	zero	APLYS,LN730
	zero	2,2   pd ld
	zero	17,1   rule/alt
	zero	17,ST592 prod/val
	equ	LN730,*-DPDA-ST730-1
"
" STATE 734
	equ	ST734,*-DPDA
	zero	STRD,LN734
	zero	2,ST765	".
	equ	LN734,*-DPDA-ST734-1
"
" STATE 736
	equ	ST736,*-DPDA
	zero	STRD,LN736
	zero	5,ST769	"(
	equ	LN736,*-DPDA-ST736-1
"
" STATE 738
	equ	ST738,*-DPDA
	zero	STRD,LN738
	zero	4,ST666	",
	zero	6,ST770	")
	equ	LN738,*-DPDA-ST738-1
"
" STATE 741
	equ	ST741,*-DPDA
	zero	APLY1,LN741
	zero	2,2   pd ld
	zero	15,1   rule/alt
	zero	15,ST619 prod/val
	equ	LN741,*-DPDA-ST741-1
"
" STATE 745
	equ	ST745,*-DPDA
	zero	STRD,LN745
	zero	4,ST650	",
	zero	6,ST775	")
	equ	LN745,*-DPDA-ST745-1
"
" STATE 748
	equ	ST748,*-DPDA
	zero	APLY1,LN748
	zero	2,2   pd ld
	zero	10,1   rule/alt
	zero	10,ST628 prod/val
	equ	LN748,*-DPDA-ST748-1
"
" STATE 752
	equ	ST752,*-DPDA
	zero	APLY1,LN752
	zero	1,1   pd ld
	zero	7,1   rule/alt
	zero	7,ST693 prod/val
	equ	LN752,*-DPDA-ST752-1
"
" STATE 756
	equ	ST756,*-DPDA
	zero	APLY,LN756
	zero	3,3   pd ld
	zero	6,1   rule/alt
	zero	6,ST319 prod/val
	zero	ST637,ST720
	equ	LN756,*-DPDA-ST756-1
"
" STATE 761
	equ	ST761,*-DPDA
	zero	APLY1,LN761
	zero	5,5   pd ld
	zero	20,2   rule/alt
	zero	20,ST36 prod/val
	equ	LN761,*-DPDA-ST761-1
"
" STATE 765
	equ	ST765,*-DPDA
	zero	APLY1,LN765
	zero	5,5   pd ld
	zero	19,2   rule/alt
	zero	19,ST41 prod/val
	equ	LN765,*-DPDA-ST765-1
"
" STATE 769
	equ	ST769,*-DPDA
	zero	STRDS,ST603

"
" STATE 770
	equ	ST770,*-DPDA
	zero	APLY,LN770
	zero	3,3   pd ld
	zero	16,1   rule/alt
	zero	16,ST615 prod/val
	zero	ST676,ST741
	equ	LN770,*-DPDA-ST770-1
"
" STATE 775
	equ	ST775,*-DPDA
	zero	NSRD,LN775
	zero	2,-ST819	".
	zero	4,-ST819	",
	zero	15,-ST817	"with
	equ	LN775,*-DPDA-ST775-1
"
" STATE 779
	equ	ST779,*-DPDA
	zero	STRD,LN779
	zero	4,ST666	",
	zero	6,ST785	")
	equ	LN779,*-DPDA-ST779-1
"
" STATE 782
	equ	ST782,*-DPDA
	zero	STRD,LN782
	zero	9,ST77	"attribute
	zero	12,ST92	"attr_acc
	equ	LN782,*-DPDA-ST782-1
"
" STATE 785
	equ	ST785,*-DPDA
	zero	APLYS,LN785
	zero	5,5   pd ld
	zero	16,2   rule/alt
	zero	16,ST770 prod/val
	equ	LN785,*-DPDA-ST785-1
"
" STATE 789
	equ	ST789,*-DPDA
	zero	STRD,LN789
	zero	5,ST791	"(
	equ	LN789,*-DPDA-ST789-1
"
" STATE 791
	equ	ST791,*-DPDA
	zero	STRDS,ST603

"
" STATE 792
	equ	ST792,*-DPDA
	zero	STRD,LN792
	zero	4,ST666	",
	zero	6,ST795	")
	equ	LN792,*-DPDA-ST792-1
"
" STATE 795
	equ	ST795,*-DPDA
	zero	APLY,LN795
	zero	8,8   pd ld
	zero	11,2   rule/alt
	zero	11,ST624 prod/val
	zero	ST682,ST748
	equ	LN795,*-DPDA-ST795-1
"
" STATE 800
	equ	ST800,*-DPDA
	zero	STRD,LN800
	zero	10,ST148	"access
	equ	LN800,*-DPDA-ST800-1
"
" STATE 802
	equ	ST802,*-DPDA
	zero	APLY1,LN802
	zero	0,0   pd ld
	zero	37,1   rule/alt
	zero	37,ST7 prod/val
	equ	LN802,*-DPDA-ST802-1
"
" STATE 806
	equ	ST806,*-DPDA
	zero	STRDS,ST1

"
" STATE 807
	equ	ST807,*-DPDA
	zero	APLY1,LN807
	zero	0,0   pd ld
	zero	1,1   rule/alt
	zero	1,ST68 prod/val
	equ	LN807,*-DPDA-ST807-1
"
" STATE 811
	equ	ST811,*-DPDA
	zero	STRD,LN811
	zero	7,ST631	"=
	equ	LN811,*-DPDA-ST811-1
"
" STATE 813
	equ	ST813,*-DPDA
	zero	APLYS,LN813
	zero	0,0   pd ld
	zero	8,2   rule/alt
	zero	8,ST683 prod/val
	equ	LN813,*-DPDA-ST813-1
"
" STATE 817
	equ	ST817,*-DPDA
	zero	STRD,LN817
	zero	15,ST335	"with
	equ	LN817,*-DPDA-ST817-1
"
" STATE 819
	equ	ST819,*-DPDA
	zero	APLYS,LN819
	zero	3,3   pd ld
	zero	11,1   rule/alt
	zero	11,ST795 prod/val
	equ	LN819,*-DPDA-ST819-1
	equ	DPDAs,*-DPDA


	zero	1,2	"SKIP/ADJ

	zero	7,1	"SKIP/ADJ

	zero	2,0	"SKIP/ADJ
	end




		    mrds_dsm_read_header.pl1        04/18/85  1429.4rew 04/18/85  0907.0       77508



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

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

mrds_dsm_read_header: proc (area_ptr, hd_ptr, iocb_ptr, a_code);

/*
   This routine using the input iocb_ptr reads a record with a  null
   key  and checks to be sure its a submodel header. If it is not it
   returns the code mrds_error_$not_dsm. If it is, then for the main
   entry  point it obtains the number of relations loads that number
   into the header and returns a pointer  to  the  header  structure
   which  it  allocated in the area pointed to by the area_ptr input
   parameter. For the version entry point after the header  is  read
   and  varified  the  version value is extracted and returned while
   the space the header record was read into is freed.  The  db_path
   entry point is similar to the version entry point but the db_path
   rather than the version is returned.

   Known Bugs:

   Other Problems:

   HISTORY

   80-08-11 Spratt: Remove code to infer database_pn  from  the  dsm
   .        path, which was valid as long as the dsm was  always  in
   .        the  db  directory.  It  became necessary to change this
   .        because dsm's are now only placed in  the  db  when  the
   .        -install  control argument is used with cmdsm, otherwise
   .        the dsm ends up in the users working directory.

   80-12-24 Davids: changed the version comparison from equal to the
   .        lastest version to < 4, since submodel code will be able
   .        to handle version 4 or later code.

   81-01-08  Davids:  added  code  description  and  reformated  the
   .        dclarations and history section added the entry  version
   .        removed  the  version check and added a check to be sure
   .        that the record read is indeed a submodel header record.
   .        reworked   the  code  creating  the  internal  procedure
   .        common.

   81-01-09 Davids: discovered that the key of the header record was
   .        not the same for version 1, 4, and 5 submodels. all keys
   .        force  the header record to the begining of the file but
   .        that can be done with keys of "", low (32) or low  (256)
   .        so  now  the header record is found just by going to the
   .        beginning of the file.

   81-01-12        Davids:        changed        reference        of
   .        mrds_dsm_display_rels.incl.pl1                        to
   .        mrds_dsm_relation_names.incl.pl1.   this   expands   the
   .        relation names for 32 to 64 characters.

   81-01-28 Davids:  changed drel_ptr to mrds_dsm_relation_names_ptr
   .        to  correspond to changes in the mrds_dsm_relation_names
   .        include file.

   81-03-31 Davids: added the db_path entry point, removed the  call
   .        to mrds_dsm_get_relation_names to determine  the  number
   .        of  relations  in  the  submodel for version 5 submodels
   .        since  for  version  5  submodels  that  information  is
   .        correctly stored in the header.

   81-05-20   Rickie   E.   Brinegar:    Changed    references    to
   .        dsm_relation_names to mrds_dsm_relation_names due  to  a
   .        change in the include file.

   81-06-01   Davids:   changed   mrds_dsm_header_str.incl.pl1    to
   .        mrds_dsm_header.incl.pl1.

   84-10-23   Thanh Nguyen:  On the opening of an old  submodel < 5,
   .        we only need to get the number of relations.  Therefore,
   .        the   entry   mrds_dsm_get_relation_names$number_of_rels
   .        should be called instead of mrds_dsm_get_relation_names.
   .        Another reason  for this change  is that  the allocation 
   .        area passing  from mrds_dsl_init_res  is too  small (200
   .        words)  to kept more  than 6 rel. names  to be filled by
   .        mrds_dsm_get_relation_names.  Kudo to  Hurst from  AFDSC
   .        for reporting this problem.

   84-11-01 Paul Benjamin: Changed to use local_hd_ptr for manipulation,
   .        only setting hd_ptr to something useful just prior to returning.
*/

/* PARAMETERS */

	dcl     area_ptr		 ptr;		/* (input) allocation area */
	dcl     db_path		 char (168);	/* (output) path of database associated with submodel */
	dcl     hd_ptr		 ptr;		/* (output) header record structure pointer */
	dcl     iocb_ptr		 ptr;		/* (input) iocb pointer */
	dcl     a_code		 fixed bin (35);	/* (output) error code */
	dcl     version		 fixed bin;	/* (output) version of submodel */

/* AUTOMATIC */

	dcl     code		 fixed bin (35) init (0); /* internal error code */
	dcl     local_hd_ptr	 ptr;		/* local copy of hd_ptr */
	dcl     01 mrds_dsm_header_copy like mrds_dsm_header; /* storage for a header record */

/* BASED */

	dcl     area_buffer		 area based (area_ptr); /* allocation buffer assumes non-freeing */

/* BUILTIN */
	dcl     addr		 builtin;
	dcl     null		 builtin;
	dcl     size		 builtin;

/* ENTRIES */

	dcl     mrds_dsm_get_relation_names$number_of_rels entry (ptr, fixed bin (35)) returns (fixed bin);
		  

%include mrds_dsm_header;
%page;
%include mrds_dsm_relation_names;

/*
   main entry point - reads and verifies the header structure, reads
   all  the  relations  and loads the relation count into the header
   structure. Why the relation count is not  stored  in  the  header
   structure to begin with i do not know.
*/

	hd_ptr = null;
	allocate mrds_dsm_header in (area_buffer) set (local_hd_ptr);

	call common (local_hd_ptr, size (mrds_dsm_header) * 4);
	if code = 0 & local_hd_ptr -> mrds_dsm_header.dsm_generator_version < 5 then
	     local_hd_ptr -> mrds_dsm_header.num_of_relations = mrds_dsm_get_relation_names$number_of_rels (iocb_ptr, code);

	if code = 0
	     then hd_ptr = local_hd_ptr;

	a_code = code;

	return;

version: entry (iocb_ptr, version, a_code);

/*
   The main reason for this entry point is so that modules that need
   to know the submodel version they are dealing with do not have to
   include the entire header structure.
*/

	call common (addr (mrds_dsm_header_copy), size (mrds_dsm_header) * 4);
	if code = 0
	then version = mrds_dsm_header_copy.dsm_generator_version;
	else version = 0;

	a_code = code;

	return;

db_path: entry (iocb_ptr, db_path, a_code);

/*
   This entry returns  just  the  db_path  that  is  stored  in  the
   submodel  header.  routines  that  need  to know just the db_path
   should not  be  required  to  know  the  entire  submodel  header
   structure.
*/

	call common (addr (mrds_dsm_header_copy), size (mrds_dsm_header_copy) * 4);
	if code = 0
	then db_path = mrds_dsm_header_copy.database_pn;
	else db_path = "";

	a_code = code;
	return;

common: proc (buffer_ptr, buffer_size);

/*
   This internal procedure reads and verifies the header structure
*/

/* PARAMETERS */

	dcl     buffer_ptr		 ptr;		/* (input) pointer to input buffer */
	dcl     buffer_size		 fixed bin (21);	/* (input) size of buffer */

/* AUTOMATIC */

	dcl     record_length	 fixed bin (21);	/* length of record */

/* CONSTANTS */

	dcl     BOF		 fixed bin init (-1) internal static options (constant);
						/* used to indicate the beginning of the file */

/* ENTRIES */

	dcl     iox_$position	 entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));

/* EXTERNAL */

	dcl     mrds_error_$not_dsm	 fixed bin (35) external static;



	code = 0;

	call iox_$position (iocb_ptr, BOF, 0, code);
	if code = 0
	then do;
		call iox_$read_record (iocb_ptr, buffer_ptr, buffer_size, record_length, code);
		if code = 0
		then do;
			if buffer_ptr -> mrds_dsm_header.name ^= "data_submodel_header"
			then code = mrds_error_$not_dsm;
		     end;

	     end;

	return;

     end /* common */;


     end /* mrds_dsm_read_header */;





		    mrds_dsm_read_relation.pl1      04/18/85  1429.4re  04/18/85  0907.0       76392



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

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

mrds_dsm_read_relation: proc (relation_name, area_ptr, a_relation_block_ptr, iocb_ptr, a_code);

/*
   This routine loads a relation_block_str from data in the submodel
   vfile  pointed  to  by the iocb_ptr parameter. The version of the
   submodel is determined and as long as its version 1, 4  or  5  it
   can  be  processed.  There  are no other submodel versions. Since
   version 1 and 4 submodels do not have access bits in the relation
   record  access  of append_tuple and delete_tuple for the relation
   and access of read and modify for the attributes in the  relation
   is  set  in the relation_block_str. Access for version 5 submodel
   relations is of course taken from the access bits in the record.

   Known bugs:

   Other problems:

   HISTORY

   80-12-23 Davids: This routine has been extensively modified  from
   .        the eariler version which had no  history  section.  The
   .        bigest changes where handling of version 4 submodels and
   .        a call to sub_err_ to explain any errors.

   81-01-06 Davids: modified  to  call  mrds_dsm_get_version  rather
   .        than reading the header struction in line.

   81-01-09   Davids:   changed   call    mrds_dsm_get_version    to
   .        mrds_dsm_read_header$version.

   81-01-14 Davids: modified to support version  1  submodels  which
   .        are handled like version 4 submodels.

   .        modified to handle the new relation_block structure  and
   .        to zero what used to be the pad fields (now mbz fields).

   81-04-30 Davids: modified to use  the  new  rel_rec_5  structure,
   .        i.e. named 1 bit access elements  rather  than  just  an
   .        unnamed bit string.
*/

/* PARAMETERS */

	dcl     relation_name	 char (*);	/* (input) name of the relation to be read */
	dcl     area_ptr		 ptr;		/* (input) area to allocate relation_block */
	dcl     a_relation_block_ptr	 ptr;		/* (output) pointer to the realtion_block str */
	dcl     iocb_ptr		 ptr;		/* (input) pointer to the submodel iocb */
	dcl     a_code		 fixed bin (35);	/* (output) a error code */

/* AUTOMATIC */

	dcl     byte_len		 fixed bin (21);	/* length in bytes of area needed for records */
	dcl     byte_ptr		 ptr init (null ());/* pointer to area records will be read into */
	dcl     code		 fixed bin (35);	/* internal error code */
	dcl     idx		 fixed bin;	/* loop indx */
	dcl     record_key		 char (256) varying;/* vfile record key */
	dcl     record_length	 fixed bin (21);	/* length of record just read */
	dcl     version		 fixed bin;	/* submodel version */

/* BASED */

	dcl     area_buffer		 area based (area_ptr); /* space for relation_block str */
	dcl     byte_string		 char (byte_len) based unal; /* space to read a record */

/* BUILTIN */

	dcl     null		 builtin;

/* ENTRIES */

	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     mrds_dsm_read_header$version entry (ptr, fixed bin, fixed bin (35));

/* EXTERNAL */

	dcl     mrds_error_$version_not_supported fixed bin (35) external static;

%include mrds_dsm_rel_rec_4;

%include mrds_dsm_rel_rec_5;

%include mrds_dsm_rel_block;

%include mrds_dsm_head_strings;

	call mrds_dsm_read_header$version (iocb_ptr, version, code);
	if code ^= 0
	then call error_exit ("Could not read submodel version");

	if version = 4
	then call process_version_1_or_4;
	else
	     if version = 5
	then call process_version_5;
	else
	     if version = 1
	then call process_version_1_or_4;
	else do;
		code = mrds_error_$version_not_supported;
		call error_exit ("Unrecognized submodel version");
	     end;




	a_code = 0;
	a_relation_block_ptr = relation_block_ptr;
	return;

error_return:
	a_code = code;
	a_relation_block_ptr = null ();
	if byte_ptr ^= null ()
	then free byte_ptr -> byte_string;
	return;

process_version_1_or_4: proc;

	record_key = relation_name;

	call iox_$seek_key (iocb_ptr, (record_key), byte_len, code);
	if code ^= 0
	then call error_exit ("Relation record was not in submodel vfile_");

	allocate byte_string set (byte_ptr);

	call iox_$read_record (iocb_ptr, byte_ptr, byte_len, record_length, code);
	if code ^= 0
	then call error_exit ("Relation record could not be read");

	rb_number_of_attributes = byte_ptr -> rel_rec_4.no_attributes;
	allocate relation_block in (area_buffer);
	relation_block.version = RELATION_BLOCK_VERSION_1;
	relation_block.dsm_rel_name = relation_name;
	relation_block.dm_rel_name = byte_ptr -> rel_rec_4.model_rel_name;
	relation_block.rel_access.append = "1"b;
	relation_block.rel_access.delete = "1"b;
	relation_block.rel_access.null = "0"b;
	relation_block.rel_access.mbz1 = "0"b;
	do idx = 1 to byte_ptr -> rel_rec_4.no_attributes;
	     relation_block.attribute_info (idx).dsm_attr_name
		= byte_ptr -> rel_rec_4.attribute_info (idx).submodel_att_name;
	     relation_block.attribute_info (idx).attr_access.read = "1"b;
	     relation_block.attribute_info (idx).attr_access.modify = "1"b;
	     relation_block.attribute_info (idx).attr_access.null = "0"b;
	     relation_block.attribute_info (idx).attr_access.mbz2 = "0"b;
	     relation_block.attribute_info (idx).dm_attr_name
		= byte_ptr -> rel_rec_4.attribute_info (idx).model_att_name;
	     relation_block.attribute_info (idx).dm_attr_flags.mbz3 = "0"b;
	end;

	free byte_ptr -> byte_string;

	return;

     end /* process_version_4 */;

process_version_5: proc;

	record_key = REL_HEAD || relation_name;

	call iox_$seek_key (iocb_ptr, (record_key), byte_len, code);
	if code ^= 0
	then call error_exit ("Relation record was not in submodel vfile_");

	allocate byte_string set (byte_ptr);

	call iox_$read_record (iocb_ptr, byte_ptr, byte_len, record_length, code);
	if code ^= 0
	then call error_exit ("Relation record could not be read");

	rb_number_of_attributes = byte_ptr -> rel_rec_5.attr_num;
	allocate relation_block in (area_buffer);
	relation_block.version = RELATION_BLOCK_VERSION_1;
	relation_block.dsm_rel_name = relation_name;
	relation_block.dm_rel_name = byte_ptr -> rel_rec_5.rel_dm_name;
	relation_block.rel_access.append = byte_ptr -> rel_rec_5.access.append;
	relation_block.rel_access.delete = byte_ptr -> rel_rec_5.access.delete;
	relation_block.rel_access.null = byte_ptr -> rel_rec_5.access.null;
	relation_block.rel_access.mbz1 = "0"b;
	do idx = 1 to byte_ptr -> rel_rec_5.attr_num;
	     relation_block.attribute_info (idx).dsm_attr_name = byte_ptr -> rel_rec_5.attr (idx).dsm_name;
	     relation_block.attribute_info (idx).attr_access.read = byte_ptr -> rel_rec_5.attr (idx).access.read;
	     relation_block.attribute_info (idx).attr_access.modify = byte_ptr -> rel_rec_5.attr (idx).access.modify;
	     relation_block.attribute_info (idx).attr_access.null = byte_ptr -> rel_rec_5.attr (idx).access.null;
	     relation_block.attribute_info (idx).attr_access.mbz2 = "0"b;
	     relation_block.attribute_info (idx).dm_attr_name = byte_ptr -> rel_rec_5.attr (idx).dm_name;
	     relation_block.attribute_info (idx).dm_attr_flags.mbz3 = "0"b;
	end;

	free byte_ptr -> byte_string;

	return;

     end /* process_version_5 */;

error_exit: proc (message);

/* PARAMETERS */

	dcl     message		 char (*);	/* (input) error message */

/* AUTOMATIC */

	dcl     retval		 fixed bin (35);

/* ENTRIES */

	dcl     sub_err_		 entry options (variable);



	call sub_err_ (code, "mrds_dsm_read_relation", "c", null (), retval, message);

	goto error_return;

     end /* error_return */;

     end /* mrds_dsm_read_relation */;





		    mrds_dsm_scanner.pl1            04/18/85  1429.4re  04/18/85  0907.0      275868



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

mrds_dsm_scanner:
     procedure (p_mrds_dsm_scanner_info_ptr, p_lex_stack_ptr, p_stack_index,
	p_code);

/*
   ??-??-?? Spratt: written

   80-06-28 Spratt: Order the alphanum_token_list by token size,  as
   .        was already done in the special_token_list.

   81-01-23: Davids: modified  internal  procedure  comment_skip  so
   .        that  before   if   calls   get_next_char_non_white   it
   .        increments  mrds_dsm_scanner_info.pos  by 1. This caused
   .        comments to really be skiped rather than causing  errors
   .        on the finial "/".

   81-05-08 Davids: Added a "PROGRAM LOGIC ERROR" clause to sub_err_
   .        message printed is the  mrds_dsm_scanner_info  structure
   .        is the wrong version.

   .        added an ioa_ call to report_mds_error to send the error
   .        message  to the listing - if a listing is being produced
   .        (listing_iocb_ptr ^= null)

   81-05-15 Davids: set p_code explicitly to zero in the init entry.

   .        reformated the call to sub_err_ and added a comment that
   .        the call to sub_err_ never returns

   .        removed unreferenced variables.

   81-05-26 Davids: rewrote most of the  comment  handling  code  so
   .        that multiple line comments and line numbers are handled
   .        correctly  and so comment lines (besides the first line)
   .        are output to the listing.

   81-07-21  Jim  Gray  :  added  a  check  for  the  legal  special
   .        characters allowed "(", ")", ",", ";", ":", and  "="  so
   .        that any other remaining special characters are detected
   .        as illegal in the scanner, and do  not  cause  a  parser
   .        failure.

   81-07-24 Davids: added the character "/" to the list  of  special
   .        characters so that comments will  be  processed  without
   .        errors.  the  character "*" does not need to be added to
   .        the special list for comment processing because once the
   .        /  is  found  a special check is made to see whether the
   .        next character is an *.

   81-09-16 Davids: added the substr builtin so that the code  would
   .        compile with -prefix stringrange. Since in execution the
   .        string  would  be  truncated  anyway the addition of the
   .        substr will not change the execution behavior.
   
   DESCRIPTION:

   Lexical analyzer or scanner for returning tokens  from  the  data
   submodel  source  to  the  parser.  A token may be an identifier,
   keyword, or end of file. Also returned  in  mrds_dsm_scanner_info
   for  use by the parser; an integer encoding value identifying the
   token, pointers to the token in the  source,  the  start  of  the
   current  line,  the  line  number and length of the token. A line
   numbered version of the original source can be produced. Comments
   and  white space are skipped over, and any invalid characters are
   detected.

   There are two entries: init entry - should be  called  first  for
   initialization  normal  entry  -  for  returning  tokens from the
   source

   Note that the value returned by p_code will currently  always  be
   zero. errors will be reported as they are found and an indication
   that     errors     have      occured      will      be      that
   mrds_dsm_scanner_info.highest_severity is ^= 0.



   PARAMETERS:

   === normal entry ===

   p_mrds_dsm_scanner_info_ptr - - (input) pointer to the info structure for
   the scanner.

   p_lex_stack_ptr - - (input) pointer to the lexical stack

   p_stack_index - - (input) stack element which is hold the returned token,
   etc.

   p_code - - (output) an error code describing reason for failure of scanner.

   lex_stack - - (output) the specified element contains the token pointer,
   length, encoding, and line number and line start pointer.

   (output) for the line numbered listing goes to switch pointed to by
   mrds_dsm_scanner_info.listing_iocb_ptr.

   === init entry ===

   p_mrds_dsm_scanner_info_ptr - - (input) same as above.

   p_code - - (output) same as above.
*/

/* PARAMETER */

	dcl     p_stack_index	 fixed bin;
	dcl     p_lex_stack_ptr	 ptr;
	dcl     p_code		 fixed bin (35);
	dcl     p_mrds_dsm_scanner_info_ptr ptr;

/* AUTOMATIC */

	dcl     current_terminal	 char (256) varying;
	dcl     current_terminal_and_token_match bit (1) aligned;
	dcl     debug_sw		 bit (1) aligned;
	dcl     encoding		 fixed bin (35);
	dcl     message		 char (256) varying;
	dcl     message_length	 fixed bin;
	dcl     symbol_found	 bit (1);
	dcl     alphanum_token_list_ptr ptr;
	dcl     special_token_list_ptr ptr;
	dcl     alphanum_token_list_index fixed bin;
	dcl     special_token_list_index fixed bin;
	dcl     alphanum_token_list_size fixed bin;
	dcl     special_token_list_size fixed bin;
	dcl     line_no_pic		 pic "zzzzzz9";
	dcl     work_area_ptr	 ptr;
	dcl     overlength_token_already_seen bit (1) aligned;

/* BASED */

	dcl     source_overlay	 char (sys_info$max_seg_size) based;
	dcl     token		 char (mrds_dsm_scanner_info.token_length)
				 based (mrds_dsm_scanner_info.token_ptr);
	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);
	dcl     1 alphanum_token_list	 based (alphanum_token_list_ptr),
		2 size		 fixed bin (35),
		2 index		 (alphanum_token_list_size refer (alphanum_token_list.size))
				 fixed bin (35);

	dcl     1 special_token_list	 based (special_token_list_ptr),
		2 size		 fixed bin (35),
		2 index		 (special_token_list_size refer (special_token_list.size))
				 fixed bin (35);
	dcl     char_string		 (sys_info$max_seg_size) char (1) based;

/* BUILTIN */

	dcl     substr		 builtin;
	dcl     reverse		 builtin;
	dcl     max		 builtin;
	dcl     string		 builtin;
	dcl     hbound		 builtin;
	dcl     null		 builtin;
	dcl     index		 builtin;
	dcl     length		 builtin;
	dcl     verify		 builtin;
	dcl     addr		 builtin;
	dcl     ltrim		 builtin;
	dcl     addrel		 builtin;

/* CONSTANT */

	dcl     MYNAME		 init ("mrds_dsm_scanner") char (16) internal static
				 options (constant);
	dcl     EOF_ENCODING	 fixed bin internal static options (constant) init (0);
	dcl     WHITESPACE_CHARS	 char (2) internal static options (constant)
				 init ("	 ");	/* tab and blank. */
	dcl     ALPHANUM_CHARS	 char (62) internal static options (constant)
				 init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890");
	dcl     IDENTIFIER_CHARS	 char (64) internal static options (constant)
				 init (
				 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-_");
	dcl     SPECIAL_CHARS	 char (7) init ("(),;:=/");
	dcl     NL_CHAR		 char (1) internal static options (constant) init ("
");

	dcl     START		 fixed bin internal static options (constant) init (0);
	dcl     CASE_END		 fixed bin internal static options (constant) init (7);
	dcl     ALPHANUM_TYPE	 fixed bin internal static options (constant) init (1);
	dcl     SPECIAL_TYPE	 fixed bin internal static options (constant) init (2);
	dcl     NL_TYPE		 fixed bin internal static options (constant) init (3);
	declare ILLEGAL_TYPE	 fixed bin int static options (constant) init (5);
	dcl     EOF_TYPE		 fixed bin internal static options (constant) init (6);
	dcl     WHITESPACE_TYPE	 fixed bin internal static options (constant) init (4);

	dcl     TYPE_NAME_ARRAY	 (0:7) char (32) varying internal static
				 options (constant)
				 init ("start", "alphanumeric", "special", "newline", "white space",
				 "illegal", "end of file", "case end");

/* ENTRY */

	dcl     sub_err_		 entry options (variable);
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     ioa_$rs		 entry options (variable);
	dcl     ioa_		 entry options (variable);
	dcl     requote_string_	 entry (char (*)) returns (char (*));
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$unimplemented_version fixed bin (35) ext;
	dcl     sys_info$max_seg_size	 fixed bin (24) ext;

/* normal entry */

	mrds_dsm_scanner_info_ptr = p_mrds_dsm_scanner_info_ptr;
	if mrds_dsm_scanner_info.version ^= MRDS_DSM_SCANNER_INFO_VERSION_1 then
	     call
		sub_err_ (error_table_$unimplemented_version, MYNAME, "s", null,
		(0),
		"PROGRAM LOGIC ERROR^/The wrong version of the mrds_dsm_scanner_info structure was supplied."
		);



/* will never return from the call to sub_err_ */

	debug_sw = mrds_dsm_scanner_info.debug_scanner;
	lex_stack_ptr = p_lex_stack_ptr;
	work_area_ptr = mrds_dsm_scanner_info.work_area_ptr;
	special_token_list_ptr = mrds_dsm_scanner_info.special_token_list_ptr;
	alphanum_token_list_ptr = mrds_dsm_scanner_info.alphanum_token_list_ptr;
	p_code = 0;
	goto state (START);

/* initialization entry */

mrds_dsm_scanner$init:
     entry (p_mrds_dsm_scanner_info_ptr, p_code);

	p_code = 0;
	mrds_dsm_scanner_info_ptr = p_mrds_dsm_scanner_info_ptr;
	work_area_ptr = mrds_dsm_scanner_info.work_area_ptr;
	call initialize_encoding_information;
	call
	     get_next_char_init (mrds_dsm_scanner_info.char_ptr,
	     mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);

	return;

/* START */
state (0):					/*
						   Using the type code for the current character, go to the appropiate state
						   for that class of tokens, the parser having initialized the current character
						   before the first call, and scanner obtaining the next character to be used
						   when called again before returning to the parser.
						*/
	token_length = 0;
	symbol_found = "0"b;
	overlength_token_already_seen = "0"b;


/* Loop from start state to the recognition states, while a token is not
   found, and end of source is not detected.
*/

	do while (^symbol_found);

	     if debug_sw then
		call
		     ioa_ ("A^[n^] ^a character (type ^d) at position ^d: ^a",
		     (
		     index ("aeiouh",
		     substr (TYPE_NAME_ARRAY (mrds_dsm_scanner_info.type), 1, 1))
		     > 0), TYPE_NAME_ARRAY (mrds_dsm_scanner_info.type),
		     mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.pos,
		     requote_string_ ((mrds_dsm_scanner_info.char)));

	     goto state (mrds_dsm_scanner_info.type);

/* ALPHANUMERIC */
state (1):					/* Letter or digit found, accumulate characters that are letters, numbers,
						   underscores, hyphens into an identifier token then make checks for keywords
						   and pathnames that may follow to provide correct parser and scanner encoding.
						   */
	     call alphanum_handler ();
	     call
		stack_put (p_lex_stack_ptr, p_stack_index,
		mrds_dsm_scanner_info.token_count);
	     symbol_found = "1"b;
	     goto state (CASE_END);			/* SPECIAL */

state (2):					/* Special character found, if slash, check for comment else return encoding
						   for the character.
						   */
	     if ^comment_skip () then do;

/* not a comment, single character special instead, get it's encoding */

		     call special_handler ();
		     call
			stack_put (p_lex_stack_ptr, p_stack_index,
			mrds_dsm_scanner_info.token_count);
		     symbol_found = "1"b;
		end;
	     goto state (CASE_END);

/* NL */
state (3):					/* new line detected */
	     call
		get_next_char_new_line (mrds_dsm_scanner_info.char_ptr,
		mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* WHITE_SPACE */
state (4):					/* white space detected, skip over it */
	     call
		get_next_char_non_white (mrds_dsm_scanner_info.char_ptr,
		mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* ILLEGAL */
state (5):					/* illegal character detected */
	     call
		ioa_$rs ("^a^a^a ^d ^a ^d^a", message, message_length,
		"Character """, mrds_dsm_scanner_info.char,
		""", before token number", mrds_dsm_scanner_info.token_count + 1,
		"on line", mrds_dsm_scanner_info.line_number, ".");
	     call
		report_mds_error (1 /* severity */, ILLEGAL_CHAR_ERROR, (message));
	     call
		get_next_char (mrds_dsm_scanner_info.char_ptr,
		mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* EOF */
state (6):					/* end of input detected */
	     encoding = EOF_ENCODING;
	     token_ptr = mrds_dsm_scanner_info.char_ptr;
	     call
		stack_put (p_lex_stack_ptr, p_stack_index,
		mrds_dsm_scanner_info.token_count);
	     symbol_found = "1"b;
	     goto state (CASE_END);

/* CASE_END */
state (7):
	end;

	if debug_sw then
	     call
		ioa_ (
		"Scanner returns: ^a token on ^a line (encoding of ^d) is ^a",
		add_cardinal_suffix ((mrds_dsm_scanner_info.token_count)),
		add_cardinal_suffix ((mrds_dsm_scanner_info.line_number)),
		encoding, requote_string_ ((token)));

	return;

stack_put:
     procedure (p_lex_stack_ptr, p_stack_index, p_token_count);
						/* START OF DECLARATIONS */
						/* Parameter */

	dcl     p_lex_stack_ptr	 ptr;
	dcl     p_stack_index	 fixed bin;
	dcl     p_token_count	 fixed bin (35);

/* Automatic */
/* Based */
/* Builtin */
/* Controlled */
/* Constant */
/* Entry */
/* External */
/* END OF DECLARATIONS */

	lex_stack_ptr = p_lex_stack_ptr;

/* increment the number of tokens seen in this line */

	p_token_count = p_token_count + 1;

/* routine to put the token info into the stack */

	lex_stack (p_stack_index).symptr = mrds_dsm_scanner_info.token_ptr;
	lex_stack (p_stack_index).symlen = mrds_dsm_scanner_info.token_length;
	lex_stack (p_stack_index).line = mrds_dsm_scanner_info.line_number;
	lex_stack (p_stack_index).symbol = encoding;
	lex_stack (p_stack_index).line_strt = mrds_dsm_scanner_info.line_ptr;
	lex_stack (p_stack_index).line_size = mrds_dsm_scanner_info.line_length;
	lex_stack (p_stack_index).token_num = mrds_dsm_scanner_info.token_count;

     end;

alphanum_handler:
     procedure ();
	dcl     current_terminal_and_token_match bit (1) aligned;


	token_ptr = char_ptr;
	token_length =
	     verify (
	     substr (mrds_dsm_scanner_info.source_ptr -> source_overlay, pos,
	     mrds_dsm_scanner_info.source_length), IDENTIFIER_CHARS);
	if token_length = 0 then do;
		token_length =
		     mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos + 1;
		mrds_dsm_scanner_info.pos = mrds_dsm_scanner_info.source_length + 1;
		mrds_dsm_scanner_info.char_ptr = null;
		mrds_dsm_scanner_info.type = EOF_TYPE;
	     end;
	else do;
		token_length = token_length - 1;
		mrds_dsm_scanner_info.pos = token_length + mrds_dsm_scanner_info.pos;
		mrds_dsm_scanner_info.char_ptr =
		     addr (mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos));
		mrds_dsm_scanner_info.char =
		     mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos);
		call
		     get_char_type (mrds_dsm_scanner_info.char,
		     mrds_dsm_scanner_info.type);
	     end;

	current_terminal = "";
	current_terminal_and_token_match = "0"b;

	do alphanum_token_list_index = 1
	     to hbound (alphanum_token_list.index, 1)
	     while (^current_terminal_and_token_match
	     & token_length
	     <= mrds_dsm_terminals
	     .TL (alphanum_token_list.index (alphanum_token_list_index)).ln);
	     if token_length
		^= mrds_dsm_terminals
		.TL (alphanum_token_list.index (alphanum_token_list_index)).ln then
		current_terminal_and_token_match = "0"b;
	     else do;
		     current_terminal =
			substr (string (mrds_dsm_terminals.TC),
			mrds_dsm_terminals
			.TL (alphanum_token_list.index (alphanum_token_list_index)).fc,
			mrds_dsm_terminals
			.TL (alphanum_token_list.index (alphanum_token_list_index)).ln);
		     current_terminal_and_token_match = (current_terminal = token);
		end;
	end;

	if current_terminal_and_token_match then do;
		encoding = alphanum_token_list.index (alphanum_token_list_index - 1);
						/* Since the index was incremented before the match was noted, the index for the match is one less than the current value of alphanum_token_list_index. */

	     end;
	else if mrds_dsm_scanner_info.identifier_encoding = -1 then do;
		call
		     ioa_$rs ("Unrecognized token: ^a^/On line ^d, token number ^d.",
		     message, message_length, token, mrds_dsm_scanner_info.line_number,
		     mrds_dsm_scanner_info.token_count);
		call
		     report_mds_error (2 /* severity */, UNRECOGNIZED_TOKEN_ERROR,
		     (message));
	     end;
	else do;
		encoding = mrds_dsm_scanner_info.identifier_encoding;

	     end;					/* Find encoding for token.  Look first in list of alphanumeric terminals.
						   If the token is not there and an identifier terminal encoding is known,
						   use the identifier encoding.
						   */


     end;

get_char_type:
     proc (p_char, p_type);
	dcl     p_char		 char (1) aligned;
	dcl     p_type		 fixed bin (35);

	if p_char = NL_CHAR then
	     p_type = NL_TYPE;
	else if index (WHITESPACE_CHARS, p_char) > 0 then
	     p_type = WHITESPACE_TYPE;
	else if index (ALPHANUM_CHARS, p_char) > 0 then
	     p_type = ALPHANUM_TYPE;
	else if index (SPECIAL_CHARS, p_char) > 0 then
	     p_type = SPECIAL_TYPE;
	else p_type = ILLEGAL_TYPE;

     end;

comment_skip:
     procedure () returns (bit (1) aligned);

/* AUTOMATIC */

	dcl     old_pos		 fixed bin (35);
	dcl     old_char		 char (1);
	dcl     old_char_ptr	 ptr;
	dcl     old_type		 fixed bin;
	dcl     new_line_index	 fixed bin (35);
	dcl     result		 bit (1) aligned;
	dcl     end_comment_index	 fixed bin;


/* check for presence of a comment, return failure if not found */

	old_type = mrds_dsm_scanner_info.type;
	old_pos = mrds_dsm_scanner_info.pos;
	old_char_ptr = mrds_dsm_scanner_info.char_ptr;
	old_char = mrds_dsm_scanner_info.char;
	call
	     get_next_char (mrds_dsm_scanner_info.char_ptr,
	     mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
	if ^(old_char = "/" & mrds_dsm_scanner_info.char = "*") then do;
		mrds_dsm_scanner_info.char_ptr = old_char_ptr;
		mrds_dsm_scanner_info.char = old_char;
		mrds_dsm_scanner_info.type = old_type;
		mrds_dsm_scanner_info.pos = old_pos;
		result = "0"b;
	     end;
	else do;

/* routine to bypass comments in the source */

		end_comment_index =
		     index (
		     substr (mrds_dsm_scanner_info.source_ptr -> source_overlay,
		     mrds_dsm_scanner_info.pos,
		     mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos + 1)
		     , "*/") + mrds_dsm_scanner_info.pos - 1;
		if end_comment_index = mrds_dsm_scanner_info.pos - 1 then
		     end_comment_index = mrds_dsm_scanner_info.source_length + 1;

		new_line_index =
		     index (
		     substr (mrds_dsm_scanner_info.source_ptr -> source_overlay,
		     mrds_dsm_scanner_info.pos,
		     mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos + 1)
		     , NL_CHAR) + mrds_dsm_scanner_info.pos - 1;

		do while ((new_line_index < end_comment_index)
		     & (mrds_dsm_scanner_info.type ^= EOF_TYPE));
		     mrds_dsm_scanner_info.pos = new_line_index;
		     call
			get_next_char_new_line (mrds_dsm_scanner_info.char_ptr,
			mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
		     new_line_index =
			index (
			substr (mrds_dsm_scanner_info.source_ptr -> source_overlay,
			mrds_dsm_scanner_info.pos,
			mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos
			+ 1), NL_CHAR) + mrds_dsm_scanner_info.pos - 1;
		end;

		if mrds_dsm_scanner_info.type ^= EOF_TYPE then do;
			mrds_dsm_scanner_info.pos = end_comment_index + 2;
			call
			     get_next_char_non_white (mrds_dsm_scanner_info.char_ptr,
			     mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);
			symbol_found = "0"b;
			result = "1"b;
		     end;
		else do;				/* check for comment error */
			call
			     ioa_$rs ("^a ^d^a", message, message_length,
			     "Comment ends line number", line_number, ".");
			call
			     report_mds_error (2 /* severity */,
			     NO_COMMENT_END_DELIMITER_ERROR, (message));
		     end;
	     end;

	return (result);

     end;

special_handler:
     procedure ();

	current_terminal_and_token_match = "0"b;
	mrds_dsm_scanner_info.token_ptr = mrds_dsm_scanner_info.char_ptr;

	do special_token_list_index = 1
	     to hbound (special_token_list.index, 1)
	     while (^current_terminal_and_token_match);
	     current_terminal =
		substr (string (mrds_dsm_terminals.TC),
		mrds_dsm_terminals
		.TL (special_token_list.index (special_token_list_index)).fc,
		mrds_dsm_terminals
		.TL (special_token_list.index (special_token_list_index)).ln);
	     token_length =
		mrds_dsm_terminals
		.TL (special_token_list.index (special_token_list_index)).ln;
	     if token_length
		> mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos
		+ 1 then
		current_terminal_and_token_match = "0"b;
	     else current_terminal_and_token_match = (current_terminal = token);
	end;

	if current_terminal_and_token_match then do;
		encoding = special_token_list.index (special_token_list_index - 1);
		mrds_dsm_scanner_info.pos =
		     mrds_dsm_scanner_info.pos + mrds_dsm_scanner_info.token_length - 1;
	     end;
	else do;
		call
		     ioa_$rs ("Special character ^a in line ^d.", message,
		     message_length, mrds_dsm_scanner_info.char,
		     mrds_dsm_scanner_info.line_number);
		call
		     report_mds_error (4 /* severity */, UNRECOGNIZED_CHARACTER_ERROR,
		     (message));
		encoding = EOF_ENCODING;
	     end;
	call
	     get_next_char (mrds_dsm_scanner_info.char_ptr,
	     mrds_dsm_scanner_info.type, mrds_dsm_scanner_info.char);

     end;

get_next_character_routine:
     procedure ();					/* dummy entry, not used */

/* This procedure has four entry points.
   get_next_char_init   should be called first to set up things
   get_next_char_new_line is used to advance the current line, output it, and get the first char
   get_next_char_non_white skips white spaces until a valid character is found
   get_next_char$get_next_char  returns only info about the next char in source
*/
/* START OF DECLARATIONS */
/* Parameter */

	dcl     p_chr_ptr		 ptr;
	dcl     p_type		 fixed bin (35);
	dcl     p_chr_val		 char (1) aligned;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     output_text		 char (256) varying;
	dcl     nonwhite_char_index	 fixed bin (35);

/* Based */

/* Builtin */
/* Controlled */
/* Constant */
/* Entry */
/* External */
/* END OF DECLARATIONS */




/* INIT */
get_next_char_init:
     entry (p_chr_ptr, p_type, p_chr_val);		/* This entry initializes internal stativ values */

	mrds_dsm_scanner_info.pos = 0;		/* Starting position is first character */
	mrds_dsm_scanner_info.line_number = 0;



/* NEW LINE */
get_next_char_new_line:
     entry (p_chr_ptr, p_type, p_chr_val);		/* entry to advance to next line */
	mrds_dsm_scanner_info.pos = mrds_dsm_scanner_info.pos + 1;
	if mrds_dsm_scanner_info.pos <= mrds_dsm_scanner_info.source_length
	then do;					/* find end of next line */

		mrds_dsm_scanner_info.line_ptr =
		     addr (mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos));
		mrds_dsm_scanner_info.line_length =
		     index (
		     substr (mrds_dsm_scanner_info.line_ptr -> source_overlay, 1,
		     mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos + 1)
		     , NL_CHAR);
		if mrds_dsm_scanner_info.line_length = 0 then
		     mrds_dsm_scanner_info.line_length =
			mrds_dsm_scanner_info.source_length
			- mrds_dsm_scanner_info.pos + 1; /* segment doesn't end last line with NL */

		mrds_dsm_scanner_info.line_number =
		     mrds_dsm_scanner_info.line_number + 1;
		mrds_dsm_scanner_info.token_count = 0;

		if mrds_dsm_scanner_info.listing_iocb_ptr ^= null then do;

/* listing switch on, output the current line */

			line_no_pic = mrds_dsm_scanner_info.line_number;
			output_text =
			     line_no_pic || "   "
			     ||
			     substr (mrds_dsm_scanner_info.line_ptr -> source_overlay, 1,
			     mrds_dsm_scanner_info.line_length);

			call
			     iox_$put_chars (mrds_dsm_scanner_info.listing_iocb_ptr,
			     addrel (addr (output_text), 1), length (output_text), code);
			if code ^= 0 then do;
				call
				     ioa_$rs ("^a ^d ^a", message, message_length,
				     "Error in trying to output line number",
				     mrds_dsm_scanner_info.line_number, "to listing segment");
				call
				     report_mds_error (4 /* severity */, LISTING_IO_ERROR,
				     (message));
			     end;
		     end;
		p_chr_val =
		     mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos);
		p_chr_ptr =
		     addr (mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos));
		call get_char_type (p_chr_val, p_type);
	     end;

	else do;
		p_type = EOF_TYPE;
		p_chr_val = " ";
	     end;
	return;

/* NEXT NON WHITE */
get_next_char_non_white:
     entry (p_chr_ptr, p_type, p_chr_val);		/* This entry skips white space */

	nonwhite_char_index =
	     verify (
	     substr (mrds_dsm_scanner_info.source_ptr -> source_overlay,
	     mrds_dsm_scanner_info.pos,
	     mrds_dsm_scanner_info.source_length - mrds_dsm_scanner_info.pos + 1),
	     WHITESPACE_CHARS);

	if nonwhite_char_index > 0 then do;
		mrds_dsm_scanner_info.pos =
		     mrds_dsm_scanner_info.pos + nonwhite_char_index - 1;
		p_chr_val =
		     mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos);
		p_chr_ptr =
		     addr (mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos));
		call get_char_type (p_chr_val, p_type);
	     end;
	else do;
		mrds_dsm_scanner_info.pos = mrds_dsm_scanner_info.source_length + 1;
		p_type = EOF_TYPE;
		p_chr_val = " ";
	     end;
	return;					/* NEXT CHAR */
get_first_char:
get_next_char:
     entry (p_chr_ptr, p_type, p_chr_val);		/* return next character in source */
	mrds_dsm_scanner_info.pos = mrds_dsm_scanner_info.pos + 1;


	if mrds_dsm_scanner_info.pos <= mrds_dsm_scanner_info.source_length
	then do;
		p_chr_val =
		     mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos);
		p_chr_ptr =
		     addr (mrds_dsm_scanner_info.source_ptr
		     -> char_string (mrds_dsm_scanner_info.pos));
		call get_char_type (p_chr_val, p_type);
	     end;
	else do;
		p_type = EOF_TYPE;
		p_chr_val = " ";
	     end;
	return;

     end get_next_character_routine;

initialize_encoding_information:
     proc;					/* START OF DECLARATIONS */
						/* Parameter */

/* Automatic */

	dcl     token_list_index	 fixed bin (35);
	dcl     non_alphanum_char_index fixed bin;
	dcl     special_token_sort_index fixed bin;
	dcl     alphanum_token_sort_index fixed bin;

/* Based */
/* Builtin */
/* Controlled */
/* Constant */
/* Entry */
/* External */
/* END OF DECLARATIONS */

	alphanum_token_list_size = hbound (mrds_dsm_terminals.TL, 1);
	special_token_list_size = hbound (mrds_dsm_terminals.TL, 1);
	allocate alphanum_token_list in (work_area);
	allocate special_token_list in (work_area);
	mrds_dsm_scanner_info.special_token_list_ptr = special_token_list_ptr;
	mrds_dsm_scanner_info.alphanum_token_list_ptr = alphanum_token_list_ptr;

	alphanum_token_list_index = 0;
	special_token_list_index = 0;

	do token_list_index = 1 to hbound (mrds_dsm_terminals.TL, 1);
	     current_terminal =
		substr (string (mrds_dsm_terminals.TC),
		mrds_dsm_terminals.TL (token_list_index).fc,
		mrds_dsm_terminals.TL (token_list_index).ln);
	     non_alphanum_char_index =
		index (ALPHANUM_CHARS, substr (current_terminal, 1, 1));

	     if non_alphanum_char_index > 0 then do;
		     alphanum_token_list_index = alphanum_token_list_index + 1;
		     do alphanum_token_sort_index = alphanum_token_list_index - 1 to 1
			by -1
			while (mrds_dsm_terminals.TL (token_list_index).ln
			> mrds_dsm_terminals
			.TL (alphanum_token_list.index (alphanum_token_sort_index)).ln);
			alphanum_token_list.index (alphanum_token_sort_index + 1) =
			     alphanum_token_list.index (alphanum_token_sort_index);
		     end;
		     alphanum_token_list.index (alphanum_token_sort_index + 1) =
			token_list_index;
		end;
	     else if current_terminal = "<identifier>" then
		mrds_dsm_scanner_info.identifier_encoding = token_list_index;
	     else do;
		     special_token_list_index = special_token_list_index + 1;
		     do special_token_sort_index = special_token_list_index - 1 to 1
			by -1
			while (mrds_dsm_terminals.TL (token_list_index).ln
			> mrds_dsm_terminals
			.TL (special_token_list.index (special_token_sort_index)).ln);
			special_token_list.index (special_token_sort_index + 1) =
			     special_token_list.index (special_token_sort_index);
		     end;
		     special_token_list.index (special_token_sort_index + 1) =
			token_list_index;
		end;
	end;
	alphanum_token_list.size = alphanum_token_list_index;
	special_token_list.size = special_token_list_index;

     end;

report_mds_error:
     proc (p_severity, p_error_code, p_message);

/* PARAMETER */

	dcl     p_severity		 fixed bin;
	dcl     p_error_code	 fixed bin (35);
	dcl     p_message		 char (*);


	mrds_dsm_scanner_info.highest_severity =
	     max (p_severity, mrds_dsm_scanner_info.highest_severity);

	call
	     ioa_$ioa_switch (mrds_dsm_scanner_info.error_iocb_ptr,
	     "^/Severity ^d, ^a^/^a", p_severity,
	     MRDS_DSM_ERROR_MESSAGE (p_error_code), p_message);

	if mrds_dsm_scanner_info.listing_iocb_ptr ^= null () then
	     call
		ioa_$ioa_switch (mrds_dsm_scanner_info.listing_iocb_ptr,
		"^/Severity ^d, ^a^/^a", p_severity,
		MRDS_DSM_ERROR_MESSAGE (p_error_code), p_message);

     end;						/* End of report_mds_error. */

add_cardinal_suffix:
     proc (p_num) returns (char (32) varying) options (non_quick);

/* The options(nonquick) is used to avoid a compiler bug.  This procedure is
   called in a stack extension and should therefore  be non-quick.  The compiler
   neglects to make it so, however.
*/

	dcl     p_num		 fixed bin (35);
	dcl     num_pic		 pic "zzzzzzzzzz9";
	dcl     rev		 char (2);
	dcl     SUFFIX		 (0:3) char (2) internal static options (constant)
				 init ("th", "st", "nd", "rd");
	dcl     idx		 fixed bin;

	num_pic = p_num;
	rev = substr (reverse (num_pic), 1, 2);		/* CHANGE 81-09-16 */
	if rev = "11" | rev = "21" | rev = "31" then
	     idx = 0;
	else idx = index ("123", substr (rev, 1, 1));

	return (ltrim (num_pic) || SUFFIX (idx));
     end;

%include mrds_dsm_parse_stack;
%page;
%include mrds_dsm_scan_info;
%page;
%include mrds_dsm_error_info;
%page;
%include mrds_dsm_terminals;


     end;





		    mrds_dsm_semantics.pl1          04/18/85  1429.4re  04/18/85  0907.0      312363



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


/* -sem mrds_dsm_semantics
   -ssl
   -table mrds_dsm_parse_table
   -alm
   -term
   -ct
   -recover ;
   -order
   <identifier>
   ;
   -parse */

mrds_dsm_semantics: proc (p_mrds_dsm_semantics_info_ptr, rule, alt, p_lex_stack_ptr, ls_top, p_code);

/*
   This is the LRK source and the semantics for parsing  mrds  cmdsm
   sources. The source mrds_dsm_semantics.pl1 is produced by running
   LRK  over  mrds_dsm_parse.lrk.  Changes  should  never  be   made
   directly   to  the  module  mrds_dsm_semantics,  but  instead  to
   mrds_dsm_parse.lrk.

   The production of a dsm is a two pass  process,  the  first  pass
   being  done  by this module (mrds_dsm_semantics) in collaboration
   with mrds_dsm_parse and mrds_dsm_scanner, and the various  tables
   and  include  files  built  by LRK using mrds_dsm_parse.lrk. This
   produces a submodel with all of the relation records  implied  by
   the  cmdsm,  with  attribute  names  filled in but no access bits
   turned on. The second pass is  done  by  mrds_dsm_compute_access.
   This  consists  solely  of  setting access bits. Using two passes
   allows the syntax  for  cmdsm  sources  to  be  completely  order
   independent,  e.g.  one  needn't define a relation before setting
   access to it (or vice versa).

   Present in the submodel at this  time  are  also  various  access
   records,  default  relation  access,  default  attribute  access,
   relation access, and attribute access.  The  record  portions  of
   these   records   are  all  identical,  being  the  access_record
   structure.  The  keys  are   built   using   strings   from   the
   mrds_dsm_head_strings  include  file  and  relation and attribute
   names, concatenating strings together in some instances.

   The  basic  scheme  of  the  semantics  is  that  each  RULE   is
   individually   invoked   by  the  parser,  mrds_dsm_parse.  Where
   necessary to keep track of information between successive  RULEs,
   the  semantics pointer in the lex_stack is used to hang arbitrary
   structures off of.  For  instance,  the  alias  RULE  leaves  the
   semantics  pointer  pointing  at  an  alias  structure  with null
   forward and backward pointers. The alias  list  RULE  leaves  the
   semantics  pointer  pointing at an end of a doubly linked list of
   alias structures. The relation spec RULE actually uses the  alias
   structures  to  figure  out  the  dsm  relation  name,  the model
   relation name, and the dsm and model attribute names.

   Known Bugs:

   Other Problems:

   1) mode_str has to be changed from update to modify. It  must  be
   changed  simultaneously  in  several modules. Since the user does
   not see the update value there is no hurry.

   HISTORY:

   ??-??-?? Spratt: written.

   80-09-20 Spratt: The alias list was being followed backwards (via
   .        the "prev" pointers) when filling  in  the  rel_rec.attr
   .        array  in  the  code  for  the  "relation specification"
   .        production. This was changed to follow  the  alias  list
   .        along  the "next" thread, hence recording the attributes
   .        in the correct order.

   80-09-25 Spratt: Added  the  "in  <relation>"  construct  to  the
   .        attracc statement.

   80-12-05 Spratt: Removed status relation  access  keyword,  added
   .        "null"  relation  access  keyword.  Formatted  the   lrk
   .        source.

   81-01-05 Davids: changed the update and u keywords to modify  and
   .        m. added the  keywords  append_tuple  and  delete_tuple.
   .        removed  the  keywords  status and s. added the key word
   .        with and corrected rel  access  spec  to  use  the  with
   .        keyword.

   .        Added  the  attribute   access   modes   read_attr   and
   .        modify_attr,  changed  read  and modify to read attr and
   .        modify attr. Changed deltup and apptup to d and a.

   81-01-27 Davids: added statements to free the alias, rel_rec  and
   .        access_record structures.

   81-02-03 Davids: modified the rel access spec rule alternative  2
   .        (with option) to take the symbol and symbol length  from
   .        ls_top  -  8 rather than 7. 7 was just plain wrong. Also
   .        the rel_access_head had to take  the  semantics  pointer
   .        from ls_top - 6 rather than 5.

   81-03-09 Davids: modified default  relation  access  and  default
   .        attribute access statements so that the access list  may
   .        optionaly be enclosed in ().

   81-04-28     Davids:     replaced      the      reference      to
   .        cmdsm_access_record.incl.pl1                        with
   .        mrds_dsm_access_record.incl.pl1

   .        added a statement  in  the  make_access_record  internal
   .        procedure  to  set  the  used  bit  of the access_record
   .        structure to "0"b;

   81-04-29 Davids: replaced the  include  file  cmdsm_rel_rec  with
   .        mrds_dsm_rel_rec_5.  all  references  to  rel_rec  where
   .        changed   to   rel_rec_5   and   the  pointer  reference
   .        rel_rec_5_ptr was added to all references to rel_rec_5.

   81-05-08  Davids:  added  the   validate_relation   routine   and
   .        corrected the report_error routine to be able to  report
   .        errors   with   severity  greater  than  1  with  out  a
   .        conversion error (there was an  extra  ^d  in  the  ioa_
   .        control string).

   .        removed the use  of  include  files  from  the  internal
   .        procedures  make_access_record  and free_link_list. this
   .        was done by declaring local pointers and refering to the
   .        based  structures  using  the pointer. The local copy is
   .        perhaps not needed but i'm stcking to the original  code
   .        as much as possible.

   81-05-11 Davids: added calls to ioa using the listing iocb_ptr if
   .        that pointer is non-null (in the report_error procedure)

   .        removed  some  undeclared   variables   (including   the
   .        iox_dcls include file - explicitly declared seek_key and
   .        write_record)  and  declared  some  builtins  that  were
   .        implicitly declared.

   81-05-12 Davids: added code to validate that no relation has  the
   .        same submodel attribute name defined twice or  uses  the
   .        same  model  attribute  to define two different submodel
   .        attributes.

   81-05-13 Davids: added code to check  the  lengths  of  both  the
   .        submodel relation name  and  attribute  name.  attribute
   .        names  are  checked  in  the  validate_relation routine,
   .        relation names are checked in the relation_specification
   .        rule (which later calls validate_relation) because it is
   .        the only  place  that  the  submodel  relation  name  is
   .        available.

   81-05-20 Davids:  changed  relacc  and  attracc  to  rel_acc  and
   .        attr_acc.

   81-05-21  Davids:  moved  code  that  checks  the  length of the
   .       submodel name to the validate_relation proc and pass the
   .       name to that proc as a parameter.

   .       added  code  to write a model_relation_name key for each
   .       relation.   the  key  points  to  the  submodel relation
   .       record.   this  code  is  used  to  be sure that a model
   .       relation is used to define only 1 submodel relation.

   81-05-22 Davids: changed code so that the model relation name key
   .        is not pointing at the relation  record  but  at  a  new
   .        (just written) record that contains no information. this
   .        was because having the two keys pointing at the relation
   .        record was screwing up compute_access which uses the key
   .        value to get the relation name.

   81-05-28 Davids: changed the cmdsm_head_strings include  file  to
   .        mrds_dsm_head_strings      include     file,     changed
   .        cmdsm_link_list include file to mrds_dsm_link_list.
*/

/* PARAMETER */

	dcl     p_mrds_dsm_semantics_info_ptr ptr;
	dcl     p_code		 fixed bin (35);
	dcl     rule		 fixed bin (24);
	dcl     alt		 fixed bin (24);
	dcl     p_lex_stack_ptr	 ptr;
	dcl     ls_top		 fixed bin (24);

/* AUTOMATIC */

	dcl     rel_rec_5_ptr	 ptr init (null ());
	dcl     work_area_ptr	 ptr;
	dcl     debug_sw		 bit (1) aligned;
	dcl     submodel_iocb_ptr	 ptr;
	dcl     message		 char (256);
	dcl     message_length;
	dcl     alias_ptr		 ptr;
	dcl     key_string		 char (256) varying;
	dcl     code		 fixed bin (35);
	dcl     attr_idx		 fixed bin;
	dcl     rec_len		 fixed bin (21);
	dcl     mode_str		 char (32) varying;
	dcl     temp_ptr		 ptr;

/* BASED */

	dcl     work_area		 area (261120) based (work_area_ptr);
	dcl     seg_str		 char (261120) based;
	dcl     1 alias		 based (alias_ptr),
		2 prev		 ptr,
		2 next		 ptr,
		2 dm_name		 char (256) varying,
		2 dsm_name	 char (256) varying;

/* BUILTIN */

	dcl     max		 builtin;
	dcl     null		 builtin;
	dcl     currentsize		 builtin;
	dcl     hbound		 builtin;
	dcl     length		 builtin;
	dcl     addr		 builtin;
	dcl     substr		 builtin;

/* ENTRY */

	dcl     mrds_dm_get_attributes entry (ptr, char (32), ptr, ptr, fixed bin (35));
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     ioa_$rs		 entry options (variable);
	dcl     ioa_		 entry () options (variable);
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$no_record fixed bin (35) external static;
	dcl     error_table_$key_duplication fixed bin (35) external static;
	dcl     mrds_error_$inconsistent_submodel fixed bin (35) external static;
	dcl     mrds_error_$invalid_rel fixed bin (35) external static;
	dcl     mrds_error_$no_model_attr fixed bin (35) external static;
	dcl     mrds_error_$no_model_rel fixed bin (35) external static;

	mrds_dsm_semantics_info_ptr = p_mrds_dsm_semantics_info_ptr;
	submodel_iocb_ptr = mrds_dsm_semantics_info.submodel_iocb_ptr;
	work_area_ptr = mrds_dsm_semantics_info.work_area_ptr;
	debug_sw = mrds_dsm_semantics_info.debug_semantics;
	lex_stack_ptr = p_lex_stack_ptr;
	p_code = 0;

	goto RULE (rule);

/* <source> ::= <statement list> ! */
RULE (0001):
	if debug_sw
	then call ioa_ ("Source.");
	return;

/* <statement list> ::= <statement list> <statement> | <statement> ! */
RULE (0002):
	if debug_sw
	then call ioa_ ("Statement list.");
	return;

/* <statement> ::= <relation statement>
   |<relation access statement>
   |<attribute access statement>
   |<default relation access statement>
   |<default attribute access statement>! */
RULE (0003):
	if debug_sw
	then call ioa_ ("Statement");
	return;

/* <relation statement> ::= <relation key> ': <relation specification list> ;! */
RULE (0004):
	if debug_sw
	then call ioa_ ("Relation statement.");
	return;

/* <relation specification list> ::= <relation specification list>, <relation specification>
   |<relation specification>! */
RULE (0005):
	if debug_sw
	then call ioa_ ("Relation specification list.");
	return;

/* <relation specification> ::= <alias> (<alias list>)! */
RULE (0006):
	if debug_sw
	then call ioa_ ("Relation specification.");
	key_string = REL_HEAD || lex_stack (ls_top - 3).semantics_ptr -> alias.dsm_name;
	call iox_$seek_key (submodel_iocb_ptr, key_string, rec_len, code);
	if code = 0
	then do;
		call ioa_$rs ("Relation ^a in line number ^d.", message, message_length,
		     lex_stack (ls_top - 3).semantics_ptr -> alias.dsm_name, lex_stack (ls_top - 3).line);
		call report_error (1, (DUPLICATE_RELATION_DEF_ERROR), (message));
		return;
	     end;
	else if code ^= error_table_$no_record
	then do;
		call ioa_$rs ("Unable to make entry for relation ^a in submodel.", message, message_length,
		     lex_stack (ls_top - 3).semantics_ptr -> alias.dsm_name);
		call report_error (4, (code), (message));
		return;
	     end;

/*  The semantics_ptr points at the tail of the alias list. When through with
   this loop, alias_ptr will point at the root ot the alias list.
*/

	alias_ptr = lex_stack (ls_top - 1).semantics_ptr;
	do attr_idx = 1 by 1 while (alias.prev ^= null);
	     alias_ptr = alias.prev;
	end;

	rel_rec_5_attr_num = attr_idx;
	allocate rel_rec_5 in (work_area) set (rel_rec_5_ptr);
	rel_rec_5_ptr -> rel_rec_5.rel_dm_name = lex_stack (ls_top - 3).semantics_ptr -> alias.dm_name;

/* alias_ptr is set to the "Root" of the list of aliases (attributes) by the short loop
   following the "prev" chain, above.
*/

	do attr_idx = 1 to rel_rec_5_attr_num;
	     rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name = alias.dsm_name;
	     rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dm_name = alias.dm_name;
	     temp_ptr = alias_ptr;
	     alias_ptr = alias.next;
	     free temp_ptr -> alias in (work_area);
	end;

	call iox_$write_record (submodel_iocb_ptr, rel_rec_5_ptr, 4 * currentsize (rel_rec_5_ptr -> rel_rec_5), code);
	if code ^= 0
	then do;
		call ioa_$rs ("Unable to write submodel entry for relation ^a.", message, message_length,
		     rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		call report_error (4, (code), message);
	     end;

	call validate_relation (lex_stack (ls_top - 3).semantics_ptr -> alias.dsm_name);

	free rel_rec_5_ptr -> rel_rec_5 in (work_area);

	return;

/* <alias list> ::= <alias list> <alias> | <alias>! */
RULE (0007):
	if debug_sw
	then call ioa_ ("Alias list.");
	if alt = 1
	then do;
		lex_stack (ls_top).semantics_ptr -> alias.prev = lex_stack (ls_top - 1).semantics_ptr;
		lex_stack (ls_top - 1).semantics_ptr -> alias.next = lex_stack (ls_top).semantics_ptr;
		lex_stack (ls_top - 1).semantics_ptr = lex_stack (ls_top).semantics_ptr;
	     end;
	return;

/* <alias> ::= <general identifier> '= <general identifier> | <general identifier>! */
RULE (0008):
	if debug_sw
	then call ioa_ ("Alias.");
	allocate alias in (work_area);
	alias.prev = null;
	alias.next = null;
	alias.dm_name = substr (lex_stack (ls_top).symptr -> seg_str, 1, lex_stack (ls_top).symlen);
	if alt = 1
	then do;
		alias.dsm_name = substr (lex_stack (ls_top - 2).symptr -> seg_str, 1, lex_stack (ls_top - 2).symlen);
		lex_stack (ls_top - 2).semantics_ptr = alias_ptr;
	     end;
	else do;
		alias.dsm_name = substr (lex_stack (ls_top).symptr -> seg_str, 1, lex_stack (ls_top).symlen);
		lex_stack (ls_top).semantics_ptr = alias_ptr;
	     end;
	return;

/* <relation access statement> ::= <relation access key> ': <rel access spec list> ;! */
RULE (0009):
	if debug_sw
	then call ioa_ ("Relation access statement.");
	return;

/* <rel access spec list> ::= <rel access spec list>, <rel access spec>
   |<rel access spec>! */
RULE (0010):
	if debug_sw
	then call ioa_ ("Rel access spec list.");
	return;

/* <rel access spec> ::= <general identifier> (<rel access modes list>)
   | <general identifier> (<rel access modes list>) <with keyword> <attribute access key> (<attr access modes list>)! */
RULE (0011):
	if debug_sw
	then call ioa_ ("Rel access spec.");
	if alt = 1
	then do;
		call process_access (REL_ACCESS_HEAD
		     || substr (lex_stack (ls_top - 3).symptr -> seg_str, 1, lex_stack (ls_top - 3).symlen),
		     lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then do;
			p_code = code;
			return;
		     end;
	     end;
	else if alt = 2
	then do;
		call process_access (REL_ACCESS_HEAD
		     || substr (lex_stack (ls_top - 8).symptr -> seg_str, 1, lex_stack (ls_top - 8).symlen),
		     lex_stack (ls_top - 6).semantics_ptr, code);
		if code ^= 0
		then do;
			p_code = code;
			return;
		     end;
		call process_access (REL_ATTR_ACCESS_HEAD
		     || substr (lex_stack (ls_top - 8).symptr -> seg_str, 1, lex_stack (ls_top - 8).symlen),
		     lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then do;
			p_code = code;
			return;
		     end;
	     end;

	return;

/* <rel access modes list> ::= <rel access modes list>, <relation access mode key>
   | <relation access mode key>! */
RULE (0012):
	if debug_sw
	then call ioa_ ("Rel access mode list.");
	if alt = 1
	then do;
		lex_stack (ls_top).semantics_ptr -> link.prev = lex_stack (ls_top - 2).semantics_ptr;
		lex_stack (ls_top - 2).semantics_ptr -> link.next = lex_stack (ls_top).semantics_ptr;
		lex_stack (ls_top - 2).semantics_ptr = lex_stack (ls_top).semantics_ptr;
	     end;
	return;



/* <relation access mode key> ::= <delete tuple key>
   | <null key>
   | <append tuple key>! */
RULE (0013):
	if debug_sw
	then call ioa_ ("Relation access mode key.");
	if alt = 1
	then mode_str = "delete_tuple";
	else if alt = 2
	then mode_str = "null";
	else mode_str = "append_tuple";

	link_str_len = length (mode_str);
	allocate link in (work_area);
	link.str = mode_str;
	link.next = null;
	link.prev = null;
	lex_stack (ls_top).semantics_ptr = link_ptr;
	return;

/* <attribute access statement> ::= <attribute access key> ': <attr access spec list> ;! */
RULE (0014):
	if debug_sw
	then call ioa_ ("Attribute access statement.");
	return;

/* <attr access spec list> ::= <attr access spec list>, <attr access spec>
   | <attr access spec>! */
RULE (0015):
	if debug_sw
	then call ioa_ ("Attr access spec list.");
	return;

/* <attr access spec> ::= <general identifier> (<attr access modes list>)
   | <general identifier> <in keyword> <general identifier> (<attr access modes list>)! */
RULE (0016):
	if debug_sw
	then call ioa_ ("Attr access spec.");
	if alt = 1
	then do;
		call process_access (ATTR_ACCESS_HEAD
		     || substr (lex_stack (ls_top - 3).symptr -> seg_str, 1, lex_stack (ls_top - 3).symlen),
		     lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
		return;
	     end;
	else do;
		call process_access (ATTR_ACCESS_HEAD
		     || substr (lex_stack (ls_top - 5).symptr -> seg_str, 1, lex_stack (ls_top - 5).symlen)
		     || ATTR_REL_DELIMITER
		     || substr (lex_stack (ls_top - 3).symptr -> seg_str, 1, lex_stack (ls_top - 3).symlen),
		     lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
		return;
	     end;

/* <attr access modes list> ::= <attr access modes list>, <attribute access mode key>
   | <attribute access mode key>! */
RULE (0017):
	if debug_sw
	then call ioa_ ("Attr access mode list.");
	if alt = 1
	then do;
		lex_stack (ls_top).semantics_ptr -> link.prev = lex_stack (ls_top - 2).semantics_ptr;
		lex_stack (ls_top - 2).semantics_ptr -> link.next = lex_stack (ls_top).semantics_ptr;
		lex_stack (ls_top - 2).semantics_ptr = lex_stack (ls_top).semantics_ptr;
	     end;
	return;

/* <attribute access mode key> ::= <read key> | <null key> | <modify key>! */
RULE (0018):
	if debug_sw
	then call ioa_ ("Attribute access mode key.");
	if alt = 1
	then mode_str = "read";
	else if alt = 2
	then mode_str = "null";
	else if alt = 3
	then mode_str = "update";
	link_str_len = length (mode_str);
	allocate link in (work_area);
	link.str = mode_str;
	link.prev = null;
	link.next = null;
	lex_stack (ls_top).semantics_ptr = link_ptr;
	return;

/* <default attribute access statement> ::= <default attribute access key> ': <attr access modes list> ;
   |   <default attribute access key> ': (<attr access modes list>) ;! */
RULE (0019):
	if debug_sw
	then call ioa_ ("Default attribute access statement.");
	if alt = 1
	then do;
		call process_access ((DEF_ATTR_ACCESS_HEAD), lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
	     end;
	else
	     if alt = 2
	then do;
		call process_access ((DEF_ATTR_ACCESS_HEAD), lex_stack (ls_top - 2).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
	     end;
	return;

/* <default relation access statement> ::= <default relation access key> ': <rel access modes list> ;
   |   <default relation access key> ': (<rel access modes list>) ;! */
RULE (0020):
	if debug_sw
	then call ioa_ ("Default relation access statement.");
	if alt = 1
	then do;
		call process_access ((DEF_REL_ACCESS_HEAD), lex_stack (ls_top - 1).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
	     end;
	else
	     if alt = 2
	then do;
		call process_access ((DEF_REL_ACCESS_HEAD), lex_stack (ls_top - 2).semantics_ptr, code);
		if code ^= 0
		then p_code = code;
	     end;
	return;



/* <relation access key> ::= <relation keyword> <access keyword> | <rel_acc keyword>! */
RULE (0021):
	if debug_sw
	then call ioa_ ("Relation access key.");
	return;

/* <attribute access key> ::= <attribute keyword> <access keyword> | <attr_acc keyword>! */
RULE (0022):
	if debug_sw
	then call ioa_ ("Attribute access key.");
	return;

/* <default attribute access key> ::= <default keyword> <attribute keyword > <access keyword> | <default keyword> <attr_acc keyword>! */
RULE (0023):
	if debug_sw
	then call ioa_ ("Default attribute access key.");
	return;

/* <default relation access key> ::= <default keyword> <relation keyword> <access keyword> | <default keyword> <rel_acc keyword>! */
RULE (0024):
	if debug_sw
	then call ioa_ ("Default relation access key.");
	return;



/* <delete tuple key> ::= <delete keyword> <tuple keyword> | <d keyword> | <delete_tuple keyword>! */
RULE (0025):
	if debug_sw
	then call ioa_ ("Delete tuple key.");
	return;

/* <append tuple key> ::= <append keyword> <tuple keyword> | <a keyword> | <append_tuple keyword>! */
RULE (0026):
	if debug_sw
	then call ioa_ ("Append tuple key.");
	return;

/* <read key> ::= <read keyword> <attr keyword> | <read_attr keyword> | <r keyword>! */
RULE (0027):
	if debug_sw
	then call ioa_ ("Read key.");
	return;

/* <modify key> ::= <modify keyword> <attr keyword> | <modify_attr keyword> | <m keyword>! */
RULE (0028):
	if debug_sw
	then call ioa_ ("Update key.");
	return;

/* <null key> ::= <null keyword> | <n keyword>! */
RULE (0029):
	if debug_sw
	then call ioa_ ("Null key.");
	return;

/* <general identifier> ::= <identifier>
   | <relation keyword>
   | <attribute keyword>
   | <access keyword>
   | <attr_acc keyword>
   | <rel_acc keyword>
   | <default keyword>
   | <in keyword>
   | <with keyword>
   | <delete keyword>
   | <append keyword>
   | <tuple keyword>
   | <attr keyword>
   | <d keyword>
   | <a keyword>
   | <delete_tuple keyword>
   | <append_tuple keyword>
   | <read keyword>
   | <read_attr keyword>
   | <r keyword>
   | <modify keyword>
   | <modify_attr keyword>
   | <m keyword>
   | <null keyword>
   | <n keyword>! */
RULE (0030):
	if debug_sw
	then call ioa_ ("General identifier.");
	return;

/* <relation keyword> ::= relation! */
RULE (0031):
	if debug_sw
	then call ioa_ ("Relation keyword.");
	return;

/* <attribute keyword> ::= attribute! */
RULE (0032):
	if debug_sw
	then call ioa_ ("Attribute keyword.");
	return;

/* <access keyword> ::= access! */
RULE (0033):
	if debug_sw
	then call ioa_ ("Access keyword.");
	return;

/* <rel_acc keyword> ::= rel_acc! */
RULE (0034):
	if debug_sw
	then call ioa_ ("Rel_acc keyword.");
	return;

/* <attr_acc keyword> ::= attr_acc! */
RULE (0035):
	if debug_sw
	then call ioa_ ("Attr_acc keyword.");
	return;

/* <default keyword> ::= default! */
RULE (0036):
	if debug_sw
	then call ioa_ ("Default keyword.");
	return;

/* <relation key> ::= <relation keyword>! */
RULE (0037):
	if debug_sw
	then call ioa_ ("Relation key.");

/* <in keyword> ::= in! */
RULE (0038):
	if debug_sw
	then call ioa_ ("In keyword.");
	return;

/* <with keyword> ::= with! */
RULE (0039):
	if debug_sw
	then call ioa_ ("With keyword.");
	return;

/* <delete keyword> ::= delete! */
RULE (0040):
	if debug_sw
	then call ioa_ ("Deltup keyword.");
	return;

/* <append keyword> ::= append! */
RULE (0041):
	if debug_sw
	then call ioa_ ("Apptup keyword.");
	return;

/* <tuple keyword> ::= tuple! */
RULE (0042):
	if debug_sw
	then call ioa_ ("Tuple keyword.");
	return;

/* <attr keyword> ::= attr! */
RULE (0043):
	if debug_sw
	then call ioa_ ("Attr keyword.");
	return;

/* <d keyword> ::= d! */
RULE (0044):
	if debug_sw
	then call ioa_ ("D keyword.");
	return;

/* <a keyword> ::= a! */
RULE (0045):
	if debug_sw
	then call ioa_ ("A keyword.");
	return;

/* <delete_tuple keyword> ::= delete_tuple! */
RULE (0046):
	if debug_sw
	then call ioa_ ("Delete_tuple keyword.");
	return;

/* <append_tuple keyword> ::= append_tuple! */
RULE (0047):
	if debug_sw
	then call ioa_ ("Append_tuple keyword.");
	return;

/* <read keyword> ::= read! */
RULE (0048):
	if debug_sw
	then call ioa_ ("Read keyword.");
	return;

/* <read_attr keyword> ::= read_attr! */
RULE (0049):
	if debug_sw
	then call ioa_ ("Read_attr keyword.");
	return;

/* <modify keyword> ::= modify! */
RULE (0050):
	if debug_sw
	then call ioa_ ("Update keyword.");
	return;

/* <modify_attr keyword> ::= modify_attr! */
RULE (0051):
	if debug_sw
	then call ioa_ ("Modify_attr keuword.");
	return;

/* <null keyword> ::= null! */
RULE (0052):
	if debug_sw
	then call ioa_ ("Null keyword.");
	return;

/* <n keyword> ::= n! */
RULE (0053):
	if debug_sw
	then call ioa_ ("N keyword.");
	return;

/* <r keyword> ::= r! */
RULE (0054):
	if debug_sw
	then call ioa_ ("R keyword.");
	return;

/* <m keyword> ::= m! */
RULE (0055):
	if debug_sw
	then call ioa_ ("U keyword.");
	return;

make_access_record: proc (p_link_ptr, p_work_area_ptr, p_access_rec_ptr);

/* PARAMETER */

	dcl     p_link_ptr		 ptr;
	dcl     p_work_area_ptr	 ptr;
	dcl     p_access_rec_ptr	 ptr;

/* AUTOMATIC */

	dcl     local_access_record_ptr ptr;
	dcl     local_link_ptr	 ptr;
	dcl     mode_idx		 fixed bin;

/* BASED */

	dcl     work_area		 area (261120) based (p_work_area_ptr);



	local_link_ptr = p_link_ptr;
	do mode_idx = 0 by 1 while (local_link_ptr ^= null);
	     local_link_ptr = local_link_ptr -> link.prev;
	end;

	access_record_mode_num = mode_idx;
	allocate access_record in (work_area) set (local_access_record_ptr);
	local_link_ptr = p_link_ptr;
	do mode_idx = 1 to access_record_mode_num;
	     local_access_record_ptr -> access_record.modes (mode_idx) = local_link_ptr -> link.str;
	     local_link_ptr = local_link_ptr -> link.prev;
	end;
	local_access_record_ptr -> access_record.used = "0"b;
	p_access_rec_ptr = local_access_record_ptr;

	return;

     end;						/* End of make_access_record. */

free_link_list: proc (p_link_ptr, p_work_area_ptr);

/* PARAMETER */

	dcl     p_link_ptr		 ptr;
	dcl     p_work_area_ptr	 ptr;

/* AUTOMATIC */

	dcl     local_link_ptr	 ptr;
	dcl     prev_link_ptr	 ptr;

/* BASED */

	dcl     work_area		 based (p_work_area_ptr) area (261120);



	local_link_ptr = p_link_ptr;
	do while (local_link_ptr ^= null);
	     prev_link_ptr = local_link_ptr -> link.prev;
	     free local_link_ptr -> link in (work_area);
	     local_link_ptr = prev_link_ptr;
	end;

	return;

     end;						/* End of free_link_list. */

report_error: proc (p_severity, p_error_number, p_message);

/* PARAMETER */

	dcl     p_severity		 fixed bin;
	dcl     p_error_number	 fixed bin (35);
	dcl     p_message		 char (*);

/* AUTOMATIC */

	dcl     long_message	 char (100);
	dcl     short_message	 char (8);

/* ENTRIES */

	dcl     convert_status_code_	 entry (fixed bin (35), char (8), char (100));


	if p_error_number > hbound (MRDS_DSM_ERROR_MESSAGE, 1)
	then do;
		call convert_status_code_ (p_error_number, short_message, long_message);
		call ioa_$ioa_switch (mrds_dsm_semantics_info.error_iocb_ptr,
		     "^[Severity ^d, Error^;^sWarning^] On or Before Line ^d.^/^a^/^a", (p_severity > 1), p_severity,
		     lex_stack (ls_top).line, long_message, p_message);
		if mrds_dsm_semantics_info.listing_iocb_ptr ^= null ()
		then do;
			call ioa_$ioa_switch (mrds_dsm_semantics_info.listing_iocb_ptr,
			     "^[Severity ^d, Error^;^sWarning^] On or Before Line ^d.^/^a^/^a", (p_severity > 1), p_severity,
			     lex_stack (ls_top).line, long_message, p_message);
		     end;
	     end;
	else do;
		call ioa_$ioa_switch (mrds_dsm_semantics_info.error_iocb_ptr,
		     "^[Severity ^d, Error^;^sWarning^] On or Before Line ^d.^/^a^/^a", (p_severity > 1), p_severity,
		     lex_stack (ls_top).line, MRDS_DSM_ERROR_MESSAGE (p_error_number), p_message);
		if mrds_dsm_semantics_info.listing_iocb_ptr ^= null ()
		then do;
			call ioa_$ioa_switch (mrds_dsm_semantics_info.listing_iocb_ptr,
			     "^[Severity ^d, Error^;^sWarning^] On or Before Line ^d.^/^a^/^a", (p_severity > 1), p_severity,
			     lex_stack (ls_top).line, MRDS_DSM_ERROR_MESSAGE (p_error_number), p_message);
		     end;
	     end;
	mrds_dsm_semantics_info.highest_severity = max (mrds_dsm_semantics_info.highest_severity, p_severity);
     end;						/* End of report_error. */

process_access: proc (p_key_string, p_link_list_ptr, p_code);

	dcl     p_key_string	 char (256) varying;
	dcl     p_link_list_ptr	 ptr;
	dcl     p_code		 fixed bin (35);



	call iox_$seek_key (submodel_iocb_ptr, p_key_string, rec_len, p_code);
	if p_code = 0
	then do;
		p_code = error_table_$key_duplication;
		call ioa_$rs ("Multiple specifications for ^a submodel entry.", message, message_length, p_key_string);
		call report_error (2, DUPLICATE_ENTRY_ERROR, (message));
		return;
	     end;
	else if p_code ^= error_table_$no_record
	then do;
		call ioa_$rs ("Unable to seek submodel entry for ^a.", message, message_length, p_key_string);
		call report_error (4, (p_code), (message));
		return;
	     end;

	call make_access_record (p_link_list_ptr, work_area_ptr, access_record_ptr);

	call iox_$write_record (submodel_iocb_ptr, access_record_ptr, 4 * currentsize (access_record), p_code);
	if p_code ^= 0
	then do;
		call ioa_$rs ("Unable to write submodel entry for ^a.", message, message_length, p_key_string);
		call report_error (4, (p_code), (message));
		return;
	     end;

	free access_record_ptr -> access_record in (work_area);

	call free_link_list (p_link_list_ptr, work_area_ptr);
	p_code = 0;
     end;						/* End of process_access. */

validate_relation: proc (dsm_relation_name);

	dcl     dsm_relation_name	 char (256) varying;

	dcl     found		 bit (1) unal;
	dcl     model_attr_idx	 fixed bin;
	dcl     j			 fixed bin;

	if length (dsm_relation_name) > 30
	then do;
		call ioa_$rs ("Submodel relation name ^a has exceeded the maximum length of 30 characters",
		     message, message_length, dsm_relation_name);
		call report_error (4, mrds_error_$inconsistent_submodel, message);
	     end;

	call mrds_dm_get_attributes
	     (mrds_dsm_semantics_info.data_model_ptr,
	     (rel_rec_5_ptr -> rel_rec_5.rel_dm_name),
	     work_area_ptr,
	     rd_ptr,
	     code);
	if code = mrds_error_$no_model_rel
	then do;
		call ioa_$rs ("Model relation ^a does not exist in the database", message, message_length,
		     rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		call report_error (4, mrds_error_$invalid_rel, message);
		return;
	     end;
	else
	     if code ^= 0
	then do;
		call ioa_$rs ("Unable to read model relation ^a for validation", message, message_length,
		     rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		call report_error (4, code, message);
		return;
	     end;

	do attr_idx = 1 to rel_rec_5_attr_num;

	     if length (rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name) > 32
	     then do;
		     call ioa_$rs ("Submodel attribute name ^a has exceeded the maximum length of 32 characters",
			message, message_length, rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name);
		     call report_error (4, mrds_error_$inconsistent_submodel, message);
		end;

	     found = "0"b;
	     do model_attr_idx = 1 to rd_ptr -> rel_desc.num_attr while (^found);
		if rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dm_name
		     = rd_ptr -> rel_desc.attributes (model_attr_idx).attribute_name
		then found = "1"b;
	     end;
	     if ^found
	     then do;
		     call ioa_$rs ("Model attribute ^a used in defining submodel attribute ^a does " ||
			"not exist in the model relation ^a", message, message_length,
			rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dm_name,
			rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name,
			rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		     call report_error (4, mrds_error_$no_model_attr, message);
		end;

	     do j = 1 to attr_idx - 1;

		if rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dsm_name
		     = rel_rec_5_ptr -> rel_rec_5.attr (j).dsm_name
		then do;
			call ioa_$rs ("Submodel attribute ^a defined multiple times at attribute positions ^i and ^i",
			     message, message_length, rel_rec_5_ptr -> rel_rec_5.attr (j).dsm_name,
			     j, attr_idx);
			call report_error (4, mrds_error_$inconsistent_submodel, message);
		     end;

		if rel_rec_5_ptr -> rel_rec_5.attr (attr_idx).dm_name
		     = rel_rec_5_ptr -> rel_rec_5.attr (j).dm_name
		then do;
			call ioa_$rs ("Model attribute ^a used multiple times at attribute positions ^i and ^i",
			     message, message_length, rel_rec_5_ptr -> rel_rec_5.attr (j).dm_name,
			     j, attr_idx);
			call report_error (4, mrds_error_$inconsistent_submodel, message);
		     end;

	     end;

	end;

	key_string = MODEL_REL_HEAD || rel_rec_5_ptr -> rel_rec_5.rel_dm_name;
	call iox_$seek_key (submodel_iocb_ptr, key_string, rec_len, code);
	if code = 0
	then do;
		call ioa_$rs ("Model relation ^a has already been used to define a relation",
		     message, message_length, rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		call report_error (4, mrds_error_$inconsistent_submodel, message);
		code = 0;
	     end;
	else
	     if code ^= error_table_$no_record
	then do;
		call ioa_$rs ("PROGRAM LOGIC ERROR^/Could not seek key for validating model relation use for ^a",
		     message, message_length, rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
		code = 0;
	     end;
	else do;
		call iox_$write_record (submodel_iocb_ptr, addr (j), 1, code);
		if code ^= 0
		then do;
			call ioa_$rs ("PROGRAM LOGIC ERROR^/Unable to write record for validating model relation use for ^a",
			     message, message_length, rel_rec_5_ptr -> rel_rec_5.rel_dm_name);
			code = 0;
		     end;
	     end;

	free rd_ptr -> rel_desc;

	return;

     end validate_relation;

%include mrds_dsm_link_list;
%page;
%include mrds_dsm_access_record;
%page;
%include mrds_dsm_parse_stack;
%page;
%include mrds_dsm_rel_rec_5;
%page;
%include mrds_dsm_head_strings;
%page;
%include mrds_dsm_sem_info;
%page;
%include mrds_dsm_error_info;
%page;
%include mrds_rel_desc;


     end;						/* End of mrds_dsm_semantics. */




		    mrds_dsm_write_header.pl1       04/18/85  1429.4re  04/18/85  0907.0       23337



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

mrds_dsm_write_header: proc (iocb_ptr, db_path, code);

/*
   This routine writes the submodel header record. The record has  a
   key  of  32  nulls  which  should make it the first record in the
   vfile_. A temporary  header  record  with  the  submodel  version
   information must already exist.

   Known Bugs:

   Other Problems:

   HISTORY

   81-02-23 Davids: written

   81-06-01   Davids:   Changed   mrds_dsm_header_str.incl.pl1    to
   .        mrds_dsm_header.incl.pl1
   */

/* PARAMETERS */

	dcl     iocb_ptr		 ptr;		/* (input) pointer to the submodels iocb */
	dcl     db_path		 char (*);	/* (input) db_path submodel is defined for */
	dcl     code		 fixed bin (35);	/* (output) error code */

/* AUTOMATIC */

	dcl     01 header_str	 like mrds_dsm_header; /* automatic version of the header record */
	dcl     key		 char (256) var;	/* header record key */
	dcl     record_length	 fixed bin (21);	/* length of the header record */

/* BASED */

%include mrds_dsm_header;


/* BUILTIN */

	dcl     addr		 builtin;
	dcl     low		 builtin;

/* ENTRIES */

	dcl     clock_		 entry () returns (fixed bin (71));
	dcl     get_group_id_	 entry () returns (char (32));
	dcl     iox_$seek_key	 entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
	dcl     iox_$rewrite_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     mrds_dsm_get_relation_names$number_of_rels entry (ptr, fixed bin (35)) returns (fixed bin);

/* EXTERNAL */

	dcl     mrds_data_$dsmd_version_number fixed bin (35) external static;

	header_str.dsm_generator_version = mrds_data_$dsmd_version_number;
	header_str.date_time_generated = clock_ ();
	header_str.database_pn = db_path;
	header_str.creator_id = get_group_id_ ();
	header_str.name = "data_submodel_header";
	header_str.num_of_relations = mrds_dsm_get_relation_names$number_of_rels (iocb_ptr, code);


	if code = 0
	then do;
		key = low (32);
		call iox_$seek_key (iocb_ptr, key, record_length, code);
		if code = 0
		then do;
			call iox_$rewrite_record (iocb_ptr, addr (header_str), record_length, code);
		     end;
	     end;

	return;

     end /* mrds_dsm_write_header */;





		    mrds_error_.alm                 08/01/88  1347.2rew 08/01/88  1300.0      273204



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

"	Error table for the Multics data base manager

"	Created January 1976 by RG Luebke, RD Lackey
"	Converted to use et_macros March 1979 by Al Kepner
"	Modified by Jim Gray - - Nov. 1979, to eliminate quotes from
"	error messages(replaced with '), so not taken as comments by ALM
"
"81-03-20 Jim Gray: combined mrds_error_ and mdbm_error_ tables
"into one mrds_error_ table, also removed unused error codes.
"Added duplicate names to dup_store and tuple_not_found
"of duplicate_key and no_current_tuple to answer TR's 8880 and 8968
"
"81-04-09 Jim Gray : combined no_recurse and recursion_error into same message.
"
"81-04-10 Jim Gray : combined identical messages for incons_db & inconsistent_database.
"
"81-04-25 Jim Gray : changed too_many_dbs message to not have the constant 64.
"
"81-05-18 Jim Gray : added max_attributes/max_indexes now that CMDB makes the checks
"
"81-06-15 Jim Gray : removed unused error codes
"
"82-03-15 R. Lackey : added  bad_rel_name,badreln
"
"82-03-22 R. Lackey : added bad_attr_name,badattrn
"
"82-03-22 R. Lackey : added no_rel_name,noreln
"
"82-03-22 R. Lackey : added attr_list_syntax_err,attrlerr
"
"82-03-22 R. Lackey : added no_primary_key,noprikey,
"
"82-03-22 R. Lackey : added no_db_path,nodbp
"
"82-04-08 R. Lackey : added no_sel_exp,nselexp
"
"82-04-12 R. Lackey : added  max_rels,max_rels
"
"82-05-25 Mike Kubicar : deleted quiesce_limit, added quiesce_pending
"
"82-06-01 R. Lackey : Added inv_rel_name_first_char and inv_attr_name_first_char
"
"82-06-18 D. Woodka : added no_model_dom,nomddom
"
"82-08-12 Mike Kubicar : Added bad_domain_proc, baddomp, as part of fix
"         for TR phx13118.
"
"82-10-05 Davids: added async_include_file_change and bad_key_retrieve
"
"
"82-10-14 Davids: added unknown_cursor_storage
"
"83-02-18 R. Harvey: removed attr_list_syntax_error, bad_attr_count, 
"	bad_ind_rid, bad_index_iid, bad_index_rid, bad_link_attr_count,
"	dup_key, file_not_readied, inc_link_acc, missing_key_attr,
"	mod_cand_key, no_link_attrs, no_par_info, unspec_mod, 
"	version_cannot_be_restr.
"
"83-03-09 Mike Kubicar : Added no_dms, data management software could not
"         be found
"
"83-04-21 Mike Kubicar : Added internal_error, which will be the same as
"	rst_logic_error
"
"84-03-29 Paul Benjamin: Changed wording of several messages.
"
"84-10-11 John Hergert : Added inval_comp_expr, Invalid selection expression  
"         for compile.
"
"85-02-08 John Hergert: Added dup_key to dup_store since so many applications
"         broke when it went away.
"
"85-04-14 Thanh Nguyen: Added incomp_se_and_scope and 
"         inconsistent_transaction_se.
"

" HISTORY COMMENTS:
"  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
"     audit(86-08-29,Blair), install(86-10-16,MR12.0-1187):
"     Added inv_domain_name_first_char, no_unref_domain, no_unref_attr,
"     no_domains_exist, no_relations_exist. new error codes for encoding
"     descriptors from new_call.
"  2) change(86-01-08,Hergert), approve(88-07-07,MCR7903),
"     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
"     Added new error codes for the new parser.
"                                                      END HISTORY COMMENTS


	include	et_macros
	et	mrds_error_
ec async_include_file_change,ainclcg,
	(Include files no longer match.)
ec attr_already_exists,attexist,
	(The given attribute name has a previous definition.)
ec attr_error,attrerr,
	(No attribute specification found following  an attribute keyword.)
ec bad_access_mode,badam,
	(Data base access mode is not a composite of r, s, m, d, or n.)
ec bad_arith_const,badacon,
	(An invalid arithmetic constant or value has been detected.)
ec bad_attr,badattr,
	(An illegal tuple attribute has been specified in the selection expression.)
ec bad_attr_name,badattrn,
	(Attribute name contains an invalid attribute name character.)
ec bad_builtin_obj,badbiobj,
	(Unable to reference the scalar built-in functions.)
ec bad_delim,baddelim,
	(A delimiter has been incorrectly specified.)
ec bad_domain_proc,baddomp,
	(Encode/decode procedure could not be accessed.)
ec bad_eq,badeq,
	(An equal sign has been incorrectly specified.)
ec bad_ident,badid,
	(An identifier contains invalid characters.)
ec bad_invert_file_type,badift,
	(Entry is not a multisegment file.)
ec bad_key_retrieve,badkeyrt,
	(Retrieval based on a primary key found multiple tuples.)
ec bad_keyword,badkeywd,
	(An expected keyword was not found.)
ec bad_model,badmodel,
	(A file which is not a data model or is inconsistent has been specified.)
ec bad_op,bad_op,
	(An arithmetic operator has been improperly specified in the -where clause.)
ec bad_pathname,bad_path,
	(The pathname supplied is a control argument.)
ec bad_quant,badquant,
	(No tuple variable was specified following a quantifier.)
ec bad_rel_name,badreln,
          (Relation name contains an invalid relation name character.)
ec bad_select_value,bdselval,
	(An unsupported data type was specified for a select item value.)
ec bad_source_path,dsrpath,
	(Source pathname is a control argument.)
ec bad_temp_rel_val,badtrval,
	(A value specified for a temporary relation index is not an integer.)
ec bad_var,badvar,
	(An illegal tuple variable has been specified in the selection expression.)
ec block_dom_incons,bdincons,
	(The domains of items being selected are inconsistent among select blocks.)
ec block_sel_incons,bsincons,
	(The number of items being selected is inconsistent among select blocks.)
ec bool_leaf,boolleaf,
	(An 'and' or 'or' operator has a constant or tuple attribute operand.)
ec cant_ref_fun,cantrfun,
	(Unable to reference a declared or built-in function.)
ec comp_sel_expr,compsex,
	(Complex selection expressions are not allowed for update operations.)
ec conversion_condition,convcon,
	(The conversion condition has been signalled during a data conversion attempt.)
ec ctl_ent_is_dir,ctlisdir,
	(The control file path is a directory, not a vfile msf.)
ec curr_not_alld,curnalld,
	(A -current operation is not permitted for a selection expression containing set operations.)
ec db_already_open,dbopen,
	(Attempt to open a data base before previous openings have been closed.)
ec db_busy,db_busy,
	(The specified data base is currently busy -- try later.)
ec db_conflict_dead_process,dbcdeadp,
	(A scope request cannot be honored due to a conflict with a nonpassive dead process.)
ec diff_comp_domain,dfcmpdm,
	(Attempt to compare attributes which are not defined over the same domain.)
ec dom_integ,dominteg,
	(A value to be inserted into the database does not satisfy integrity constraints.)
ec domain_already_defined,domdef,
	(The given domain name has a previous definition.)
ec dup_invert_dir_name,dupidn,
	(Inversion entry not a directory.)
ec dup_not_alld,dupnalld,
	(A -dup is not allowed in a -current clause or in an operation other than retrieve.)
ec dup_rel,dup_reln,
	(The given relation name has a previous definition.)
ec (dup_key,dup_store,duplicate_key),dupstore,
	(A tuple with the specified primary key already exists.)
ec dup_temp_rel_attr,duptratt,
	(A non-unique attribute name was found in the definition of a temporary relation.)
ec duplicate_opt,dup_opt,
	(A control option was given more than once.)
ec duplicate_scope,dupscope,
	(Attempt to define scope upon a file more than once.)
ec empty_range,emprange,
	(No range definitions were found following a -range keyword.)
ec empty_select,empsel,
	(No tuple attribute or tuple variable was specified following a -select or -current keyword.)
ec empty_where,empwhere,
	(No predicate follows the -where keyword.)
ec error_condition,errcond,
	(The error condition has been signalled during a data conversion attempt.)
ec expr_stack_ovfl,estackov,
	(Translator error -- expression stack overflow.)
ec expr_syntax,exprsyn,
	(A syntax error has been detected within an arithmetic expression.)
ec expression_not_complete,moreexp,
	(A relation definition expression is not complete.)
ec ext_data,extdata,
	(Data follows the right parenthesis.)
ec fixedoverflow_condition,fixoverf,
	(The fixed overflow condition has been signalled during a data conversion attempt.)
ec free_not_quiesced,freenqui,
	(Attempt to free a data base which was not quiesced.)
ec fun_syntax,funsyn,
	(A syntax error has been detected within a function reference.)
ec hold_quiesced_db,hldquidb,
	(Attempt to quiesce a data base before previously quiesced data bases have been freed.)
ec ill_term,illterm,
	(There is an illegal term in the -where clause.)
ec illegal_procedure_condition,illprocc,
	(The illegal procedure condition has been signalled during a data conversion attempt.)
ec inc_attr_acc,incatacc,
	(Incorrect access to attribute.)
ec inc_ready_mode,incrmod,
	(The specified operation is not compatible with the current file ready mode.)
ec inc_rel_acc,incrlacc,
	(Incorrect access to relation.)
ec inc_secure_open,inc_open,
	(Attempt to open secured data base from model, or through non-secure submodel.)
ec incomp_se,incompse,
	(A selection expression of -another is valid only for a retrieve operation.)
ec incomp_se_and_scope,incpsesc,
	(The select expression was -another, but the scope has been changed from non-shared to shared mode)
ec incomplete_declaration,baddcl,
	(Incomplete declaration.)
ec (incons_db,inconsistent_database),inconsdb,
	(There is an inconsistency in the database. If this error persists, contact your Data Base Administrator.)
ec inconsistent_close,badclose,
	(The data base has been closed -- but has been locked because of an inconsistency.)
ec inconsistent_data_length,incondl,
	(The selection exression was -another, but the current data length is different than the previous call to retrieve.)
ec inconsistent_info,inconsis,
	(An internal inconsistency has been detected.)
ec inconsistent_num_files,incnfile,
	(Number of files in data base does not match number specified in db_model.)
ec inconsistent_options,incn_opt,
	(Options supplied cannot be used together.)
ec inconsistent_submodel,insub,
	(Inconsistent submodel.)
ec inconsistent_transaction_se,intxse,
	(The selection expression was -another, but the original selection expression was in another transaction.)
ec incorrect_dsmd_seq,dsmd_seq,
	(Data submodel definition entry called in incorrect sequence.)
ec insuff_args,fewargs,
	(There is no argument corresponding to a .V. in the selection expression.)
ec (internal_error,rst_logic_error),interr,
	(Internal MRDS programming error.  Please contact the MRDS developers.)
ec inv_attr_name_first_char,ivatrn1c,
	(Invalid attribute name; attribute names must begin with an alphabetic character.)
ec inv_comparison,invcomp,
	(The data types cannot be compared.)
ec inv_domain_name_first_char,ivdmn1c,
	(Invalid domain name; domain names must begin with an alphabetic character.)
ec inv_keyword,invkeywd,
	(An unrecognizable keyword was found in the selection expression.)
ec inv_literal_type,invlityp,
	(The value of a constant is not a string or arithmetic data type.)
ec inv_operator,invop,
	(The relational operator index is not valid.)
ec inv_rel_name_first_char,ivrnm1c,
	(Invalid relation name; relation names must begin with an alphabetic character.)
ec inv_string,invstrng,
	(An invalid string constant has been specified in the selection expression.)
ec inv_string_len,invstrln,
	(An invalid repetition factor has been specified for a string constant.)
ec inv_token,invtoken,
	(An unrecognizable token was found in the selection expression.)
ec inval_comp_expr,invlcomp,
	(Invalid selection expression for compile.)
ec inval_del_expr,invl_del,
	(Invalid selection expression for delete.)
ec inval_dtr_expr,invl_dtr,
	(Invalid selection expression for define_temp_rel.)
ec inval_mod_expr,invl_mod,
	(Invalid selection expression for modify.)
ec inval_rtrv_expr,bad_rtrv,
	(Invalid selection expression for retrieve.)
ec invalid_db_index,badindex,
	(Specified data base index does not correspond to currently open data base.)
ec invalid_dec_data,invdcdta,
	(Invaliddata.)
ec invalid_dm_descriptor,indmdesc,
	(Data type given by descriptor not supported by Data Base Manager.)
ec invalid_opening_mode,inopmode,
	(Invalid opening mode.)
ec invalid_precision,badprec,
	(Invalid precision specification.)
ec invalid_rel,invrel,
	(Submodel relation failed to perfectly validate against the model relation.)
ec invalid_rel_index,invrelno,
	(An invalid relation index has been given.)
ec invalid_scale,badscale,
	(Invalid scale specification.)
ec invalid_select_sets,invl_ss,
	(An invalid select_sets sequence has been detected.)
ec invalid_string_length,badstrlg,
	(Invalid string length.)
ec key_encd_ovfl,kencdov,
	(An overflow has occurred while encoding a floating point key/index value.)
ec list_duplicate,list_dup,
	(A duplicate appears in the given list.)
ec lit_string_ovfl,litsovfl,
	(Translator error -- the literal area has overflowed.)
ec long_ident,longid,
	(An identifier exceeds the maximum length of 32 characters.)
ec long_index,longind,
	(An index attribute is longer than the maximum key length allowed.)
ec long_key,longkey,
	(The primary key is longer than the maximum length allowed.)
ec max_and_groups,maxag,
	(Translator error -- maximum number of 'and' groups exceeded.)
ec max_and_terms,maxat,
	(Translator error -- maximum number of terms in 'and' group exceeded.)
ec max_attributes,maxattrs,
	(The maximum number of attributes allowed per relation has been exceeded.)
ec max_expr_items,maxexitm,
	(Too many items have been specified in an arithmetic expression.)
ec max_indexes,maxindxs,
	(The maximum number of secondaryily indexed attributes for a single relation has been exceeded.)
ec max_rels,max_rels,
	(The maximum number of relation allowed per data base has been exceeded.)
ec max_retr_len,mxretrln,
	(The selected attributes exceeded the maximum temporary space available to hold them.)
ec max_select_items,maxsel,
	(Too many items have been specified for selection in a -current or -select clause.)
ec max_sf_args,mxsfargs,
	(The maximum number of scalar function arguments allowed has been exceeded.)
ec max_temp_rels,mxtemrel,
	(The maximum number of temporary relation definitions has been exceeded.)
ec max_tup_var,mxtupvar,
	(Too many tuple variables have been specified.)
ec max_vars_rel,maxvrl,
	(More tuple variables than iocb's for a given relation.)
ec missing_relation_name,norelnam,
	(Relation name not specified.)
ec missing_select,noselect,
	(An expected -select clause was not found.)
ec mixed_versions,mix_ver,
	(Attempt to use different version data bases in same argument list.)
ec mod_key_attr,modkey,
	(Attempt to modify a key attribute.)
ec mult_asts,multasts,
	(Multiple asterisks followed an attribute name.)
ec mult_att_def,multadef,
	(An attribute has been multiply specified within a relation expression.)
ec mult_att_ref,multaref,
	(An attribute has been multiply referenced within a relation expression.)
ec mult_def_var,muldfvar,
	(A tuple variable has been multiply defined in the range clause.)
ec mult_expr_vars,mulexpva,
	(An arithmetic expression involving more than one tuple variable has been specified.)
ec mult_index,multind,
	(A relation has been specified more than once in the index clause.)
ec mult_paren,multpar,
	(Multiple left parentheses were found.)
ec multiple_tuples_found,multtupl,
	(A selection expression for modify resulted in more than one tuple being selected.)
ec my_quiesced_db,myquidb,
	(Attempt to quiesce a data base which has already been quiesced by this process.)
ec no_attr_lp,noattrlp,
	(No attribute name was found following the left parenthesis.)
ec no_attr_spec,noattr,
	(None of the submodel attributes were found in the data model.)
ec no_ctl_path,no_ctlp,
	(No control file path name was supplied.)
ec no_database,no_db,
	(No MRDS data base model found with the given pathname.)
ec no_db_path,nodbp,
	(No database path was supplied.)
ec no_dms,nodms,
	(Data management software could not be found.)
ec no_domains,nodomain,
	(No domain specification found following a domain keyword.)
ec no_domains_exist,nodmne,
	(No domains exist for the specified database.)
ec no_dups_for_set_oper,nosetdup,
	(Duplicates are not allowed in set operations.)
ec no_inds,noinds,
	(No index specification found following an index keyword.)
ec no_key_specified,nokey,
	(No key attribute field defined.)
ec no_left_paren,noleftpa,
	(No left parenthesis was found following the relation name.)
ec no_model_access,nomdacc,
	(Insufficient access to read database model or submodel.)
ec no_model_attr,nomdatt,
	(The specified data model attribute name does not exist.)
ec no_model_dom,nomddom,
	(The specified data model domain name does not exist.)
ec no_model_rel,nomdrel,
	(The specified data model relation name does not exist.)
ec no_model_submodel,no_md_sm,
	(No data base model or submodel found with the given pathname.)
ec no_prev_store,noprvst,
	(A -another keyword has been specified for store without a previous store.)
ec no_prior_se,noprise,
	(A -another or -current keyword has been specified without a prior valid selection expression.)
ec no_primary_key,noprikey,
	(No primary key attributes were specified for the relation.)
ec no_rel_attr,nrelattr,
	(No attributes were specified for the relation.)
ec (no_recursion,recursion_error),norecurs,
	(This command/subroutine may not be called recursively.)
ec no_rels,norels,
	(No relation specification found following a relation keyword.)
ec no_relations_exist,norelse,
	(No relations exist in the specified database.)
ec no_rel_name,noreln,
	(No relation name was found.)
ec no_sel_exp,nselexp,
	(No selection expression was found.)
ec no_sm_rel,nosmrel,
	(No relation by this name exists in the submodel.)
ec no_temp_dir,no_tdir,
	(No temporary directory path was supplied.)
ec no_tr_keys,no_tkeys,
	(No primary keys were designated in the selection expression.)
ec no_tuple,notuple,
	(There is no tuple satisfying the qualifications.)
ec no_tuple_effect,notupef,
	(Some of the tuple variables have no effect on the select set.)
ec no_unref_attr,nounrefa,
	(There were no unreferenced attributes.)
ec no_unref_domain,nounrefd,
	(There were no unreferenced domains.)
ec no_wakeup_user,nowkpusr,
	(A waiting and blocked data base user could not be awakened.)
ec node_stack_ovfl,nodovfl,
	(Translator error -- the node stack has overflowed.)
ec non_scope_ready,nonscrdy,
	(File was not readied for scope_update or scope_retrieve.)
ec not_dsm,not_dsm,
	(The specified view pathname is not a data submodel.)
ec not_freeing_area,notfree,
	(The supplied area does not have the freeing attribute.)
ec not_leaf,notleaf,
	(A 'not' operator has a constant or tuple attribute operand.)
ec one_tuple_op,onetupop,
	(More than one tuple variable was selected for a modify or delete.)
ec op_stack_ovfl,opovfl,
	(Translator error -- the operator stack has overflowed.)
ec open_name_already_known,openknow,
	(The open name given is already defined, open names must be unique.)
ec open_name_not_known,nmunknow,
	(The given open name is not currently defined.)
ec open_order,open_ord,
	(There was an attempt to open an old version data base with new version data bases open.)
ec overflow_condition,overfcon,
	(The overflow condition has been signalled during a data conversion attempt.)
ec parse_error,parsform,
	(Syntax error.)
ec parser_logic_error,log_err,
	(Logic error in MRDS selection expression parser caused by bad DPDA.)
ec parser_stack_overflow,stk_ovl,
	(A selection expression parser stack has overflowed.)
ec parser_unrecognized_state,bad_st,
	(Unrecognized DPDA state encountered by selection expression parser.)
ec previously_defined_index,predefix,
	(An attribute was previously defined as an index.)
ec process_not_found,procnfnd,
	(Unable to locate specified process in the data base control segment.)
ec quiesce_pending,quipend,
	(Another process is waiting to quiesce the database.)
ec quiesce_too_few,quitofew,
	(The number of data bases to quiesce is negative or zero.)
ec quiesced_db,quidb,
	(The data base has been quiesced by another process.)
ec quiesced_dead_db,quideddb,
	(The data base has been quiesced by a process which no longer exists.)
ec range_syntax,rngerr,
	(A syntax error has been detected within a -range clause.)
ec rel_name_too_long,relnol,
	(The relation name exceeds the 30-character limit.)
ec rel_node,relnode,
	(A relational operator has a term or group of terms as an operand.)
ec rst_bad_attribute_count,attr_cnt,
	(Model structure and attribute count don't agree.)
ec rst_bad_bit_string,bad_bstr,
	(Bit string violates syntax rules.)
ec rst_bad_child_count,childcnt,
	(Model structure and child link count don't agree.)
ec rst_bad_declaration,bad_decl,
	(Error in the declaration of a domain.)
ec rst_bad_domain_count,dom_cnt,
	(Model structure and domain count don't agree.)
ec rst_bad_encoding,bad_enco,
	(Source character was incorrectly encoded.)
ec rst_bad_file_count,file_cnt,
	(Model structure and file count don't agree.)
ec rst_bad_link_count,link_cnt,
	(Model structure and link count don't agree.)
ec rst_bad_model,badmodel,
	(Inconsistent data base model detected.)
ec rst_bad_number_syntax,bad_numb,
	(Syntax error was found in a number.)
ec rst_bad_relation_count,rel_cnt,
	(Model structure and relation count don't agree.)
ec rst_bad_semantics,bad_sem,
	(The intended meaning of a statement may be lost or misinterpreted.)
ec rst_childless_parent,no_child,
	(The given foreign key has no child links.)
ec rst_comment_ends_source,comm_end,
	(Source segment ends in the middle of a comment.)
ec rst_conversion_error,conv_err,
	(Overflow occured trying to convert number to binary.)
ec rst_dup_file,dup_file,
	(The given file name has a previous definition.)
ec rst_illegal_char,bad_char,
	(Illegal character being skipped.)
ec rst_inconsis_option,incon_op,
	(The given attributes in a declaration are contradictory.)
ec rst_invalid_structure_type,inv_stru,
	(The given number has no defined structure correspondence.)
ec rst_io_error,io_error,
	(An error was detected during an I/O operation.)
ec rst_link_attr_differ,lk_attr,
	(The parent/child attribute counts differ.)
ec rst_list_delete_fail,del_fail,
	(The item to be deleted was not in the list.)
ec rst_list_duplicate,list_dup,
	(Attempt to add a duplicate to the given list.)
ec rst_missing_file_model,no_model,
	(File model segment not found.)
ec rst_missing_pathname,no_path,
	(An expected pathname was not found.)
ec rst_missing_ref_domain,no_dom,
	(A domain referenced by an attribute wasn't found.)
ec rst_model_limit,modlimit,
	(The capacity of the data base model has been exceeded.)
ec rst_name_duplicate,dup_name,
	(A relation's attribute list contains a duplicate name.)
ec rst_name_too_long,lg_name,
	(A name exceeds it's maximum allowable length.)
ec rst_no_key_attr,no_key,
	(The given relation does not specify any key attributes.)
ec rst_no_link_relation,nolk_rel,
	(The given link does not have a relation attached.)
ec rst_not_rel_attr,nrelattr,
	(A relation does not contain the referenced attribute.)
ec rst_option_limit,opt_lim,
	(The upper limit for an option's value was exceeded.)
ec rst_parse_err_correct,perr_cor,
	(Unable to understand statement structure, attempting guess at intended syntax.)
ec rst_parse_err_no_correct,perr_nco,
	(Unable to understand statment structure, and attempt at guessing intended syntax failed.)
ec rst_parse_err_no_recover,perr_nre,
	(Unable to comprehend statement structure, and attempt to recover by skipping to next recognizable delimiter failed.)
ec rst_parse_err_recover,perr_rec,
	(Unable to comprehend statement structure, skipping to next recognizable delimiter.)
ec rst_parse_fail,par_fail,
	(Totally confused by statement syntax, unable to continue parsing.)
ec rst_pathname_ends_source,pathends,
	(The source segment ends during a path/entry name.)
ec rst_rel_has_file,rel_file,
	(A referenced relation has a previous file definition.)
ec rst_reserved_name,reserved,
	(A reserved name was used.)
ec rst_string_ends_source,str_ends,
	(The source segment ends within a quoted string.)
ec rst_token_too_long,lg_token,
	(A token exceeds the maximum string size.)
ec rst_undef_rel,undefrel,
	(A referenced relation has not been previously defined.)
ec rst_undone_option,undone,
	(The specified option is not implemented.)
ec rst_unused_attr,nrefattr,
	(The given attribute has never been referenced in a data base relation.)
ec rst_unused_attr_dom,nrefadom,
	(The given domain has never been referenced in a data base relation.)
ec rst_wrong_command,wrongcmd,
	(The command or subroutine call was given in an incompatible situation or sequence.)
ec scal_func_conversion,sclfuncv,
	(A conversion condition was raised while processing a scalar function.)
ec scope_empty,emptyscp,
	(Attempt to delete scope tuple from empty scope set.)
ec scope_mrds_access_conflict,scopmrds,
	(The requested scope exceeds the MRDS access granted for this relation.)
ec scope_not_empty,scopenem,
	(Attempt to define scope while scope is not empty.)
ec scope_not_found,scopemis,
	(Specified scope tuple not in current scope.)
ec scope_not_set,scopenon,
	(No scope currently set for the specified relation.)
ec scope_system_access_conflict,scopesys,
	(The requested scope exceeds the system acl's on the given relation.)
ec scope_viol,scpviol,
	(This operation is not permitted within the current scope definition.)
ec sel_blk_synt,seblsyn,
	(A syntax error has been detected within a select block.)
ec select_mismatch,fewvals,
	(There are not enough value arguments to satisfy all specified select items.)
ec select_syntax,selerr,
	(A syntax error has been detected within a -select or -current clause.)
ec sell_syntax,sesyntax,
	(A syntax error has been detected within the selection expression.)
ec set_ovfl,setovfl,
	(Too many select blocks have been specified in the selection expression.)
ec set_syntax,setsynt,
	(Select blocks have been incorrectly combined.)
ec size_condition,sizecon,
	(The size condition has been signalled during a data conversion attempt.)
ec surplus_text,surptext,
	(Text follows the logical end of the source segment.)
ec too_many_args,manyargs,
	(The maximum number of expected arguments has been exceeded.)
ec too_many_attributes,attrovfl,
	(The maximum number of attributes for a relation has been exceeded.)
ec too_many_dbs,maxdbs,
	(Attempt to open more than the maximum allowable number of openings at one time.)
ec too_many_data_models,toomany,
	(Attempt to open more than the maximum number for data model openings.)
ec too_many_open_names,tmopennm,
	(Too many open names have been defined, some must be deleted first.)
ec too_many_temp_files,too_mtf,
	(The maximum number of temporary files has been exceeded.)
ec trouble_lock,trouble,
	(The data base is locked and may be inconsistent.)
ec (tuple_not_found,no_current_tuple),notuple,
	(No tuple was found which satisfied the selection expression.)
ec unable_to_create_channel,un_crchn,
	(An event channel needed to activate a queued process could not be created.)
ec unable_to_queue_user,un_q_usr,
	(A user could not be placed in the waiting queue due to an error.)
ec unaccep_fn_args,unafnarg,
	(A function reference includes an unacceptable argument, or the wrong number of arguments.)
ec unbal_parens,unbalpar,
	(The number of right parentheses does not match the number of left parentheses.)
ec undef_attr,undefatt,
	(A referenced attribute has not been previously defined.)
ec undef_fun,undefun,
	(A referenced function is not built-in nor has it been declared.)
ec undef_rel,undefrel,
	(A specified relation name is undefined in the submodel.)
ec (undef_temp_rel,undefined_temp_rel_index),badtrel,
	(The given index does not refer to a currently defined temporary relation.)
ec undef_var,undefvar,
	(A specified tuple variable has not been previously defined.)
ec undefined_domain,undefdom,
	(A referenced domain has not been previously defined.)
ec underflow_condition,undercon,
	(The underflow condition has been signalled during a data conversion attempt.)
ec unimplemented_syntax,unsyntax,
	(The supplied syntax is not implemented in this version of MRDS.)
ec unknown_cursor_storage,unkcusg,
	(The pointer to the storage for the cursor pointers is bad.)
ec unknown_file_name,unk_flnm,
	(Specified relation name not known to this process.)
ec unknown_proc_id,unk_pid,
	(An unidentifiable data base user process has been encountered.)
ec unknown_relation_name,unkrel,
	(Relation name specified is not in the current view of the data base.)
ec unshared_opening,unshared,
	(This operation is not valid for nonshared openings.)
ec unsup_type,unstype,
	(An unsupported data type has been specified as a value.)
ec upd_temp_rel,updtprel,
	(Update operations are not permitted for temporary relations.)
ec update_not_allowed,noupdate,
	(A relation is not available for update operations.)
ec user_not_found,usr_nfnd,
	(Unable to locate specified user in the data base control block.)
ec var_stack_ovfl,varovfl,
	(Translator error -- the variable stack has overflowed.)
ec version_3_db,ver3db,
	(Version 3 databases are no longer supported by MRDS.)
ec version_1_dsm,ver1dsm,
	(Version 1 submodels are no longer supported by MRDS.)
ec version_not_supported,notsuprt,
	(The database is a version not supported by this command/subroutine.)
ec view_prevent,viewprev,
	(The specified operation cannot be accomplished using the current database view.)
ec where_syntax,whereerr,
	(A syntax error has been detected within the -where clause.)

"
" new_call errors. These are only used in rmdb_create_descriptor_.rd
"
ec  bad_array_bounds,badarray,
	(The array bounds are invalid.)
ec  bad_attribute,bad_attr,
	(One of the attributes is invalid.)
ec  bad_precision,bad_prec,
	(The precision is invalid.)
ec  inconsistent_attributes,inc_attr,
	(Inconsistent combination of attributes.)

	end

*/
                                          -----------------------------------------------------------


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

*/
