



		    mrds_dsl_ready_all.pl1          08/01/88  1347.6r w 08/01/88  1314.1      119160



/****^  ***********************************************************
        *                                                         *
        * 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-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Added code to allocate and free the resultant_attributes_info_ptr
     structure (phx20301, mrds #154). Added a pointer to it as an additional
     parameter to the call to mu_sec_make_res.
                                                   END HISTORY COMMENTS */


/* HISTORY:

   Originally written by Jim Gray - - July 1979

   81-05-29 Jim Gray : combined functions of mrds_dsl_ready_file into
   this module, and changed to handle to resultant structure.

   81-09-15 Davids: added the rtrim operator.  this  was  needed  so
   that the module would compile when -prefix stringsize was used in
   the call to pl1. The length of rm_rel_array.name.submodel was not
   changed  to char (30) even though 30 characters is the max length
   because the current length of 32 is hard-wired in to the code  in
   several places.

   82-07-26 R. Harvey: fixed call to mrds_dsl_finish_file in cleanup
   handler to correspond with reality.

   82-10-05 Mike Kubicar : Converted this module for the relation manager.
   Specifically, the call to mrds_dsl_finish_file was remove (the module
   has been deleted) and replaced by a call to relation_manager_$close.  At
   the point that mrds_dsl_finish_file was called, no scopes had yet been
   set nor cursor created.  Thus, merely closing the relation will suffice.

   83-02-22 Bert Moberg : get temp segment and open submodel in this routine
   instead of mu_sec_make_res to save much time

   83-03-17 Bert Moberg : fixed bug where finish_code was used before it was
   inited; also did some clean up

*/

mrds_dsl_ready_all: ready_all: procedure (database_index, ready_mode, error_code);

/* DESCRIPTION:

   given a database index of an open database, and a file ready mode,
   this routine will ready all files that are not currently readied
   for that database, using the given ready mode.
   if an error occurs, any files that this
   routine has readied, will be finished so as to leave the user
   in a known state for his file ready modes

*/

/* PARAMETERS:

   database_index - - (input) fixed bin(35) integer returned by the call to mrds_dsl_open for this opening

   ready_mode - - (input) fixed bin integer between 1 and 6 representing correspondingly
   retrieve, monitor_retrieve, update, load, scope_retrieve, and scope_update
   file ready modes

   error_code - - (output) fixed bin(35) error type encoding, 0 unless an error occured

   sub_error_ - - (output) condition, signaled upon error occurence to provide more  info

*/
%page;
/* check for a recursive call */

	error_code = 0;				/* initialize */

	if previous_invocation then do;
		error_code = mrds_error_$no_recursion;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
		     "Attempt to invoke this routine recursively, a release must be done first.");
	     end;
	else do;

		previous_invocation = ON;

/* initialize the "files to be readied list" cleanup */

		dbrdy_ptr = null ();
		temp_area_ptr = null ();
		submodel_iocb_ptr = null ();
		resultant_attributes_info_ptr = null;
		clean_up_condition = OFF;

		on cleanup begin;			/* in case user does a quit/release */
			clean_up_condition = ON;
			call clean_up ();
		     end;

/* make sure this is a legal database index */

		call get_pointers ();

		if error_code = 0 then do;


/* initialize the list of files to be readied */

			call init_file_list ();

/* get a list of all non-ready files for this database */

			do fa_index = 1 by 1 to rm_rel_array.num_rels;

			     call add_file ();	/* put in ready list */

			end;

/* ready each file in the list */

			call ready_files ();

		     end;

/* on error or cleanup, finish all files that we readied
   and get rid of the ready list we built */

		call clean_up ();

	     end;

	return;
%page;
get_pointers: procedure ();

/* get the nonsecure resultant segment pointer */

	call mu_database_index$get_resultant_model_pointer (database_index, dbcb_ptr);
	if dbcb_ptr = null () then do;
		error_code = mrds_error_$invalid_db_index;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a",
		     "The database index", database_index, "does not refer to a known database open by this process.");
	     end;
	else do;

/* get secure resultant pointer */

		rdbi_ptr = dbcb.rdbi_ptr;

/* get the database db_model segment pointer */

		dbm_ptr = null;
		call hcs_$initiate ((rm_db_info.db_path), "db_model", "", 0, 0, dbm_ptr, error_code);
		if error_code = error_table_$moderr then do;
			call mrds_dm_authorization$set_needed_access (rtrim (rm_db_info.db_path), error_code);
			if error_code ^= 0 then
			     error_code = error_table_$moderr;
			else call hcs_$initiate ((rm_db_info.db_path), "db_model", "", 0, 0, dbm_ptr, error_code);
		     end;
		if dbm_ptr ^= null () then
		     error_code = 0;		/* in case already known to process, etc. */
		else call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get a pointer to the database segment """,
			rtrim (rm_db_info.db_path) || ">db_model", """.");

/* get pointer to the file array */

		rmra_ptr = rm_db_info.ra_ptr;		/* array of files accessible by this users */

	     end;

     end;
%page;
init_file_list: procedure ();

/* fill in the header to the "files to be readied" list */

	if dbcb_ptr ^= null () then do;

		allocate db_rdy in (dbcb.static_area);
		db_rdy.frdy_ptr = null;
		db_rdy.dbi = database_index;
		db_rdy.dbcb_ptr = dbcb_ptr;
		db_rdy.db_model_ptr = dbm_ptr;

	     end;

     end;
%page;
add_file: procedure ();

/* fill in the next entry in the "files to be readied" list */

	allocate file_rdy in (dbcb.static_area);
	file_rdy.next = null;
	file_rdy.name = rtrim (rm_rel_array.name (fa_index).submodel);
	file_rdy.mode = ready_mode;
	file_rdy.file_array_index = fa_index;
	file_rdy.file_readied = OFF;

/* put the next file to ready in the list in order */

	if db_rdy.frdy_ptr = null () then do;
		db_rdy.frdy_ptr = frdy_ptr;		/* first on list */
		last_frdy_ptr = frdy_ptr;
	     end;
	else do;					/* put at end of list */
		last_frdy_ptr -> file_rdy.next = frdy_ptr;
		last_frdy_ptr = frdy_ptr;
	     end;

     end;
%page;
ready_files: procedure ();

	call mu_temp_segments$get_temp_segment (database_index, caller_name, temp_area_ptr, error_code);
	if error_code ^= 0 then
	     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
		"Unable to get a tempoaray segment.");

	if dbcb.dsm_sw & error_code = 0 then do;
		call mrds_dsm_open$read ((rm_db_info.sm_path), submodel_iocb_ptr, error_code);
		if error_code ^= 0 then
		     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^a",
			"Unable to open the submodel using the path -", rm_db_info.sm_path);
	     end;

/* allocate structure to keep track of duplicate rm_attr_info's */

	rai_init_number_of_attributes = mrds_data_$number_of_resultant_attributes;
	allocate resultant_attributes_info in (dbcb.static_area)
	     set (resultant_attributes_info_ptr);
	resultant_attributes_info.current_number_of_attributes = 0;

/* make a call to ready_file for each of the files in the ready list */

	do frdy_ptr = db_rdy.frdy_ptr repeat file_rdy.next
	     while (frdy_ptr ^= null () & error_code = 0);

	     call mu_sec_make_res (dbrdy_ptr, frdy_ptr, temp_area_ptr, submodel_iocb_ptr, resultant_attributes_info_ptr, error_code);

	     if error_code = error_table_$moderr |
		error_code = error_table_$no_info then /* no access on entry */
		error_code = mrds_error_$no_model_access;
	     else file_rdy.file_readied = ON;		/* even if not error free, so can be un-built */

	end;

     end;
%page;
clean_up: proc;

/* clear the database file ready list out of the dbcb area */
/* in addition, un-ready any files readied, if an error occured */

	declare hold_ptr		 ptr;
	declare rel_info_ptr	 ptr;

	finish_code = 0;
	if submodel_iocb_ptr ^= null () then do;
		call mrds_dsm_close (submodel_iocb_ptr, finish_code);
		if finish_code ^= 0 & ^clean_up_condition then
		     call sub_err_ (finish_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to close the submodel during clean up.");
	     end;
	if temp_area_ptr ^= null () then do;
		call mu_temp_segments$delete_temp_segment (caller_name, temp_area_ptr, finish_code);
		if finish_code ^= 0 & ^clean_up_condition then
		     call sub_err_ (finish_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to release a temp segment during clean up.");
	     end;

	if dbrdy_ptr ^= null () then do;

		do frdy_ptr = db_rdy.frdy_ptr repeat hold_ptr
		     while (frdy_ptr ^= null);

		     hold_ptr = file_rdy.next;

/* if an error occurred, any files that were in the ready list
   and were readied before the error occurence, must be finsihed,
   so as to leave the user in a known state.  Since no scopes have
   been set or cursors created, a file is finished merely by closing
   the relation. */

		     if (error_code ^= 0 | clean_up_condition) &
			file_rdy.file_readied
		     then do;
			     rel_info_ptr = rm_rel_array.rel_data (file_rdy.file_array_index).ri_ptr;
			     if rel_info_ptr ^= null then
				call dbcb.relmgr_entries.close (rel_info_ptr -> rm_rel_info.opening_id, finish_code);
			     if finish_code ^= 0 & ^clean_up_condition then
				call sub_err_ (finish_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				     "Unable to finish the file """, file_rdy.name, """ during clean up.");
			end;

		     free file_rdy in (dbcb.static_area);

		end;

		free db_rdy in (dbcb.static_area);
		dbrdy_ptr = null ();

	     end;

	     if resultant_attributes_info_ptr ^= null
	     then free resultant_attributes_info in (dbcb.static_area);

/* reset recursion flag */

	previous_invocation = OFF;

     end;
%page;
	declare (addr, fixed, null,
	        rel, rtrim)		 builtin;
	declare temp_area_ptr	 ptr;
	declare submodel_iocb_ptr	 ptr;
	declare error_code		 fixed bin (35);	/* error return status */
	declare database_index	 fixed bin (35);	/* database opening index */
	declare ready_mode		 fixed bin;	/*  between 1 and 6 for file ready mode */
	declare fa_index		 fixed bin;	/* index into file array */
	declare clean_up_condition	 bit (1);		/* on => cleanup has been signaled */
	declare cleanup		 condition;	/* signaled upond quit/release */
	declare last_frdy_ptr	 ptr;		/* points to last on list */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (18) init ("mrds_dsl_ready_all"); /* name of calling routine */
	declare continue		 char (1) init ("c"); /* dont stop after printing mesg */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets resultant pointer */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* not open db index */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment length */
	declare finish_code		 fixed bin (35);	/* discarded clean up error code */
	declare previous_invocation	 bit (1) init ("0"b) int static; /* recursion flag */
	declare mrds_error_$no_recursion fixed bin (35) ext; /* attempt to invoke recursively */
	declare error_table_$moderr	 fixed bin (35) ext;/* not enough access */
	declare mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets access for DBA types */
	declare error_table_$no_info	 fixed bin (35) ext;/* no acl to db_dir or db_model */
	declare mrds_data_$number_of_resultant_attributes fixed bin (35) external;
	declare mrds_error_$no_model_access fixed bin (35) ext; /* no access to model */
	dcl     mrds_dsm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mu_temp_segments$get_temp_segment entry (fixed bin (35), char (*), ptr, fixed bin (35));
	dcl     mu_temp_segments$delete_temp_segment entry (char (*), ptr, fixed bin (35));
	dcl     mu_sec_make_res	 entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2),
				 ptr, fixed bin (35));
%page;
%include mdbm_db_file_list;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_dbcb;
%page;
%include mrds_res_attr_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_db_model;

     end;




		    mrds_dsl_resultant_storage.pl1  04/18/85  1437.3re  04/18/85  0907.8       71937



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - August 1979
   Modified by Jim Gray - - 80-9-24, to add the entry $get_opening_temp_dir,
   in order to be able to get the temp dir for a particular opening.
   Also, if the temp_dir is all blanks (initial state), then it is now
   set to the process directory (the default) in this routine during a $get.

   Modified by Ron Harvey - - 83-01-18, to use get_shortest_path_ before
   saving off the directory.
*/

mrds_dsl_resultant_storage: procedure (); return;		/* not valid entry */

/* DESCRIPTION:

   this routine is used to set and retrieve the storage location for
   the resultant database model that is created at open time from
   the users model or submodel, and used for runtime access of the
   data in the database by dsl_$store, retrieve, etc.
   each opening may use a different storage location for it's resultant
   via intervening calls to the $set entry to this routine,
   with the pathname of the desired storage location.
   the open modules that create the dbcb, rdbi, select
   segments of the resultant call the $get entry to find
   out what directory to store the resultant under.

*/

/* PARAMETERS:

   set entry ===

   relative_path - - (input) char(*), the pathname of the directory under which
   the resultant model for the next opening is to be stored. this
   should have a larger quota than the process directory if a
   large database opening is planned, or many opens are to be done.

   error_code - - (output) fixed bin(35), error status encoding, 0 unless an error occurred,
   such as an invalid pathname, or pathname not a directory.

   sub_errror_ - - (output) condition, signaled upone occurence of error to propvide more info

   get entry ===

   returns(char(168)) - - (output) the current pathname that the last opening
   would have stored it's resultant model under. the default(i.e. set was never called)
   is the user's process directory.

   get_opening_temp_dir entry ===

   database_index - - (input) fixed bin(35), the database opening index of the
   particular opening whose temporary storage directory is desired.

   error_code - - (output) fixed bin(35), the error status encoding, 0 unless an error occurred,
   such as an invalid database index.

   returns(char(168)) - - (output) the temporary storage directory path for the
   particular database opening whose index was given.


*/

set: set_temp_dir: entry (relative_path, error_code);

/* check for a valid length, and legal pathname */

	error_code = 0;				/* initialize */

	call expand_pathname_ (relative_path, directory_path, entryname, error_code);
	if error_code ^= 0 then
	     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
		"Unable to expand the pathname """, relative_path, """.");
	else do;

/* check to be sure that this is a directory */

		call hcs_$status_minf (directory_path, entryname, chase, type, bit_count, error_code);
		if error_code ^= 0 then
		     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to get the status of the entry """, relative_path, """.");
		else do;

			MSF = ((bit_count > 0) & (type = DIRECTORY));
			if type ^= DIRECTORY | MSF then do;
				error_code = error_table_$no_dir;
				call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				     "The pathname """, relative_path, """ does not refer to a directory.");
			     end;
			else do;

/* good directory path, save it for reference by the $get entry */

				saved_directory = get_shortest_path_ (rtrim (directory_path) || ">" || rtrim (entryname));

			     end;

		     end;

	     end;

	return;

get: get_temp_dir: entry returns (char (168));

/* return the remembered resultant model storage directory */

	if saved_directory = BLANK then
	     saved_directory = get_pdir_ ();

	return (saved_directory);

get_opening_temp_dir: entry (db_index, code) returns (char (168));

/* routine to get the temp dir for a particular database opening specified by it's index */

	code = 0;
	returned_dir = BLANK;

/* check for a valid database opening index */

	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
	if dbcb_ptr = null () then
	     code = mrds_error_$invalid_db_index;
	else do;

/* get the path of the resultant model for this openiong */

		call hcs_$fs_get_path_name (dbcb_ptr, pathname, pathname_len, dbcb_segment, code);
		if code ^= 0 then ;
		else do;

			returned_dir = pathname;

		     end;

	     end;

	return (returned_dir);

	declare saved_directory	 char (168) int static init ((168)" "); /* blanks => use process dir */
	declare pathname_len	 fixed bin;	/* length of directory portion returned */
	declare code		 fixed bin (35);	/* error code for get_opening_temp_dir entry */
	declare db_index		 fixed bin (35);	/* database opening index */
	declare dbcb_ptr		 ptr;		/* pointer to the resultant model */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* not good opening index */
	declare returned_dir	 char (168);	/* path to resultant model for a given opening */
	declare pathname		 char (168);	/* temp for getting directory portion of dbcb segment path */
	declare dbcb_segment	 char (32);	/* name of dbcb segment for this opening */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); /* gets path from pointer */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets resultant model ptr from index */
	declare get_pdir_		 entry () returns (char (168)); /* gets process directory */
	declare BLANK		 char (1) init (" ") int static options (constant); /* space character */
	declare error_table_$no_dir	 fixed bin (35) ext;/* path not to directory */
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35)); /* breaks apart, and checks path */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare get_shortest_path_	 entry (char (*)) returns (char (168));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	declare bit_count		 fixed bin (24);	/* current bit count of entry */
	declare MSF		 bit (1);		/* on => multisegment file */
	declare DIRECTORY		 fixed bin (2) init (2); /* type for directory */
	declare chase		 fixed bin (1) init (1); /* causes links to be chased */
	declare directory_path	 char (168);	/* directory portion of path */
	declare entryname		 char (32);	/* entry portion of path */
	declare relative_path	 char (*);	/* input pathname */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare type		 fixed bin (2);	/* 0 => link, 1 => seg, 2 => dir */
	declare caller_name		 char (26) init ("mrds_dsl_resultant_storage"); /* name of calling routine */
	declare continue		 char (1) init ("c"); /* dont stop after printing mesg */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare (null, rtrim)	 builtin;

     end;




		    mrds_dsl_retrieve.pl1           08/01/88  1347.6rew 08/01/88  1300.0      553563



/****^  ***********************************************************
        *                                                         *
        * 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(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-06-27 by Thanh
     Nguyen. (see mrds #137)
  2) change(86-06-10,Blair), approve(86-08-07,MCR7491),
     audit(86-08-07,Gilcrease), install(86-08-15,MR12.0-1127):
     Check to see if we were called by copy_mrds_data before issuing an error
     about the se_txn not being the same as the current txn (mrds #156).
  3) change(86-06-19,Dupuis), approve(86-08-07,MCR7491),
     audit(86-08-07,Gilcrease), install(86-08-15,MR12.0-1127):
     This entry is being made to cover the change made on 86-02-18 by John
     Hergert (mrds error list #153).
  4) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, changed references to sel_ptr to selct_list_ptr.
                                                   END HISTORY COMMENTS */


mrds_dsl_retrieve: retrieve: proc;

/* (database_index, selection_expression, values,...., values, code) */

/* BEGIN DESCRIPTION

   The purpose of this procedure is to implement the dsl_$retrieve function.
   This procedure creates an argument list for and calls translate,
   then calls search.

   END DESCRIPTION
*/
%page;
/* HISTORY:

   76-02-01  Originally written by R. D. Lackey.

   77-03-01 R. D. Lackey: Modified  to support set operations.

   77-09-01 R. D. Lackey: Modified  to  correct  deletion  of  non-
   allocated file.

   77-11-01 R. D. Lackey:  Modified  to  correct  static  variables
   used by  multiple databases.

   78-07-01 Oris Friesen: Modified  to  fix  problems  with  nested
   intersects  and  differences.

   78-07-14 Oris Friesen: Modified to fix union bug.

   78-10-01 JA  Weeldreyer: Incorporated  MR7.0  changes.

   79-03-26 Al Kepner: Added caller parameter to mrds_dsl_translate.

   79-08-27 Al Kepner : Modified  to expand  the  current_data   and
   static_data  variables  (used  in eliminating duplicates) to full
   segments.

   79-10-24  Davids: Modified the  length  calculation  for  varying
   strings  so  that it takes into account bit verus character data.
   Also so that it takes the length from the correct location in the
   tuple.

   79-10-30 Jim Gray: Modified to set  the  select_list pointer from
   dbcb.current_ptr when a -current clause is used.

   79-11-14 Jim Gray: Modified to fix  looping  cleanup  handler bug
   by adding clean_up_condition variable.

   80-02-14 Jim Gray: Modified to put allocations in a   non-freeing
   extensible area managed by this routine.

   80-04-01 Jim Gray: Modified to change data_ptr passed back by the
   $set_tuple entry used by define_temp_rel so that it points to the
   data  portion  of  the  varying  character  string  current_data,
   not the count word.

   80-05-08  Davids:  modified  assignments  of  tuple_num_atts  and
   tuple_nvar_atts  to  take  values from rm_rel_info.model_num_attr
   and  model_nvar_atts   rather   than   rm_rel_info.num_attr   and
   nvar_atts.  This  was  to  fix  a problem with submodels were the
   submodel view did not contain a varying string attribute and  the
   model did.

   80-09-16 Davids: removed  declarations  of  variables  that  were
   never referenced. Also removed from the entry point set_tuple two
   lines of code that as the first thing done  saved  the  value  of
   area_ptr  in  a temporary and then set the value of area_ptr back
   before the return. the assignment into a temporary was causing an
   illegal   modifier   condition   because  of  the  value  of  the
   uninitialized bits in the stack (area_ptr is  automatic)  -  this
   only  happened when the code was compiled with optimize. when the
   code was not compiled with optimize  other  garbage  values  were
   used  which by coincidence represented a pointer. since there was
   no reason to save the value of area_ptr the code was removed.

   80-09-16 Jim  Gray:  to  put  the  duplicate  processing  and set
   operation processing vfile storage  into  the  same  directory as
   the resultant model which may be  other  than the [pd],  due to a
   call to set_mrds_temp_dir.

   80-09-18 Jim  Gray:  to  correct  the  routine  build_data_string,
   the last assignment, where the true length is being set, to change
   cur_pos / 9 to (cur_pos - 1) /  9, so that one too many characters
   are not set as the length. this is due to the fact that cur_pos is
   a substr index, not an offset.

   80-09-23 Jim Gray: to  make sure that the per  call work area was
   cleaned up when the cleanup condition was invoked, not just after
   errors and normal exit. This required taking the temp file  clean
   up into a separate routine, so that the non "-another" case could
   do its  own cleanup without causing new temp segs to be generated.

   80-11-10 Jim Gray: to change dele_$path calls to hcs_$del_dir_tree
   and hcs_$delentry_file calls to improve performance.

   81-01-17 Jim Gray : made same changes as  made  to  mus_mod_ubtup
   for TR 8670, the variable involved in this case was tup_array.

   81-01-29  Gray : removed references to mdbm_data_$current_version
   using a constant instead to allow for future db version expansion.

   81-02-03 Jim Gray : changed calculation of the varying  attribute
   bit  length in the routine build_data_string in answer to TR 9041
   so that set operations would work correctly.  Also  made  comment
   about the problem with the set operation tuple not being the same
   format  as  temp  and  perm  rel  tuples,  which  was  fixed   in
   mrds_dsl_define_temp_rel instead.

   81-03-11 Jim Gray : changed setting of  select_list  pointer  for
   set  operations  so  that  -another  calls  would get the correct
   select list. See TR 9269.

   81-03-24 Jim Gray : added capability for selection expression  to
   be declared by caller to be char varying as well as just char.

   81-07-02  Roger  Lackey  :  to  fixed  the   place   where   call
   clean_up_per_call_area  was  called  so  that error exit does not
   call it twice.

   81-07-15 Roger Lackey : to add code to automatically turn on  the
   retain_dup  (like -dup argument in select exp) when the following
   conditions exists: 1) only a single tuple varaiable exists 2) all
   primary  key  attributes  are  selected  3)  only one "and" group
   exists

   81-07-25 Jim Gray : changed handling of no  and  group  case  for
   auto -dup, so that when no where clause exists, if only one tuple
   variable is specified, the -dup option can still be  forced  when
   all key attrs are selected.

   81-09-10   Jim   Gray   :   For   TR   11483,   changed   routine
   return_data_temp,  so  that  set  operations  referring to tuples
   having varying character strings  got  their  lengths  calculated
   properly.  It  previously  was not considering whether the length
   was in bits or chars.

   81-09-10 Davids: Moved the code that sets the value  of  num_ptrs
   to  before  any  reference  num_ptrs  is  made,  i.e.  before any
   reference to arg_des_ptr is made. This prevents a  subscriptrange
   condition.

   81-10-22 Davids: Have converted references of the form:
   .          ptr = addr (bit_array (large_offset))
   .	              to
   .          ptr = add_bit_offset (bit_array_ptr, large_offset - 1)
   This gets around a pl1 bug (tr11784) that causes the first method
   to  produce  the  wrong  value  when  the code is compiled with a
   subscriptrange condition. The "-1" is needed because  bit_array's
   first element is 1 not 0.

   82-06-17  R.   Harvey:  Modified dup_check to not concatenate key
   with  rest  of record when record is longer than 256 chars.  This
   gets  around  a  pl1  bug  (tr12672) and also makes the code more
   efficient.				 
					 
   82-07-21 D. Woodka : Modified to correct a bug  (tr phx12285)  so	 
   the  dup_check  procedure would  not  return  with icode ^= 0 and 
   dup_flag = ON. This caused  a loop  of code in move_db_to_file to
   execute one too many times and return an end_of_information error
   code.

   82-08-23 Mike Kubicar : Converted module to use the simple vector
   structure instead of the tuple structure.

   82-10-25 Davids: Minor changes to the build_data_string internal proc.
   move the assignment of the rai_ptr to the first thing in the
   select_list.num_items loop so that the definition order can be determined,
   it was being assigned after that point. Also changed the assignment into
   bit_str to just assign the whole tup_data value instead of taking a
   substr since the value now contains only the value of the attribute
   of interest.

   82-11-04 Davids: Yet another change to build_data_string. Corrected the
   compound statement executed for the case of
                 if old_vi ^= select_list.item.var_index (i)
   it incorrected included the assignment of the tuple_data pointer (td_ptr)
   which meant that value of the tuple_data changed only when the tuple
   variable index changed. This was screwing up the data stored to determine
   duplicates and resulted in non-duplicate data being identified as a duplicate.

   83-01-03 Davids: Modified the build_data_string internal proc to correctly
   build the data string, i.e. make sure that it starts out as a string of
   nulls and only move that part of the varying strings that contain data.

   83-01-06 Davids: Added code to handle transactions.

   83-01-11 Davids: Modified the declaration of tup_data in build_data_string
   to be actual_len instead of rm_attr_info.bit_length. This stops a 
   stringsize condition what was causing the unused bits of tup_data from
   being truncated during the assignment into the data_string.

   83-01-14 Davids: Added code to set mftxn_code = 0 if the code was really
   tuple_not_found - that is not an error so the transaction should commit.
   Also so that this module will return the error code returned by the
   transaction code if there is a problem finishing the transaction - that type
   of error is more important than a mrds error.

   83-01-24 Davids: modifed to set mstxn_id = "0"b as the first thing, so that
   it is set incase an error occurs in argument processing or getting the 
   database index.

   83-02-03 Roger Lackey : Removed the bit_str init from build_data_string and 
   replaced it with a substr to be used when necessary.

   83-04-11 Davids: replaced references to add_bit_offset with references to 
   addbitno.

   83-05-04 Davids: Modified so that mu_define_area is called with a name
   of MRDS || dbi_pic. This will allow closes to be faster since all
   temp_segments with the name MRDS || dbi_pic can be deleted/freed in 1 call.
   the variable dbi_pic was created as an easy way to convert from fixed bin
   to character.

   83-05-24 R. Harvey: Added code to support to re-retrieve a tuple when 
   -current specifies attributes that were not previously retrieved. Also fixed
   another occurrence of the bug TR 12672.

   83-05-31 Mike Kubicar : Updated relation manager calling sequences.

   83-06-08 Davids: Added the internal procedure build_vector_from_string
   and modified the set_tuple entry to call it so that the data returned
   is in the form of a vector instead of just a varying character string.

   83-06-20 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)

   83-08-03 Harvey: Fixed TR phx15427 where duplicate suppression is not 
   performed on a submodel where no key attributes are present.

   83-08-22 Mike Kubicar : Removed the redundant bit fd.dup_keys_allowed.
   Duplicate suppression is done before this bit is checked.  It also caused
   an error with duplicate suppression of sets.

   83-10-03 Paul Benjamin: Added comments in repsonse to audit; became 10th
   person to modify the code.

   84-08-29 Thanh Nguyen & Roger Lackey: Fixed the subroutine 
   build_vector_from_string to advance the "current position" for the varying 
   character string as same as any other data type when building the simple 
   typed vector list. 

   84-12-19 Thanh Nguyen: Added code to continue to retrieve another tuple if
   the retrieved tuple from -another was deleted by another parallel running 
   process (error code = mrds_error_$inconsistent_data_length) in share mode.

   85-01-15 Thanh Nguyen:  Added code to create a special work area using 
   mu_define_area$define_spec_temp_dir_area.  For now, this work area is used
   by mu_retrieve and mu_get_data to "allocate" value_for_db and value_for_user
   thru function mrds_space_allocate and reinitialize the area thru subroutine
   mrds_area_initialize.

   85-01-25 Thanh Nguyen & John Hergert: Moved the code which was added at
   84-12-19 to get_next_tuple subroutine in mu_retrieve to improve performance.

   85-04-14 Thanh Nguyen: Added code to reject the transaction of a retrieve
   with "-another" and the tx id is not the same as the transaction of the 
   original select expression.  And also added code to return an warning error
   along with data when the scope was changed from non-shared mode to shared 
   mode.

   85-06-27 Thanh Nguyen : Modified code not to call to error in the case of 
   invalid dbi.  Also moved the reseting of dbcb.non_shared_to_shared flag
   from init subroutine of this module to mrds_dsl_optimize and 
   mrds_dsl_gen_srch_prog.

   86-02-18 Hergert: Fixed bug where invalid dbi caused linkage error
   to transaction_manager_. This is because mstxn_txn_id was uninitialized.
*/
%page;
/* INPUT CONDITIONS:

   database_index 		is the index of the database the caller wishes to retrieve.

   selection_expression 	is the expression supplied by the user to select the tuples to be retrieved.

   values  		are the retrieved tuple values or attribute values.
*/

/* OUTPUT DEFINITIONS:

   If no errors are encountered the retrieval was performed.

   code = 0;			    if no errors were detected.

   code = error_table_$bad_ptr;	    if the dbcbw_ptr could not be obtained.

   code = mrds_error_$tuple_not_found;      if a tuple selected was not found in the database.

   code = mrds_error_$invalid_db_index;     if no dbcb_ptr was found for the database index.

   If less then  4 arguments were passed to this procedure the
   condition arg_error will be signaled.

code = something else;		    if another error is detected by this module.
*/
%page;
	area_ptr, dbcb_ptr = null;
	mstxn_txn_id = "0"b;
	st_entry = "0"b;				/* remember retr. entry */
	call cu_$arg_list_ptr (al_ptr);		/* Get pointer to this proc arg list */
	if al_ptr = null then signal arg_error;		/* This returns you to command level */

	nargs = divide (arg_list.arg_count, 2, 17, 0);	/* Get the number of arguments to this proc */
	if nargs < 4 then signal arg_error;		/* This returns to command level */



	if arg_list.code = 4 then num_ptrs = arg_list.arg_count; /* Determine number of ptrs in arg list */
	else num_ptrs = arg_list.arg_count + 1;


	call cu_$arg_ptr (nargs, cd_ptr, arg_len, icode); /* Get  pointer to callers return code */
	if icode ^= 0 then signal arg_error;		/* This returns to command level */

	call cu_$arg_ptr (1, dbi_ptr, arg_len, icode);	/* Get pointer to database index */
	if icode ^= 0 then call error (icode);

	call cu_$arg_ptr (2, se_ptr, se_len, icode);	/* Get pointer to selection expression */
	if icode ^= 0 then call error (icode);


	if arg_list.code = 4 then
	     desc_ptr = arg_list.arg_des_ptr (nargs + 2);
	else desc_ptr = arg_list.arg_des_ptr (nargs + 3);

	if descriptor.type = 22 then do;
		se_len_ptr = addrel (se_ptr, -1);	/* get current length of varying string */
		se_len = se_len_ptr -> fb35u;
	     end;


	appl_ptr = addr (arg_list.arg_des_ptr (3));	/* Get pointer to the beginning  */
						/*   of the arg_ptr_list for translate */
						/* Now get pointer to beginning of descriptor */
						/*   pointer list for translate */
	if arg_list.code = 4 then adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 3));
	else adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 4));

	num_args = nargs - 3;			/* Number of args passed to translate */

	call mu_database_index$get_resultant_model_pointer (database_index, dbcb_ptr); /* Get the dbcb pointer */
	if dbcb_ptr = null then do;
	     code = mrds_error_$invalid_db_index;
	     return;
	end;

	call init;

	mstxn_transactions_needed = dbcb.transactions_needed;

	original_appl_ptr = appl_ptr;			/* static data needed in case transaction is rolled back */
	original_adpl_ptr = adpl_ptr;
	original_num_args = num_args;

	on cleanup begin;				/* Establish a cleanup handler */
		call mstxn_cleanup;
		call cleanup_handler;
	     end;
	on any_other call mstxn_any_other;		/* Establish an any_other handler */
%include mrds_start_transaction;

	if mstxn_code ^= 0
	then call error (mstxn_code);

	dbcb.user_started_transaction = user_started_transaction;
	dbi_pic = dbcb.dbi;
	call mu_define_area$define_temp_dir_area (dbcb.retrieve_area_ptr, database_index, (sys_info$max_seg_size), "MRDS" || dbi_pic,
	     "0"b /* not extensible */, "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, icode);
	if icode ^= 0 then call error (icode);
	area_ptr = dbcb.retrieve_area_ptr;
						/* Create a work area for mu_retrieve to allocate the value_for_user and value_for_db. */
	call mu_define_area$define_spec_temp_dir_area (dbcb.work_area_ptr, database_index, "MRDS" || dbi_pic, icode);
	if icode ^= 0 then call error (icode);

	call mrds_dsl_translate (dbcb_ptr, area_ptr, mrds_data_$caller_retrieve,
	     se_ptr, se_len, appl_ptr, adpl_ptr, num_args, icode);
	if icode ^= 0 then call error (icode);
	if ^dbcb.val_rtrv then call error (mrds_error_$inval_rtrv_expr);

	if dbcb.another_flag = ON then do;
		if dbcb.se_transaction_id ^= "0"b
		then if dbcb.se_transaction_id ^= user_transaction_id
		     then if ^dbcb.data.dont_check_txn_id
		          then call error (mrds_error_$inconsistent_transaction_se);
	     end;
	else if dbcb.current_flag = OFF then do;	/* If this invocation is not because of */
		call clean_up_temp_files ();		/* -another cleanup the previous tuple area */
		retrieve_info.auto_dup_determined = "0"b; /* Not determined yet */

	     end;


	if dbcb.ss_ptr ^= null then do;		/* SET RETRIEVALS are handled special */
		ss_ptr = dbcb.ss_ptr;
		if ^dbcb.another_flag then call init_set;


		select_list_ptr = dbcb.select_ptr;


		call get_set_another;		/* Pass the tuple data to user */
	     end;					/* set retrieval */
%page;
	else do;					/* Non-set retrieval */
		call mrds_dsl_search (dbcb_ptr, area_ptr, icode); /* Search for a tuple */
		if icode ^= 0 then call error (icode);

		retrieve_info.retain_dup = dbcb.dup_retain; /* ON => we retain duplicates */

		ti_ptr = dbcb.ti_ptr;		/* Establish tuple_info pointer */
		range_ptr = dbcb.range_ptr;
		select_list_ptr = dbcb.select_ptr;


		if dbcb.another_flag = ON & retrieve_info.retain_dup = OFF then do;

/*  If not done yet determine if retain dup should automatically be turned on */



			if dbcb.pred_ptr = null then
			     number_of_and_groups = 0;/* check for 1 T.V. relation dump  */
			else number_of_and_groups = dbcb.pred_ptr -> pred_array.num_ands;


			if ^retrieve_info.auto_dup_determined &
			     number_of_and_groups < 2 &
			     range.num_vars = 1 then do; /* Only one tuple variable must exists */
				rmri_ptr = range.tup_var (1).ri_ptr;
				if select_list.num_items >= rm_rel_info.nkey_attr & rm_rel_info.nkey_attr > 0 then do; /* Got to have enough key attrs */
					key_used_len = rm_rel_info.nkey_attr;

					allocate key_used in (dbcb.static_area) set (key_used_ptr);
					key_used (*) = "0"b; /* Init to off */

					do i = 1 to select_list.num_items; /* See if we use all primary key attrs */
					     found = "0"b;

					     do j = 1 to key_used_len while (^found);
						if select_list.item (i).ai_ptr = rm_rel_info.key_attr_ptrs (j) then do;
							found = "1"b;
							key_used (j) = "1"b; /* Remember we used it */
						     end;
					     end;
					end;	/* END i = 1 to select_list.num_items */

					if index (string (key_used), "0"b) = 0 then dbcb.dup_retain, retrieve_info.retain_dup = "1"b;
					if key_used_ptr ^= null then free key_used;
				     end;
				retrieve_info.auto_dup_determined = "1"b; /* Rember we determined it already */
			     end;			/* END if range.num_vars = 1 */

			if ^retrieve_info.retain_dup then call another; /* If selection expression was -another and
						   we are not retaining duplicates then call the another proc */

		     end;



		else if dbcb.current_flag = OFF & retrieve_info.retain_dup = OFF then do;
			call build_data_string (static_data);
						/* Otherwise save the data for possible future use by -another */
			retrieve_info.unique_count = 1;

		     end;
		else if dbcb.current_flag = ON then
		     select_list_ptr = dbcb.current_ptr;	/* get select list for -current */

		call return_data_tup;
		num_tuples_retrieved = num_tuples_retrieved + 1;

	     end;

	if num_tuples_retrieved = 0 then /* If none were retrieved return an error */
	     call error (mrds_error_$tuple_not_found);

	else if dbcb.another_flag = ON & dbcb.non_shared_to_shared then
	     code = mrds_error_$incomp_se_and_scope;
	else code = 0;				/* Return with no errors */



	call clean_up_per_call_area ();

exit:

	if code = mrds_error_$tuple_not_found | /* tuple not found is not really */
	     code = mrds_error_$incomp_se_and_scope	/* This is just the warning, we allow to return data. */
	then mftxn_code = 0;			/* an error so we don't want transaction to abort */
	else mftxn_code = code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0				/* problems finishing the transaction are more important */
	then code = mftxn_code;			/* than any error mrds could produce on its own */

	return;					/* Return to caller with some code */

should_rollback:
     proc () returns (bit (1));

/* This module requests no rollbacks. */

	return ("0"b);

     end should_rollback;

restore_significant_data: proc;

	appl_ptr = original_appl_ptr;
	adpl_ptr = original_adpl_ptr;
	num_args = original_num_args;

	call clean_up_per_call_area ();

     end restore_significant_data;
%page;
set_tuple: entry (a_dbcb_ptr, a_area_ptr, data_ptr, a_code);

/* ENtry to retrieve a tuple for define temp rel given a set selection expr. */

	dcl     (a_dbcb_ptr,
	        a_area_ptr,
	        data_ptr)		 ptr;
	dcl     a_code		 fixed bin (35);

	area_ptr = a_area_ptr;
	dbcb_ptr = a_dbcb_ptr;
	st_entry = "1"b;
	call init;
	ss_ptr = dbcb.ss_ptr;
	if ^dbcb.another_flag then do;		/* if first time */
		call init_set;
	     end;
	call get_temp_record (set_info.cur_fdx, current_data, icode); /* get next tuple */
	if icode = error_table_$end_of_info then icode = mrds_error_$tuple_not_found;
	if icode ^= 0 then call error (icode);
	num_tuples_retrieved = num_tuples_retrieved + 1;
	set_info.cur_data_valid = "0"b;
	call build_vector_from_string (addr (current_data), data_ptr);
	a_code = 0;

st_exit:
	return;
%page;
add_record: proc (fdx, data);				/* Adds a data item to a temp-file */
						/* Duplicates are retained according to the attach description */
	dcl     data		 char (*) varying;
	dcl     fdx		 fixed bin;
	dcl     key_only		 bit (1);

	key_only = (length (data) <= 256);
	fd_ptr = retrieve_info.ret_fd_ptr (fdx);	/* Set the file desc pointer */

	if key_only = ON then do;
		call iox_$seek_key (fd.iocb_ptr, (data), rec_len, icode);
		if icode ^= error_table_$no_record then if icode ^= 0 then call error (icode);
		fd.rec_buf = "";
		fd.cur_key = data;
		fd.rec_len = 0;
	     end;
	else do;
		call iox_$seek_key (fd.iocb_ptr, (substr (data, 1, 256)), rec_len, icode);
		if icode ^= error_table_$no_record then if icode ^= 0 then call error (icode);
		fd.cur_key = substr (data, 1, 256);
		fd.rec_buf = substr (data, 257);
		fd.rec_len = length (data) - 256;
	     end;

	if (icode = error_table_$no_record) | (icode = 0) then do;
		call iox_$write_record (fd.iocb_ptr, addr (fd.rec_buf), fd.rec_len, icode);
		fd.rec_count = fd.rec_count + 1;
	     end;
	else call error (icode);

     end add_record;
%page;
another: proc;

/* This internal procedure handles the case where the selection expression is "-another".
   It checks for duplicate data from prievious calls to a retrieve with -another.

   This procedure returns to its calling procedure only when a unique data group has been found otherwise the
   error procedure is called.
*/

	dcl     fdx		 fixed bin internal static;

	dup_flag = ON;				/* Set duplicate record indicator on to start with */

	do while (dup_flag = ON);
	     call build_data_string (current_data);

	     if retrieve_info.unique_count = 1 then do;
		     if current_data ^= static_data then do; /* If the current data is
						   different then the first data acquired form
						   retrieve then do */
						/* Create a new duplicate data file */
			     call create_temp_file (fdx);
			     call add_record (fdx, static_data); /* Add the first data rec */
						/*   add_record set the dup_flag */
			     call add_record (fdx, current_data); /* Add the second data record */
			     retrieve_info.unique_count = 2; /* The number of unique records = 2 */
			     dup_flag = OFF;	/* Turn it off cause we don't have any now */
			end;
						/* If current_data = record then it is a duplicate
						   and dup_flag is left on */
		end;

	     else do;				/* This is for unique count greater then or equal  2 */
		     dup_flag = OFF;
		     if retrieve_info.retain_dup = OFF then /* We are retaining duplicates */
			call dup_check (fdx, current_data, dup_flag); /* This sets the dup_flag */
		     if dup_flag = OFF then do;
			     call add_record (fdx, current_data);
			     retrieve_info.unique_count = retrieve_info.unique_count + 1; /* If no
						   duplicates were found the
						   record was added to duplicate file
						   so add one to the unique data count */
			end;
		end;				/* Else the record was a duplicate and dup_flag is still on */

	     if dup_flag = ON then call mrds_dsl_search (dbcb_ptr, area_ptr, icode); /* See if ANOTHER record exists */
	     if icode ^= 0 then call error (icode);

	end;					/* END of do while (dup_flag = ON */

	return;					/* Return to calling proc */
     end another;
%page;
build_data_string: proc (data_str);

/* Procedure to build a character string from the selected attributes. */

	dcl     bit_str		 bit (9 * maxlength (data_str)) based (bs_ptr);
	dcl     data_str		 char (*) var;
	dcl     (bs_ptr,
	        td_ptr)		 ptr;
	dcl     tup_data		 bit (actual_len) based (td_ptr);
	dcl     (cur_pos,
	        old_vi,
	        j,
	        i)		 fixed bin (35);
	dcl     length_word_overlay	 fixed bin (35) unaligned based;
	dcl     actual_len		 fixed bin (35);	/* actual amount of bits of data in tup_data */

	cur_pos = 1;				/* initialize */

	bs_ptr = addrel (addr (data_str), 1);		/* point to data portion of string */
	old_vi = 0;

	do i = 1 to select_list.num_items;		/* look at every selected attribute */

	     rai_ptr = select_list.item.ai_ptr (i);	/* get info pointers */

	     if old_vi ^= select_list.item.var_index (i) then do; /* if must initialize */
		     old_vi = select_list.item.var_index (i); /* set for next time */
		     rmri_ptr = range.tup_var.ri_ptr (select_list.item.var_index (i));

		     do j = 1 to tuple_info.num_tuples while (tuple_info.tuple.var_index (j) ^= old_vi);
		     end;				/* locate tuple ptr */
		     simple_typed_vector_ptr
			= tuple_info.tuple.tuple_ptr (j);
		end;				/* tuple initialization */
	     td_ptr = simple_typed_vector.
		dimension (rm_attr_info.defn_order).value_ptr;

	     if mu_data_class$varying (addr (rm_attr_info.domain_ptr -> rm_domain_info.db_desc))
	     then do;
		     if mu_data_class$bit (addr (rm_attr_info.domain_ptr -> rm_domain_info.db_desc))
		     then actual_len = td_ptr -> length_word_overlay + 36; /* + 36 for length word */
		     else actual_len = td_ptr -> length_word_overlay * 9 + 36; /* char count * 9 for bit count */
		end;
	     else actual_len = rm_attr_info.bit_length;	/* set up for fixed length */

	     substr (bit_str, cur_pos, actual_len) = tup_data; /* move the value */
	     if actual_len < rm_attr_info.bit_length then
		substr (bit_str, cur_pos + actual_len, rm_attr_info.bit_length - actual_len) = "0"b;
	     cur_pos = cur_pos + rm_attr_info.bit_length;
	     if cur_pos > length (bit_str) then call error (mrds_error_$max_retr_len);

	end;					/* concatenation loop */

	addr (data_str) -> fb35u = ceil ((cur_pos - 1) / 9); /* set true length */

     end build_data_string;
%page;
build_vector_from_string: proc (bvfs_data_ptr, bvfs_simple_typed_vector_ptr);

/*
   This procedur takes a varying bit string containing data and converts it
   to a simple vector containing data.
*/

/* PARAMETERS */

	dcl     bvfs_data_ptr	 ptr;		/* (input) pointer to a varying char string containing data */
	dcl     bvfs_simple_typed_vector_ptr ptr;	/* (input) pointer to a vector, the data will be output */


/* AUTOMATIC */

	dcl     cur_pos		 fixed bin (35);	/* position of first bit of the next attr value */
	dcl     old_vi		 fixed bin (35);	/* var_index of the last attr looked at */
	dcl     i			 fixed bin (35);	/* loop counter */
	dcl     bit_string_len	 fixed bin (35);	/* number of bits in data string */
	dcl     bit_string_ptr	 ptr;		/* pointer to data bits */

/* BASED */

	dcl     bit_array		 (bit_string_len) bit (1) unal based (bit_string_ptr);
						/* bit string of data to be converted to vector */
	dcl     length_word_overlay	 fixed bin (35) unal based;




	bit_string_len = bvfs_data_ptr -> length_word_overlay * 9;
	bit_string_ptr = addrel (bvfs_data_ptr, 1);

	select_list_ptr = dbcb.select_ptr;

	cur_pos = 1;
	old_vi = 0;

	bvfs_simple_typed_vector_ptr ->
	     simple_typed_vector.number_of_dimensions = select_list.num_items;

	do i = 1 to select_list.num_items;
	     if cur_pos > bit_string_len
	     then call error (mrds_error_$max_retr_len);

	     if old_vi ^= select_list.item.var_index (i)
	     then old_vi = select_list.item.var_index (i);

	     rai_ptr = select_list.item.ai_ptr (i);

	     bvfs_simple_typed_vector_ptr ->
		simple_typed_vector.dimension (i).value_ptr = addr (bit_array (cur_pos));

	     cur_pos = cur_pos + rm_attr_info.bit_length;
	end;

	return;

     end build_vector_from_string;
%page;
create_temp_file: proc (x);				/* Creates a temp-file and its file desctor block */

/*  	PARAMETER	*/

	dcl     x			 fixed bin;	/* (OUTPUT) retrieve_info.ret_fd_ptr table index */


/*	MULTICS	*/


	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/*	OTHERS	*/

	dcl     atd		 char (200);
	dcl     KEYED_SEQ_UPDATE	 fixed bin internal static options (constant) init (10);
	dcl     number		 picture "99";


	x = 0;					/* Init */

	do i = 1 to mrds_data_$max_sets while (x = 0);	/* Find first null pointer in table */
	     if retrieve_info.ret_fd_ptr (i) = null then x = i;
	end;
	if x = 0 then call error (mrds_error_$too_many_temp_files);

	allocate fd in (dbcb.static_area) set (fd_ptr);
	retrieve_info.ret_fd_ptr (x) = fd_ptr;		/* Save the file descriptor pointer */

	number = x;				/* Make the number a picture */

	fd.name = unique_chars_ ("0"b) || ".mrds_temp." || number; /* Generate a unique file name */

	atd = "vfile_ " || rtrim (get_resultant_dir ()) || ">" || fd.name || "-dup_ok"; /* develop attach descriptor */

	call iox_$attach_ioname ((fd.name), fd.iocb_ptr, atd, icode);
	if icode = 0 then
	     call iox_$open (fd.iocb_ptr, KEYED_SEQ_UPDATE, "0"b, icode);
	if icode ^= 0 then call error (icode);


	fd.cur_key = low (256);
	fd.desc = 0;
	fd.rec_count = 0;

     end create_temp_file;
%page;
delete_temp_file: proc (x);				/* Deletes a single temp-file */

	dcl     x			 fixed bin;	/* (INPUT) retrieve_info.ret_fd_ptr index */

	dcl     file_name		 char (32);


	if retrieve_info.ret_fd_ptr (x) ^= null then do;
		fd_ptr = retrieve_info.ret_fd_ptr (x);	/* Set the pointer to the file descriptor */
		file_name = fd.name;

		call iox_$close (fd.iocb_ptr, icode);
		if icode = 0 then call iox_$detach_iocb (fd.iocb_ptr, icode);
		if icode = 0 then call iox_$destroy_iocb (fd.iocb_ptr, icode);
		if icode = 0 then
		     begin;

			call hcs_$del_dir_tree (get_resultant_dir (), file_name, icode);
			if icode = error_table_$notadir | icode = 0 then
			     call hcs_$delentry_file (get_resultant_dir (), file_name, icode);

			declare hcs_$del_dir_tree	 entry (char (*), char (*), fixed bin (35)); /* deletes sub directory contents */
			declare hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35)); /* deletes segs and empty dirs */
			declare error_table_$notadir	 fixed bin (35) ext; /* entry was not a directory */

		     end;

		if icode ^= 0 & ^clean_up_condition then call error (icode);
		free fd in (dbcb.static_area);	/* Deallocate this file descriptor */
		retrieve_info.ret_fd_ptr (x) = null;
	     end;
     end delete_temp_file;
%page;
get_resultant_dir: procedure () returns (char (168));

/* routine to get the resultant models storage directory */

	declare pathname		 char (168);	/* directory under which resultant model is stored */
	declare mrds_dsl_resultant_storage$get_opening_temp_dir entry (fixed bin (35), fixed bin (35))
				 returns (char (168)); /* gets temp dir for a particular opening */

/* good index, get a pathname from the dbcb segment pointer */

	pathname = mrds_dsl_resultant_storage$get_opening_temp_dir (dbcb.dbi, icode);
	if icode ^= 0 then
	     call error (icode);			/* does not return */

/* 				The dbcb segment pointer could not be expanded into a pathname. */

	else return (pathname);			/* good path of model dir found */

     end;
%page;
delete_temp_record: proc (fdx, data);

	dcl     fdx		 fixed bin;	/* (INPUT) File desc index into retrieve_info.ret_fd_ptr array */
	dcl     data		 char (*) varying;	/* (INPUT) */
	dcl     (new_key, rec_found)	 bit (1);

	fd_ptr = retrieve_info.ret_fd_ptr (fdx);	/* Set the file desc pointer */

	if length (data) <= 256 then do;		/* All data resides in key */
		call iox_$seek_key (fd.iocb_ptr, (data), rec_len, icode);
		if icode = 0 then
		     call iox_$delete_record (fd.iocb_ptr, icode);
	     end;

	else do;					/* All data does _n_o_t reside in the key */
		new_key, rec_found = OFF;		/* Init */

		call iox_$seek_key (fd.iocb_ptr, substr (data, 1, 256), rec_len, icode);
		do while (icode = 0 & new_key = OFF & rec_found = OFF);
		     call iox_$read_key (fd.iocb_ptr, fd.cur_key, fd.rec_len, icode);
		     if fd.cur_key ^= substr (data, 1, 256) then
			new_key = ON;
		     if icode = 0 & new_key = OFF then do;
			     call iox_$read_record (fd.iocb_ptr, addr (fd.rec_buf), length (fd.rec_buf), fd.rec_len, icode);
			     if icode = 0 then
				if substr (data, 257) = substr (fd.rec_buf, 1, rec_len) then
				     rec_found = ON;
			end;
		end;
		if icode = 0 then do;
			if rec_found = ON then
			     call iox_$delete_record (fd.iocb_ptr, icode);
			else icode = error_table_$no_record;
		     end;
	     end;
	if icode ^= 0 then call error (icode);

     end delete_temp_record;
%page;
difference: proc;					/* SET DIFFERENCE operation */

	set_info.cur_data_valid = OFF;		/* not valid while being changed */

	if sb (set_info.sbi - 1).file = OFF then do;	/* If it's not in a file, put it in one */
		call create_temp_file (sb (set_info.sbi - 1).fdx);
		call move_db_to_file (set_info.sbi - 1, sb (set_info.sbi - 1).ss_item_num, sb (set_info.sbi - 1).fdx);
		sb (set_info.sbi - 1).file = ON;	/* it's in a file now */
	     end;

	fd_ptr = retrieve_info.ret_fd_ptr (sb (set_info.sbi - 1).fdx); /* So we use the right file desc */
	call iox_$position (fd.iocb_ptr, -1, 0, icode);	/* Position to BOF to read it seq  */

	set_info.cur_fdx = sb (set_info.sbi - 1).fdx;	/* This is where the difference
						   between these two will reside */

	call init_search (set_info.sbi);

	call get_data (set_info.sbi, current_data, icode);

	do while (icode = 0);			/* Do the difference */

	     if icode = 0 then do;			/* If we got the data then see if a match
						   is found from the previous selected data */
		     call dup_check (sb (set_info.sbi - 1).fdx, current_data, dup_flag);
		     if dup_flag = ON then do;	/* If so this is an difference so delete it  */
			     call delete_temp_record (set_info.cur_fdx, current_data); /* Remove it
						   from temp file */
			end;
		     dbcb.another_flag = ON;		/* For mrds_dsl_search in get_data */
		end;

	     call get_data (set_info.sbi, current_data, icode);


	end;

	if icode ^= error_table_$end_of_info then call error (icode);
	else icode = 0;

	if sb (set_info.sbi).file then call delete_temp_file (sb (set_info.sbi).fdx); /* Delete the temp file
						   no longer needed */
	set_info.sbi = set_info.sbi - 1;		/* Set up for next set operation */
	sb (set_info.sbi).fdx = set_info.cur_fdx;	/* This becomes that set block file desc index */



     end difference;
%page;
dup_check: proc (fdx, data, dup_flag);

	dcl     fdx		 fixed bin;	/* (INPUT) File desc index into retrieve_info.ret_fd_ptr array */
	dcl     data		 char (*) varying;	/* (INPUT) */
	dcl     dup_flag		 bit (1);		/* (OUTPUT) ON = duplicate record found */
	dcl     new_key		 bit (1);

	fd_ptr = retrieve_info.ret_fd_ptr (fdx);	/* Set the file desc pointer */
	dup_flag = OFF;				/* Set OFF to start with */

	if length (data) <= 256 then do;		/* All data resides in key */
		call iox_$seek_key (fd.iocb_ptr, (data), rec_len, icode);
		if icode = 0 then
		     dup_flag = ON;
	     end;

	else do;					/* All data does _n_o_t reside in the key */
		new_key = OFF;			/* Init */

		call iox_$seek_key (fd.iocb_ptr, substr (data, 1, 256), rec_len, icode);
		if icode ^= 0 then if icode ^= error_table_$no_record then call error (icode);
		do while (icode = 0 & new_key = OFF & dup_flag = OFF);
		     call iox_$read_key (fd.iocb_ptr, fd.cur_key, fd.rec_len, icode);
		     if fd.cur_key ^= substr (data, 1, 256) then
			new_key = ON;
		     if icode = 0 & new_key = OFF then do;
			     call iox_$read_record (fd.iocb_ptr, addr (fd.rec_buf), length (fd.rec_buf), fd.rec_len, icode);
			     if icode = 0 then
				if substr (data, 257) = substr (fd.rec_buf, 1, rec_len) then
				     dup_flag = ON;
			end;
		end;

	     end;

     end dup_check;
%page;

get_data: proc (sbi, current_data, icode);

/* This procedure gets the next data record from either the database or a temp-file
   for the set block specified by set block index (sbi)

   when the data is to be retrieve from the database the calling procedure
   must have called init_search prior to the first call to get_data
   so that mrds_dsl_search will get subsequent tuples for
   the selection expression		*/


	dcl     sbi		 fixed bin;	/* (INPUT) Set block index */
	dcl     current_data	 char (*) varying;	/* (OUTPUT) data returned */
	dcl     icode		 fixed bin (35);	/* (OUTPUT) Error code */

	if sb (sbi).file = ON then do;		/* Data is from a file */
		call get_temp_record (sb (sbi).fdx, current_data, icode);
		if icode ^= 0 then if icode ^= error_table_$end_of_info then call error (icode);
	     end;
	else do;					/* Data is from the database */
		call mrds_dsl_search (dbcb_ptr, area_ptr, icode);
		if icode = 0 then
		     call build_data_string (current_data);
		else do;
			if icode ^= mrds_error_$tuple_not_found then call error (icode);
			else icode = error_table_$end_of_info;
		     end;
	     end;

     end get_data;
%page;
get_set_another: proc;				/* Retrieve set another operation */

	call get_temp_record (set_info.cur_fdx, current_data, icode); /* Get next record from
						   temp file */

	if icode = 0 then /* If there is one move it to user's variables */
	     call return_data_temp (current_data);
	else if icode = error_table_$end_of_info then /* Convert this to mrds_error */
	     icode = mrds_error_$tuple_not_found;

	if icode ^= 0 then call error (icode);

	num_tuples_retrieved = num_tuples_retrieved + 1;

	set_info.cur_data_valid = ON;			/* It's valid now */

     end get_set_another;
%page;
get_temp_record: proc (fdx, current_data, icode);		/* Gets a single record from a temp-file */

	dcl     fdx		 fixed bin;	/* (INPUT) File descriptor index into
						   retrieve_info.ret_fd_ptr array */
	dcl     current_data	 char (*) varying;	/* (OUTPUT) Char string of key||data record */
	dcl     icode		 fixed bin (35);	/* (OUTPUT) Error code */

	fd_ptr = retrieve_info.ret_fd_ptr (fdx);	/* Set the file desc pointer */
	set_info.cur_data_valid = OFF;


	call iox_$read_key (fd.iocb_ptr, fd.cur_key, fd.rec_len, icode);

	if icode = 0 then do;
		if fd.rec_len > 0 then /* If there is any data in record read the record */
		     call iox_$read_record (fd.iocb_ptr, addr (fd.rec_buf), mrds_data_$max_data_length,
			fd.rec_len, icode);
		else do;				/* Otherwise position to next rec as read_record would */
			call iox_$position (fd.iocb_ptr, 0, 1, icode);
			if icode = error_table_$end_of_info then icode = 0; /* We'l catch this on next call */
		     end;
	     end;

	if icode = 0 then do;
		current_data = fd.cur_key || substr (fd.rec_buf, 1, fd.rec_len); /* Key + any data */
		set_info.cur_data_valid = ON;		/* It's valid now */
	     end;



     end get_temp_record;
%page;
init: proc;

/* initialization procedure */

	num_tuples_retrieved, icode = 0;		/* Init  to start with */
	key_used_ptr = null;

	if dbcb.retr_info_ptr = null then do;
		allocate retrieve_info in (dbcb.static_area) set (dbcb.retr_info_ptr);
		retrieve_info.version = retrieve_info_version;
		do i = 1 to mrds_data_$max_sets;
		     retrieve_info.ret_fd_ptr (i) = null;
		end;
	     end;

     end init;
%page;
init_search: proc (sbi);				/* Initializes mrds_dsl_search fo a new selection esbipression */

	dcl     x			 fixed bin;
	dcl     sbi		 fixed bin;	/* select block index */

	if sb.file (sbi) = ON
	then do;
		fd_ptr = retrieve_info.ret_fd_ptr (sb.fdx (sbi));
		call iox_$position (fd.iocb_ptr, -1, 0, icode); /* point to beginning */
		if icode ^= 0 then call error (icode);
	     end;

	else do;
		x = sb.ss_item_num (sbi);
		range_ptr,
		     dbcb.range_ptr = select_sets.items (x).range_ptr;
		dbcb.so_ptr = select_sets.items (x).so_ptr;
		ti_ptr,
		     dbcb.ti_ptr = select_sets.items (x).ti_ptr;
		select_list_ptr,
		     dbcb.select_ptr = select_sets.items (x).select_ptr;
		dbcb.another_flag, dbcb.current_flag = OFF; /* So dsl_search will initialixe */
	     end;

     end init_search;
%page;
init_set: proc;

/* Procedure to build a set of data */

	if select_sets.dup_retain then call error (mrds_error_$no_dups_for_set_oper);
	do i = 1 to mrds_data_$max_sets;		/* free any file descriptors that may be allocated */
	     if retrieve_info.ret_fd_ptr (i) ^= null then /* Delete temp file and */
		call delete_temp_file (i);		/* Null the dbdb.ret_fd_ptr (i) */
	end;

	retrieve_info.first_sw = ON;			/* So setup_set will initialize */

	call setup_set_info;

	do while (set_info.last_sb_oper = OFF);
						/* 1 => union 2 => intersection  3 =>Difference */
	     goto case (set_info.oper);

case (1):	     call union;
	     goto case_out;

case (2):	     call intersection;
	     goto case_out;

case (3):	     call difference;
	     goto case_out;

case_out:
	     call setup_set_info;			/* Setup next set operation */
	end;

	goto kase (set_info.oper);

kase (1): call union;
	goto kase_out;

kase (2): call intersection;
	goto kase_out;

kase (3): call difference;
	goto kase_out;

kase_out:

	fd_ptr = retrieve_info.ret_fd_ptr (set_info.cur_fdx);
	call iox_$position (fd.iocb_ptr, -1, 0, icode);	/* Rewind the file */

     end init_set;
%page;
intersection: proc;					/* INTERSECTION SET operation */

	set_info.cur_data_valid = OFF;		/* Cause were gona change it */

	if sb (set_info.sbi - 1).file = OFF then do;	/* If its not inafile put in one */
		call create_temp_file (sb (set_info.sbi - 1).fdx);
		call move_db_to_file (set_info.sbi - 1, sb (set_info.sbi - 1).ss_item_num, sb (set_info.sbi - 1).fdx);
		sb (set_info.sbi - 1).file = ON;	/* Got it on a file now */
	     end;

	fd_ptr = retrieve_info.ret_fd_ptr (sb (set_info.sbi - 1).fdx); /* So we use the right file desc */
	call iox_$position (fd.iocb_ptr, -1, 0, icode);	/* Position to BOF cause were gonna read it seq  */

	call create_temp_file (set_info.cur_fdx);	/* Tempfile
						   for intersection */
	call init_search (set_info.sbi);

	call get_data (set_info.sbi, current_data, icode);

	do while (icode = 0);			/* Do the intersection */

	     if icode = 0 then do;			/* If we got the data then see if a match
						   is found from the previous selected data */
		     call dup_check (sb (set_info.sbi - 1).fdx, current_data, dup_flag);
		     if dup_flag = ON then do;	/* If so this is an intersection so save it  */
			     call dup_check (set_info.cur_fdx, current_data, dup_flag); /* see if there is
						   already one on the file */
			     if ^dup_flag then call add_record (set_info.cur_fdx, current_data);
			end;
		     dbcb.another_flag = ON;		/* For mrds_dsl_search in get_data */
		end;

	     call get_data (set_info.sbi, current_data, icode);

	end;

	if icode ^= error_table_$end_of_info then call error (icode);
	else icode = 0;

	if sb (set_info.sbi).file then call delete_temp_file (sb (set_info.sbi).fdx); /* Delete the temp file
						   no longer needed */
	set_info.sbi = set_info.sbi - 1;		/* Set up for next set operation */

	sb (set_info.sbi).fdx = set_info.cur_fdx;	/* This becomes that set block file desc index */



     end intersection;
%page;
move_db_to_file: proc (sbi, is, fdx);			/* Adds data selected to a temp-file */

	dcl     is		 fixed bin;	/* (INPUT) Select sets item index */
	dcl     fdx		 fixed bin;	/* (INPUT) File desc index into retrieve_info.ret_fd_ptr array */
	dcl     sbi		 fixed bin;	/* INPUT: select block index used by init_search */


	call init_search (sbi);			/* Init pointers for mrds_dsl_search */

	icode = 0;

	do while (icode = 0);			/* Get all the tuples that satisfy the selection exp */

	     call mrds_dsl_search (dbcb_ptr, area_ptr, icode);

	     if icode = 0 then do;			/* If we found one get it from db  */

		     call build_data_string (current_data);
		     if icode = 0 then do;
			     call dup_check (fdx, current_data, dup_flag);
			     if dup_flag = OFF then call add_record (fdx, current_data);
			end;
		     dbcb.another_flag = ON;		/* So search will continue searching */

		end;
	end;

	if icode ^= 0 then if icode ^= mrds_error_$tuple_not_found then call error (icode);

     end move_db_to_file;
%page;
move_file_to_file: proc (from_fdx, to_fdx);

/* Moves data from a temp-file to a temp-file handling duplicates */

	dcl     (from_fdx,				/* (INPUT) file descriptor index
						   into retrieve_info.ret_fd_ptr array */
	        to_fdx)		 fixed bin;	/* (INPUT) File des index into retrieve_info.ret_fd_ptr array */


	fd_ptr = retrieve_info.ret_fd_ptr (from_fdx);

	call iox_$position (fd.iocb_ptr, -1, 0, icode);	/* Rewind the file */

	if icode ^= 0 then call error (icode);

	do while (icode = 0);			/* As long as there are records on input file */

	     call get_temp_record (from_fdx, current_data, icode); /* Get rec from file */

	     if icode = 0 then do;
		     call dup_check (to_fdx, current_data, dup_flag);
		     if dup_flag = OFF then call add_record (to_fdx, current_data);
		end;
	end;

	if icode ^= 0 then if icode ^= error_table_$end_of_info then call error (icode);

     end move_file_to_file;
%page;
return_data_temp: proc (data_str);

/* Procedure to return data to the caller from a temporary hold file. */

	dcl     bs_ptr		 ptr;
	dcl     data_str		 char (*) var;
	dcl     (cur_pos,
	        len,
	        i)		 fixed bin (35);

	cur_pos = 1;				/* initialize */
	bs_ptr = addr (data_str);
	bs_ptr = addrel (bs_ptr, 1);

START_RETURN_DATA_TEMP:

	do i = 1 to select_list.num_items;		/* for each selected attribute */

	     rai_ptr = select_list.item.ai_ptr (i);	/* point to attr info */

	     len = rm_attr_info.bit_length;

	     call mu_get_data$get_data_item (rai_ptr, dbcb.work_area_ptr,
		addbitno (bs_ptr, cur_pos - 1),
		select_list.item.user_ptr (i),
		select_list.item.user_desc_ptr (i), icode);
	     if icode ^= 0 then
		if icode = error_table_$noalloc then
		     go to START_RETURN_DATA_TEMP;
		else call error (icode);

	     cur_pos = cur_pos + len;			/* tidy up */

	end;					/* select item loop */

     end return_data_temp;
%page;
return_data_tup: proc;

/* Procedure to return data to the caller from the tuples retrieved. */

BEGIN_RETURN_DATA_TUP:

	do i = 1 to select_list.num_vars;		/* loop for each selected item */
	     var_index = move_list_array.var_index (i);
	     do j = 1 to tuple_info.num_tuples while (tuple_info.tuple.var_index (j) ^= var_index);
	     end;
	     icode = 0;
	     if range.tup_var (var_index).copy_for_current
	     then do;
		     rmri_ptr = range.tup_var (var_index).ri_ptr;
		     call mu_cursor_manager_$get (dbcb.dbi, rmri_ptr, (0), rm_rel_info.rel_id,
			dbcb.relmgr_entries.create_cursor, dbcb.relmgr_entries.open,
			dbcb.cursor_ptrs_storage_ptr, dbcb.cursor_storage_area_ptr,
			cursor_ptr, icode);
		     if icode ^= 0 then call error (icode);
		     call dbcb.relmgr_entries.get_tuple_by_id (
			cursor_ptr,
			tuple_info.tuple (var_index).tuple_id,
			rm_rel_info.id_list_ptr, dbcb.select_area_ptr,
			tuple_info.tuple (var_index).tuple_ptr,
			icode);
		     if icode ^= 0 then call error (icode);
		     range.tup_var (var_index).copy_for_current = "0"b;
		     range.tup_var (var_index).copied_for_current = "1"b;
		end;				/* copy for current */
	     call mu_get_data$get_data (range.tup_var.ri_ptr (move_list_array.var_index (i)), dbcb.work_area_ptr,
		tuple_info.tuple.tuple_ptr (j), move_list_array.ml_ptr (i), icode);
	     if icode ^= 0 then
		if icode ^= error_table_$noalloc
		then call error (icode);
		else go to BEGIN_RETURN_DATA_TUP;
	end;					/* loop for each item */


	dcl     icode		 fixed bin (35);
	dcl     cursor_ptr		 ptr;
	dcl     (i, j)		 fixed bin;
	dcl     var_index		 fixed bin;

     end return_data_tup;
%page;
setup_set_info: proc;				/* Prepares set_info and set blocks for next set operation */

	dcl     ix		 fixed bin;



	if retrieve_info.first_sw = ON then do;		/* First time this proc has been called for this set selection */

		set_info.cur_fdx = 0;
		set_info.ssi = 0;
		set_info.sbi = 0;
		set_info.cur_data_valid = OFF;
		retrieve_info.first_sw = OFF;
		set_info.last_sb_oper = OFF;
	     end;


	do while (select_sets.items (set_info.ssi + 1).oper_flag = OFF);
	     set_info.ssi = set_info.ssi + 1;
	     ix, set_info.sbi = set_info.sbi + 1;

	     sb (ix).ss_item_num = set_info.ssi;
	     sb (ix).fdx = 0;
	     sb (ix).file = OFF;
	     sb (ix).eod = OFF;
	     sb (ix).first = ON;
	end;

	set_info.ssi = set_info.ssi + 1;
	set_info.oper = select_sets.items (set_info.ssi).op_code;
	if set_info.ssi + 1 > select_sets.nitems then
	     set_info.last_sb_oper = ON;

     end setup_set_info;
%page;
union: proc;					/* UNION set operation */

	set_info.cur_data_valid = OFF;		/* It isgona change */

	if sb (set_info.sbi - 1).file = ON then do;	/* Previous set block is a file so use it */
		set_info.cur_fdx = sb (set_info.sbi - 1).fdx;
		if sb (set_info.sbi).file = ON then /* Current set block is a file so add it to previous */
		     call move_file_to_file (sb (set_info.sbi).fdx, set_info.cur_fdx); /*   set block file */

		else /* Add the selected tuples from db to previous sb file */
		     call move_db_to_file (set_info.sbi, sb (set_info.sbi).ss_item_num, set_info.cur_fdx);
	     end;

	else do;					/* Previous set block was not a file */
		if sb (set_info.sbi).file = ON then do; /* Current sb is a file */
			set_info.cur_fdx = sb (set_info.sbi).fdx;
			call move_db_to_file (set_info.sbi - 1, sb (set_info.sbi - 1).ss_item_num, set_info.cur_fdx);
		     end;

		else do;				/* Neither previous sb or current sb is a file */
			call create_temp_file (set_info.cur_fdx);
			call move_db_to_file (set_info.sbi, sb (set_info.sbi).ss_item_num, set_info.cur_fdx);
			call move_db_to_file (set_info.sbi - 1, sb (set_info.sbi - 1).ss_item_num, set_info.cur_fdx);
		     end;

		sb (set_info.sbi - 1).fdx = set_info.cur_fdx; /* Stash the fdx */
		sb (set_info.sbi - 1).file = ON;	/* Indicate that the file exists */
	     end;

	set_info.sbi = set_info.sbi - 1;		/* Keep track of where we are */


     end union;
%page;

error: proc (cd);

	dcl     cd		 fixed bin (35);	/* (INPUT) error code */

	if st_entry then do;
		a_code = cd;
		goto st_exit;
	     end;
	else do;
		code = cd;			/* Return the error code to caller */
		call cleanup_handler;		/* Tidy up before we leave */
		goto exit;			/* Exit mrds_dsl_sec_retrieve */
	     end;

     end error;
%page;
cleanup_handler: proc;

	clean_up_condition = ON;			/* to avoid loops */

	on seg_fault_error goto get_out;

	call clean_up_temp_files ();

	call clean_up_per_call_area ();

get_out:
	clean_up_condition = OFF;

	return;

     end cleanup_handler;
%page;
clean_up_per_call_area: procedure ();

/* routine to capture philosophy for "releasing" per call work area */

	if dbcb_ptr = null () then ;
	else if dbcb.retrieve_area_ptr ^= null () then do;
		call mu_release_area (dbcb.retrieve_area_ptr);

/* do not null area pointers, this would cause getting new temp segs, instead of reuse */

	     end;

     end;
%page;
clean_up_temp_files: procedure ();

/* routine to get rid of all temp files */

	if dbcb_ptr ^= null then do;
		if dbcb.retr_info_ptr ^= null then do;
			do i = 1 to mrds_data_$max_sets; /* free any file descriptors that may be allocated */
			     if retrieve_info.ret_fd_ptr (i) ^= null then /* Delete temp file and */
				call delete_temp_file (i); /* Null the dbdb.ret_fd_ptr (i) */
			end;
		     end;
	     end;

     end;
%page;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_range;
%page;
%include mrds_select_list;
%page;
%include mrds_tuple_info;
%page;
%include mdbm_arg_list;
%page;
%include mrds_select_sets;
%page;
%include mrds_retrieve_info;
%page;
%include mrds_fd;
%page;
%include mdbm_descriptor;
%page;
%include mrds_predicate_tree;
%page;
%include vu_typed_vector;
%page;

	dcl     current_data	 char (4 * sys_info$max_seg_size - 4) varying based (dbcb.current_data_ptr);
	dcl     static_data		 char (4 * sys_info$max_seg_size - 4) varying based (dbcb.static_data_ptr);

	dcl     1 set_info		 aligned internal static,
		2 oper		 fixed bin,	/* Set operation being performed */
		2 ssi		 fixed bin,	/* Current select_sets index */
		2 sbi		 fixed bin,	/* Current selct_block index */
		2 cur_fdx		 fixed bin,	/* Current file desc index into retrieve_info.ret_fd_ptr array */
		2 cur_data_valid	 bit (1) unaligned, /* ON => data in variable current_data is valid */
		2 last_sb_oper	 bit (1) unaligned, /* ON => this is last set block */
		2 reserved	 bit (34) unaligned;/* Reserved for future use */



	dcl     1 sb		 (20) aligned internal static, /* Set block */
		2 ss_item_num	 fixed bin,	/* Index into select_sets table */
		2 fdx		 fixed bin,	/* File desc index into dbdb.ret_fd_ptr array */
		2 file		 bit (1) unaligned, /* ON => this set_block is a file */
		2 eod		 bit (1) unaligned, /* ON => end of data for this set_block */
		2 first		 bit (1) unaligned, /* ON => this first reference to this set_block */
		2 reserved	 bit (33) unaligned;/* Reserved for future use */
						/* Multics Subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     error_table_$end_of_info ext fixed bin (35);
	dcl     error_table_$no_record ext fixed bin (35);
	dcl     error_table_$noalloc	 ext fixed bin (35);
	dcl     iox_$attach_ioname	 entry (char (*), ptr, char (*), fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$delete_record	 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_$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_$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     (iox_$detach_iocb, iox_$destroy_iocb) entry (ptr, fixed bin (35));

	dcl     sys_info$max_seg_size	 ext fixed bin (35);

/*   DBM Routines */

	dcl     mrds_data_$caller_retrieve fixed bin (17) ext;
	dcl     mrds_data_$max_attributes fixed bin (35) ext static;
	dcl     mrds_data_$max_data_length fixed bin (21) ext;
	dcl     mrds_data_$max_id_len	 fixed bin (35) ext;
	dcl     mrds_data_$max_select_items ext fixed bin;
	dcl     mrds_data_$max_sets	 ext fixed bin;
	dcl     mrds_dsl_search	 entry (ptr, ptr, fixed bin (35));
	dcl     mrds_dsl_translate	 entry (ptr, ptr, fixed bin, ptr, fixed bin, ptr, ptr, fixed bin, fixed bin (35));
	dcl     mrds_error_$incomp_se_and_scope ext fixed bin (35);
	dcl     mrds_error_$inconsistent_transaction_se ext fixed bin (35);
	dcl     mrds_error_$invalid_db_index ext fixed bin (35);
	dcl     mrds_error_$inval_rtrv_expr ext fixed bin (35);
	dcl     mrds_error_$max_retr_len ext fixed bin (35);
	dcl     mrds_error_$no_dups_for_set_oper ext fixed bin (35);
	dcl     mrds_error_$too_many_temp_files ext fixed bin (35);
	dcl     mrds_error_$tuple_not_found ext fixed bin (35);
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mu_get_data$get_data	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_get_data$get_data_item entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_data_class$varying	 entry (ptr) returns (bit (1) aligned);
	dcl     mu_data_class$bit	 entry (ptr) returns (bit (1) aligned);

/*  OTHERS  */

	dcl     (se_ptr,				/* pointer to selection expr. */
	        cd_ptr,				/* pointer to status code */
	        dbi_ptr,				/* ptr to db index */
	        appl_ptr,				/* pointer to args for translate */
	        adpl_ptr)		 ptr;		/* pointer to descs for translate */

	dcl     fb35u		 fixed bin (35) unal based;

	dcl     icode		 fixed bin (35);	/* Internal error code */

	dcl     code		 fixed bin (35) based (cd_ptr); /* Output: status code */
	dcl     database_index	 fixed bin (35) based (dbi_ptr); /* input: db index */
	dcl     rec_len		 fixed bin (21);

	dcl     (nargs,				/* num args passed in */
	        se_len,				/* length of selection expr. */
	        arg_len,				/* length of an arg */
	        number_of_and_groups,			/* Number of and groups in a slection exp */
	        num_args,				/* num args for translate */
	        num_tuples_retrieved)	 fixed bin;	/* Count of tuples found on this call to secure_retrieve */
	dcl     i			 fixed bin;

	dcl     (null,
	        addr,
	        ceil,
	        addbitno,
	        addrel,
	        substr,
	        length,
	        low,
	        maxlength,
	        index,
	        rtrim,
	        divide,
	        fixed,
	        rel,
	        string)		 builtin;

	dcl     (cleanup, any_other, arg_error) condition;

	dcl     dup_flag		 bit (1);		/* Duplicate record indicator */
	dcl     st_entry		 bit (1);		/* to remember which entry used */
	dcl     original_appl_ptr	 ptr;		/* copy of original value of appl_ptr incase of rollback */
	dcl     original_adpl_ptr	 ptr;		/* copy of original value of adpl_ptr incase of rollback */
	dcl     original_num_args	 fixed bin;	/* copy of original value of num_args incase of rollback */

/* STATIC VARIABLES */

	dcl     OFF		 bit (1) init ("0"b) internal static options (constant);
	dcl     ON		 bit (1) init ("1"b) internal static options (constant);
	declare clean_up_condition	 bit (1) init ("0"b); /* on => clean up proc called */
	declare seg_fault_error	 condition;
	declare mu_release_area	 entry (ptr);
	declare area_ptr		 ptr;
	dcl     mu_cursor_manager_$get entry (fixed bin (35), ptr, fixed bin (35), bit (36) aligned, entry, entry, ptr, ptr,
				 ptr, fixed bin (35));
	declare mu_define_area$define_temp_dir_area entry (ptr, fixed bin (35), fixed bin (18), char (11), bit (1) aligned,
				 bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     mu_define_area$define_spec_temp_dir_area entry (ptr, fixed bin (35), char (11), fixed bin (35));
	declare se_len_ptr		 ptr;		/* temp for getting varying se length */
	dcl     found		 bit (1);
	dcl     j			 fixed bin;
	dcl     key_used		 (key_used_len) bit (1) based (key_used_ptr);
	dcl     key_used_len	 fixed bin;
	dcl     key_used_ptr	 ptr;
	dcl     dbi_pic		 picture "999";

     end mrds_dsl_retrieve;




		    mrds_dsl_search.pl1             08/01/88  1347.6r w 08/01/88  1315.0      237771



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

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

mrds_dsl_search: proc (dbcb_ptr, area_ptr, code);

/*
   .                        BEGIN_DESCRIPTION
   This  is the procedure which directs the searching of the database to locate
   the  next  tuple satisfying the selection expression.  Search is implemented
   as  a  finite  state  machine  which  recognizes  six op codes, namely:

   (1) initialize tuple variable ranges,

   (2) move comparison values,

   (3) select next tuple,

   (4) return information,

   (5) return null.

   (6) initialize the search_vars structure

   The  search_vars  and  search_ops  structures  must be in existence prior to
   calling mrds_dsl_search.

   .    State 6 is executed first and initiates the  search_vars
   .    structure. Among other things this structure will keep a
   .    pointer to the tid list.

   .    State 2 (move) is executed next. This state  moves  into
   .    locations  known  to state 3 values that will be used to
   .    locate tuples using key searchs. It will also encode the
   .    values if need be.

   .    State  1  (init)  is now executed.  It merely  marks the
   .    search as .  starting at the top of the relation.

   .    State  3  (select)  is now executed,  it selects a tuple
   .    based  on  the search specification  and the rest of the
   .    conditions on    the tuple.  mu_retrieve does the actual
   .    retrieveal.

   .    State 4 is the normal return  case,  it  sets  the  next
   .    state to be executed back to 3 and returns.

   .    State  5  is  the  error  case  it  sets  the  code   to
   .    tuple_not_found and returns.

   Note  that  for  more  complex   SEs   there   may   be   several
   move-init-select  loops but the function of each loop remains the
   same.
   .                           END_DESCRIPTION

*/


/* MRDS_DEGUG_TOOL SWITCHES:

   bit 1 = display each tuple located.
   bits 2 thru 9 = not used.

*/
%page;
/* HISTORY:

   76-01-01 O.  D.  Friesen: Pre-MR7.0 version written.

   78-09-01 J.  A.  Weeldreyer: Completely rewritten for MR7.0.

   79-05-17 Al Kepner: Modified to add entries db_on and db_off.

   79-06-18   Al   Kepner:   Modified   to   interpret  error_table_$no_key  as
   tuple_not_found.

   79-07-03 Al Kepner: Modified to use mu_convert$convert_data and to eliminate
   code  for  setting the bit length of a varying character string.  The length
   of  a  varying  character string will now be stored in the db as a character
   count.

   79-07-31 Al Kepner: Modified to make -current work correctly.

   79-08-30 Davids: Modified to handle the where clause ((r.i > 4) & (r.i < 6))
   where i is a secondary index.

   79-09-06  Davids:  Modified  to  accommodate  a  new  calling  sequence  for
   mu_encd_key  .  Also
   inclusion   of   mdbm_ind_sel_info.incl.pl1.    Note:   move_data.t_ptr  and
   init_info.val_ptr  both  point  to  a ind_sel_info structure - hopefully the
   same one.

   79-10-01 Jim Gray: Modified to correct clean up handler.

   79-11-14   Rickie   E.    Brinegar:  Modified  to  use  mrds_debug_tool  and
   db_mrds_dsl_search   instead   of   entry   points   db_on  and  db_off  and
   debug_switch.

   79-11-14 Rickie E.  Brinegar: Modified to allocate tid_array and tid_list in
   select_area, an area which is never freed.

   79-12-21  Jim  Paradise:  Modified  to  dimension  data_array  starting at 0
   instead of 1 (got a subscriptrange error).

   80-02-04  Rickie  E.   Brinegar: Modified to keep the intersection code from
   leaving the tl_ptr pointing to a useless tid_list.

   80-02-05  Jim  Gray:  Modified  to add area_ptr parameter, for passing on to
   mu_retrieve, and mrds_dsl_eval_expr.

   80-02-15  Davids: corrected indexing into data_array so that element zero is
   never  referenced.  redeclared data_array to start will element 1.  Modified
   mu_retrieve  interface  so  that it accepts an output variable which
   points  to  tuple.data of the current tuple.  corrected handling of code for
   extracting values of varying attributes for key head types.

   80-08-01  E Brunelle: Modified to use temp segments as opposed to allocating
   storage in search_area.

   80-10-20  Jim  Gray: Modified to put calls to temp seg manager in mdbm_util_
   format   for   naming   conventions,   and   add   db_index   parameter   to
   get_temp_segment entries.  This allows the opening resultant dir to be used.

   80-10-22  Jim Gray: Modified to fix bug from brunelle's change, he felt that
   union  and  differ  operators  in  the  init_range  operation would not work
   properly  unless  all of the init operation were allowed to complete, rather
   than  doing  an err_xfer immediately.  The operand_error routine was written
   for  this,  but has now be commented out.  The error introduced was that the
   error_table_$no_key  condition  was  no  longer  captured  in the code for a
   unique  index  operand  in  init_range.   It  was discovered that unions and
   differs  can not be generated by mrds_dsl_srch_prog, so that Brunelles worry
   was  unfounded,  at least for now.  Several initializations for ta_nids that
   were removed were added back, and the same for some tid_list.ta_ptr nulling.

   80-10-23 Davids: Modified d_ptr to be an array (data_ptrs) with an extent of
   mrds_data_$max_tup_var.   This  allows multiple retrieve operations in a row
   without  lossing  the first d_ptr values.  It is assumed (I cannot prove it,
   but  it  looks this way) that the multiple retrieve operations will all deal
   with  different tuple variables.  The d_ptr is used only when moving varying
   length attributes.  This fixes TR7675.

   80-10-24  Jim  Gray:  Modified  to allow tid_lists to freed when they are no
   longer  needed,  (otherwise  the growth of space usage is exponential in the
   number  of  move-init-select  triples being executed on the number of tuples
   involved  at each level.) This reduces the actual storage need to the number
   of  move-init-select  triples  needed  to implement the selction expression.
   The  area  for  freeing  them is managed as an internal static area, that is
   emptied  whenever  a new selection expression is started.  This required the
   new dbcb.new_select_expr bit in the mrds_dbcb.incl include file.

   80-10-25  Jim Gray: Modified to correct logic in init_range/unique_index, so
   that  when no_key is found, the ntids is set to 0, and the init_info loop is
   exited   normally,  rather  than  taking  an  immediate  err_xfer,  so  that
   search_vars  is  properly  set up to free the tid_array temp segment, and so
   that  the  tid_list  is  freed.   Previously, one un-freed temp segment (and
   tid_list)  was  left  around every time the no_key condition happened, which
   would eventually blow out the static_area.

   81-03-11 Rickie E.  Brinegar: Modified the index range code to behave in the
   same  manner  as  the  unique index code works in regards to getting back an
   error  code  which  is  not  zero from the indexing routine.  The error code
   error_table_$no_record  is  now  treated as a good transfer instead of as an
   error  transfer  for  the  case of the index range.  This permits the proper
   freeing of tid_list structures.

   81-03-27  Jim  Gray  :  changed  dbi  parameter  in   mu_pos_rel,
   mu_get_tid$get_tid_key,    get_tid_hash,    get_index_tids,   and
   retrieve to dbcb_ptr  as  part  of  getting  rid  of  mus_ptr_man
   module.

   81-04-25 Jim Gray : changed length declarations of  dbi_pic,  and
   mrds_data_$temp_seg_name, to allow three digit db_index values as
   part of increasing from 64 to 128 possible database openings.

   81-05-01 Jim Gray : commented out call to mu_hash_key, so  module
   mu_hash_key  could  be  removed,  since  blocked  files  are  not
   implemented.

   81-05-01 Jim Gray : extended tid_list  structure  to  contain  an
   extended  file_id,  and  added comparison of file_id's to current
   tid  comparison  in  the  init  section  for   the   intersection
   operation.  This  was  not  done  for  union  and  difference, as
   gen_srch_prog can not currently generate these operators.


   81-05-22 Jim Gray : added error message to give  details  when  a
   conversion  type move_info failed in it's call to mu_convert. The
   data types, and the source data value are displayed.  Also  added
   conversion  of move_info.s_ptr from the tuple.var_offset array to
   the current offset, for varying attrs, prior to this conversion.

   81-06-01 Jim Gray :  changed  to  use  new  resultant  structure.
   Blocked  file  code  removed,  and code never referenced removed.
   This included for the init operation, the  difference  and  union
   operations  (gen_srch_prog  never  genrates any but intersection)
   and the hash, link chain type of operand location mechanisms. The
   move_info foreign key, and encode_attr options were removed also.

   81-06-12 Jim Gray : removed extra assignment of  tid_list.fwd_thd
   pointer  for  the  case  of  init_info  operator with null second
   operand. This assignment is taken care of  by  the  free_tid_list
   routine,  and this extra code was accidentally left in during the
   addition of this routine.

   81-06-17  Jim  Gray   :   added   iocb   ptr   index   param   to
   mu_get_tid$get_tid_key so that retrieves would not be required to
   use the dedicated update iocb.

   81-06-30 Jim Gray : added a second key  value  parameter  to  the
   call  to  get  tuple  id's on a key head or index, so that ranges
   like 10 < x < 20 could be handled in one call  to  vfile  select,
   instead of two.

   81-07-01 Jim Gray : changed call to mu_pos_rel into a direct call
   to  iox_$position to avoid un-needed overhead. mu_pos_rel used to
   call iox_$control "seek_head", but that is  un-necessary  without
   blocked files, and position is needed for mu_scan_records to work
   properly. Also added call to  mu_scan_records$init  for  retrieve
   only openings, so that the EOF indicator would be reset.

   81-07-18  Jim  Gray  :  changed  to  handled  new  encodings   of
   init_info.op_type for the new access methods.

   81-07-22 Jim Gray  :  added  logic  to  allow  vfile  to  do  the
   intersection  of  tid lists whenever possible, rather than having
   mrds do it, as vfile can do it faster  on  a  previously  defined
   subset, using less space than the mrds method.

   82-06-07 Davids: expanded the description at the begining of the
   source.

   82-09-02 Mike Kubicar : made the changes necessary to use the simple
   vector structure instead of the tuple structure.

   82-0-21 Davids: changed references to search_vars.info.iocb_ind (vi) to
   search_vars.info.cursor_ptr (vi) (this changes the calling parameters of
   mu_get_tid$get_tid_key and $key_index_tids. Also removed the call to
   iox_$control (select control order) which was used to overcome a bug
   with record status and the calls to iox_$position and mu_scan_records$init
   which were used to initialize the position when the entire relation is to
   be retrieved.

   82-10-01 Davids: removed references to move_info.encd_index and
   mu_encd_key$encd_key since this is no longer done by mrds (its
   done by the relation manager).

   82-10-05 Davids: changed calling sequences of mu_get_tid entries

   82-10-13 Davids: Changes to get the module to compile. Removed the
   the references to rm_rel_info.file_id and tid_list.file_id which
   was assigned from rm_rel;_info.file_id. tid_list.file_id was
   used in the intersection merge loop.

   82-10-22 D. Woodka : Changed to set search_vars.info.first_seq_io
   if the range is unrestricted.

   82-10-22 Davids: Updated the parameter list of mu_retrieve, removed
   data_ptrs parameter. 

   82-10-28 Davids:Modified the call to mu_get_tid$get_tid_key to use
   the select_area instead of the area input as a parameter (area_ptr).
   The call to mu_get_tid$get_index_tids does not need to be modified since
   it uses an area set up spefically to hold tids.

   82-10-29 Davids: Modified so that move_info.s_ptr is now used for the
   pointer to the source data instead of using s_ptr to point to an offset
   in the tuple for the data when the source is a varying string.

   82-11-10 Davids: all calls to mu_temp_segments$free_temp_segment were
   modified to pass pointer (ta_ptr, 0) instead of just a ta_ptr. It used
   to be that the tid_array (based off of ta_ptr) was just overlayed on the
   temp segment with conversion to the relation manager the temp segment
   has become an area and the tid_array allocated in that area. The ta_ptr
   therefore no longer points to the base of the segment. The call to the
   pointer function corrects that. This modification has also been made
   to the assignment of the ta_ptr from tid_list.ta_ptr when a previous subset
   is to be used.

   82-12-21 Davids: Modified the internal proc combine_opnds to also copy the
   value of the non_standard_vfile_descriptor element of the tid_list to keep
   from using the last subset incorrectly. TR14389

   83-01-14 Davids: Modified the internal proc free_tid_list to correctly
   handle the case of removing the second element from the tid list. It was
   incorrectly changing the value of stack_ptr (pointer to the first element
   on the list) if the value of stack_ptr and last_tl_ptr (pointer to the
   parent of the element to be deleted) where equal, i.e. the element to be
   deleted was the second element on the list. It now changes the value of 
   stack_ptr only if stack_ptr and tl_ptr (pointer to the element to be
   deleted) are equal, i.e. the element to be deleted is the first first
   element on the list.

   83-04-04 Davids: Explicitly declared the builtins fixed, pointer, rel.
   Removed declarations to BIT_VAR, data_array, offset.

   83-04-22 Mike Kubicar : Removed most of the code for the init operation
   since all this is now handled by relation manager.  A select with the
   proper search specification does the same thing.  Also, the init_info
   structure no longer exists.  Finally, the calling sequence for mu_retrieve
   has changed.

   83-05-18 Ron Harvey : Changed calling sequence of mu_retrieve in order to
   accommodate a 'shortened' simple_typed_vector.

   83-05-21 Mike Kubicar : Updated to use new search specification

   84-10-21 John Hergert: added initialization of search_vars.info.ntids. Also
   removed duplicate initialization of search_vars.info.first_seq_io.

*/
%page;
	dbi_pic = dbcb.dbi;				/* convert dbi to 3 chars */
	temp_seg_name = mrds_data_$temp_seg_name || dbi_pic; /* make unique name for temp segs for this dbi */
	stack_ptr = null;				/* initiallize */
	display_tuples = "0"b;

/*	display_tuples = substr (db_mrds_dsl_search, 1, 1);   Removered for performance */

	icode = 0;
	on cleanup call tidy_up;
	sv_ptr = dbcb.sv_ptr;
	so_ptr = dbcb.so_ptr;
	ti_ptr = dbcb.ti_ptr;
	select_area_ptr = dbcb.select_area_ptr;
	range_ptr = dbcb.range_ptr;			/* to obtain tuple variable name for debugging. */

next:	;					/* main loop */
	go to operation (search_ops.op.code (search_ops.ic));

operation (1): ;					/* initialize variable range */

	vi = search_ops.op.var_ind (search_ops.ic);	/* var index */
	rmri_ptr = search_vars.info.ri_ptr (vi);	/* point to rel_info */
	search_vars.info.ntids (vi) = 0;
	search_vars.info.first_seq_io (vi) = "1"b;	/* indicate that the first sequential i/o is to be done */
	search_ops.ic = search_ops.ic + search_ops.op.good_xfer (search_ops.ic);
	go to next;
%page;
operation (2): ;					/* move values required for init. or select */

	mi_ptr = search_ops.op.info_ptr (search_ops.ic);	/* pick up move info */
	vi = search_ops.op.var_ind (search_ops.ic);
	rmri_ptr = search_vars.info.ri_ptr (vi);

	do while (mi_ptr ^= null);			/* move each item in list, in turn */

	     if move_info.extr_attr
	     then move_info.s_ptr = tuple_info.tuple
		     (move_info.tuple_var_index).tuple_ptr
		     -> simple_typed_vector
		     .dimension (move_info.tuple_attr_index).value_ptr;
	     if move_info.var_ind > 0 then /* if db. */
		if search_vars.new_val (move_info.var_ind, vi) then /* if new value */
		     must_move = "1"b;
		else must_move = "0"b;		/* if have moved this before */
	     else must_move = "1"b;
	     if must_move then do;

		     if move_info.bit_move then /* if straight bit move */
			targ_string = src_string;
		     else if move_info.var_move then do;/* is variable len field */
			     true_len = move_info.s_ptr -> fb35u;
			     if addr (move_info.s_desc) -> descriptor.type = CHAR_VAR
			     then true_len = true_len * 9 + 36;
			     else true_len = true_len + 36;
			     ts_ptr = move_info.t_ptr;
			     true_string = move_info.s_ptr -> true_string;
			end;
		     else if move_info.expr then do;	/* if expression */
			     call mrds_dsl_eval_expr (area_ptr, move_info.s_ptr,
				search_vars.info.ri_ptr (move_info.var_ind),
				tuple_info.tuple (move_info
				.tuple_var_index).tuple_ptr, icode);
			     if icode ^= 0 then call error (icode);
			end;
		     else do;			/* is straight assign_ conversion */
			     temp_s_ptr = move_info.s_ptr;
			     call mu_convert$convert_data (temp_s_ptr, addr (move_info.s_desc),
				move_info.t_ptr, addr (move_info.t_desc), icode);
			     if icode ^= 0 then do;
				     call sub_err_ (icode, caller_name, continue, info_ptr, return_value,
					"^/^a^a^a^a^a",
					"Unable to convert a """, mu_display_descriptor (addr (move_info.s_desc)),
					""" into a """, mu_display_descriptor (addr (move_info.t_desc)),
					""" data type, during the search operation.");

				     call mdb_display_data_value$ptr (temp_s_ptr, addr (move_info.s_desc));

				     call error (icode);

				end;

			end;
		end;				/* if must move */

	     mi_ptr = move_info.fwd_thd;

	end;					/* move loop */

	do i = 1 to search_vars.nvars;		/* remember all vals moved for this var. */
	     search_vars.new_val (i, search_ops.op.var_ind (search_ops.ic)) = "0"b;
	end;

	search_ops.ic = search_ops.ic + search_ops.op.good_xfer (search_ops.ic);
	go to next;
%page;
operation (3): ;					/* select next tuple */

	seli_ptr = search_ops.op.info_ptr (search_ops.ic);/* pick up select info */

	if dbcb.current_flag then icode = 0;		/* -current so no need to retrieve */
	else call mu_retrieve (dbcb_ptr, area_ptr,
		addr (search_vars.info (search_ops.op.var_ind (search_ops.ic))),
		select_info.relation_search_specification_ptr,
		select_info.cvla_ptr, select_info.tid_ptr,
		(range.tup_var.name (search_ops.op.var_ind (search_ops.ic))),
		tuple_info.tuple (select_info.tuple_info_index).tuple_ptr,
		range.tup_var.stv_ptr (select_info.tuple_info_index),
		range.tup_var.idl_ptr (select_info.tuple_info_index),
		icode);				/* retrieve the tuple */
	if icode ^= 0 then
	     if icode ^= mrds_error_$no_tuple
		& icode ^= error_table_$no_record then call error (icode);
	     else search_ops.ic = search_ops.ic + search_ops.op.err_xfer (search_ops.ic);
	else do;
		do i = 1 to search_vars.nvars;	/* tell that we have new set ov vals to move */
		     search_vars.new_val (search_ops.op.var_ind (search_ops.ic), i) = "1"b;
		end;
		if display_tuples then do;
			temp_rti_ptr = addr (search_vars.info (search_ops.op.var_ind (search_ops.ic)));
			temp_rmri_ptr = temp_rti_ptr -> rtrv_info.ri_ptr;
			call mdb_display_tuple_$data (
			     tuple_info.tuple (select_info
			     .tuple_info_index).tuple_ptr,
			     temp_rmri_ptr, iox_$user_output, icode);
			call ioa_ ("Tuple Accepted for ""^a""",
			     rtrim (range.tup_var.name (search_ops.op.var_ind (search_ops.ic))));
			if icode ^= 0 then call error (icode);
			call ioa_ ("TID = ^w", select_info.tid_ptr -> b36);
		     end;
		search_ops.ic = search_ops.ic + search_ops.op.good_xfer (search_ops.ic);
	     end;
	go to next;
%page;
operation (4): ;					/* return data */

	search_ops.ic = search_ops.ic + search_ops.op.good_xfer (search_ops.ic);
	code = 0;
exit:	;
	return;

operation (5): ;					/* return null */
	code = mrds_error_$tuple_not_found;
	go to exit;

operation (6): ;					/* pickup svp */

	dbcb.sv_ptr,
	     sv_ptr = search_ops.op.info_ptr (search_ops.ic);
	do i = 1 to search_vars.nvars;		/* init move flags */
	     do j = 1 to search_vars.nvars;
		search_vars.new_val (i, j) = "1"b;
	     end;
	end;
	search_ops.ic = search_ops.ic + search_ops.op.good_xfer (search_ops.ic);
	go to next;
%page;
error: proc (cd);

/* Error Procedure */

	dcl     cd		 fixed bin (35);

	if cd = mrds_error_$no_tuple
	     | cd = error_table_$no_record
	     | cd = mrds_error_$tuple_not_found then do;	/* if normal termination */
		search_ops.ic = search_ops.ic + search_ops.op.err_xfer (search_ops.ic);
		go to next;
	     end;
	else do;					/* if true error */
		code = cd;
		call tidy_up;
		go to exit;
	     end;

     end error;
%page;
tidy_up: proc;

/* Cleanup Procedure */

	dcl     temp_tl		 ptr init (null);

	tl_ptr = stack_ptr;
	do while (tl_ptr ^= null);
	     temp_tl = tid_list.fwd_thd;
	     if tid_list.free_array then do;
		     ta_nids = tid_list.nids;
		     ta_ptr = tid_list.ta_ptr;
		     call mu_temp_segments$free_temp_segment (temp_seg_name, pointer (ta_ptr, 0), icode);
		     tid_list.free_array = "0"b;
		end;
	     free tl_ptr -> tid_list in (internal_static_area);
	     tl_ptr = temp_tl;
	end;

	stack_ptr = null ();

     end tidy_up;
%page;
	dcl     (code,				/* Output: status code */
	        icode,				/* internal status code */
	        true_len)		 fixed bin (35);	/* true length of variable len attr. */

	dcl     CHAR_VAR		 fixed bin (5) int static options (constant) init (22);

	dcl     (i,				/* internal index */
	        j,
	        vi)		 fixed bin;	/* var. index */

	dcl     (d_ptr		 init (null),	/* to tuple.data */
	        es_ptr		 init (null),
	        opnd1p		 init (null),	/* pointers to tid_lists in stack */
	        opnd2p		 init (null),
	        stack_ptr		 init (null),	/* to head of stack of tid_lists */
	        tl_ptr		 init (null),	/* to tid list */
	        ts_ptr		 init (null)) ptr;	/* to variable string */

	dcl     (display_tuples,
	        must_move)		 bit (1);

	dcl     b36		 bit (36) based;
	dcl     fb35u		 fixed bin (35) unal based;
	dcl     src_string		 bit (move_info.sbit_len) based (move_info.s_ptr);
	dcl     targ_string		 bit (move_info.tbit_len) based (move_info.t_ptr);
	dcl     true_string		 bit (true_len) based (ts_ptr);

	dcl     data_ptrs		 (mrds_data_$max_tup_var) ptr init (null ());
	dcl     mrds_data_$max_tup_var fixed bin (35) external static;

	dcl     1 tid_list		 aligned based (tl_ptr), /* structure for stacking up tuple ids */
		2 fwd_thd		 ptr,
		2 free_array	 bit (1) unal,	/* if array needs to be freed */
		2 non_standard_vfile_descriptor bit (1),/* on => secondary index type desc */
		2 reserved	 bit (34) unal,
		2 tup_var_index	 fixed bin,	/* tup var iocb identifier */
		2 nids		 fixed bin (35),	/* no. ids in array */
		2 ta_ptr		 ptr;		/* pointer to array of tuple ids */

	dcl     dbi_pic		 pic "999";
	dcl     temp_seg_name	 char (26);

	dcl     (error_table_$no_record,
	        mrds_error_$no_tuple,
	        mrds_data_$max_id_len,
	        mrds_error_$tuple_not_found,
	        sys_info$max_seg_size) ext fixed bin (35);

	dcl     (addr,
	        fixed,
	        null,
	        pointer,
	        rel,
	        rtrim
	        /*	        substr     */
	        )			 builtin;

	dcl     cleanup		 condition;

	dcl     ioa_		 entry options (variable);
	dcl     iox_$user_output	 ptr ext;
	dcl     mdb_display_tuple_$data entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsl_eval_expr	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_convert$convert_data entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_retrieve		 entry (ptr, ptr, ptr, ptr, ptr, ptr, char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     mu_temp_segments$free_temp_segment entry (char (*), ptr, fixed bin (35));

	dcl     (temp_rti_ptr,
	        temp_rmri_ptr)	 ptr;		/* temp ptrs for mdb_display_tuple_ */

	dcl     area_ptr		 ptr;

	dcl     mrds_data_$max_attributes fixed bin (35) ext static;
	dcl     mrds_data_$temp_seg_name char (23) ext;	/* common name for temp segments */

	dcl     internal_static_area	 area (1024) int static; /* space for tid list managment */
	declare sub_err_		 entry options (variable); /* reports error details */
	declare continue		 char (1) init ("c") int static options (constant); /* dont stop after printing error */
	declare info_ptr		 ptr init (null ());/* dummy arg */
	declare caller_name		 char (32) init ("mrds_dsl_search") int static options (constant); /* name of calling routine */
	declare return_value	 fixed bin (35) init (0); /* dummy arg */
	declare mu_display_descriptor	 entry (ptr) returns (char (120) varying); /* gets char form of descriptor */
	declare mdb_display_data_value$ptr entry (ptr, ptr); /* outputs char form of data value */
	declare temp_s_ptr		 ptr;		/* temp, so that mvoe_info.s_ptr doesn't get changed */
	declare 1 reset_info	 aligned,		/* does reset of subset number */
		2 words		 (4) fixed bin (35) init (0, 0, 0, 0),
		2 dap		 ptr init (null ());
%page;
%include mrds_dbcb;
%page;
%include mrds_search_ops;
%page;
%include mrds_tuple_info;
%page;
%include mrds_search_vars;
%page;
%include mdbm_rtrv_info;
%page;
%include mrds_range;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_ind_sel_info;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_debug_names;
%page;
%include vu_typed_vector;

     end mrds_dsl_search;




		    mrds_dsl_semantics.pl1          08/01/88  1421.6rew 08/01/88  1300.0      600741



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-11,Dupuis), install(88-08-01,MR12.2-1073):
     Written.
  2) change(88-06-27,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-11,Dupuis), install(88-08-01,MR12.2-1073):
     Fixed bugs and inadequacies from original design required to pass audit
     and regression tests.
                                                   END HISTORY COMMENTS */


mrds_dsl_semantics:
    proc (psi_ptr, ls_top, prod_no, code);

/*	SEMANTICS SEGMENT mrds_dsl_semantics.pl1
   Generated by: Hergert.SysMaint.a using LALR 7.3a of Thursday, January 24, 1985
   Generated at: Ford ECC Multics C
   Generated on: 11/26/85  1644.7 est Tue
   Generated from: >udd>MRDS>Hergert>p>d>mrds_dsl.lalr
*/


/* -controls
   -count
   -long_source
   -source
   -symbols
   -terminals
   -production_names
   -table mrds_dsl_tables
   -terminals_list
   -variables_list
   -production
   -semantics mrds_dsl_semantics
   -synonyms '<=  ='<      ^>
   =    ^'<>     ^>'<
   ^=   '<>      >'<
   >    ^'<=     ^='<
   >=   =>       ^'<
   '<    ^>=      ^=>
   .V. .v.
   .X. .x.
   -range -from
   &   -and
   '|  -or
   ^   -not
   -order
   &
   (
   )
   *
   +
   ,
   -
   -all_of
   -any_of
   -ascending
   -current
   -descending
   -differ
   -dup
   -group_by
   -having
   -inter
   -is_between
   -is_in
   -is_like
   -is_not_between
   -is_not_in
   -is_not_like
   -is_not_null
   -is_null
   -no_optimize
   -no_ot
   -order_by
   -print_search_order
   -pso
   -range
   -select
   -union
   -where
   .
   .V.
   .X.
   /
   ::
   '<
   '<=
   <bit_string>
   <integer>
   <string>
   <symbol>
   =
   >
   >=
   [
   ]
   ^
   ^=
   '|
   '|'|
   (* COMMENTS

   To add a new production to the language, just insert the production in
   the appropriate place in this description of the grammar. Also create
   a new "prod (%%%%N): return;" sequence in the correct place, where N
   is the relative production number in the rule. Then use the command
   "lalr mrds_dsl". New tables will be created, a new mrds_dsl_semantics.pl1
   and a few other things. To test the new grammar use the command
   "lalrp mrds_dsl -trace". This invokes an interpretor that will wait
   for terminal input. Enter a sample grammar and end it with the string "EOI".
   After the grammar is proven correct the old mrds_dsl_semantics.pl1 will
   have to be modified to reflect the new grammar. Usually some of the
   productions have to be renumbered and code must be installed to handle the
   new ones.

   If a new kewyword was added then a new keyword table must also be created.
   This is done with the kwsl command: "kwsl mrds_dsl". It will create a
   new mrds_dsl.incl.pl1. This must renamed to mrds_dsl_keywords.incl.pl1
   and modified by changing the size of keyword.name and adding the new level
   major_keyword according to the old mrds_dsl_keywords.incl.pl1
   Also the declaration and initialization of op_array in 
   mrds_dsl_where_clause_ needs to be changed to reflect the new token ids
   of the relational operators. I know this stinks, but...

   Due to a bug in the LALR compiler the production
   <attrubute_spec> ::= <relation>.<attribute> has to be represented as
   <attribute_spec> ::= <symbol>.<symbol> which is syntactically
   equivalent.

   -pso and -no_ot have been removed. Since they currently can
   exist anyplace in a selection expression, to maintain
   upward compatibility, their parsing was moved to the scanner.

   -another and -compiled have been removed from <control_order>.
   They will be handled outside of the parser.

   <control_order> was renamed <current_clause>
   *)
   %page;

   (* SELECTION EXPRESSION *)
   -parse */

        dbcb_ptr = static_data.dbcb_ptr;
        select_area_ptr = static_data.select_area_ptr;
        lex_stack_ptr = static_data.lex_stack_ptr;
        code = 0;

        if debug
        then call ioa_ (
	        "Semantics: production ^d, Lex stack token '^a', stack top ^d",
	        prod_no, lex_token, ls_top);

        goto prod (prod_no);




/* <selection_expression> ::=
   <current_clause>   |
   <query> -order_by <order_spec_list> |
   <query> ! */

prod (1):
        call mrds_dsl_select_clause_$finish (dbcb_ptr, static_data.range_ptr,
	   static_data.select_list_ptr, dbcb.ti_ptr, caller,
	   area_ptr, argp_ptr, descp_ptr, num_args, cur_sw, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;

prod (2):
        call error (mrds_error_$unimplemented_syntax, LOUD, 1, SE_TYPE, "");
        goto exit;

prod (3):

/* If we are compiling, pred_leaf_list_ptr will point to a structure containg
   pointers to the predicate leaves generated in where_clause that were
   specified as .x. These have to be filled in at run time. trl_ptr will
   point to a structure containing info on the temp rels used in a cse.
   Since we dont know the se_index at this point we pass the pointer
   back to compile in the cse struc and let him worry about it.
*/

        if caller = mrds_data_$caller_compile then do;
	  dbcb.compiled_se_info_ptr -> compiled_se_info.temp_x_leaf_ptr =
	       static_data.x_pred_leaf_ptr;
	  dbcb.compiled_se_info_ptr
	       -> compiled_se_info.temp_temp_rel_list_ptr = static_data.trl_ptr;
        end;

        goto exit;



/* <current_clause> ::=
   <current_header> |
   <current_header> <select_list> ! */

prod (4):
        goto exit;

prod (5):
        goto exit;




/* <current_header> ::= -current ! */

prod (6):
        if dbcb.current_ptr ^= null then do;
	  select_list_ptr, static_data.select_list_ptr = dbcb.current_ptr;
	  string (select_list.var_exists) = "0"b;
	  select_list.num_vars, select_list.num_items = 0;
        end;
        else call init_select_list;

        if caller = mrds_data_$caller_compile
        then call error (mrds_error_$inval_comp_expr, LOUD, 0, SE_TYPE,
	        "A selection expression consisting of -current cannot be compiled."
	        );
        if dbcb.range_ptr = null
        then /* no existing s.e. */
	   call error (mrds_error_$no_prior_se, LOUD, 0, SE_TYPE, "");

        if dbcb.ss_ptr ^= null ()
        then call error (mrds_error_$curr_not_alld, LOUD, 0, SE_TYPE, "");

        dbcb.current_flag = "1"b;

        goto exit;




/* <query> ::=
   <query_expression> |
   <query> <set_op> <query_expression>   ! */

prod (7):
        goto exit;

prod (8):

        ss_ptr = dbcb.ss_ptr;
        nitems_init = 2 * mrds_data_$max_sets;

        if se_pending then do;
	  if select_sets.nitems + 1 >= nitems_init	/* make sure there is roomm for the se and its required oper */
	  then
	       call error (mrds_error_$set_ovfl, LOUD, 0, SE_TYPE, "");

	  select_sets.nitems = select_sets.nitems + 1;
	  select_sets.items.oper_flag (select_sets.nitems) = "0"b;
						/* not an operator */
	  select_sets.items.range_ptr (select_sets.nitems) = dbcb.range_ptr;
	  select_sets.items.select_ptr (select_sets.nitems) =
	       dbcb.select_ptr;
	  select_sets.items.ti_ptr (select_sets.nitems) = dbcb.ti_ptr;
	  select_sets.items.so_ptr (select_sets.nitems) = dbcb.so_ptr;

	  se_pending = "0"b;
        end;

        select_sets.nitems = select_sets.nitems + 1;	/* incr. item count */

        select_sets.items.oper_flag (select_sets.nitems) = "1"b;
						/* build oper. item in structure */
        select_sets.items.op_code (select_sets.nitems) = op_stack (op_top);
        op_top = op_top - 1;

        goto exit;




/* <set_op> ::=
   -union |
   -inter |
   -differ   ! */

prod (9):

        call process_set_op (UNION);

        goto exit;

prod (10):

        call process_set_op (INTERSECTION);

        goto exit;

prod (11):

        call process_set_op (DIFFERENCE);

        goto exit;




/* <query_expression> ::=
   <query_clause> |
   ( <query> ) ! */

prod (12):
        dbcb.range_ptr, range_ptr = static_data.range_ptr;
        dbcb.select_ptr = static_data.select_list_ptr;
        dbcb.print_search_order = dbcb.se_info_ptr -> se_info.pso_seen;
        dbcb.no_optimize = dbcb.se_info_ptr -> se_info.no_ot_seen;
        option_list_ptr = static_data.option_list_ptr;

        if option_list.force then do;			/* setup the option specified in the smo command */
	  dbcb.print_search_order = option_list.pso;
	  dbcb.no_optimize = ^option_list.ot;
        end;
        else do;
	  if option_list.pso then dbcb.print_search_order = "1"b;
	  if ^option_list.ot then dbcb.no_optimize = "1"b;
        end;

        call get_relation_statistics (code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        call mrds_dsl_optimize (dbcb_ptr, pred_tree_ptr, dbcb.so_ptr, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        se_pending = "1"b;

        goto exit;

prod (13):
        goto exit;



/* <query_clause> ::=
   <required_clause> |
   <required_clause> <optional_clauses> ! */

prod (14):
        goto exit;

prod (15):
        goto exit;




/* <required_clause> ::=
   <range_clause> <select_clause> |
   <select_clause> <range_clause> ! */

prod (16):
        goto exit;

prod (17):
        goto exit;




/* <optional_clauses> ::=
   <where_clause> |
   <group_clause> |
   <where_clause> <group_clause> ! */

prod (18):
        goto exit;

prod (19):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (20):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <group_clause> ::=
   -group_by <simple_expr> |
   -group_by <simple_expr> -having <qualifier> ! */

prod (21):
        goto exit;

prod (22):
        goto exit;




/* <order_spec_list> ::=
   <simple_expr> |
   <simple_expr> <direction> |
   <order_spec_list> , <simple_expr> |
   <order_spec_list> , <simple_expr> <direction> ! */

prod (23):
        goto exit;

prod (24):
        goto exit;

prod (25):
        goto exit;

prod (26):
        goto exit;




/* <direction> ::=
   -ascending |
   -descending ! */

prod (27):
        goto exit;

prod (28):
        goto exit;

%page;
/*
   (* RANGE CLAUSE *)




   <range_clause> ::= -range <range_def_list>   ! */

prod (29):
        goto exit;


/* <range_def_list> ::=
		<sql_range_def_list> |
		<dsl_range_def_list> ! */

prod (30):
        return;

prod (31):
        return;


/* <sql_range_def_list> ::=
		<sql_range> |
		<sql_range_def_list> , <sql_range> ! */

prod (32):
        return;

prod (33):
        return;


/* <sql_range> ::=
		<sql_range_item> |
		<sql_range_item> (+) ! */

prod (34):
        return;

prod (35):
        return;


/* <sql_range_item> ::=
		<relation_id> |
		<relation_id> <relation_label> ! */

prod (36):
        return;

prod (37):
        return;


/* <dsl_range_def_list> ::=
		<dsl_range_item> |
		<dsl_range_def_list> <dsl_range_item> ! */

prod (38):
        return;

prod (39):
        return;


/* <dsl_range_item> ::= ( <relation_label> <relation_id> ) ! */

prod (40):
        range_ptr = static_data.range_ptr;
        string (range.tup_var (range.num_vars).needed_bits) = "0"b;
        range.tup_var (range.num_vars).copy_for_current,
	   range.tup_var (range.num_vars).copied_for_current = "0"b;

        range.tup_var.name (range.num_vars) = get_stacked_token (ls_top - 2);
						/* Grab the label */

        do i = 1 to range.num_vars - 1;
	  if range.name (range.num_vars) = range.name (i)
	  then call error (mrds_error_$mult_def_var, LOUD, 2, RC_TYPE,
		  "The relation label '"
		  || get_stacked_token (ls_top - 2)
		  || "' has already been used to identify a relation.");
        end;

        goto exit;




/* <relation_id> ::=
   <relation> |
   <v_arg_substitution> |
   <db_label>.<relation> ! */

prod (41):
        range_ptr = static_data.range_ptr;
        if range.num_vars >= mrds_data_$max_tup_var
        then call error (mrds_error_$max_tup_var, LOUD, 0, RC_TYPE,
	        "The maximum number is "
	        || ltrim (char (mrds_data_$max_tup_var)));
        range.num_vars = range.num_vars + 1;		/* increment count */
        rmra_ptr = static_data.rdbi_ptr -> rm_db_info.ra_ptr;	/* point to perm rel array */

        if length (lex_token) < mrds_data_$max_id_len
        then
	   i = index (string (rm_rel_array.name), "!" || lex_token || " ");
        else i = index (string (rm_rel_array.name), "!" || lex_token);
        if i = 0
        then call error (mrds_error_$undef_rel, LOUD, 0, RC_TYPE,
	        "The relation '" || lex_token
	        || "' is unknown in this opening.");
						/* if not found */

        i = divide ((i - 1), 33, 17, 0) + 1;		/* convert from char to array index */

        range.tup_var.used (range.num_vars) = "0"b;	/* initially assume variable not used  */
        range.tup_var.whole_tuple_selected (range.num_vars) = "0"b;
						/* initially assume variable not selected  */
        range.tup_var.temp_rel (range.num_vars) = "0"b;	/* was found, init. tup var info */
        range.tup_var.rel_index (range.num_vars) = i;
        range.tup_var.ri_ptr (range.num_vars) =
	   rm_rel_array.rel_data.ri_ptr (i);

        goto exit;


prod (42):
        range_ptr = static_data.range_ptr;
        if range.num_vars >= mrds_data_$max_tup_var
        then call error (mrds_error_$max_tup_var, LOUD, 0, RC_TYPE,
	        "The maximum number is "
	        || ltrim (char (mrds_data_$max_tup_var)));
        range.num_vars = range.num_vars + 1;		/* increment count */
        if descriptor_ptr -> bit36 = FB35
        then /* if value is fixed bin, no need to convert */
	   temp_rel_index = arg_ptr -> fixed_bin_35;

        else do;					/* no such luck, must convert */

	  if ^mu_valid_data_type$valid_scalar_data_type (descriptor_ptr
	       -> bit36)
	  then
	       call error (mrds_error_$bad_temp_rel_val, ^LOUD, 0, "",
		  "");

	  call mu_convert$convert_data (arg_ptr, descriptor_ptr,
	       addr (temp_rel_index), addr (FB35), code);
	  if code ^= 0 then goto exit;

        end;					/* converting temp. rel. value */

        rmra_ptr = static_data.rdbi_ptr -> rm_db_info.tra_ptr;
        if temp_rel_index < 1 | rm_rel_array.num_rels < temp_rel_index
        then /*  if correspond. temp. rel. not yet defined */
	   call error (mrds_error_$undef_temp_rel, ^LOUD, 0, "",
	        "");

        if rm_rel_array.rel_data.ri_ptr (temp_rel_index) = null
        then
	   call error (mrds_error_$undef_temp_rel, ^LOUD, 0, "",
	        "");

        range.tup_var.used (range.num_vars) = "0"b;	/* initially assume variable not used  */
        range.tup_var.whole_tuple_selected (range.num_vars) = "0"b;
						/* initially assume variable not selected  */
        range.tup_var.temp_rel (range.num_vars) = "1"b;	/* init tup_var info */
        range.tup_var.rel_index (range.num_vars) = temp_rel_index;
        range.tup_var.ri_ptr (range.num_vars) =
	   rm_rel_array.rel_data.ri_ptr (temp_rel_index);

        if caller = mrds_data_$caller_compile then do;
	  if static_data.trl_ptr = null then do;
	      allocate temp_rel_list in (select_area) set (static_data.trl_ptr);
	      static_data.trl_ptr -> temp_rel_list.number_of_temp_rels = 0;
	  end;

	  trl_ptr = static_data.trl_ptr;
	  temp_rel_list.number_of_temp_rels =
	       temp_rel_list.number_of_temp_rels + 1;	/* save the name of the temp rel for CSE */
	  temp_rel_list.name (number_of_temp_rels) =
	       rm_rel_array.name.submodel (temp_rel_index);
	  temp_rel_list.index (number_of_temp_rels) = temp_rel_index;
        end;

        goto exit;

prod (43):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");

        goto exit;


%page;
/*
   (* SELECT CLAUSE *)




   <select_clause> ::=
   <select_header> * |
   <select_header> <select_list> ! */

prod (44):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (45):
        call mrds_dsl_select_clause_$finish (dbcb_ptr, static_data.range_ptr,
	   static_data.select_list_ptr, dbcb.ti_ptr, caller,
	   area_ptr, argp_ptr, descp_ptr, num_args, cur_sw, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;




/* <select_header> ::=
   -select  |
   -select -distinct
   -select -dup  ! */

prod (46):
        call init_select_list;
        goto exit;

prod (47):
        call init_select_list;
        goto exit;

prod (48):

        dbcb.val_mod, dbcb.val_del, dbcb.val_dtr = "0"b;

        if dbcb.ss_ptr = null
        then dbcb.dup_retain = "1"b;			/* set correct dup flag */
        else dbcb.ss_ptr -> select_sets.dup_retain = "1"b;

        call init_select_list;

        goto exit;




/* <select_list> ::=
   <select_item> |
   <select_list> <select_item> ! */

prod (49):
        goto exit;

prod (50):
        goto exit;




/* <select_item> ::=
   <select_id> |
   <select_id> :: <alias> ! */

prod (51):
        goto exit;

prod (52):
        call error (mrds_error_$unimplemented_syntax, LOUD, 1, SE_TYPE, "");
        goto exit;



/* <select_id> ::=
   <attribute> |
   ( <simple_expr> ) |
   ( <simple_expr> ) * |
   <relation> . <attribute> |
   <relation> . <attribute> * ! */

prod (53):
						/* this means that a whole relation is to be returned */
        call get_attribute_info (^ATTRIBUTE, ^KEY, static_data.rel_index, attr_index);

        call mrds_dsl_select_clause_$all_attributes (dbcb_ptr, static_data.range_ptr,
	   static_data.select_list_ptr, rmri_ptr, static_data.rel_index, cur_sw,
	   caller,
	   code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;

prod (54):
        call error (mrds_error_$unimplemented_syntax, LOUD, 2, SE_TYPE, "");
        goto exit;

prod (55):
        call error (mrds_error_$unimplemented_syntax, LOUD, 3, SE_TYPE, "");
        goto exit;

prod (56):
        call get_attribute_info (ATTRIBUTE, ^KEY, static_data.rel_index, attr_index);

        call mrds_dsl_select_clause_$one_attribute (dbcb_ptr, static_data.range_ptr,
	   static_data.select_list_ptr, rmri_ptr, attr_index, static_data.rel_index, ^KEY, cur_sw,
	   caller, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;


prod (57):
        call get_attribute_info (ATTRIBUTE, KEY, static_data.rel_index, attr_index);

        call mrds_dsl_select_clause_$one_attribute (dbcb_ptr, static_data.range_ptr,
	   static_data.select_list_ptr, rmri_ptr, attr_index, static_data.rel_index, KEY, cur_sw,
	   caller, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;


%page;
/*
   (*  WHERE CLAUSE *)




   <where_clause> ::=
   -where <qualifier> ! */

prod (58):
        call mrds_dsl_where_clause_$finish (psi_ptr,pred_tree_ptr);

        goto exit;




/* <qualifier> ::=
   <qualifier_term> |
   <qualifier> <or_op> <qualifier_term>  ! */

prod (59):
        goto exit;

prod (60):
        call mrds_dsl_where_clause_$build_node (psi_ptr,dbcb_ptr, select_area_ptr,
	   lex_stack.token_id (ls_top - 1),
	   LOGICAL_NODE, ^NOT_NODE, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;




/* <qualifier_term> ::=
   <qualifier_factor> |
   <qualifier_term> <and_op> <qualifier_factor> ! */

prod (61):
        goto exit;

prod (62):
        call mrds_dsl_where_clause_$build_node (psi_ptr,dbcb_ptr, select_area_ptr,
	   lex_stack.token_id (ls_top - 1), LOGICAL_NODE, ^NOT_NODE, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;




/* <qualifier_factor> ::=
   <predicate> |
   <not_op> <predicate> ! */

prod (63):
        goto exit;

prod (64):
        call mrds_dsl_where_clause_$build_node (psi_ptr,dbcb_ptr, select_area_ptr,
	   lex_stack.token_id (ls_top - 1),
	   LOGICAL_NODE, NOT_NODE, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;




/* <predicate> ::=
   <term> |
   (<qualifier>) ! */

prod (65):
        goto exit;

prod (66):
        goto exit;




/* <term> ::=
   <expr_or_query> <comp_op> <expr_or_query> |
   <expr_or_query> <is_in> ( <query_literal> ) |
   <like_item> <like> <regular_expr> |
   <attribute_spec> <is_null> |
   <expr> <between> <expr> <and_op> <expr> ! */

prod (67):
        call mrds_dsl_where_clause_$build_node (psi_ptr,dbcb_ptr, select_area_ptr,
	   lex_stack.token_id (ls_top - 1),
	   ^LOGICAL_NODE, ^NOT_NODE, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;

prod (68):
        goto exit;

prod (69):
        goto exit;

prod (70):
        goto exit;

prod (71):
        goto exit;




/* <expr_or_query> ::=
   ( <query_literal> ) |
   [ <old_func_or_expr> ] |
   <expr> |
   <x_arg_substitution> ! */

prod (72):
        goto exit;

prod (73):
        efd_ptr = expr_efd_ptrs (current_expr_level);
        call mrds_dsl_expr_$finish (psi_ptr,efd_ptr, select_area_ptr,
	   current_expr_level);

        if exp_fun_data.var_index <= 0 then do;		/* if constant expression */
	  if exp_fun_data.ef_ptr ^= null ()
	  then do;
	      call mrds_dsl_eval_expr (area_ptr, exp_fun_data.ef_ptr,
		 null, null, code);			/* evaluate const. expr */
	      if code ^= 0
	      then call error (code, LOUD, 0, WCE_TYPE,
		      "Error occured while evaluating expression.");
	  end;
	  call mrds_dsl_where_clause_$build_literal (psi_ptr,dbcb_ptr,
	       select_area_ptr, exp_fun_data.assn_ptr,
	       addr (exp_fun_data.descriptor), static_data.x_pred_leaf_ptr, ^X_SW,
	       code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        else do;
	  call mrds_dsl_where_clause_$build_expr (psi_ptr,efd_ptr, select_area_ptr,
	       code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        current_expr_level = current_expr_level - 1;

        goto exit;

prod (74):
        goto exit;

prod (75):
        call mrds_dsl_where_clause_$build_literal (psi_ptr,dbcb_ptr, select_area_ptr,
	   null, null, static_data.x_pred_leaf_ptr, X_SW, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;




/* <query_literal> ::=
   <query> |
   <constant_list> ! */

prod (76):
        goto exit;

prod (77):
        goto exit;




/* <old_func_or_expr> ::=
   <old_function> |
   <old_expr> |
   ( <old_expr> ) ! */

prod (78):
        efd_ptr = func_efd_ptrs (current_func_level);

        if exp_fun_data.var_index <= 0 then do;		/* function is a constant */
	  call mrds_dsl_eval_func (area_ptr, exp_fun_data.ef_ptr, null, null,
	       code);
	  if code ^= 0
	  then
	       call error (code, LOUD, 0, WCF_TYPE,
		  "Error occured while evaluating function.");
	  if addr (exp_fun_data.descriptor) -> descriptor.type > 18
	       & addr (exp_fun_data.descriptor) -> descriptor.type < 23
	  then char_sw = CHAR_SW;
	  else char_sw = ^CHAR_SW;
	  call mrds_dsl_expr_$build_literal (psi_ptr,dbcb_ptr, exp_fun_data.assn_ptr,
	       addr (exp_fun_data.descriptor), char_sw, current_expr_level,
	       code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        else do;
	  if expr_efd_ptrs (current_expr_level) -> exp_fun_data.var_index = 0
	  then
	       expr_efd_ptrs (current_expr_level) -> exp_fun_data.var_index =
		  exp_fun_data.var_index;
	  else if expr_efd_ptrs (current_expr_level)
		  -> exp_fun_data.var_index ^= exp_fun_data.var_index
	       then call error (mrds_error_$mult_expr_vars, LOUD, 0,
		       WCE_TYPE, "");		/* else must match established var. */

	  call mrds_dsl_expr_$build_function (psi_ptr,dbcb_ptr, efd_ptr,
	       current_expr_level, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        current_func_level = current_func_level - 1;

        goto exit;


prod (79):
        goto exit;

prod (80):
        goto exit;




/* <like_item> ::=
   <attribute_spec> |
   <function> ! */

prod (81):
        goto exit;

prod (82):
        goto exit;




/* <is_in> ::=
   -is_in |
   -is_not_in ! */

prod (83):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (84):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <like> ::=
   -is_like |
   -is_not_like ! */

prod (85):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (86):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <is_null> ::=
   -is_null |
   -is_not_null ! */

prod (87):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (88):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <between> ::=
   -is_between |
   -is_not_between ! */

prod (89):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (90):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <comp_op> ::=
   <rel_op> |
   <rel_op> -any_of | (* ^= -any_of is always true *)
   <rel_op> -all_of ! (* = -all_of is always false *) */

prod (91):
        goto exit;

prod (92):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (93):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <rel_op> ::=
   =  |  ^=  |  >   |  >=  |  '<  |  '<= ! */

prod (94):
        goto exit;

prod (95):
        goto exit;

prod (96):
        goto exit;

prod (97):
        goto exit;

prod (98):
        goto exit;

prod (99):
        goto exit;


/* <regular_expr> ::=
		<expr> |
		<x_arg_substitution> ! */

prod (100):
        return;

prod (101):
        return;
%page;
/*
   (*   EXPRESSIONS   *)


   (* SIMPLE EXPR  I.E. no arg substitution *)




   <simple_expr> ::=
   <simple_arith_term> |
   <simple_expr> <add_op> <simple_arith_term> ! */

prod (102):
        goto exit;

prod (103):
        goto exit;




/* <simple_arith_term> ::=
   <simple_arith_factor> |
   <simple_arith_term> <mult_op> <simple_arith_factor> ! */

prod (104):
        goto exit;

prod (105):
        goto exit;




/* <simple_arith_factor> ::=
   <simple_primary> |
   <simple_arith_factor> '|'| <simple_primary> |
   <add_op> <simple_primary> ! */

prod (106):
        goto exit;

prod (107):
        call error (mrds_error_$unimplemented_syntax, LOUD, 1, SE_TYPE, "");
        goto exit;

prod (108):
        goto exit;




/* <simple_primary> ::=
   <attribute_spec> |
   <function> |
   (<simple_expr>) |
   <constant> ! */

prod (109):
        goto exit;

prod (110):
        goto exit;

prod (111):
        goto exit;

prod (112):
        goto exit;

%page;
/*
   (* STANDARD EXPR  I.E. arg substitution *)




   <expr> ::=
   <arith_term> |
   <expr> <add_op> <arith_term> ! */

prod (113):
        goto exit;

prod (114):
        goto exit;




/* <arith_term> ::=
   <arith_factor> |
   <arith_term> <mult_op> <arith_factor> ! */

prod (115):
        goto exit;

prod (116):
        goto exit;




/* <arith_factor> ::=
   <primary> |
   <arith_factor> '|'| <primary> |
   <add_op> <primary> ! */

prod (117):
        if primary_type = "ATTR" then do;
	  call mrds_dsl_where_clause_$build_attribute (psi_ptr,dbcb_ptr,
	       select_area_ptr,
	       static_data.rel_index,
	       static_data.rmri_ptr -> rm_rel_info.attr_ptrs (attr_index), code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        else if primary_type = "CONS" then do;
	       call mrds_dsl_where_clause_$build_literal (psi_ptr,dbcb_ptr,
		  select_area_ptr,
		  constant_ptr, descriptor_copy_ptr, static_data.x_pred_leaf_ptr,
		  ^X_SW, code)
		  ;
	       if code ^= 0 then call error (code, ^LOUD, 0, "", "");
	   end;
	   else if primary_type = "VARG" then do;
		  call mrds_dsl_where_clause_$build_literal (psi_ptr,dbcb_ptr,
		       select_area_ptr,
		       arg_ptr, descriptor_ptr, static_data.x_pred_leaf_ptr,
		       ^X_SW, code);
		  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
	        end;

        goto exit;

prod (118):
        call error (mrds_error_$unimplemented_syntax, LOUD, 1, SE_TYPE, "");
        goto exit;

prod (119):
        if primary_type = "CONS" then do;
	  char_descriptor.length =
	       lex_stack.token_length (ls_top)
	       + lex_stack.token_start_pos (ls_top)
	       - lex_stack.token_start_pos (ls_top - 1);
	  constant_ptr = lex_stack.token_ptr (ls_top - 1);
	  allocate descriptor_copy in (literal_area);
	  descriptor_copy = addr (char_descriptor) -> descriptor_copy;
	  call mrds_dsl_where_clause_$build_literal (psi_ptr,dbcb_ptr,
	       select_area_ptr,
	       constant_ptr, descriptor_copy_ptr, static_data.x_pred_leaf_ptr, ^X_SW,
	       code)
	       ;
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;
        else call error (mrds_error_$unimplemented_syntax, LOUD, 1, SE_TYPE,
	        "");
        goto exit;




/* <primary> ::=
   <attribute_spec> |
   <function> |
   (<expr>) |
   <constant> |
   <v_arg_substitution>   ! */

prod (120):
						/* Say this attribute is needed, although it may not be */
        static_data.range_ptr -> range.tup_var (static_data.rel_index).needed_bits
	   .
	   attr (static_data.rmri_ptr -> rm_rel_info.attr_ptrs (attr_index)
	   -> rm_attr_info.defn_order) = "1"b;

        primary_type = "ATTR";

        goto exit;

prod (121):
        primary_type = "FUNC";
        goto exit;

prod (122):
        primary_type = "EXPR";
        goto exit;

prod (123):					/* constant */
        primary_type = "CONS";

        goto exit;

prod (124):					/* .v. */
        primary_type = "VARG";

        goto exit;


%page;
/*
   (* OLD EXPR  I.E. BRACKETS AROUND EXPRESSIONS  *)




   <old_expr> ::=
   <old_primary> <arith_op> <old_primary> ! */

prod (125):

        call mrds_dsl_expr_$condense_stack (psi_ptr,dbcb_ptr, select_area_ptr,
	   get_stacked_token (ls_top - 1), current_expr_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;




/* <old_primary> ::=
   <relation>.<attribute> |
   <old_function> |
   <constant> |
   ( <old_expr> ) |
   <v_arg_substitution>   ! */

prod (126):
        call init_expression;
        call get_attribute_info (ATTRIBUTE, ^KEY, static_data.rel_index, attr_index);
        efd_ptr = expr_efd_ptrs (current_expr_level);

        if exp_fun_data.var_index = 0
        then exp_fun_data.var_index = static_data.rel_index;
        else if static_data.rel_index ^= exp_fun_data.var_index
	   then
	        call error (mrds_error_$mult_expr_vars, LOUD, 0, WCE_TYPE,
		   "");				/* else must match that already set */

        call mrds_dsl_expr_$build_attribute (psi_ptr,dbcb_ptr, static_data.range_ptr, static_data.rel_index,
	   rm_rel_info.attr_ptrs (attr_index), current_expr_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;


prod (127):
        efd_ptr = func_efd_ptrs (current_func_level);

        if exp_fun_data.var_index <= 0 then do;		/* function is a constant */
	  call mrds_dsl_eval_func (area_ptr, exp_fun_data.ef_ptr, null, null,
	       code);
	  if code ^= 0
	  then
	       call error (code, LOUD, 0, WCF_TYPE,
		  "Error occured while evaluating function.");
	  if addr (exp_fun_data.descriptor) -> descriptor.type > 18
	       & addr (exp_fun_data.descriptor) -> descriptor.type < 23
	  then char_sw = CHAR_SW;
	  else char_sw = ^CHAR_SW;
	  call mrds_dsl_expr_$build_literal (psi_ptr,dbcb_ptr, exp_fun_data.assn_ptr,
	       addr (exp_fun_data.descriptor), char_sw, current_expr_level,
	       code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        else do;
	  if expr_efd_ptrs (current_expr_level) -> exp_fun_data.var_index = 0
	  then
	       expr_efd_ptrs (current_expr_level) -> exp_fun_data.var_index =
		  exp_fun_data.var_index;
	  else if expr_efd_ptrs (current_expr_level)
		  -> exp_fun_data.var_index ^= exp_fun_data.var_index
	       then call error (mrds_error_$mult_expr_vars, LOUD, 0,
		       WCE_TYPE, "");		/* else must match established var. */

	  call mrds_dsl_expr_$build_function (psi_ptr,dbcb_ptr, efd_ptr,
	       current_expr_level, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        current_func_level = current_func_level - 1;

        goto exit;


prod (128):
        call init_expression;
        call mrds_dsl_expr_$build_literal (psi_ptr,dbcb_ptr, constant_ptr,
	   descriptor_copy_ptr,
	   ^CHAR_SW, current_expr_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;

prod (129):
        goto exit;

prod (130):
        call init_expression;
        call mrds_dsl_expr_$build_literal (psi_ptr,dbcb_ptr, arg_ptr, descriptor_ptr,
	   ^CHAR_SW, current_expr_level,
	   code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;




/* <old_function> ::= <fn_name> (<old_arg_list>)   ! */

prod (131):

        call mrds_dsl_func_$finish (psi_ptr,dbcb_ptr, select_area_ptr, area_ptr,
	   func_efd_ptrs (current_func_level),
	   current_func_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;





/* <old_arg_list> ::=
   <old_arg> |
   <old_arg_list> <old_arg>   ! */

prod (132):
        goto exit;

prod (133):
        goto exit;




/* <old_arg> ::=
   [ <old_func_or_expr> ] |
   <old_function> |
   <relation>.<attribute> |
   <constant> |
   <v_arg_substitution> ! */

prod (134):
        efd_ptr = expr_efd_ptrs (current_expr_level);
        call mrds_dsl_expr_$finish (psi_ptr,efd_ptr, select_area_ptr,
	   current_expr_level);

        if exp_fun_data.var_index <= 0 then do;		/* if really a constant */

	  call mrds_dsl_eval_expr (area_ptr, exp_fun_data.ef_ptr, null, null,
	       code);
	  if code ^= 0
	  then call error (code, LOUD, 0, WCE_TYPE,
		  "Error occured while evaluating the expression.");
	  call mrds_dsl_func_$build_literal (psi_ptr,dbcb_ptr, exp_fun_data.assn_ptr,
	       addr (exp_fun_data.descriptor), current_func_level, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;					/* if constant */

        else do;					/* if not constant */
	  if func_efd_ptrs (current_func_level) -> exp_fun_data.var_index = 0
	  then
	       func_efd_ptrs (current_func_level) -> exp_fun_data.var_index =
		  exp_fun_data.var_index;
	  else if func_efd_ptrs (current_func_level)
		  -> exp_fun_data.var_index ^= exp_fun_data.var_index
	       then call error (mrds_error_$mult_expr_vars, LOUD, 0,
		       WCE_TYPE, "");		/* else must match established var. */

	  call mrds_dsl_func_$build_expr_func (psi_ptr,dbcb_ptr, efd_ptr,
	       EXPRESSION, current_func_level, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        current_expr_level = current_expr_level - 1;

        goto exit;

prod (135):
        efd_ptr = func_efd_ptrs (current_func_level);
        if exp_fun_data.var_index <= 0 then do;		/* if really a constant */
	  call mrds_dsl_eval_func (area_ptr, exp_fun_data.ef_ptr, null, null,
	       code);
	  if code ^= 0
	  then call error (code, LOUD, 0, WCF_TYPE,
		  "Error occured while evaluating function.");
	  call mrds_dsl_func_$build_literal (psi_ptr,dbcb_ptr, exp_fun_data.assn_ptr,
	       addr (exp_fun_data.descriptor), current_func_level - 1, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;					/* if constant */

        else do;					/* if not constant */
	  if func_efd_ptrs (current_func_level - 1) -> exp_fun_data.var_index
	       = 0
	  then
	       func_efd_ptrs (current_func_level - 1)
		  -> exp_fun_data.var_index =
		  exp_fun_data.var_index;
	  else if func_efd_ptrs (current_func_level - 1)
		  -> exp_fun_data.var_index ^= exp_fun_data.var_index
	       then call error (mrds_error_$mult_expr_vars, LOUD, 0,
		       WCE_TYPE, "");		/* else must match established var. */

	  call mrds_dsl_func_$build_expr_func (psi_ptr,dbcb_ptr, efd_ptr,
	       ^EXPRESSION,
	       current_func_level - 1, code);
	  if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        end;

        current_expr_level = current_expr_level - 1;
        current_func_level = current_func_level - 1;


        goto exit;

prod (136):
        call get_attribute_info (ATTRIBUTE, ^KEY, static_data.rel_index, attr_index);
        efd_ptr = func_efd_ptrs (current_func_level);

        if exp_fun_data.var_index = 0
        then exp_fun_data.var_index = static_data.rel_index;
        else if static_data.rel_index ^= exp_fun_data.var_index
	   then
	        call error (mrds_error_$mult_expr_vars, LOUD, 0, WCF_TYPE,
		   "");				/* else must match that already set */

        call mrds_dsl_func_$build_attribute (psi_ptr,dbcb_ptr, static_data.range_ptr, static_data.rel_index,
	   rm_rel_info.attr_ptrs (attr_index), current_func_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;

prod (137):
        call mrds_dsl_func_$build_literal (psi_ptr,dbcb_ptr, constant_ptr,
	   descriptor_copy_ptr, current_func_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;

prod (138):
        call mrds_dsl_func_$build_literal (psi_ptr,dbcb_ptr, arg_ptr, descriptor_ptr,
	   current_func_level, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");
        goto exit;

%page;
/*
   (* COMMON PRODUCTIONS *)




   <function> ::= <fn_name> (<arg_list>)   ! */

prod (139):
        call error (mrds_error_$unimplemented_syntax, LOUD, 3, SE_TYPE, "");
        goto exit;




/* <arg_list> ::=
   <expr> |
   <arg_list> , <expr>   ! */

prod (140):
        goto exit;

prod (141):
        goto exit;



/* <attribute_spec> ::=
   <attribute> |
   <symbol> . <symbol>   |
   <db_label> . <relation> . <attribute>  ! */

prod (142):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;

prod (143):
        call get_attribute_info (ATTRIBUTE, ^KEY, static_data.rel_index, attr_index);

        goto exit;

prod (144):
        goto exit;




/* <constant_list> ::=
   <constant_item> , <constant_item> |
   <constant_list> , <constant_item> ! */

prod (145):
        goto exit;

prod (146):
        goto exit;




/* <constant_item> ::=
   <constant> |
   <v_arg_substitution> |
   <x_arg_substitution> ! */

prod (147):
        goto exit;

prod (148):
        goto exit;

prod (149):
        goto exit;




/* <constant> ::=
   <string> |
   <integer> |
   <bit_string> ! */

prod (150):
        j = index (substr (lex_token, 2), DQ);

        if j = 0 then do;				/* no double quotes */
	  char_descriptor.length = lex_stack.token_length (ls_top) - 2;
						/* dont want first and last quotes */
	  if char_descriptor.length = 0 then do;	/* null string */
	      string_len = 0;
	      allocate string_token in (select_area) set (constant_ptr);
	  end;
	  else constant_ptr = addcharno (lex_stack.token_ptr (ls_top), 1);
						/* skip 1st quote */
        end;

        else do;					/* yech, we have double quotes */
	  string_len = lex_stack.token_length (ls_top);
	  allocate string_token in (select_area);

	  i = 1;					/* next free spot in string_token */
	  k = 2;					/* start after first quote */
	  done = "0"b;
	  do while (^done);				/* process each DQ  taking only one of the two quotes */

	      substr (string_token, i, j) = substr (lex_token, k, j);

	      i = i + j;
	      k = k + j + 1;

	      j = index (substr (lex_token, k), DQ);

	      if j = 0 then do;			/* all done, but need rest of string */
		substr (string_token, i, string_len - k) =
		     substr (lex_token, k, string_len - k);
		i = i + string_len - k;
		done = "1"b;
	      end;
	  end;

	  constant_ptr = addr (string_token);
	  char_descriptor.length = i - 1;
        end;					/* else if have DQ */


        allocate descriptor_copy in (literal_area);
        descriptor_copy = addr (char_descriptor) -> descriptor_copy;

        if debug
        then
	   call ioa_ (
	        "Quoted strings: input -> '^a' output -> '^a' descriptor -> ^o"
	        ,
	        lex_token, cons, descriptor_copy);

        goto exit;

prod (151):
        char_descriptor.length = lex_stack.token_length (ls_top);
        constant_ptr = lex_stack.token_ptr (ls_top);
        allocate descriptor_copy in (literal_area);
        descriptor_copy = addr (char_descriptor) -> descriptor_copy;

        goto exit;

prod (152):
        b_pos =
	   lex_stack.token_length (ls_top) - index (reverse (lex_token), B)
	   + 1;

/* convert the base to something meaningful */
        if b_pos = lex_stack.token_length (ls_top)
        then base = 1;
        else base =
	        binary (substr (lex_token, lex_stack.token_length (ls_top)),
	        17);

        if search (lex_token,QUOTE)=0 then do; /* bit integer i.e. 101b */
	   bit_start_pos=1;                  /* first bit pos in token */
	   i=1;                              /* token len - i = pos of last data char in token */
	   k=1;                              /* token len - k = num of data chars in token */
        end;
        else do;                             /* bit string i.e. "101"b */
	   bit_start_pos=2;
	   i=2;
	   k=3;
        end;

        j = verify (substr (lex_token, bit_start_pos, b_pos - k),
	   LEGAL_CHARACTERS (base));			/* do the characters in the string make sense given the base */

        if j = 0 then do;				/* all characters are good */
	  char_descriptor.length, string_len = (b_pos - k) * base;
	  allocate string_token in (select_area);

	  do j = bit_start_pos to b_pos - i;			/* replace characters with their corresponding bit string */
	      substr (string_token, (j - i) * base + 1, base) =
		 substr (
		 HEX_BITS (
		 index ("0123456789abcdef", substr (lex_token, j, 1))),
		 5 - base);
	  end;

	  constant_ptr = string_ptr;
	  allocate descriptor_copy in (literal_area);
	  descriptor_copy = addr (char_descriptor) -> descriptor_copy;

	  if debug
	  then call ioa_ (
		  "Bit string: input -> '^a' output -> '^a' descriptor -> ^o"
		  ,
		  lex_token, string_token, descriptor_copy);
        end;
        else call error (mrds_error_$inv_string, LOUD, 0, WC_TYPE,
	        "The bit string contains characters that conflict with given base."
	        );

        goto exit;




/* <arith_op> ::= <mult_op> | <add_op> ! */

prod (153):
        goto exit;

prod (154):
        goto exit;




/* <add_op> ::= + | - ! */

prod (155):
        goto exit;

prod (156):
        goto exit;




/* <mult_op> ::= * | / ! */

prod (157):
        goto exit;

prod (158):
        goto exit;




/* <and_op> ::= & ! */

prod (159):
        goto exit;




/* <or_op>  ::= '| ! */

prod (160):
        goto exit;




/* <not_op> ::= ^ ! */

prod (161):
        goto exit;




/* <v_arg_substitution> ::=  .V. ! */

prod (162):
        call get_next_arg (arg_ptr, descriptor_ptr);

        goto exit;




/* <x_arg_substitution> ::=  .X. ! */

prod (163):
        goto exit;




/* <db_label> ::= <symbol> ! */

prod (164):
        call error (mrds_error_$unimplemented_syntax, LOUD, 0, SE_TYPE, "");
        goto exit;




/* <relation> ::= <symbol>   ! */

prod (165):
        goto exit;




/* <relation_label> ::= <symbol> ! */

prod (166):
        goto exit;




/* <attribute> ::=  <symbol>   ! */

prod (167):
        goto exit;




/* <fn_name> ::= <symbol> ! */

prod (168):
        if dbcb.sfi_ptr = null () then do;
	  call mrds_dsl_get_builtins (dbcb_ptr, code);
	  if code ^= 0 then call error (code, LOUD, 0, WCF_TYPE, "");
        end;

        current_func_level = current_func_level + 1;	/* now make a new function level */
        allocate exp_fun_data in (select_area);
        unspec (exp_fun_data) = "0"b;
        func_efd_ptrs (current_func_level) = efd_ptr;

        current_expr_level = current_expr_level + 1;	/* and since a function is a expression, a new one of these */
        allocate exp_fun_data in (select_area);
        unspec (exp_fun_data) = "0"b;
        expr_efd_ptrs (current_expr_level) = efd_ptr;

        call mrds_dsl_expr_$init (psi_ptr,current_expr_level);
        call mrds_dsl_func_$init (psi_ptr,dbcb_ptr, lex_token, dbcb.sfi_ptr,
	   select_area_ptr,
	   current_func_level, code)
	   ;
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        goto exit;




/* <alias> ::=  <symbol>   ! */

prod (169):
        goto exit;


exit:
        return;

get_relation_statistics:
    procedure (code);

/* DESCRIPTION:

   This routine updates the current relation  population  statistics
   for  each  relation  in the range clause for this block. Temp rel
   stats never need to be updated, they are set at definition  time.
   Perm  rels  are  updated  at  first  reference  time,  and  every
   mrds_data_$ statistic_update_count_interval reference  times,  or
   mrds_data_$statistics_update_time_interval   elapsed  real  time,
   whichever comes first. Small size relations have their statistics
   updated  every  selection  expression,  to avoid large perenctage
   changes over few update I/O operations,  "small"  is  defined  in
   mrds_data_$statistics_update_small_rel_size.      The     current
   statistics  are  expected  to  be  reasonable  accurate  for  the
   optimization  of  search  costs  done  in  mrds_dsl_permute.  The
   statistics kept are the number of  tuples  in  the  relation  and
   number of dupliacte index values for each index.

*/

dcl     i			 fixed bin;		/* loop index */
dcl     mrds_data_$statistics_update_count_interval
			 fixed bin (35) ext;	/* number of rel refs before update needed */
dcl     mrds_data_$statistics_update_small_rel_size
			 fixed bin (35) ext;	/* num tuples below which
						   must update stats every S.E. */
dcl     mrds_data_$statistics_update_time_interval
			 fixed bin (71) ext;	/* number of real microsecs before update needed */
dcl     code		 fixed bin (35);		/* local error code */
dcl     mu_rel_statistics$record_statistics
			 entry (fixed bin (35), entry, entry, entry,
			 entry, entry, ptr, ptr, ptr,
			 fixed bin (35), fixed bin (35));

dcl     current_time	 fixed bin (71);		/* variable for current time */


        current_time = clock ();

/* go through all relations referenced in the range clause */

        do i = 1 to range.num_vars while (code = 0);

	  if ^range.tup_var (i).temp_rel then do;	/* only need to update perm rels */

	      rmri_ptr = range.tup_var (i).ri_ptr;

/* don't update relations already seen in this selection expresion */

	      if rm_rel_info.last_statistics_update_s_e_ref_num
		 ^= dbcb.last_s_e_id_num then do;

		if rm_rel_info.last_statistics_update_count ^= 0
		then /* 0 => never got stats */
		     rm_rel_info.last_statistics_update_count =
			rm_rel_info.last_statistics_update_count + 1;
						/* add to ref cnt */

		if rm_rel_info.last_statistics_update_count = 0
		     | rm_rel_info.current_tuple_population
		     <= mrds_data_$statistics_update_small_rel_size
		     | rm_rel_info.last_statistics_update_count
		     > mrds_data_$statistics_update_count_interval
		     | current_time
		     - rm_rel_info.last_statistics_update_time
		     > mrds_data_$statistics_update_time_interval then do;
						/* time to do update */

		    call mu_rel_statistics$record_statistics (dbcb.dbi,
		         dbcb.relmgr_entries.create_cursor,
		         dbcb.relmgr_entries.open,
		         dbcb.relmgr_entries.get_duplicate_key_count,
		         dbcb.relmgr_entries.get_population,
		         dbcb.relmgr_entries.get_count,
		         dbcb.cursor_ptrs_storage_ptr,
		         dbcb.cursor_storage_area_ptr, rmri_ptr,
		         dbcb.last_s_e_id_num, code);

		    if caller = mrds_data_$caller_compile
		         & rm_rel_info.current_tuple_population = 0
		    then rm_rel_info.current_tuple_population = 5;
		end;
	      end;
	  end;
        end;
    end get_relation_statistics;

get_attribute_info:
    proc (attribute, key, rel_index, attr_index);
						/* procedure to check an attribute and get the info for it */
dcl     (rel_index, attr_index)
			 fixed bin parameter;
dcl     (attribute, key)	 bit (1) aligned parameter;
dcl     (rel_pos, attr_pos)	 fixed bin;

        range_ptr = static_data.range_ptr;
        if attribute then do;				/* find relation and attribute positions in lex stack */
	  if key then do;				/* found a * after attribute for temp rel */
	      rel_pos = 3;
	      attr_pos = 1;
	  end;
	  else do;
	      rel_pos = 2;
	      attr_pos = 0;
	  end;
        end;
        else rel_pos, attr_pos = 0;

        rel_name = get_stacked_token (ls_top - rel_pos);
        attr_name = get_stacked_token (ls_top - attr_pos);

/* make sure the relation name is good */
        do rel_index = 1 to range.num_vars
	   while (rel_name ^= range.tup_var.name (rel_index));
        end;

        if rel_index > range.num_vars
        then call error (mrds_error_$bad_var, LOUD, rel_pos, SE_TYPE,
	        "The relation identifier '" || rtrim (rel_name)
	        || "' is unknown in this opening.");

        if range.tup_var.temp_rel (rel_index)
        then rmra_ptr = static_data.rdbi_ptr -> rm_db_info.tra_ptr;
        else rmra_ptr = static_data.rdbi_ptr -> rm_db_info.ra_ptr;

        static_data.rmri_ptr, rmri_ptr =
	   rm_rel_array.rel_data
	   .ri_ptr (range.tup_var.rel_index (rel_index));

        if attribute then do;
	  do attr_index = 1 to rm_rel_info.num_attr
	       while (attr_name
	       ^= rm_rel_info.attr_ptrs (attr_index) -> rm_attr_info.name);
	  end;

	  if attr_index > rm_rel_info.num_attr
	  then call error (mrds_error_$bad_attr, LOUD, attr_pos, SE_TYPE,
		  "The attribute '" || rtrim (attr_name)
		  || "' does not exist in the relation '"
		  || rtrim (rm_rel_info.name) || "'.");
        end;

    end get_attribute_info;

dbf:
    entry ();
        debug = "0"b;
        return;

dbn:
    entry ();
        debug = "1"b;
        return;


error:
    proc (cd, loud, stack_offset, error_type, message);

dcl     cd		 fixed bin (35);		/* standard error code */
dcl     loud		 bit (1) aligned;		/* OFF => dont print or signal error */
dcl     stack_offset	 fixed bin;		/* offset from ls_top of where token is in lex stack */
dcl     error_type		 char (*);
dcl     message		 char (*);

        se_info_ptr = dbcb.se_info_ptr;
        code = cd;

        if se_info.error_info_supplied then do;		/* sombody else did the dirty work */
						/* now just get the token */
	  se_info.token_length =
	       lex_stack.token_length (ls_top - se_info.stack_offset);
	  se_info.token_start =
	       lex_stack.token_start_pos (ls_top - se_info.stack_offset);
        end;

        else do;
	  se_info.loud = loud;
	  se_info.error_type = error_type;
	  se_info.token_start =
	       lex_stack.token_start_pos (ls_top - stack_offset);
	  se_info.token_length =
	       lex_stack.token_length (ls_top - stack_offset);

	  if code = mrds_error_$unimplemented_syntax
	  then se_info.error_msg =
		  "Unimplemented token is '"
		  || get_stacked_token (ls_top - stack_offset) || "'.";
	  else se_info.error_msg = message;
        end;

        goto exit;

    end error;

get_next_arg:
    proc (a_ptr, d_ptr);
dcl     (d_ptr, a_ptr)	 ptr;

        if num_args < 1
        then call error (mrds_error_$insuff_args, ^LOUD, 0, "", "");

        a_ptr = argp_ptr -> based_ptr;			/* get ptr to arg */
        d_ptr, desc_ptr = descp_ptr -> based_ptr;		/* and ptr to desc. */

        if descriptor.type = VAR_CHAR | descriptor.type = VAR_BIT
        then
	   /* if varying */
	   a_ptr = addrel (a_ptr, -1);		/* include length */

        argp_ptr = addrel (argp_ptr, 2);		/* adjust argp_ptr to bypass this arg */
        descp_ptr = addrel (descp_ptr, 2);		/* and the descp_ptr */
        num_args = num_args - 1;			/* and the remaining arg count */

    end get_next_arg;

get_stacked_token:
    proc (position) returns (char (*));
dcl     position		 fixed bin;
dcl     len		 fixed bin;
dcl     token		 char (len) based;
        len = lex_stack (position).token_length;
        return (lex_stack (position).token_ptr -> token);
    end get_stacked_token;

init_expression:
    proc;

/* This proc is called for every argument in an expression to make
   sure that we will have a exp_fun_data structure to put the expression
   into. It checks to see if our func level is the same as our expr level
   and makes a new struct if it is. The only time the func and expr level
   are the same is if the current expr is a func. The parser does not know
   when it encounters a new expression so we have to help it a little.
*/

        if current_expr_level = current_func_level then do;
	  current_expr_level = current_expr_level + 1;	/* make a new expr level */
	  allocate exp_fun_data in (select_area);
	  unspec (exp_fun_data) = "0"b;
	  expr_efd_ptrs (current_expr_level) = efd_ptr;
	  call mrds_dsl_expr_$init (psi_ptr,current_expr_level);
        end;

    end;

init_select_list:
    proc;

/* routine to initialize a select_list structure. This holds the select clause */
        allocate select_list in (select_area) set (static_data.select_list_ptr);
        select_list_ptr = static_data.select_list_ptr;
        select_list.mla_ptr = null ();
        allocate free_relations in (select_area);
        free_relations.num_free_rels = 0;
        string (select_list.var_exists) = "0"b;
        select_list.num_vars, select_list.num_items = 0;	/* init. to empty */
    end;

process_set_op:
    proc (type);

dcl     type		 fixed bin;

        if dbcb.ss_ptr = null then do;			/* first time */
	  dbcb.val_rtrv,				/* init valid. flags */
	       dbcb.val_dtr = "1"b;
	  dbcb.val_mod,
	       dbcb.val_del = "0"b;

	  nitems_init = 2 * mrds_data_$max_sets;	/* set up select sets structure */
	  allocate select_sets in (select_area);
	  select_sets.dup_retain = "0"b;
	  select_sets.nitems = 0;
	  dbcb.ss_ptr = ss_ptr;

	  do k = 1 to static_data.select_list_ptr -> select_list.num_items;
	      select_sets.domains (k) =
		 static_data.select_list_ptr -> select_list.ai_ptr (k)
		 -> rm_attr_info.domain_ptr -> rm_domain_info.name;
	  end;

	  op_top = 0;

        end;
        else do;
	  ss_ptr = dbcb.ss_ptr;
	  nitems_init = 2 * mrds_data_$max_sets;
        end;

        if se_pending then do;
	  if select_sets.nitems + 1 >= nitems_init	/* check for the se and its required oper */
	  then call error (mrds_error_$set_ovfl, LOUD, 0, SE_TYPE, "");

	  select_sets.nitems = select_sets.nitems + 1;
	  select_sets.items.oper_flag (select_sets.nitems) = "0"b;
						/* not an operator */
	  select_sets.items.range_ptr (select_sets.nitems) = dbcb.range_ptr;
	  select_sets.items.select_ptr (select_sets.nitems) =
	       dbcb.select_ptr;
	  select_sets.items.ti_ptr (select_sets.nitems) = dbcb.ti_ptr;
	  select_sets.items.so_ptr (select_sets.nitems) = dbcb.so_ptr;

	  se_pending = "0"b;
        end;

        allocate range in (select_area) set (static_data.range_ptr);
        static_data.range_ptr -> range.num_vars = 0;

        pred_tree_ptr = null;

        if op_top >= mrds_data_$max_sets
        then /* if overflowing operator stack */
	   call error (mrds_error_$set_ovfl, LOUD, 0, SE_TYPE, "");

        op_top = op_top + 1;
        op_stack (op_top) = type;

    end process_set_op;

init:
    entry (a_lex_stack_ptr, a_se_info_ptr, a_dbcb_ptr, psi_ptr, a_area_ptr, a_caller,
         a_option_list_ptr, a_argp_ptr, a_descp_ptr, a_num_args, a_cur_sw);

        allocate static_data in (parser_work_area);

/* copy the outside world into static locals */
        static_data.lex_stack_ptr = a_lex_stack_ptr;
        dbcb_ptr, static_data.dbcb_ptr = a_dbcb_ptr;
        static_data.area_ptr = a_area_ptr;
        static_data.caller = a_caller;
        static_data.option_list_ptr = a_option_list_ptr;
        static_data.argp_ptr = a_argp_ptr;
        static_data.descp_ptr = a_descp_ptr;
        static_data.num_args = a_num_args;
        static_data.cur_sw = a_cur_sw;
        dbcb.se_info_ptr = a_se_info_ptr;

        select_area_ptr, static_data.select_area_ptr = dbcb.select_area_ptr;
        static_data.trl_ptr, static_data.x_pred_leaf_ptr, pred_tree_ptr = null;
        static_data.char_descriptor.type="5260"b3;
        current_expr_level, current_func_level = 0;


/* Range clause initializations */
        if cur_sw
        then static_data.range_ptr = dbcb.range_ptr;
        else do;
	  allocate range in (select_area) set (static_data.range_ptr);
	  static_data.range_ptr -> range.num_vars = 0;
        end;

        static_data.rdbi_ptr = dbcb.rdbi_ptr;

        return;

%include mrds_lex_stack;
%page;
%include mrds_se_info;
%page;
%include mrds_se_options;
%page;
%include mrds_dbcb;
%page;
%include mrds_range;
%page;
%include mrds_compiled_se_info;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mdbm_descriptor;
%page;
%include mrds_select_list;
%page;
%include mrds_select_sets;
%page;
%include mdbm_scope_info;
%page;
%include mrds_predicate_tree;
%page;
%include mrds_lit_info;
%page;
%include mrds_exp_fun_data;

/* declarations are sorted by variable name. Please keep it this way. */

dcl     ATTRIBUTE		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     B			 char (1) aligned init ("b") internal
			 static options (constant);
dcl     CHAR_SW		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     DQ		 char (2) init ("""""") aligned internal
			 static options (constant);	/* 2 quotes, i hope */
dcl     EXPRESSION		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     FB35		 bit (36) init ("404000000043"b3) internal
			 static options (constant);
dcl     HEX_BITS		 (16) char (4)
			 init ("0000", "0001", "0010", "0011", "0100",
			 "0101", "0110", "0111", "1000", "1001", "1010",
			 "1011", "1100", "1101", "1110", "1111")
			 internal static options (constant);
dcl     KEY		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     LEGAL_CHARACTERS	 (4) char (16)
			 init ("01", "0123", "01234567",
			 "0123456789abcdef") internal static
			 options (constant);
dcl     LOGICAL_NODE	 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     LOUD		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     NOT_NODE		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     QUOTE		 init ("""") char(1) internal static
			 options (constant);
dcl     VAR_BIT		 init (20) fixed bin (5) internal static
			 options (constant);
dcl     VAR_CHAR		 init (22) fixed bin (5) internal static
			 options (constant);
dcl     X_SW		 bit (1) aligned init ("1"b) internal
			 static options (constant);
dcl     a_area_ptr		 ptr parameter;
dcl     a_argp_ptr		 ptr parameter;
dcl     a_caller		 fixed bin (35) parameter;
dcl     a_cur_sw		 bit aligned parameter;
dcl     a_dbcb_ptr		 ptr parameter;
dcl     a_descp_ptr		 ptr parameter;
dcl     a_lex_stack_ptr	 ptr parameter;
dcl     a_num_args		 fixed bin parameter;
dcl     a_option_list_ptr	 ptr parameter;
dcl     a_se_info_ptr	 ptr parameter;
dcl     addcharno		 builtin;
dcl     addr		 builtin;
dcl     addrel		 builtin;
dcl     attr_name		 char (32);
dcl     b_pos		 fixed bin;
dcl     base		 fixed bin;
dcl     based_ptr		 ptr based;
dcl     binary		 builtin;
dcl     bit36		 bit (36) based;
dcl     bit_start_pos          fixed bin;
dcl     char		 builtin;
dcl     char_sw		 bit (1) aligned;
dcl     clock		 builtin;
dcl     code		 fixed bin (35) parameter;
dcl     cons		 char (char_descriptor.length)
			 based (constant_ptr);
dcl     debug		 bit internal static init ("0"b);
dcl     descriptor_copy	 bit (36) aligned based (descriptor_copy_ptr);
dcl     descriptor_copy_ptr	 ptr;
dcl     divide		 builtin;
dcl     done		 bit (1) aligned;
dcl     fixed		 builtin;
dcl     fixed_bin_35	 fixed bin (35) based;
dcl     1 free_relations	 based (select_list.fr_ptr) aligned,
						/* list of relation used in the select clause */
	2 num_free_rels	 fixed bin,
	2 free_rels	 (mrds_data_$max_relations) fixed bin;
						/* array to hold all indicies of free vars */
dcl     i			 fixed bin;
dcl     index		 builtin;
dcl     ioa_		 entry () options (variable);
dcl     j			 fixed bin;
dcl     k			 fixed bin;
dcl     length		 builtin;
dcl     lex_stack_ptr	 ptr;
dcl     lex_token		 char (lex_stack (ls_top).token_length)
			 based (lex_stack (ls_top).token_ptr);
dcl     literal_area	 area based (dbcb.select_area_ptr);
dcl     ls_top		 fixed bin parameter;
dcl     ltrim		 builtin;
dcl     mrds_data_$caller_compile
			 fixed bin (35) external static;
dcl     mrds_data_$max_attributes
			 fixed bin (35) external static;
dcl     mrds_data_$max_expr_stack_size	 fixed bin (35) external static;
dcl     mrds_data_$max_id_len	 fixed bin (35) external static;
dcl     mrds_data_$max_relations
			 fixed bin (35) external static;
dcl     mrds_data_$max_select_items
			 fixed bin (35) external static;
dcl     mrds_data_$max_sets	 fixed bin (35) external static;
dcl     mrds_data_$max_temp_rels
			 fixed bin (35) external static;
dcl     mrds_data_$max_tup_var fixed bin (35) external static;
dcl     mrds_dsl_eval_expr	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl     mrds_dsl_eval_func	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl     mrds_dsl_expr_$build_attribute
			 entry (ptr,ptr, ptr, fixed bin, ptr, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_expr_$build_function
			 entry (ptr,ptr, ptr, fixed bin, fixed bin (35));
dcl     mrds_dsl_expr_$build_literal
			 entry (ptr, ptr,ptr, ptr, bit (1) aligned,
			 fixed bin, fixed bin (35));
dcl     mrds_dsl_expr_$condense_stack
			 entry (ptr, ptr,ptr, char (1) aligned, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_expr_$finish	 entry (ptr,ptr, ptr, fixed bin);
dcl     mrds_dsl_expr_$init	 entry (ptr,fixed bin);
dcl     mrds_dsl_func_$build_attribute
			 entry (ptr,ptr, ptr, fixed bin, ptr, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_func_$build_expr_func
			 entry (ptr,ptr, ptr, bit (1) aligned, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_func_$build_literal
			 entry (ptr,ptr, ptr, ptr, fixed bin, fixed bin (35))
			 ;
dcl     mrds_dsl_func_$finish	 entry (ptr,ptr, ptr, ptr, ptr, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_func_$init	 entry (ptr,ptr, char (*), ptr, ptr, fixed bin,
			 fixed bin (35));
dcl     mrds_dsl_get_builtins	 entry (ptr, fixed bin (35));
dcl     mrds_dsl_optimize	 entry (ptr, ptr, ptr, fixed bin (35));
dcl     mrds_dsl_select_clause_$all_attributes
			 entry (ptr, ptr, ptr, ptr, fixed bin,
			 bit (1) aligned, fixed bin (35), fixed bin (35))
			 ;
dcl     mrds_dsl_select_clause_$finish
			 entry (ptr, ptr, ptr, ptr, fixed bin (35), ptr,
			 ptr, ptr, fixed bin, bit (1) aligned,
			 fixed bin (35));
dcl     mrds_dsl_select_clause_$one_attribute
			 entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin,
			 bit (1) aligned, bit (1) aligned,
			 fixed bin (35), fixed bin (35))
			 ;
dcl     mrds_dsl_where_clause_$build_attribute
			 entry (ptr,ptr, ptr, fixed bin, ptr, fixed bin (35))
			 ;
dcl     mrds_dsl_where_clause_$build_expr
			 entry (ptr,ptr, ptr, fixed bin (35));
dcl     mrds_dsl_where_clause_$build_literal
			 entry (ptr,ptr, ptr, ptr, ptr, ptr, bit (1) aligned,
			 fixed bin (35));
dcl     mrds_dsl_where_clause_$build_node
			 entry (ptr,ptr, ptr, fixed bin, bit (1) aligned,
			 bit (1) aligned, fixed bin (35));
dcl     mrds_dsl_where_clause_$finish
			 entry (ptr,ptr);
dcl     mrds_error_$bad_attr	 fixed bin (35) external static;
dcl     mrds_error_$bad_temp_rel_val
			 fixed bin (35) external static;
dcl     mrds_error_$bad_var	 fixed bin (35) external static;
dcl     mrds_error_$curr_not_alld
			 fixed bin (35) external static;
dcl     mrds_error_$insuff_args
			 fixed bin (35) external static;
dcl     mrds_error_$inv_string fixed bin (35) external static;
dcl     mrds_error_$inval_comp_expr
			 fixed bin (35) external static;
dcl     mrds_error_$max_tup_var
			 fixed bin (35) external static;
dcl     mrds_error_$mult_def_var
			 fixed bin (35) external static;
dcl     mrds_error_$mult_expr_vars
			 fixed bin (35) external static;
dcl     mrds_error_$no_prior_se
			 fixed bin (35) external static;
dcl     mrds_error_$set_ovfl	 fixed bin (35) external static;
dcl     mrds_error_$undef_rel	 fixed bin (35) external static;
dcl     mrds_error_$undef_temp_rel
			 fixed bin (35) external static;
dcl     mrds_error_$unimplemented_syntax
			 fixed bin (35) external static;
dcl     mu_convert$convert_data
			 entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl     mu_valid_data_type$valid_scalar_data_type
			 entry (bit (36)) returns (bit (1) aligned);
dcl     null		 builtin;
dcl     prod_no		 fixed bin parameter;
dcl     rel		 builtin;
dcl     rel_name		 char (32);
dcl     reverse		 builtin;
dcl     rtrim		 builtin;
dcl     se_info_ptr		 ptr;
dcl     search		 builtin;
dcl 1 static_data aligned based (parser_static_info.static_data_ptr),
      2 area_ptr ptr,
      2 arg_ptr ptr,
      2 argp_ptr ptr,
      2 constant_ptr ptr,
      2 dbcb_ptr ptr,
      2 descp_ptr ptr,
      2 descriptor_ptr ptr,
      2 lex_stack_ptr ptr,
      2 pred_tree_ptr ptr,
      2 option_list_ptr ptr,
      2 range_ptr ptr,
      2 rdbi_ptr ptr,
      2 rmri_ptr ptr,
      2 select_area_ptr ptr,
      2 select_list_ptr ptr,
      2 trl_ptr ptr,
      2 x_pred_leaf_ptr ptr,
      2 attr_index fixed bin,
      2 caller fixed bin (35),
      2 char_descriptor aligned,
	3 type bit (12) unal,
	3 length fixed bin (23) unal,
      2 cur_sw bit(1) aligned,
      2 se_pending bit (1) aligned,
      2 current_expr_level fixed bin,
      2 current_func_level fixed bin,
      2 num_args fixed bin,
      2 op_top fixed bin,
      2 primary_type char (4) aligned,
      2 rel_index fixed bin,
      2 efd_ptrs (mrds_data_$max_expr_stack_size),
          3 expr_efd_ptrs ptr,
          3 func_efd_ptrs ptr,
      2 op_stack (mrds_data_$max_sets) fixed bin;
dcl     string		 builtin;
dcl     string_len		 fixed bin;
dcl     string_ptr		 ptr;
dcl     string_token	 char (string_len) based (string_ptr);
dcl     substr		 builtin;
dcl     sys_info$max_seg_size	 fixed bin (35) external static;
dcl     temp_rel_index	 fixed bin (35);
dcl     unspec		 builtin;
dcl     verify		 builtin;

    end mrds_dsl_semantics;





		    mrds_dsl_set_fscope.pl1         08/01/88  1347.6r w 08/01/88  1314.2      603549



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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-10-17 by Jim
     Lippard (mrds #145, SCP-6258).
  2) change(86-10-03,Dupuis), approve(86-10-21,MCR7562), audit(86-10-22,Blair),
     install(86-10-23,MR12.0-1199):
     Changed references to DEFAULT_WAIT to be mrds_data_$lock_wait_time.
  3) change(87-10-13,Dupuis), approve(87-10-13,MCR7777),
     audit(87-11-18,Brunelle), install(87-11-30,MR12.2-1006):
     Fixed a problem where the internal proc queue_scope was getting a null
     pointer fault trying to reference thru ul_ptr.
                                                   END HISTORY COMMENTS */


mrds_dsl_set_fscope: set_fscope: procedure;

/*   
	BEGIN_DESCRIPTION
   This procedure sets the user's scope of access to the database if it is open in the
   shared mode.  Calling sequence is:

   call dsl_$set_fscope (db_index,
   rel_name, permit_requests, prevent_requests, ...,
   rel_name, permit_requests, prevent_requests, wait_seconds[optional],  code);
	END_DESCRIPTION
   
   HISTORY:

   Written April 28, 1976 by R. G. Luebke

   Modified by O D Friesen July, 1977, to queue scope  requests  for
   the  user Changed to set_fscope by Oris D. Friesen - Sept. 1978 -
   to set scopes at file level instead of rel. level

   Modified by M.  Pierret  December  1979  for  the  following:  1.
   Redesigned  the queueing/wakeup system so that user must re-check
   her ability to set scope when awakened, and  be  responsible  for
   wakeing  the  next  elibible user in the queue and detecting dead
   processes in the  queue;  2.  Restructured  the  entire  program,
   adding  commentation;  3.  Coordinate  with  dl_scope the dbc and
   user_list entries that they share; 4. Made call to mu_empty_scope
   compatible with new changes.

   Modified by M. Pierret 13 April 1980 to remove priority queueing.

   Modified by M. Pierret 27 June 1980, changing fil  and  file_name
   to   rel   and  model_rel_name,  resolving  naming  discrepancies
   concerning submodels, and fixing various logic  errors  involving
   passive_sw, setting up fil_list and scope_info, and redecoratng.

   Modified by Jim Gray -  -  80-11-14,  to  put  common  code  into
   check_scope_and_access,      plus     adding     the     routines
   check_mrds_access, check_system_access, check_file_open,  and  to
   add mrds/system access checking at scope time, so that more scope
   than current access can not be granted,  and  to  put  the  vfile
   opening  for a relation at set_scope time, so that relations that
   are not having scope set will  not  be  opened,  plus  the  vfile
   opening  process  will  not  be  the  one  to  detect  any access
   violation.  Also  added  check  to  prevent  null  permit   scope
   requests,  so  null  access  on files can be detected. Also fixed
   set_scope_all bug by putting file ready  mode  checks  in  common
   check_mrds_access  routine,  so  that  now  can't get update when
   opened retrieve.

   80-12-11 Jim Gray : added use of include file mdbm_scope_requests
   as  part  of  change  from  r-u  to  r-s-m-d  type  scope  modes.
   mdbm_scope_info and mdbm_users include files also  changed  as  a
   result.  Added local declarations of actual/user_permits/prevents
   and   actual_conflict_detail.   The   later    was    added    to
   check_scope/conflict  interface to be able to report exact detail
   of why a set_scope failed. Changed the mrds_access conflcit check
   to   be   more   detailed,   The  routines  get_permit_scope  and
   get_rmds_access  were  added  for  error  detail.  The  calls  to
   store_scope,  plus the setting of the check_scope flag were moved
   to the common routine check_scope_and_access. Common code was put
   in  activate_or_queue.  A  bug  in  awakened was fixed that would
   cause a queued process to loop forever,  if  a  non-passive  dead
   process  was  created  while  he was still in the queue. now that
   update has been turned into 3 separate permissions.

   80-12-11 Jim Gray : found that MSF's could look  like  they  have
   "rw",  but have been set to just "w", and that is all that exists
   on the components. For cases  where  "r"  appears,  an  aditional
   check  on component 0 of the MSF was added to make sure it really
   was "r".

   80-12-12 Jim Gray : added initialization of fil_list  pad  areas,
   and  also  set update bit on according to whether one of a+m+d is
   on. Improved the system access conflict error message to give the
   required access for the requested scope.

   80-12-12 Jim Gray : Found that the wait_sec option was having  no
   effect,  even in default mode. No waiting was ever occuring. This
   was because the DEFAULT_WAIT was declared fixed  bin  (71),  then
   being  overlayed  with  a  fixed bin(35) number, getting only the
   upper (zeroed) half of the double word number.

   80-12-12 Jim Gray : Found that the awakened procedure did not set
   the  upper  bound  on  the  loop  through  the  scope_info  array
   properly, thus causing it to access beyond the end  of  the  dbcb
   segment  in the resultant model. Now it uses scope_info.nfiles as
   it should. This only happend when a queued waiter was woke up  by
   a scope deleter, and no further conflict existed.

   80-12-12 Jim Gray : Added debug message of SCOPE REQUEST GRANTED,
   that  is  issued  when a user that has been queued is awoken, and
   finds no conflict in being able to set his scope.

   80-12-15 Jim Gray : changed being  queued,  and  request  granted
   from   queue   informative   messages   from  sub_err_,  to  ioa_
   displayable via mrds_debug_tool with switch 1 being set for  this
   module.

   80-12-15 Jim Gray : Modified logic to  allow  null  permit  scope
   requests.  For  file  readying nothing is done in this case, same
   for system access checking. However, a true "null" scope tuple is
   set in the fil_list string and in the scope_info

   80-12-16 Jim Gray : added requirement that a null permit  request
   has  system  acl  to  the  relation  data  of "r", so that a user
   without sufficient access can not prevent  others  from  using  a
   relation he has no access to.

   81-1-11 Jim Gray : added handling of touched bit  in  scope_info,
   so that null scope requests can be displayed.

   81-01-27 Jim Gray : added call to  set_needed_access  for  system
   acl   failures,  so  that  DBA  types  will  never  fail  due  to
   insufficient access.

   81-06-17  Jim  Gray  :  removed  file  opening  logic,  now  that
   mu_open_iocb_manager handles it at first data reference time.

   81-07-23 Jim Gray : added check for the scope mode encoding being
   too large.

   81-12-15 R. Lackey : Modified to seach rel_array for full 32 character name. TR11887

   82-01-08 R. Lackey : Added check to detect relation names longer then 30 characters.

   82-09-22 Davids: added call to dbcb.relmgr_entries.set_scope in the
   activate_user_scope internal proc. This required changing the calling
   sequence of the internal procs store_scope and add_fil_list_entry to
   include the parameter rmri_ptr so that add_fil_list_entry can set the
   value of the relation's opening_id.

   82-10-04 Davids: added the internal proc scopes_by_this_process and
   placed a call to it activite_user_scopes right before the call to
   relmgr_entries.set_scope. scopes_by_this_process combines all the scopes
   that a process may have on a relation. A process could have more than
   once set of scopes if the database has been opened multiple times.

   82-10-14 Davids: added code to open a relation before the call to the
   relation manager set scope routine because that routine expects the
   relation to already be opened. 

   82-12-10 Davids: Modified the call to dbcb.relmgr_entries.open by
   enclosing the db_path and model name in ()s. This was needed because
   the declaration of the relation manager entries in the dbcb was changed
   from options variable to reality. The db_path and model_name are
   declared as character aligned in include files while the entry expects
   character unaligned.

   83-01-21 Kubicar: Added transaction code

   83-01-25 Davids: Added check of mstxn_code after the mrds_start_transaction
   include file to be sure that the transaction was started ok (if it had to
   be started). Also created the new entry point set_relmgr_scopes out of
   code that used to be in activate_user_scope. This new entry is called from
   both activate_user_scope and the clean_up procedure. The call in clean_up
   was needed to be sure that the relation manager scopes and mrds scopes
   matched. Corrected scope calculation in the internal procedure
   scopes_by_this_process.

   83-02-07 Davids: Modified the set_relmgr_scopes internal procedure to 
   create a copy of the rmri_ptr instead of using the copy in the fil_list
   structure. This is needed because the ring brackets of the db.control
   segment which is where the fil_list is kept may be 5,5,5 in which case the 
   pointer cannot be used to reference the rm_rel_info structure which is in
   the resultant and may have different ring brackets, i.e. 4,4,4.

   83-02-15 Davids: explicitly declared variables that were
   declared by context or implication and deleted declarations
   to variables that were not referenced.

   84-07-26 Thanh Nguyen: Modified the ioa_args of the call sub_err_ due to
   TR #phx17395, problem number 113 in the mrds error list.

   85-03-14 Thanh Nguyen: Modified the awakened procedure to handle the case
   of the conflict_sw is on and the ul_ptr is null after the call to 
   wakeup_next_waiter internal subroutine. (TR #phx19144).

   85-03-22 Thanh Nguyen: Modified the awakened procedure again to handle the 
   case of the timed-out.  It will try to lock the scope_lock no more than 3
   times before it will dequeue the timed-out user or will set the
   trouble_switch.(TR #19174).

   85-04-14 Thanh Nguyen: Modified code not to get the out of subrange while
   checking for the conflict of the scope.

   85-10-17 Jim Lippard: Changed to not set trouble switch when the scope_lock
   can't be set and to wait the user's specified wait time rather than
   mrds_data_$lock_wait_time.
*/
%page;
	entry_name = "set_fscope";			/* normal entry point */
	args_exp = 5;				/* 5 input arguments */
	num_filns = 0;
	dbc_ptr = null ();				/* initialize */
	call cu_$arg_count (nargs);			/* get number of args */
	if nargs < args_exp
	then signal arg_error;			/* must be at least args_exp args */
						/* signal is used here because we can't determine */
						/* where the error code argument is */

	if mod (nargs - 3, 3) = 0
	then do;
		call cu_$arg_ptr (nargs - 1, ws_ptr, arg_len, icode);
		if icode ^= 0
		then signal arg_error;
	     end;
	else ws_ptr = addr (mrds_data_$lock_wait_time);

common_label:
	mstxn_txn_id = "0"b;
	call cu_$arg_ptr (nargs, cd_ptr, arg_len, icode); /* get pointer to last arg (code) */
	if icode ^= 0
	then signal arg_error;
	code = 0;

/* Set up condition handlers. Note that they come before the label pntr2, where dl_fscope_all_ptr enters.
   This entry is for now unused, and if used, it is assumed that handlers are provided by the caller */

	on cleanup call clean_up;
	on quit
	     begin;
		call clean_up;
		call continue_to_signal_ (icode);
	     end;


	call cu_$arg_ptr (1, dbi_ptr, arg_len, icode);	/* get db_index */
	if icode ^= 0
	then call error (icode);
	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
						/* look up db's pointer */
	if dbcb_ptr = null ()			/* we don't know about this data base */
	then call error (mrds_error_$invalid_db_index);

pntr2:


	dbc_ptr = dbcb.dbc_ptr;			/* get pointer to data base control segment */
	if dbcb.scope_ptr = null
	then call error (mrds_error_$non_scope_ready);

	scope_ptr = dbcb.scope_ptr;
	rdbi_ptr = dbcb.rdbi_ptr;
	rmra_ptr = rm_db_info.ra_ptr;

	if scope_info.active_scopes > 0		/* all scope must be set at one time, so there */
	then call error (mrds_error_$scope_not_empty);	/* ..cannot be existing scope at this point */



	call set_lock_$lock (dbc.scope_lock, (wait_seconds), icode);
						/* lock scope portion of dbc */
	if icode = error_table_$invalid_lock_reset |
	     icode = error_table_$locked_by_this_process
	then icode = 0;
						/* ignore these error codes */
	if icode ^= 0
	then do;					/* somebody else has got it locked */
		call error (icode);

	     end;




	QUE_FREE = fixed (unspec (CHAR_Q_F), 71);	/* Set wakeup message constant */
	ALARM = fixed (unspec (CHAR_ALARM), 71);	/* Set time-out message constant */

	empty_on_err = ON;				/* Must empty scope on error (for cleanup purposes) */

/* Position to this user's user_list in dbc */

	ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);
	this_ul_ptr = null;
	do while (ul_ptr ^= null);
	     if user_list.process_id = get_process_id_ ()
	     then do;
		     if user_list.rdbi_bits = addr (rdbi_ptr) -> ptr_bit_string
		     then do;
			     this_ul_ptr = ul_ptr;
			     ul_ptr = null;
			end;
		     else ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		end;
	     else ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
	end;

	if this_ul_ptr = null			/* User is not in open list - DBC was probably reset */
	then call error (mrds_error_$invalid_db_index);

	ul_ptr = this_ul_ptr;

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

	call mrds_dm_authorization$get_user_class (rtrim (rm_db_info.db_path), addr (local_area),
	     mrds_authorization_structure_version, mrds_authorization_ptr, icode);
	if icode ^= 0 then call error (icode);

/* Initialize some variables. */

	user_list.queue_activ = OFF;
	user_list.bypass_count = 0;
	check_scope = ON;				/* OFF-> don't bother checking for conflict */
	conflict_sw = OFF;				/* ON -> a conflict was found */
	re_check = OFF;				/* ON -> a conflict was resolved, so try again */
	first_scope_triple = ON;			/* Processing firstrelation in scope request */

/*  Set up transactions */

	mstxn_transactions_needed = dbcb.transactions_needed;
	on cleanup
	     begin;
		call mstxn_cleanup;
		call clean_up;
	     end;
	on quit
	     begin;
		call clean_up;
		call mstxn_any_other;
	     end;
	on any_other call mstxn_any_other;

%include mrds_start_transaction;

	if mstxn_code ^= 0
	then call error (mstxn_code);

	dbcb.user_started_transaction = user_started_transaction;

/* Do one of the following blocks of code, as appropriate */

/* ************* Entry point is set_fscope ************* */

	if entry_name = "set_fscope"
	then do;

		num_tuples = divide (nargs - 2, 3, 17); /* calculate number of scope tuples */

		do i = 1 to num_tuples;		/* iterate once for each scope tuple */
		     arg_index = 3 * (i - 1) + 2;	/* position to ith scope tuple */
		     call cu_$arg_ptr (arg_index, rel_ptr, rel_len, icode);
						/* get rel_name */
		     if icode ^= 0
		     then call error (icode);



/* BEGIN 82-01-08 Roger Lackey ********************************************* */

		     if length (rtrim (rel_name)) > 30 then call error (mrds_error_$rel_name_too_long);

/* END   82-01-08 Roger Lackey ********************************************* */

/* BEGIN CHANGE 81-12-15 RDL ******************************************** */

		     rel_name_32 = rel_name;		/* Used for searching */
		     l = index (string (rm_rel_array.name), "!" || rel_name_32);

/* END   CHANGE 81-12-15 RDL ******************************************** */

/* find file (relation) and get it's model name and the permits-pervent */

		     if l = 0 then do;
			     call sub_err_ (mrds_error_$unknown_relation_name, caller_name, continue, info_ptr, return_value,
				"^/^a^a^a", "The relation name """, rel_name,
				""" was not found in the users view of the database.");
			     call error (mrds_error_$unknown_relation_name);
			end;
		     else do;
			     l = ((l - 1) / 33) + 1;	/* convert from char to array index */
			     submodel_rel_name = rm_rel_array.name.submodel (l);
			     model_rel_name = rm_rel_array.rel_data.model_name (l);
			     rmri_ptr = rm_rel_array.rel_data.ri_ptr (l);
			end;

/* ptr to file info */

		     call cu_$arg_ptr (arg_index + 1, permit_requests_ptr, arg_len, icode);
						/* get permit ops */
		     if icode ^= 0
		     then call error (icode);

		     call cu_$arg_ptr (arg_index + 2, prevent_requests_ptr, arg_len, icode);
						/* get prevent ops */
		     if icode ^= 0
		     then call error (icode);


/* assert whether we can successfully set scope without conflict by:
   checking user's scope tuples (conceived at ready time) to make
   sure scope hasn't been defined already by this user;
   and then to actually check for a conflict */

		     do pos_in_si = scope_info.nfiles to 1 by -1
			while (submodel_rel_name ^= scope_info.scope.sm_name (pos_in_si));
		     end;

		     if string (scope_info.scope.flags (pos_in_si))
						/* scope has already been defined for this file (relation) */
		     then call error (mrds_error_$duplicate_scope);


		     call check_scope_and_access (rmri_ptr);

		end;

		call activate_or_queue ();

	     end;

/* ************* Entry point is set_fscope_all or set_fscope_all_ptr ************* */

	if entry_name = "set_fscope_all" | entry_name = "set_fscope_all_ptr"
	then do;

		if entry_name = "set_fscope_all"
		then do;
			call cu_$arg_ptr (2, permit_requests_ptr, arg_len, icode);
						/* get permit ops */
			if icode ^= 0
			then call error (icode);

			call cu_$arg_ptr (3, prevent_requests_ptr, arg_len, icode);
						/* get prevent ops */
			if icode ^= 0
			then call error (icode);
		     end;

/* Iterate over each relation in scope_info */

		do pos_in_si = 1 to scope_info.nfiles;
		     model_rel_name = scope_info.scope.name (pos_in_si);
		     submodel_rel_name = scope_info.scope.sm_name (pos_in_si);

		     rmri_ptr = null ();
		     call check_scope_and_access (rmri_ptr);

		end;


		call activate_or_queue ();
	     end;


	code = 0;

	if dbc_ptr ^= null ()
	then
	     call set_lock_$unlock (dbc.scope_lock, code);/* unlock the scope table */
exit:

/* End the transaction */

	mftxn_code = code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0
	then code = mftxn_code;

	return;
%page;
activate_or_queue: procedure ();

/* common routine for queueing user if he found a conflict to his request,
   or going ahead with giving him the permissions/prevents he asked for */

/* If there was a conflict, then add user to waiting queue and wait.
   If not, activate the user.  Use the scope already stored */

	if conflict_sw then do;
		call queue_scope (FIRST_QUEUE);	/* go to sleep  and when awakened, try it again */
		call awakened;
	     end;
	else call activate_user_scope;		/* no conflict, so go ahead */

     end;
%page;
mrds_dsl_set_fscope_all:
set_fscope_all:
     entry;

/*
   *
   *  call mrds_dsl_set_fscope_all (db_index, permit_requests, prevent_requests, wait_seconds[optional], code);
   *
*/


	entry_name = "set_fscope_all";
	args_exp = 4;				/* at least 4 -- maybe 5 -- arguments are expected
						   to be present */
	dbc_ptr = null;
	call cu_$arg_count (nargs);
	if nargs < args_exp
	then signal arg_error;
	if nargs = args_exp + 1
	then do;
		call cu_$arg_ptr (nargs - 1, ws_ptr, arg_len, icode);
		if icode ^= 0
		then signal arg_error;
	     end;
	else ws_ptr = addr (mrds_data_$lock_wait_time);
	goto common_label;
%page;
pntr:
set_fscope_all_pntr:
mrds_dsl_set_fscope_all_pntr:
     entry (a_dbcb_ptr, a_permit_requests_ptr, a_prevent_requests_ptr, a_ws_ptr, a_cd_ptr);

/*
   *
   *  entry point used to set scopes when data base has been opened in
   *   EXCLUSIVE mode -- pointer is used in place of data base index
   *
*/

	dcl     (
	        a_dbcb_ptr,				/* dbcb parameter */
	        a_permit_requests_ptr,		/* permit options parameter */
	        a_prevent_requests_ptr,		/* prevent options parameter */
	        a_ws_ptr,				/* wait_seconds parameter */
	        a_cd_ptr
	        )			 ptr;		/* return code parameter */


	entry_name = "set_fscope_all_ptr";
	dbc_ptr = null;
	args_exp = 5;				/* 5 arguments are expected to be present */
	if a_ws_ptr = null
	then ws_ptr = addr (mrds_data_$lock_wait_time);
	else ws_ptr = a_ws_ptr;
	dbcb_ptr = a_dbcb_ptr;
	permit_requests_ptr = a_permit_requests_ptr;
	prevent_requests_ptr = a_prevent_requests_ptr;
	cd_ptr = a_cd_ptr;
	goto pntr2;
%page;
check_scope_and_access: procedure (dummy_ptr);

/* routine to check for scope conflicts, and to   guarantee that scope granted does not exceed actual access
   the user currently has via either mrds or the system
   Also,  if this relation, has not yet had it's vfile opened, do so now */

	call check_mrds_access (dummy_ptr);
	call check_system_access (dummy_ptr);

	if dbc.active_users = 0 & dbc.waiting_users = 0	/* If there are no active or waiting scope users, */
	then check_scope = OFF;			/* no need to even check scope--you've got it */

/* check scope now */

	if check_scope & ^conflict_sw			/* if we have a conflict already, no need to check */
	then do;
		conflict_ul_ptr = null;
		re_check = ON;
	     end;

/* Check for conflict for this relation */

	do while (re_check);
	     re_check = OFF;

	     call mu_check_scope (dbc_ptr, addr (model_rel_name),
		(this_ul_ptr), permit_requests_ptr, prevent_requests_ptr,
		addr (actual_conflict_detail), conflict_sw, conflict_ul_ptr);

	     if conflict_sw then do;			/* there was a conflict */
		     call check_dead_proc (conflict_sw, status);
		     if ^conflict_sw then /* conflict was worked out */
			re_check = ON;
		     else do;			/* still a conflict */
			     conflict_user_id = conflict_ul_ptr -> user_list.ids.group_id;
			     conflict_relation = submodel_rel_name;
			     conflict_detail_known = ON;
			     if status = DEAD then do;/* non-passive dead process conflcit */
				     icode = mrds_error_$db_conflict_dead_process;
				     call report_conflict_detail (DEAD_PROC_REPORT);
				     call error (icode);
				end;
			end;
		end;
	end;

/* Whether there was a conflict or not, store the relevant information about this scope request. */
/* The information for each relation will be stored in a fil_list entry and an entry in the scope_info array. */

	call store_scope (dummy_ptr);

	declare dummy_ptr		 ptr;		/* communicates rmri_ptr between modules */
     end;
%page;
check_mrds_access: procedure (rmri_ptr);

/* routine to check that the access permission  bits in the resultant
   model are >= the scope that is being requested */

/* get the relation access permission bits */

	if rmri_ptr = null () then do;
		i = index (string (rm_rel_array.name), "!" || submodel_rel_name);
		i = ((i - 1) / 33) + 1;		/* convert from char to array index */
		rmri_ptr = rm_rel_array.rel_data.ri_ptr (i);
		model_rel_name = rm_rel_array.rel_data (i).model_name;
	     end;


/* check that the file was readied for scope_retrieve(ready_mode = 5),
   or scope_update(ready_mode = 6) and that if scope_retrieve, the requested
   permit op does not exceed the allowable of retrieve. */

	if rmri_ptr -> rm_rel_info.ready_mode < 5 then
	     call error (mrds_error_$non_scope_ready);

	if rmri_ptr -> rm_rel_info.ready_mode = 5 &
	     (permit_requests.modify_attr | permit_requests.append_tuple | permit_requests.delete_tuple) then
	     call error (mrds_error_$update_not_allowed);

	if ^rmri_ptr -> rm_rel_info.mdbm_secured then
	     rel_append_perm, rel_delete_perm,
		attr_modify_perm, attr_retr_perm = ON;	/* model openings or un-secured submodel openings
						   always have correct mrds access */
	else do;					/* secured submodel opening */

/* always gather all mrds access permission, in case we have to display for error */

		attr_modify_perm, attr_retr_perm = OFF; /* init */

/* check for retrieve/modify permission on at least one attribute in the relation */

		do i = 1 to rmri_ptr -> rm_rel_info.num_attr while (^attr_retr_perm | ^attr_modify_perm);
		     rai_ptr = rmri_ptr -> rm_rel_info.attr_ptrs (i);
		     if ^attr_retr_perm then
			attr_retr_perm = rai_ptr -> rm_attr_info.read_perm; /* see if this attr has read permission */
		     if ^attr_modify_perm then
			attr_modify_perm = rai_ptr -> rm_attr_info.modify_perm; /* if attr has modify permission */
		end;

		attr_null_perm = (^(attr_retr_perm) & ^(attr_modify_perm));

/* check for either append_tuple or delte_tuple on the relation */

		rel_append_perm = rmri_ptr -> rm_rel_info.append_tuple_perm;
		rel_delete_perm = rmri_ptr -> rm_rel_info.delete_tuple_perm;
		rel_null_perm = (^(rel_append_perm) & (^rel_delete_perm));

	     end;

/* check for correct access from mrds to set this scope */

	if (permit_requests.read_attr & ^(attr_retr_perm)) |
	     (permit_requests.modify_attr & ^(attr_modify_perm)) |
	     (permit_requests.append_tuple & ^(rel_append_perm)) |
	     (permit_requests.delete_tuple & ^(rel_delete_perm)) then do;

		call sub_err_ (mrds_error_$scope_mrds_access_conflict, caller_name, continue, info_ptr, return_value,
		     "^/^a^a^a^a^a^a^a",
		     "The scope permission request of """, get_permit_scope (),
		     """ on relation """, rmri_ptr -> rm_rel_info.name,
		     """ exceeds the access granted by MRDS of """,
		     get_mrds_access (), """.");
		call error (mrds_error_$scope_mrds_access_conflict);
	     end;

/* check that the user is not requesting null access scope permissions, which have no meaning,
   and could cause an attemp to open a file for which the user has no access */

	null_permit_request = ^(permit_requests.read_attr | permit_requests.modify_attr |
	     permit_requests.append_tuple | permit_requests.delete_tuple);

	null_prevent_request = ^(prevent_requests.read_attr | prevent_requests.modify_attr |
	     prevent_requests.append_tuple | prevent_requests.delete_tuple);

	null_request = (null_prevent_request & null_permit_request);

/* BEGIN CHANGE 81-07-23 ************************************************* */

	if permit_requests_ptr -> fb35_ovrly > 15 | prevent_requests_ptr -> fb35_ovrly > 15 then do;
		call sub_err_ (error_table_$bad_arg, caller_name, continue, info_ptr, return_value,
		     "^/^a^a^a^/^a^/^a",
		     "The permit or prevent encodings summed to > 15 for relation """,
		     rm_rel_info.name, """",
		     "Allowed values are:",
		     "0(null), 1(read_attr), 2(append_tuple), 4(delete_tuple), 8(modify_attr)");
		call error (error_table_$bad_arg);
	     end;

/* END CHANGE 81-07-23 ****************************************** */


	declare fb35_ovrly		 fixed bin (35) based; /* overlay for checking encoding sum */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* bad argument given */
	declare mrds_error_$scope_mrds_access_conflict fixed bin (35) ext; /* access permission < scope requested */
	declare (rmri_ptr, rai_ptr)	 ptr;		/* temporary ptrs for this routine */
	declare i			 fixed bin;	/* loop index */

     end;
%page;
check_system_access: procedure (rmri_ptr);

/* this routine checks whether the actual system acl's that user
   has for the relation's data vfile are sufficient to grant the requested
   scope request. "r" for r or n, "rw" for a or m or d */

	call mu_get_relation_acl (rtrim (rm_db_info.db_path), rtrim (model_rel_name),
	     mrds_authorization.administrator, read_access, write_access, error_code);
	if error_code ^= 0 then do;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "^/^a^/^a^a",
		     "Unable to get access information on the MSF component ",
		     """" || rtrim (rm_db_info.db_path) || ">",
		     rtrim (model_rel_name) || ">0"".");
		call error (error_code);
	     end;

/* check for a system access violation by the requested scope */

	if ((permit_requests.read_attr | null_permit_request) & ^read_access) |
	     ((permit_requests.modify_attr | permit_requests.append_tuple | permit_requests.delete_tuple) &
	     ^(write_access & read_access)) then do;

/* get a displayable form of system access */

		system_access = "";

		if read_access then
		     system_access = system_access || "r";

		if write_access then
		     system_access = system_access || "w";

		if system_access = "" then
		     system_access = "null";

/* get a displayable form of the required access
   for this scope request permit codes */

		if permit_requests.modify_attr | permit_requests.append_tuple | permit_requests.delete_tuple then
		     required_access = "rw";
		else required_access = "r";

		call sub_err_ (mrds_error_$scope_system_access_conflict, caller_name,
		     continue, info_ptr, return_value,
		     "^/^a^a^a^a^a^a^a^a^a",
		     "The requested permit scope """, get_permit_scope (),
		     """ for relation """, rmri_ptr -> rm_rel_info.name,
		     """ requires """, required_access,
		     """ access, but this exceeds the users system access to the relation data of """,
		     system_access, """.");
		call error (mrds_error_$scope_system_access_conflict);
	     end;


	declare error_code		 fixed bin (35);	/* local version of error code */
	declare mu_get_relation_acl	 entry (char (*), char (*),
				 bit (1), bit (1), bit (1), fixed bin (35)); /* finds multics acls */
	declare required_access	 char (4) varying;	/* the access required by this scope request */
	declare system_access	 char (4) varying;	/* r, rw, w or null */
	declare mrds_error_$scope_system_access_conflict fixed bin (35) ext; /* acls not sufficient for scope */
	declare read_access		 bit (1);		/* on => has read access to relation data */
	declare write_access	 bit (1);		/* on => has write access to relation data */
	declare rmri_ptr		 ptr;		/* local temp ptr */

     end;
%page;
get_permit_scope: procedure () returns (char (80) varying);

/* routine to get displayable form of the scope permit modes
   that the user requested, for output in error messages */

	permit_scope = "";

	if permit_requests.read_attr then
	     permit_scope = permit_scope || "read_attr ";

	if permit_requests.modify_attr then
	     permit_scope = permit_scope || "modify_attr ";

	if permit_requests.append_tuple then
	     permit_scope = permit_scope || "append_tuple ";

	if permit_requests.delete_tuple then
	     permit_scope = permit_scope || "delete_tuple ";

	if permit_scope = "" then
	     permit_scope = "null ";

	return (permit_scope);

	declare permit_scope	 char (80) varying; /* message display format of scope */

     end;
%page;
get_mrds_access: procedure () returns (char (120) varying);

/* routine to get displayable form of current mrds acl's
   for reporting in error messages */

	mrds_access = "";

	if attr_null_perm then

	     mrds_access = mrds_access || "null on all attributes in the relation ";

	else do;

		if attr_retr_perm then
		     mrds_access = mrds_access || "read_attr ";

		if attr_modify_perm then
		     mrds_access = mrds_access || "modify_attr ";

		mrds_access = mrds_access || "on some attribute(s) in the relation ";

	     end;

	mrds_access = mrds_access || "and ";

	if rel_append_perm then
	     mrds_access = mrds_access || "append_tuple ";

	if rel_delete_perm then
	     mrds_access = mrds_access || "delete_tuple ";

	if rel_null_perm then
	     mrds_access = mrds_access || "null ";

	mrds_access = mrds_access || "on the relation";


	return (mrds_access);



	declare mrds_access		 char (120) varying;/* display form of mrds acl's  */

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

	dcl     cd		 fixed bin (35);

	code = cd;
	call clean_up;
	go to exit;

     end error;
%page;

store_scope: procedure (ss_rmri_ptr);

/*

   This routine stores the scope request information associated with
   a given relation.  The information updated is in the scope_info of
   the user's resultant model and the fil_list (list of relations)
   associated with the  user's user_list in the DBC.

*/

	dcl     ss_rmri_ptr		 ptr;		/* (input) needed to pass to add_fil_list_entry */

	scope_info.scope (pos_in_si).flags.touched = ON;

	if permit_requests.read_attr then
	     scope_info.scope (pos_in_si).flags.permits.read_attr = ON;

	if permit_requests.modify_attr then
	     scope_info.scope (pos_in_si).flags.permits.modify_attr = ON;

	if permit_requests.append_tuple then
	     scope_info.scope (pos_in_si).flags.permits.append_tuple = ON;

	if permit_requests.delete_tuple then
	     scope_info.scope (pos_in_si).flags.permits.delete_tuple = ON;

	if prevent_requests.read_attr then
	     scope_info.scope (pos_in_si).flags.prevents.read_attr = ON;

	if prevent_requests.modify_attr then
	     scope_info.scope (pos_in_si).flags.prevents.modify_attr = ON;

	if prevent_requests.append_tuple then
	     scope_info.scope (pos_in_si).flags.prevents.append_tuple = ON;

	if prevent_requests.delete_tuple then
	     scope_info.scope (pos_in_si).flags.prevents.delete_tuple = ON;

	scope_info.active_scopes = scope_info.active_scopes + 1;

	if first_scope_triple
	then do;
		flo_ptr = addr (user_list.fil_list_ofs);/* ptr to file list offset */
		first_scope_triple = OFF;
	     end;

	call add_fil_list_entry (flo_ptr, ss_rmri_ptr);

	flo_ptr = addr (fil_list.next_ofs);


	return;

     end store_scope;
%page;
add_fil_list_entry: proc (prev_ofs_ptr, afle_rmri_ptr);

/*  *  This routine adds an entry in a fil_list.  If the user is quiescing
   *  then default scope settings are assigned.  The user is also determined
   *  as a non-passive user here if the scope request is update. */

	dcl     prev_ofs_ptr	 ptr;		/* a pointer to the offset location which
						   currently points to nowhere -- indicating it is currently
						   the last file in the list */
	dcl     afle_rmri_ptr	 ptr;		/* (input) to relation's rm_rel_info structure */
	dcl     ophset		 bit (18) unal based; /* a based offset */


	allocate fil_list in (dbc.static_area);
	unspec (fil_list) = "0"b;			/* zero pad areas */
	fil_list.name = model_rel_name;
	fil_list.rmri_ptr = afle_rmri_ptr;

	if user_list.open_mode = mdbm_data_$quiesce_mode
	then do;
		fil_list.permits.read_attr = ON;
		fil_list.permits.modify_attr = ON;
		fil_list.permits.append_tuple = ON;
		fil_list.permits.delete_tuple = ON;

		fil_list.prevents.read_attr = ON;
		fil_list.prevents.modify_attr = ON;
		fil_list.prevents.append_tuple = ON;
		fil_list.prevents.delete_tuple = ON;
	     end;
	else do;
		fil_list.permits.read_attr = permit_requests.read_attr;
		fil_list.permits.modify_attr = permit_requests.modify_attr;
		fil_list.permits.append_tuple = permit_requests.append_tuple;
		fil_list.permits.delete_tuple = permit_requests.delete_tuple;

		fil_list.prevents.read_attr = prevent_requests.read_attr;
		fil_list.prevents.modify_attr = prevent_requests.modify_attr;
		fil_list.prevents.append_tuple = prevent_requests.append_tuple;
		fil_list.prevents.delete_tuple = prevent_requests.delete_tuple;
	     end;

	user_list.passive_sw = ON;
	if permit_requests.modify_attr | permit_requests.append_tuple | permit_requests.delete_tuple then do;
		fil_list.permits.update = ON;
		user_list.passive_sw = OFF;		/* user wants to be permitted to do a store, a modify */
	     end;					/*          or a delete --- thus, is a non-passive user */
	if fil_list.prevents.modify_attr | fil_list.prevents.append_tuple | fil_list.prevents.delete_tuple then
	     fil_list.prevents.update = ON;

	fil_list.next_ofs = NULL_OFS;			/* this is last file in the list */
	prev_ofs_ptr -> ophset = rel (fl_ptr);		/* update previous last file */
     end add_fil_list_entry;
%page;
activate_user_scope: proc;

/*
   This procedure links a user to the list of active users.
   If this is a non-initial attempt to set scope (ie, user was queued), then
   this procedure delinks the user from the waiting list before adding the
   user to the active list. It also makes a call to set the relation manager
   scopes.
*/


	if info.msg = QUE_FREE			/* not the first time this request has been made */
						/* unlink from waiting list -- and from priority list */
	then call mu_de_queue_user (NO_DQ_OPEN, SAVE_FIL_LIST, dbc_ptr, (this_ul_ptr), icode);

/* Link user to active list */

	ulo_ptr = addr (dbc.active_users_ofs);
	ul_ptr = convert (dbc_ptr, dbc.active_users_ofs);
	do while (ul_ptr ^= null);
	     ulo_ptr = addr (user_list.next_active_ofs);
	     ul_ptr = convert (dbc_ptr, user_list.next_active_ofs);
	end;
	ulo_ptr -> ophset = rel (this_ul_ptr);		/* link user to active list */
	dbc.active_users = dbc.active_users + 1;
	ul_ptr = this_ul_ptr;
	user_list.active_sw = ON;
	user_list.waiting_sw = OFF;

	call set_relmgr_scopes;

     end activate_user_scope;
%page;
scopes_by_this_process: proc (sbtp_rel_name, sbtp_faul_ptr, sbtp_pid, sbtp_relmgr_my_permits, sbtp_relmgr_others_permits);

/*
   This procedure looks at each user with active scopes in the user_list
   and for each user with the same process id as the current it user it
   looks for a scope for the input relation. For each scope it finds it
   takes the union of the permit and prevent ops to come up with a "scope"
   that can be passed to the relation manager set_scope routine.
*/

/* PARAMETERS */

	dcl     sbtp_rel_name	 char (30);	/* (input) relation under consideration */
	dcl     sbtp_faul_ptr	 ptr;		/* (input) pointer to the first active_user user_list structure */
	dcl     sbtp_pid		 bit (36);	/* (input) process id of the current process */
	dcl     sbtp_relmgr_my_permits bit (2) aligned;	/* (input) */
						/*         bit 1 true => process has set a scope permit */
						/*               of read on at least 1 opening */
						/*         bit 2 true => process has set a scope permit of modify */
						/*               or delete or append on at least 1 opening */
	dcl     sbtp_relmgr_others_permits bit (2) aligned; /* (input) */
						/*         bit 1 false => process has set a scope prevent */
						/*                        of read on at least 1 of its openings */
						/*         bit 2 false => process has set a scope prevent of */
						/*                         at least modify or delete or append in each opening */
						/*                          and all 3 prevents are set at least once. */

/* AUTOMATIC */

	dcl     sbtp_aul_ptr	 ptr;		/* pointer to a active_user user_list structure */
	dcl     sbtp_fl_ptr		 ptr;		/* pointer to a file_list structure */
	dcl     sbtp_rel_found	 bit (1);		/* "1"b => current user has active scopes on the */
						/*         relation under consideration */
	dcl     sbtp_r_prevents	 bit (1);		/* true if the process as set an r prevent in any of its openings */
	dcl     sbtp_a_prevents	 bit (1);		/* true if the process as set an a prevent in any of its openings */
	dcl     sbtp_d_prevents	 bit (1);		/* true if the process as set an d prevent in any of its openings */
	dcl     sbtp_m_prevents	 bit (1);		/* true if the process as set an m prevent in any of its openings */

%page;
	sbtp_aul_ptr = sbtp_faul_ptr;
	sbtp_relmgr_my_permits = "00"b;
	sbtp_r_prevents = "0"b;
	sbtp_a_prevents = "0"b;
	sbtp_d_prevents = "0"b;
	sbtp_m_prevents = "0"b;
	do while (sbtp_aul_ptr ^= null ());
	     if sbtp_aul_ptr -> user_list.ids.process_id = sbtp_pid
	     then do;
		     sbtp_fl_ptr = convert (dbc_ptr, sbtp_aul_ptr -> user_list.offsets.fil_list_ofs);
		     sbtp_rel_found = "0"b;
		     do while ((sbtp_fl_ptr ^= null ()) & ^(sbtp_rel_found));
			if sbtp_fl_ptr -> fil_list.name = sbtp_rel_name
			then do;
				sbtp_rel_found = "1"b;
				sbtp_relmgr_my_permits =
				     sbtp_relmgr_my_permits |
				     sbtp_fl_ptr -> fil_list.permits.read_attr ||
				     sbtp_fl_ptr -> fil_list.permits.update;
				sbtp_r_prevents = sbtp_r_prevents | sbtp_fl_ptr -> fil_list.prevents.read_attr;
				sbtp_a_prevents = sbtp_a_prevents | sbtp_fl_ptr -> fil_list.prevents.append_tuple;
				sbtp_d_prevents = sbtp_d_prevents | sbtp_fl_ptr -> fil_list.prevents.delete_tuple;
				sbtp_m_prevents = sbtp_m_prevents | sbtp_fl_ptr -> fil_list.prevents.modify_attr;
			     end;
			else sbtp_fl_ptr = convert (dbc_ptr, sbtp_fl_ptr -> fil_list.next_ofs);
		     end;
		end;
	     sbtp_aul_ptr = convert (dbc_ptr, sbtp_aul_ptr -> user_list.offsets.next_active_ofs);
	end;

	sbtp_relmgr_others_permits = ^sbtp_r_prevents || ^(sbtp_a_prevents & sbtp_d_prevents & sbtp_m_prevents);

	return;

     end scopes_by_this_process;
%page;
set_relmgr_scopes: proc;

/*
   This  procedure  loops though each relation with scope set, opens
   the  relation  if its not yet open and determines the total scope
   the  calling  process  has  on  the  relation (if the database is
   opened  multiple  times  there can be different scopes).  It then
   tells the relation manager what this total scope is.
*/

/* AUTOMATIC */

	dcl     srs_relmgr_my_permits	 bit (2) aligned;	/* bit 1 true => process has set a scope permit */
						/*               of read on at least 1 opening*/
						/* bit 2 true => process has set a scope permit of modify */
						/*               or delete or append on at least 1 opening*/
	dcl     srs_relmgr_others_permits bit (2) aligned;/* bit 1 false => process has set a scope prevent */
						/*                of read on at least 1 of its openings */
						/* bit 2 false => process has set a scope prevent of */
						/*                at least modify or delete or append in each opening */
						/*                 and all 3 prevents are set at least once. */
	dcl     srs_first_ul_ptr	 ptr;		/* pointer to first user list element */
	dcl     srs_fl_ptr		 ptr;		/* points to a fil_list structure */
	dcl     srs_process_id	 bit (36);	/* process id of caller */
	dcl     srs_rmri_ptr	 ptr;		/* pointer to rm_rel_info structure */


	srs_first_ul_ptr = convert (dbc_ptr, dbc.active_users_ofs);
	srs_fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);
	srs_process_id = get_process_id_ ();
	do while (srs_fl_ptr ^= null ());
	     srs_rmri_ptr = srs_fl_ptr -> fil_list.rmri_ptr;
	     srs_rmri_ptr = pointer (baseptr (baseno (srs_rmri_ptr)), rel (srs_rmri_ptr));
	     if srs_rmri_ptr -> rm_rel_info.opening_id = "0"b
	     then call open_relation (srs_rmri_ptr);
	     call scopes_by_this_process (srs_fl_ptr -> fil_list.name,
		srs_first_ul_ptr, srs_process_id,
		srs_relmgr_my_permits, srs_relmgr_others_permits);
	     call dbcb.relmgr_entries.set_scope (srs_rmri_ptr -> rm_rel_info.opening_id,
		srs_relmgr_my_permits, srs_relmgr_others_permits, icode);
	     if icode ^= 0
	     then call error (icode);
	     srs_fl_ptr = convert (dbc_ptr, srs_fl_ptr -> fil_list.next_ofs);
	end;

	return;

     end set_relmgr_scopes;

clean_up:
     proc;

	if dbc_ptr ^= null
	then do;
		if code ^= error_table_$lock_wait_time_exceeded
		then do;
						/* if a timeout then leave scope as is */

/* if this user is on either the active or waiting list --- then delink */
/* also, reset all counts , tallies, etc */

			if empty_on_err
			then do;
				call mu_empty_scope (dbcb.dbc_ptr, dbcb.scope_ptr, dbcb.rdbi_ptr, "1"b);
						/* delink */
				call set_relmgr_scopes;
			     end;
		     end;
		call set_lock_$unlock (dbc.scope_lock, icode);
	     end;
     end clean_up;
%page;
queue_scope:
     proc (first_time_asleep);

	dcl     first_time_asleep	 bit (1);

	ul_ptr = this_ul_ptr;
	if first_time_asleep
	then do;
		call ipc_$create_ev_chn (user_list.ev_chn_id, state);
						/* create an event channel on which we can
						   receive a wakeup message
						   or a timer runout message */
		if state ^= 0
		then call error (mrds_error_$unable_to_create_channel);
		wait_list.chn_id = user_list.ev_chn_id;
		wait_list.nchn = 1;
		user_list.priority_high = OFF;
		user_list.waiting_sw = ON;
		user_list.active_sw = OFF;
		user_list.allowance_count = dbc.active_users + dbc.waiting_users + WAIT;
		ulo_ptr = addr (dbc.waiting_users_ofs);
		ul_ptr = convert (dbc_ptr, dbc.waiting_users_ofs);
		do while (ul_ptr ^= null);
		     ulo_ptr = addr (user_list.next_waiting_ofs);
		     ul_ptr = convert (dbc_ptr, user_list.next_waiting_ofs);
		end;
		ulo_ptr -> ophset = rel (this_ul_ptr);	/* link user to waiting list */
		dbc.waiting_users = dbc.waiting_users + 1;
		ul_ptr = this_ul_ptr;

		call set_lock_$unlock (dbc.scope_lock, icode);

		wait_sec_fb71 = wait_seconds;		/* move to fixed bin (71) variable */
		call timer_manager_$alarm_wakeup (wait_sec_fb71, REL_SEC, user_list.ev_chn_id);
						/* set max wait time */
		icode = 0;			/* not a real error, just reporting */
		call report_conflict_detail (BEING_QUEUED_REPORT);
	     end;

	else do;
		user_list.event_signal_sw = OFF;
		user_list.queue_activ = OFF;
		call set_lock_$unlock (dbc.scope_lock, icode);
	     end;

	call ipc_$block (addr (wait_list), addr (info), state);
						/* go blocked */
	if state ^= 0
	then call error (mrds_error_$unable_to_queue_user);


     end queue_scope;
%page;
awakened: proc;

/* There are two possible ways we could have been awakened:
   if we ran out of time (message of ALARM), or by set/dl_fscope (msg of QUE_FREE)
   If we timed out, we must give up with an error message; if awakened by dl_fscope then scope has been freed so
   we're going to try again. Note that the scope lock must be re-locked in order for us to check for a conflict */

	dcl     idx		 fixed bin;

	if info.msg = ALARM				/* timed-out, so quit */
	then do;
		user_list.event_signal_sw = OFF;
		icode = error_table_$lock_wait_time_exceeded;
						/* Try 3 times before we give it up.  If we get the lock then we can dequeue */
		do idx = 1 to 3 while (icode ^= 0);
		     call set_lock_$lock (dbc.scope_lock, (mrds_data_$lock_wait_time), icode);
		     if icode = error_table_$invalid_lock_reset |
			icode = error_table_$locked_by_this_process
		     then icode = 0;
		end;
		if icode ^= 0 then
		     /* Some one hung the scope queue, so DBA should check at it. */
		     dbc.trouble_switch = ON;
		icode = mrds_error_$db_busy;
		call report_conflict_detail (TIME_OUT_REPORT);
		call error (icode);
	     end;

	call set_lock_$lock (dbc.scope_lock, (mrds_data_$lock_wait_time), icode);
	if icode = error_table_$invalid_lock_reset |
	     icode = error_table_$locked_by_this_process
	then icode = 0;				/* these error codes are expected */

	if icode ^= 0
	then do;
		dbc.trouble_switch = ON;
		call error (icode);
	     end;

	if info.msg = QUE_FREE			/* awakened by dl_fscope */
	then do;
		ul_ptr = this_ul_ptr;
		user_list.queue_activ = ON;

		if user_list.dead_proc_conflict
		then call error (mrds_error_$db_conflict_dead_process);


		conflict_sw = OFF;			/* re-check for conflict */
		do idx = 1 to scope_info.nfiles while (^conflict_sw);
		     re_check = ON;
		     do while (re_check);
			re_check = OFF;
			model_rel_name = scope_info.scope.name (idx);
			submodel_rel_name = scope_info.scope.sm_name (idx);

			unspec (remembered_permits), unspec (remembered_prevents) = "0"b; /* init */

			remembered_permits.read_attr =
			     scope_info.scope (idx).flags.permits.read_attr;
			remembered_permits.modify_attr =
			     scope_info.scope (idx).flags.permits.modify_attr;
			remembered_permits.append_tuple =
			     scope_info.scope (idx).flags.permits.append_tuple;
			remembered_permits.delete_tuple =
			     scope_info.scope (idx).flags.permits.delete_tuple;

			remembered_prevents.read_attr =
			     scope_info.scope (idx).flags.prevents.read_attr;
			remembered_prevents.modify_attr =
			     scope_info.scope (idx).flags.prevents.modify_attr;
			remembered_prevents.append_tuple =
			     scope_info.scope (idx).flags.prevents.append_tuple;
			remembered_prevents.delete_tuple =
			     scope_info.scope (idx).flags.prevents.delete_tuple;

			call mu_check_scope (dbc_ptr, addr (model_rel_name), ul_ptr, addr (remembered_permits),
			     addr (remembered_prevents), addr (actual_conflict_detail),
			     conflict_sw, conflict_ul_ptr);

			if conflict_sw then do;
				call check_dead_proc (conflict_sw, status);
				if ^conflict_sw then /* conflict was worked out */
				     re_check = ON;
				else do;
					conflict_user_id = conflict_ul_ptr -> user_list.ids.group_id;
					conflict_relation = submodel_rel_name;
					conflict_detail_known = ON;
					if status = DEAD then do; /* non-passive dead_proc remains */
						icode = mrds_error_$db_conflict_dead_process;
						call report_conflict_detail (DEAD_PROC_REPORT);
						call error (icode);
					     end;
				     end;
			     end;
		     end;
		end;

		if conflict_sw then do;
			call wakeup_next_waiter;
			if ul_ptr ^= null then do;
				user_list.event_signal_sw = OFF;
				user_list.bypass_count = user_list.bypass_count + 1;
			     end;
			if dbc.wakeup_waiters > 0 then
			     dbc.wakeup_waiters = dbc.wakeup_waiters - 1;
			call queue_scope (QUEUE_AGAIN);
		     end;
		else do;
			if substr (db_mrds_dsl_set_fscope, 1, 1) = "1"b then /* debug display on */
			     call ioa_ ("^/Scope request granted from queue.");
			call activate_user_scope;
			dbc.wakeup_waiters = dbc.wakeup_waiters - 1;
			user_list.event_signal_sw = OFF;
			if ^(prevent_requests.append_tuple &
			     prevent_requests.delete_tuple &
			     prevent_requests.modify_attr &
			     prevent_requests.read_attr)
						/* If user is preventing anyone from doing anything,
						   useless to wakeup someone */
			then call wakeup_next_waiter; /* Here such is not the case */
		     end;
	     end;

     end awakened;
%page;
wakeup_next_waiter:
     proc;

/*
   This routine looks through the waiting queue for a user that can be awakened to set scope.
   It looks for only one such user; it is the responsible of the newly awakened user to wake up the next (as
   this processis doing now).
*/

	wakeup = OFF;
	ul_ptr = convert (dbc_ptr, dbc.waiting_users_ofs);

	do while (ul_ptr ^= null & ^wakeup);
	     if ^user_list.event_signal_sw
	     then do;

/* Check each relation (file). */

		     fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);
		     wakeup = ON;
		     conflict_sw = OFF;

		     do while (fl_ptr ^= null & ^conflict_sw);

			model_rel_name = fil_list.name;

			unspec (actual_permits), unspec (actual_prevents) = "0"b; /* init */

			actual_permits.read_attr = fil_list.permits.read_attr;
			actual_permits.modify_attr = fil_list.permits.modify_attr;
			actual_permits.append_tuple = fil_list.permits.append_tuple;
			actual_permits.delete_tuple = fil_list.permits.delete_tuple;

			actual_prevents.read_attr = fil_list.prevents.read_attr;
			actual_prevents.modify_attr = fil_list.prevents.modify_attr;
			actual_prevents.append_tuple = fil_list.prevents.append_tuple;
			actual_prevents.delete_tuple = fil_list.prevents.delete_tuple;

			call mu_check_scope (dbc_ptr, addr (model_rel_name), ul_ptr, addr (actual_permits),
			     addr (actual_prevents), addr (unused_conflict_detail),
			     conflict_sw, conflict_ul_ptr);

/* If there was a conflict, see if it is because of a dead process.
   If there is a dead process that was passive, it will be de-queued and this process will continue checkin the files;
   Otherwise it will give up on this user. */

			if conflict_sw then do;
				call check_dead_proc (conflict_sw, status);
				if conflict_sw then
				     wakeup = OFF;
			     end;
			else fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
		     end;

		     if wakeup
		     then do;
			     call hcs_$wakeup (user_list.process_id, user_list.ev_chn_id, QUE_FREE, state);
			     if state ^= 0
			     then wakeup = OFF;
			     else do;
				     user_list.event_signal_sw = ON;
				     dbc.wakeup_waiters = dbc.wakeup_waiters + 1;
				end;
			end;

		     if ^wakeup
		     then do;
			     user_list.bypass_count = user_list.bypass_count + 1;
			     if user_list.bypass_count > user_list.allowance_count
			     then user_list.priority_high = ON;
			end;
		end;

	     ul_ptr = convert (dbc_ptr, user_list.next_waiting_ofs);
	end;

     end wakeup_next_waiter;
%page;
check_dead_proc:
     proc (conflict_sw, status);

/*
   This routine checks for a potential stiff (dead process pointed to by conflict_ul_ptr) and does what it can about it.
   If the process is dead and was a passive user, that process is de-queued.
   If dead and non_passive then it alerts the dbc to the fact that the db might be in an inconsistent state.
*/

	dcl     conflict_sw		 bit (1);
	dcl     status		 bit (1);

/* Find out if conflicting proc is dead or alive. */

	if conflict_ul_ptr -> user_list.dead_proc
	then status = DEAD;
	else do;
		call set_lock_$lock ((conflict_ul_ptr -> user_list.db_lock_id), 0, state);
		if state = 0
		then status = ALIVE;
		else if state = error_table_$invalid_lock_reset
		then status = DEAD;
		else if state = error_table_$locked_by_this_process
		     | state = error_table_$lock_wait_time_exceeded
		then status = ALIVE;
		else call error (state);
	     end;

/* Now try and de-queue if dead/passive, quit if dead/non-passive, nothing if alive. */

	if status = DEAD
	then if conflict_ul_ptr -> user_list.passive_sw
	     then do;
		     conflict_sw = OFF;
		     call mu_de_queue_user (DQ_OPEN, FREE_FIL_LIST, dbc_ptr, conflict_ul_ptr, icode);
		     if icode ^= 0
		     then call error (icode);
		end;
	     else do;
		     dbc.dead_proc_flag = ON;
		     conflict_ul_ptr -> user_list.dead_proc = ON;
		     user_list.dead_proc_conflict = ON;
		end;

	return;

     end check_dead_proc;
%page;
convert:
     proc (a_ptr, ofs) returns (ptr);

	dcl     a_ptr		 ptr;
	dcl     ofs		 bit (18) unal;

	if ofs = NULL_OFS
	then return (null);
	else return (ptr (a_ptr, ofs));

     end convert;
%page;
open_relation: proc (or_rmri_ptr);

/*
   This procedure opens a relation, it assumes that the relation is
   not yet opened, i.e. rm_rel_info.opening_id = "0"b
*/

/* PARAMETERS */

	dcl     or_rmri_ptr		 ptr;		/* (input) pointer to the rm_rel_info of the relation to be opened */

/* AUTOMATIC */

	dcl     or_code		 fixed bin (35);	/* standard error code */
	dcl     or_rdbi_ptr		 ptr;		/* pointer to the database's rm_db_info structure */




	or_rdbi_ptr = pointer (or_rmri_ptr, 0);

	call dbcb.relmgr_entries.open ((or_rdbi_ptr -> rm_db_info.db_path),
	     (or_rmri_ptr -> rm_rel_info.model_name),
	     or_rmri_ptr -> rm_rel_info.opening_id,
	     or_code);
	if or_code ^= 0
	then call error (or_code);

	return;

     end open_relation;
%page;
report_conflict_detail: procedure (report_type);

/* report the detail of the conflict preventing this scope request
   from being granted. reports are at three times, upon being queued for the first
   time, upon time out after waiting in the queue, and upon detection
   of a non-passive dead process */

	if substr (db_mrds_dsl_set_fscope, 1, 1) = "1"b then do; /* if debug display on */
		if report_type = DEAD_PROC_REPORT then
		     report_reason = "A non passive dead process is blocking scope requests.";
		else if report_type = BEING_QUEUED_REPORT then
		     report_reason = "You are queued until a conflict is overcome, or wait time is exceeded.";
		else if report_type = TIME_OUT_REPORT then
		     report_reason = "Your wait time elapsed without being able to resolve the conflict.";

		call ioa_ ("^/^a", report_reason);

	     end;

	if conflict_detail_known &
	     (report_type ^= BEING_QUEUED_REPORT | substr (db_mrds_dsl_set_fscope, 1, 1) = "1"b) then do;

		permit_conflict = "";

		if actual_conflict_detail.permits.read_attr then
		     permit_conflict = permit_conflict || "read_attr ";

		if actual_conflict_detail.permits.modify_attr then
		     permit_conflict = permit_conflict || "modify_attr ";

		if actual_conflict_detail.permits.append_tuple then
		     permit_conflict = permit_conflict || "append_tuple ";

		if actual_conflict_detail.permits.delete_tuple then
		     permit_conflict = permit_conflict || "delete_tuple ";

		if permit_conflict = "" then
		     permit_conflict = "null ";

		prevent_conflict = "";

		if actual_conflict_detail.prevents.read_attr then
		     prevent_conflict = prevent_conflict || "read_attr ";

		if actual_conflict_detail.prevents.modify_attr then
		     prevent_conflict = prevent_conflict || "modify_attr ";

		if actual_conflict_detail.prevents.append_tuple then
		     prevent_conflict = prevent_conflict || "append_tuple ";

		if actual_conflict_detail.prevents.delete_tuple then
		     prevent_conflict = prevent_conflict || "delete_tuple ";

		if prevent_conflict = "" then
		     prevent_conflict = "null ";

		call sub_err_ (icode, caller_name, continue, info_ptr, return_value,
		     "^/^a^a^a^a^a^/^a^a^a^a^a",
		     "The user """, conflict_user_id, """ has prevents conflicting with requested permits of """,
		     permit_conflict, """", "and/or permits conflicting with requested prevents of """,
		     prevent_conflict, """ on relation """, conflict_relation, """.");

		return;


		declare (permit_conflict, prevent_conflict) char (80) varying; /* extra scope that was not present */
		declare report_type		 fixed bin; /* encoding for caller */
		declare report_reason	 char (120) varying; /* detail about caller */

	     end;

     end;
%page;
/***********
*
*   These routines are used by the transaction processing include files.
*   Restore_significant_data is called to reinitialize variables in case
*   of a rollback.  Should_rollback determines whether a transaction should
*   be rolled back or aborted on error.  Currently, it is always aborted.
*
**********/


restore_significant_data:
     proc;
	user_list.queue_activ = OFF;
	user_list.bypass_count = 0;
	check_scope = ON;				/* OFF-> don't bother checking for conflict */
	conflict_sw = OFF;				/* ON -> a conflict was found */
	re_check = OFF;				/* ON -> a conflict was resolved, so try again */
	first_scope_triple = ON;			/* Processing firstrelation in scope request */
     end restore_significant_data;



should_rollback:
     proc returns (bit (1));
	return ("0"b);
						/* No rollbacks requested or desired */
     end should_rollback;

%page;
/* Based */
	dcl     db_index		 fixed bin (35) based (dbi_ptr),
						/* index of data base to perform set_fscope upon */
	        rel_name		 char (rel_len) based (rel_ptr);
						/* relation name part of scope tuple */

	dcl     code		 fixed bin (35) based (cd_ptr);
						/* standard return code */

/* Automatic structures */

	dcl     1 wait_list,
		2 nchn		 fixed bin,	/* one event channel */
		2 chn_id		 (1) fixed bin (71);/* channel id */

	dcl     1 info,				/* event information */
		2 chn_id		 fixed bin (71),
		2 msg		 fixed bin (71),	/* message from process doing the awakening */
		2 sender		 bit (36),	/* process id of the process doing the awakening */
		2 origin,
		  3 dev_sig	 bit (18) unal,	/* device signal */
		  3 ring		 bit (18) unal,	/* ring  id */
		2 chn_index	 fixed bin;	/* index of the channel id */
	dcl     ptr_bit_string	 bit (72) based;	/* bit string value of a pointer variable */
	dcl     state		 fixed bin (35);	/* return code from set_lock and ipc_  */
	dcl     empty_on_err	 bit (1) aligned init ("0"b);
						/* ON if we are to empty scope in case of error */
	dcl     check_scope		 bit (1);		/* OFF=>don't bother checking for conflict: either */
						/* ..there are no active users to contend with, or */
						/* ..there are active users and we are trying to set */
						/* ..an exclusive setting; thus cannot succeed */
	dcl     re_check		 bit (1);		/* ON if we are to re-check for conflict */
	dcl     first_scope_triple	 bit (1);		/* ON if we are still
						   processing the first rel of scope request */
	dcl     wakeup		 bit (1);		/* ON if we are to wake this waiting user up */
	dcl     conflict_sw		 bit (1) unal;	/* ON => conflict between
						   desired scope and scope in effect now */
	dcl     status		 bit (1) unal;	/* status code of DEAD or ALIVE */
	dcl     wait_seconds	 fixed bin (35) based (ws_ptr);
						/* seconds this user is willing to wait */
	dcl     wait_sec_fb71	 fixed bin (71);	/* fixed bin (71) format for wait_seconds param. */
	dcl     entry_name		 char (32);	/* name by which this procedure was called */
	dcl     model_rel_name	 char (30);	/* name of relation in model for which scope is to be set */
	declare submodel_rel_name	 char (32);	/* submodel version of rel name */
	dcl     (
	        nargs,				/* number of arguments passed */
	        arg_len,
	        num_tuples,				/* number of scope tuples to be defined */
	        i,
	        l,
	        pos_in_si,
	        args_exp,				/* number of args in the calling argument list */
	        arg_index,				/* index to 1st arg of current tuple in arg list */
	        rel_len
	        )			 fixed bin;	/* length of rel_name in chars */

	dcl     icode		 fixed bin (35);	/* internal status code */


	dcl     rel_name_32		 char (32);	/* Used for searching rel_array */
	dcl     ophset		 bit (18) unal based;
						/* a based offset */

	dcl     (
	        cd_ptr,				/* pointer to code */
	        dbi_ptr,				/* pointer to db_index */
	        ws_ptr,				/* ptr to wait time in seconds */
	        conflict_ul_ptr,			/* ptr to a user who conflicts with requested scope */
	        rel_ptr,				/* pointer to rel_name */
	        ulo_ptr,				/* ptr to the last 'next' offset in the user_list */
	        flo_ptr,				/* ptr to the last 'next' offset
						   in the fil_list(list of rels) */
	        this_ul_ptr				/* ptr to a given user list entry */
	        )			 ptr;		/* pointer to prevent ops */


	dcl     (any_other, cleanup, quit, arg_error)
				 condition;

	dcl     (addr, divide, length, mod,
	        null, pointer, rel, baseno, baseptr)
				 builtin;


/*                    Multics subroutines                     */

	dcl     cu_$arg_count	 entry (fixed bin),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35)),
	        get_process_id_	 entry returns (bit (36)),
	        ipc_$block		 entry (ptr, ptr, fixed bin (35)),
	        ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35)),
	        timer_manager_$alarm_wakeup
				 entry (fixed bin (71), bit (2), fixed bin (71)),
	        hcs_$wakeup		 entry (bit (*), fixed bin (71), fixed bin (71), fixed bin (35)),
	        set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35)),
	        set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));

/*                    Other subroutines                    */

	dcl     mu_empty_scope	 entry (ptr, ptr, ptr, bit (1) unal),
	        mu_database_index$get_resultant_model_pointer
				 entry (fixed bin (35), ptr),
	        mu_check_scope	 entry (ptr, ptr, ptr, ptr, ptr, ptr, bit (1), ptr),
	        mu_de_queue_user
				 entry (bit (1), bit (1), ptr, ptr, fixed bin (35));

/*                    External data                    */
	dcl     error_table_$lock_wait_time_exceeded
				 fixed bin (35) ext,
	        error_table_$locked_by_this_process
				 fixed bin (35) ext,
	        error_table_$invalid_lock_reset
				 fixed bin (35) ext,
	        mdbm_data_$quiesce_mode
				 fixed bin (35) ext,
	        mrds_data_$lock_wait_time
				 fixed bin (35) ext,
	        mrds_error_$unable_to_create_channel
				 fixed bin (35) ext,
	        mrds_error_$duplicate_scope
				 fixed bin (35) ext,
	        mrds_error_$invalid_db_index
				 fixed bin (35) ext,
	        mrds_error_$rel_name_too_long
				 fixed bin (35) ext,
	        mrds_error_$scope_not_empty
				 fixed bin (35) ext,
	        mrds_error_$unknown_relation_name
				 fixed bin (35) ext,
	        mrds_error_$non_scope_ready
				 fixed bin (35) ext,
	        mrds_error_$db_conflict_dead_process
				 fixed bin (35) ext,
	        mrds_error_$db_busy	 fixed bin (35) ext,
	        mrds_error_$unable_to_queue_user
				 fixed bin (35) ext,
	        mrds_error_$update_not_allowed
				 fixed bin (35) ext,
	        sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     NULL_CHAR		 char (8) init ("");
	dcl     OFF		 bit (1) init ("0"b) static internal options (constant);
	dcl     ON		 bit (1) init ("1"b) static internal options (constant);

/* sub_err_ declarations */

	declare sub_err_		 entry options (variable); /* reports error detail */
	declare continue		 char (1) init ("c"); /* dont stop after printing */
	declare caller_name		 char (32) init ("mrds_dsl_set_fscope"); /* name of calling routine */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare 1 (actual_permits, actual_prevents, remembered_permits, remembered_prevents) like common;
	declare attr_retr_perm	 bit (1);		/* on => retr access permission */
	declare attr_modify_perm	 bit (1);		/* on => modify on some attr */
	declare attr_null_perm	 bit (1);		/* on => null on some attr */
	declare rel_append_perm	 bit (1);		/* on => append-tuple access permission */
	declare rel_delete_perm	 bit (1);		/* on => delete tuple access permission */
	declare rel_null_perm	 bit (1);		/* on => null tuple access permission */
	declare 1 actual_conflict_detail,		/* detail of scope denial */
		2 permits		 like common,
		2 prevents	 like common;
	declare 1 unused_conflict_detail,		/* thorw away detail */
		2 permits		 like common,
		2 prevents	 like common;
	declare TIME_OUT_REPORT	 fixed bin init (1);/* report reason for last conflict before time out */
	declare BEING_QUEUED_REPORT	 fixed bin init (2);/* report for first conflict forcing queueing  */
	declare DEAD_PROC_REPORT	 fixed bin init (3);/* report detail on non-passive dead proc conflict */
	declare conflict_detail_known	 bit (1) init ("0"b); /* on => conflict_detail data set up */
	declare conflict_user_id	 char (32);	/* user id of user causing conflict */
	declare conflict_relation	 char (32);	/* name of relation conflict occured at */
	declare ioa_		 entry options (variable); /* reports debug display info */
	declare null_request	 bit (1);		/* on => no permits/prevents requested */
	declare null_permit_request	 bit (1);		/* on => no permits specified */
	declare null_prevent_request	 bit (1);		/* on => no prevents specified */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* DBA detecter */
	declare local_area		 area (100);	/* space for DBA info */
	dcl     empty		 builtin;
	dcl     fixed		 builtin;
	dcl     index		 builtin;
	dcl     ptr		 builtin;
	dcl     rtrim		 builtin;
	dcl     string		 builtin;
	dcl     substr		 builtin;
	dcl     unspec		 builtin;
%page;
%include mdbm_scope_requests;
%page;
%include mrds_debug_names;
%page;
%include mrds_dbcb;
%page;
%include mdbm_dbc;
%page;
%include mdbm_users;
%page;
%include mdbm_scope_info;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mrds_authorization;
%page;


     end mrds_dsl_set_fscope;






		    mrds_dsl_set_scope.pl1          08/01/88  1347.6r w 08/01/88  1315.0      158094



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

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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-07-01 by Thanh
     Nguyen. (see mrds #137)
                                                   END HISTORY COMMENTS */

/* HISTORY:
   Originally written by Jim Gray - - September 1979
   5-jun-80 Davids: Modified to correctly calculate the number of arguments   when called with the dl_scope_all entry.
   Modified by Jim Gray - - June 1980, to detect dl_scope on unshared openings.

   80-12-10 Jim Gray : removed conversion or r-s-m-d modes to r-u type scope modes
   so that complete r-s-m-d modes could be implemented.
   Also changed displayed names of modes as follows:
   retrieve now = read_attr, store/update now = append_tuple
   delete now = delete_tuple, modify now = modify_attr
   This was done to agree with security acl modes.
   Also added use of mrds_new_scope_modes and mrds_opening_modes_ include files.

   80-12-11 Jim Gray : Changed error reproting on detection of invalid combination
   of modes into a sum when the set_scope_all entry was used.

   81-01-29 Jim Gray : removed references to mdbm_data_$current_version,
   using a constant instead, to allow for future db version expansion.
   Previously, since no relation name was available, a null ptr was referenced.

   81-06-01 Jim Gray : removed all code tranlating from a file
   to relation interface, as part of changing to use new resultant model
   structures.

   83-06-20 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)

   85-07-01 Thanh Nguyen: Added code to set the dbcb.scopes_changed on when
   ever scopes had been successfully modified.  The mrds_dsl_gen_srch_prog 
   and mrds_dsl_optimize will reset at the time they build a new search_vars
   structure for a new select_expression.  So we can detect that the scopes
   had been changed in -another.
*/

mrds_dsl_set_scope: procedure (); return;		/* not valid entry */

/* DESCRIPTION:
   this routine was written to allow upward compatible calls to
   dsl_$set_scope, dsl_$set_scope_all, dsl_$dl_scope, and dsl_$dl_scope_all.
   if this routine is called by a user with an old version database,
   the calls are simply passed on(via generate_call) to the old version programs.
   if called by the new version database user, the _all entries,
   simply call the corresponding fscope_all entries to take the
   correct scope action on all files, and thus all relations.
   if the non "_all" entries are called, then a new argument list is built
   that contains the file names of files containing the given relations,
   the permit/prevent operations are set according, and the appropriate
   fscope entry point is called. note: relation modify/delete are converted to file update scope.  */

/* PARAMETERS:
   database_index - - (input) fixed bin(35) aligned, the opening index returned
   from the call to dsl_$open for the users database.

   relation_name - - (input) char nonvarying, only for the non "_all" entries,
   the name of the relation on which to set/delete scope.
   any number of relation_name/permits/prevents triples may be present(up to number of relation).
   when this argument is missing(in "_all" entries) all relations are affected.

   permits - - (input) fixed bin (17), the operations to be permitted on the relations,
   it is a sum of the codes desired, where the allowed codes are:
   1(retrieve), 2(store/update), 4(delete), 8(modify)

   prevents - - (input) fixed bin (17), the operations which others(processes)
   are to prevented from doing. a sum of the desired codes, as above.

   wait_time - - (input) fixed bin (35), optional time to wait in seconds, on set_scope entries,
   if the request can not be honored immediately.

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

   sub_error_ - - (output) condition, signaled upon occurence of an error to provide more info  */

/* NOTE ON USE OF DSL_$DL_SCOPE WITH NEW VERSION DATABASES:

   The use of dsl_$dl_scope with blocked files,
   when not all relations in the file are specified in the argument list,
   will not be allowed for the following reasons:

   1) this routine is primarily a transition tool to get old version
   application programs to run without change on new version databases
   by converting set/dl_scope calls into set/dl_fscope (file scope) calls.
   Since relations get default unblocked files when processed
   by create_mrds_db, and there is only one relation per file,
   no problems are encountered in the use of this tool.
   However, the following example illustrates a problem with "partial dl_scope",
   on blocked files.

   EXAMPLE: file_1 has two relations rel_1 and rel_2 with current scope settings of:
   rel_1 has retrieve and update scopes, rel_2 has only retrieve scope.
   a call to this module to delete both retrieve and update
   scope on rel_1 would be transformed into a call to dl_fscope on file_1.
   this would result in null scopes for both rel_1 and rel_2!!
   attempts to access or delete scope on rel_2 would result in an error.

   this is a problem with the algorithm used in this module, i.e. deleting
   the maximum, not minimum scope on a file.

   2) to correct the problem noted in 1 above would require changes to the
   rm_rel_array to maintain per process scopes in affect per relation,
   thus requiring recompilation of many modules, when ideally the
   transition tool should be limited to the logic in this module.

   3) most important, if users are going to change to the new blocked file
   structure for their databases, then they should be making use of the
   set/dl_fscope entries, and not this transition tool, which may eventually
   not be supported.


   Therefore the following RESTRICTIONS ON THE USE OF DL_SCOPE are enforced:

   1) no restrictions on the user of dl_scope_all.

   2) no restrictions on unblocked files.

   3) when blocked files are in use, dl_scope may be successfully be used
   only when all relations in the file have their complete scopes given
   in the call, i.e. "partial deletes are not allowed"

   in terms of the given example this means, that to remove update permission
   from rel_1, the call would contain the arguments:

   rel_1 update null rel_2 update null

   for relation/permit/prevent triples, even though rel_2 has no update permission
   in the sense of the old scope mechanism.

*/

set_scope: entry ();

/* entry called to set scope on a single relation, or list of relations */

	SET_SCOPE_ENTRY = ON;
	SCOPE_ALL_ENTRY = OFF;
	min_args = 5;				/* args = db_index, rel_name, permits, prevents, error_code
						   any number of rel_name/permits/prevents triples allowed
						   wait time argument is optional */

	goto common_scope_routine;			/* use goto to save external argument list for cu_ call */




set_scope_all: entry ();

/* entry called to set scope on all relations, without naming them */

	SET_SCOPE_ENTRY = ON;
	SCOPE_ALL_ENTRY = ON;
	min_args = 4;				/* args = db_index, permits, prevents, error_code
						   wait time argument is optional */

	goto common_scope_routine;






dl_scope: entry ();

/* entry called to delete scope on a single relation, or list of relations */

	SET_SCOPE_ENTRY = OFF;
	SCOPE_ALL_ENTRY = OFF;
	min_args = 5;				/* args = db_index, rel_name, permits, prevents, error_code
						   any number of rel_name/permits/prevents triples allowed
						   wait time argument not allowed */

	goto common_scope_routine;




dl_scope_all: entry ();

/* entry called to delete scope on all relations without naming them */

	SET_SCOPE_ENTRY = OFF;
	SCOPE_ALL_ENTRY = ON;
	min_args = 2;				/* args = db_index, error_code */

	goto common_scope_routine;

common_scope_routine: ;

/* logic common to all entry points for setting/deleting scope,
   on all relations, or one at a time, as specified by arguments */

	error_code = 0;				/* initialize */

/* get the external procedures argument list, before going to an internal routine */

	call cu_$arg_list_ptr (al_ptr);		/* get argument list */

/* determine user's database version number */

	call get_version_of_caller ();

/* now make the appropriate call -- to set_scope for old versions, to set_fscope for new_versions */

	call pass_call_to_correct_version ();

/* now set the users error code, if neccessary */

	if error_code = 0 then
	     if dbcb_ptr ^= null then
		dbcb.scopes_changed = "1"b;
	     else;
	else if desc_index = 0 & ^(SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY) then ; /* can't get descriptor, or dl_scope_all */
	else do;
		desc_ptr = arg_list.arg_des_ptr (desc_index + nargs);
		if ^(SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY) & /* ignore for dl_scope_all */
		     desc_ptr -> descriptor_ovrly ^= fixed_bin_35_descr then ; /* don't assign unknown data type */
		else if arg_list.arg_des_ptr (nargs) -> error_code_ovrly ^= 0 then ; /* set by called version */
		else arg_list.arg_des_ptr (nargs) -> error_code_ovrly = error_code;
	     end;

	return;

get_version_of_caller: procedure ();

/* first get the callers argument list, and check for minimum arguments,
   before finding version of database from resultant model via the database index */

	if SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY then /* dl_scope_all called */
	     nargs = arg_list.arg_count / 2;		/* not an options (variable) entry */
	else nargs = arg_list.desc_count / 2;		/* = number of args if called options(variable) */
	desc_index = 0;				/* in case of early error */

	if nargs < min_args then do;
		error_code = error_table_$wrong_no_of_args;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a ^d ^a",
		     "The number of arguments =", nargs,
		     "was less than the minimum of", min_args,
		     "or the entry was not declared ""options (variable)"".");
	     end;
	else do;

/* get the offset of descriptors in the argument list */

		if SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY then ; /* no descriptors for dl_scope_all */
		else if arg_list.code = SPECIAL then
		     desc_index = nargs + 1;
		else desc_index = nargs;
		num_ptrs = desc_index + nargs;

/* check for a valid error code argument, and then initialize it */

		desc_ptr = arg_list.arg_des_ptr (desc_index + nargs);
		if ^(SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY) & /* can't check descriptor on dl_scope_all */
		     desc_ptr -> descriptor_ovrly ^= fixed_bin_35_descr then do;
			error_code = error_table_$bad_arg;
			call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^a",
			     "The error code(last) argument",
			     "was not declared ""fixed binary (35) aligned"".");
		     end;
		else do;

			arg_list.arg_des_ptr (nargs) -> error_code_ovrly = 0; /* initialize users error code */

/* check for old or new version database call to set_scope
   by getting the version out of the resultant model built
   at open time, via the given database index */

			num_dims = 0;

			if SCOPE_ALL_ENTRY & ^SET_SCOPE_ENTRY then /* can't check descriptor on dl_scope_all */
			     desc_ptr = addr (fixed_bin_35_descr); /* => don't convert, use arg directly */
			else desc_ptr = arg_list.arg_des_ptr (desc_index + 1);

			call mu_convert_parameter$convert_input_parameter (arg_list.arg_des_ptr (1), desc_ptr, db_index_ptr,
			     addr (fixed_bin_35_descr), addr (local_area), error_code);
			if error_code ^= 0 then do;
				call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
				     "The database index argument could not be converted to ""fixed binary (35) aligned"".");
			     end;
			else do;

/* check for valid database index, in order to get resultant model pointer */

				call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);

				if dbcb_ptr = null () then do;
					error_code = mrds_error_$invalid_db_index;
					call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a",
					     "The database index =", db_index,
					     "does not refer to a database that is currently open by this process.");
				     end;

			     end;

		     end;

	     end;

     end;

pass_call_to_correct_version: procedure ();

/* call old set_scope, for old version database calls,
   and the new set_fscope for new version database calls,
   after converting relation names into files names,
   with duplicates removed, and max permissions granted,
   and max prevents allowed that will not conflict. */

	if error_code ^= 0 then ;
	else do;

		new_al_ptr = al_ptr;

		exclusive_opening = (fixed (dbcb.open_mode) = EXCLUSIVE_RETRIEVAL |
		     fixed (dbcb.open_mode) = EXCLUSIVE_UPDATE);
		if exclusive_opening then error_code = mrds_error_$unshared_opening;

		if SCOPE_ALL_ENTRY then do;


			if SET_SCOPE_ENTRY then
			     entry_name = mrds_dsl_set_fscope$set_fscope_all;
			else entry_name = mrds_dsl_dl_fscope$dl_fscope_all;
		     end;
		else do;

			if SET_SCOPE_ENTRY then
			     entry_name = mrds_dsl_set_fscope$set_fscope;
			else entry_name = mrds_dsl_dl_fscope$dl_fscope;
		     end;

		if error_code ^= 0 then ;
		else call cu_$generate_call (entry_name, new_al_ptr);
	     end;
     end;

	declare sub_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (20) init ("mrds_dsl_set_scope"); /* name of calling routine */
	declare continue		 char (1) init ("c"); /* don't stop after printing error msg */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare cu_$arg_list_ptr	 entry (ptr);	/* gets pointer to argument list */
	declare cu_$generate_call	 entry (entry, ptr);/* makes call to given entry with given arg list */
	declare SCOPE_ALL_ENTRY	 bit (1);		/* on => all entry called */
	declare entry_name		 entry options (variable) variable;
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets ptr for opening index */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* bad database indeex */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* bad subroutine argument */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* bad argument count */
	declare db_index		 fixed bin (35) based (db_index_ptr); /* database index */
	declare db_index_ptr	 ptr;		/* points to database index */
	declare nargs		 fixed bin;	/* number of input arguments */
	declare descriptor_ovrly	 bit (36) unal based; /* overlay for descriptor */
	declare fixed_bin_35_descr	 bit (36) init ("100000100000000000000000000000100011"b); /* descriptor for fixed bin(35) */
	declare desc_index		 fixed bin;	/* offset to start of descriptors in array */
	declare SPECIAL		 fixed bin init (8);/* special version code for arg list */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare new_al_ptr		 ptr;		/* points to converted argument list */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	declare (addr, rel, fixed, null, empty) builtin;
	declare min_args		 fixed bin;	/* either 4 or 5, for "all" or not entries */
	declare CHAR_NONVAR		 fixed bin init (21); /* nonvarying character string data type */
	declare fixed_bin_17_descr	 bit (36) init ("100000100000000000000000000000010001"b); /* descriptor for fixed bin (17) */
	declare char_nonvar_descr	 bit (36) init ("101010100000000000000000000000011110"b); /* char(30) nonvarying descriptor */
	declare NON_SPECIAL		 fixed bin init (4);/* no extra pointer in arg list */
	declare local_area		 area (100);	/* space for converting parameters */
	declare SET_SCOPE_ENTRY	 bit (1);		/* on => called to set, not delete, scope */
	declare error_code_ovrly	 fixed bin (35) based; /* overlay for assigning error code */
	declare mu_convert_parameter$convert_input_parameter entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); /* gets in needed type */

	declare (mrds_dsl_dl_fscope$dl_fscope,
	        mrds_dsl_dl_fscope$dl_fscope_all,
	        mrds_dsl_set_fscope$set_fscope,
	        mrds_dsl_set_fscope$set_fscope_all) entry options (variable); /* actual procedures that will be called */
	declare mrds_error_$unshared_opening fixed bin (35) ext; /* opened er or eu => dont allow delete scope */
	declare exclusive_opening	 bit (1);		/* on => er or eu open mode */

%include mdbm_descriptor;
%include mrds_new_scope_modes;
%include mrds_opening_modes_;
%include mrds_dbcb;
%include mdbm_arg_list;


     end;




		    mrds_dsl_set_user_vals.pl1      08/01/88  1347.6rew 08/01/88  1300.0       80415



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, changed references of sel_ptr to select_list_ptr.
                                                   END HISTORY COMMENTS */



mrds_dsl_set_user_vals:
    procedure (dbcb_ptr, area_ptr, argp_ptr, descp_ptr, num_args, arg_sel_ptr,
        code);

/* HISTORY: 
   84-07-19 Hergert: Extracted from mrds_dsl_select_clause. This was done
   to avoid expensive initializations in mrds_dsl_select_clause that werent
   necessary when processing -another's. update_movelists was eliminated
   and the code was put inline in the entry "another" */

        select_list_ptr = arg_sel_ptr;
        call set_u_vals;
        code = 0;
        return;

another:
    entry (dbcb_ptr, area_ptr, argp_ptr, descp_ptr, num_args, code);

/* This entry is called by translate to reset the user value items in
   the select list to correspond to the new arguments in case of a -another. */

        select_list_ptr = dbcb.select_ptr;
        call set_u_vals;				/* this is the beginning of what was update_movelist */
        do k = 1 to select_list.num_vars;		/* loop through for each var */
	  ml_ptr = move_list_array.ml_ptr (k);
	  mli = 0;
	  do i = 1 to select_list.num_items;		/* update each item */
	      if select_list.item.var_index (i)
		= move_list_array.var_index (k) then do;
		mli = mli + 1;
		move_list.item.attr_index (mli) =
		    select_list.item.ai_ptr (i) -> rm_attr_info.defn_order;
		move_list.item.user_ptr (mli) =
		    select_list.item.user_ptr (i);
		move_list.item.user_desc_ptr (mli) =
		    select_list.item.user_desc_ptr (i);
	      end;
	  end;
        end;					/* this is the end of what was update movelist */

        code = 0;
exit:
        return;					/* that's all, folks */

error:
    proc (cd);

/* Internal error procedure */

dcl     cd		 fixed bin (35);		/* internal status code */

        code = cd;					/* pass bad news back to caller */
        go to exit;

    end error;

set_u_vals:
    proc;						/* Procedure to fill in user value items in the select list */

        arg_ptr = null;				/* initialize */

        pa_size = num_args;				/* set size of template array */
        desc_ptr = descp_ptr -> ptr_array (num_args);	/* get last of value args */
        skip_flag = "0"b;

        if descriptor.type = STRUCTURE then do;		/* if everything included in structure */

	  call mu_break_structure (area_ptr,
	      argp_ptr -> ptr_array (num_args),
	      descp_ptr -> ptr_array (num_args), arg_ptr, arg_count, icode);
	  if icode ^= 0 then call error (icode);
	  if arg_count ^= select_list.num_items then do;	/* if no. components doesn't match no. sel. items */
	      dbcb.val_mod, dbcb.val_rtrv = "0"b;
	      skip_flag = "1"b;
	  end;

	  else do;
	      num_args = num_args - 1;		/* update unused value counter */
	      pa_size = arg_count;			/* set size of template array */
	      a_ptr = addr (str_args (1));		/* point to first of arg pointers */
	      d_ptr = addr (str_args (arg_count + 1));	/* point to first of desc. pointers */
	      was_structure = "1"b;			/* remember was struct. */
	  end;

        end;					/* breaking up structure */

        else do;					/* if value for each select item specified separately */

	  if select_list.num_items > num_args then do;	/* if not enougn values to cover all items */
	      dbcb.val_mod, dbcb.val_rtrv = "0"b;
	      skip_flag = "1"b;
	  end;

	  else do;
	      num_args = num_args - select_list.num_items;/* update unused value count, we will use sufficient values from the end of the list to cover all select items. */

	      a_ptr = addr (argp_ptr -> ptr_array (num_args + 1));
						/* point to first used arg pointer */
	      d_ptr = addr (descp_ptr -> ptr_array (num_args + 1));
						/* point to first used desc. pointer */
	      pa_size = select_list.num_items;		/* set template size */
	      was_structure = "0"b;			/* remember was not struct. */
	  end;

        end;					/* item values specified separately */

        if ^skip_flag then do;			/* if have user values to set */

	  do i = 1 to select_list.num_items;		/* for each specified select item */

	      select_list.item.user_desc_ptr (i), desc_ptr =
		d_ptr -> ptr_array (i);		/* pick up pointer to current value descriptor */
	      rdi_ptr =
		select_list.item.ai_ptr (i) -> rm_attr_info.domain_ptr;

	      if desc_ptr -> bit36
		= rm_domain_info.user_desc /* if no conversion required */
		| descriptor.type = STRUCTURE
		| descriptor.number_dims ^= "0"b then do;

		select_list.item.must_convert (i) = "0"b;
						/* remember no conversion required */
		select_list.item.user_ptr (i) = a_ptr -> ptr_array (i);
						/* pick up pointer to user value */
		if ^was_structure
		then /* if vals. specified separately */
		     if descriptor.type = VAR_CHAR
		         | descriptor.type = VAR_BIT
		     then /* if varying */
			select_list.item.user_ptr (i) =
			    addrel (select_list.item.user_ptr (i), -1);
						/* to include length */

	      end;				/* if no conversion required */

	      else do;				/* if conversion is required */

		select_list.item.must_convert (i) = "1"b;
						/* remember to convert */
		select_list.item.user_ptr (i) = a_ptr -> ptr_array (i);
						/* pick up pointer to user value */
		if ^was_structure
		then /* if vals. specified separately */
		     if descriptor.type = VAR_CHAR
		         | descriptor.type = VAR_BIT
		     then /* if varying */
			select_list.item.user_ptr (i) =
			    addrel (select_list.item.user_ptr (i), -1);
						/* to include length */

		if ^mu_valid_data_type$valid_scalar_data_type (desc_ptr
		    -> bit36)
		then call error (mrds_error_$bad_select_value);
						/* if unsupported data type */

	      end;				/* where conversion is required */

	  end;					/* filling in user value info. */

	  if arg_ptr ^= null then arg_ptr = null;

        end;					/* if had user values */
    end set_u_vals;

%include mrds_dbcb;
%page;
%include mrds_select_list;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_move_list;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_descriptor;
%page;

dcl     (
        argp_ptr,					/* Input/Output -- pointer to next arg pointer */
        arg_sel_ptr,
        descp_ptr,					/* Input/Output -- pointer to next descriptor pointer */
        arg_ptr,					/* pointer to pointer list returned by break_structure */
        a_ptr,					/* points to list of arg pointers */
        d_ptr
        )			 ptr;			/* points to list of descriptor pointers */

dcl     skip_flag		 bit (1);			/* on if no user vaos to set */

dcl     (
        num_args,					/* Input/Output -- number of unused value args */
        i,					/* internal index */
        k,					/* internal index */
        mli,					/* internal index */
        pa_size,					/* current size of ptr_array */
        arg_count
        )			 fixed bin;		/* number of arguments out of break_structure */

dcl     (
        code,					/* Output -- return code */
        icode
        )			 fixed bin (35);		/* internal status code */

dcl     was_structure	 bit (1) unal;		/* on if user vals in structure */
dcl     str_args		 (2 * arg_count) ptr based (arg_ptr);
						/* structure items from break_structure */
dcl     ptr_array		 (pa_size) ptr based;	/* template */
dcl     bit36		 bit (36) based;		/* template */

dcl     STRUCTURE		 fixed bin (5) int static init (17)
			 options (constant);
dcl     VAR_BIT		 fixed bin (5) int static init (20)
			 options (constant);
dcl     VAR_CHAR		 fixed bin (5) int static init (22)
			 options (constant);

dcl     (
        mrds_error_$bad_select_value,
        sys_info$max_seg_size
        )			 fixed bin (35) ext;

dcl     (addr, addrel, fixed, null, rel)
			 builtin;

/* Multics subroutines */

/* MRDS subroutines */

dcl     mu_break_structure	 entry (ptr, ptr, ptr, ptr, fixed bin,
			 fixed bin (35));
dcl     mu_valid_data_type$valid_scalar_data_type
			 entry (bit (36)) returns (bit (1) aligned);
						/* decides if supported data type */
dcl     area_ptr		 ptr;
dcl     continue		 char (1) init ("c");	/* dont stop after printing error mesg */
dcl     info_ptr		 ptr init (null ());	/* unused */
dcl     return_value	 fixed bin (35) init (0);	/* unused */
dcl     caller_name		 char (32) init ("mrds_dsl_set_user_vals");
						/* name of calling module */

    end mrds_dsl_set_user_vals;




		    mrds_dsl_store.pl1              08/01/88  1347.6r w 08/01/88  1314.2      224037



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

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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-04-19 by Thanh
     Nguyen. (see mrds #136)
                                                   END HISTORY COMMENTS */

mrds_dsl_store:
store:
     proc;


/*

		      BEGIN_DESCRIPTION

   The call to store looks like :

   call  mrds_dsl_store (database_index, relation_name, value_1, ..., value_n,
   code);

   store  accepts  as  input  from  the  caller an index to the database to be
   referenced  the  name  of  the  relation  to  be  affected the values to be
   assigned to a tuple of the affected relation and a recturn code.

   if the attempt to store is unsuccesful for some reason a nonzero code value
   is returned to the caller

   store  requires  that  the  database is open for update or exclusive update
   activity and that append_tuple or store_tuple scope be set on the relation.
		       END_DESCRIPTION

   Known Bugs:
      1) data types of the arguments are not checked so it is possible
         to have a character string dbi which is treated as a fixed
         bin (35) value (NSD 83-04-05)

   Other Problems:
      1) replacing the mdbm_arg_list include file with the system arg_list
         include file would reduce the number of index calculations needed
         and the divide operation to get the number of arguments. It would
         also improve the readability since descriptor and argument pointers
         would be separated.
      2) investigate the need to call mu_release_area in every call (is
         it really necessary to free the temp segment or can it be kept
         around) also a faster way to empty the area.

   HISTORY:

   76-02-01 Oris Friesen : Originally written.

   78-05-01 J. A. Weeldreyer: Rewritten for MR7.0.

   79-22-04 Al Kepner: to add scope checking.

   79-08-27  NSDavids:  Modified  to return a zero value error code if the the
   store was successful rather than just not changing the value of the code.

   79-12-01  Jim  Gray  : Modified to add call to mu_valid_data_type, and make
   changes  to  assign_  length parameter handling to make packed decimal data
   types available, also corrected signed scale problem

   80-02-01  Jim  Gray  :  Modified  to  put  allocations  in  a  non-freeing,
   extensible area managed by this routine.

   80-05-08 Davids: modified assignments of tuple_num_atts and tuple_nvar_atts
   to  take  values from rm_rel_info.model_num_attr and model_nvar_atts rather
   than  rm_rel_info.num_attr  and  nvar_atts.  This was to fix a problem with
   submodels were the submodel view did not contain a varying string attribute
   and the model did.

   80-12-10  Jim  Gray  :  modified  scope check to handle r-u to r-s-m-d type
   scope  modes  change, and new name of append_tuple for store.  Details of a
   store scope violation are now reported via sub_err_

   81-01-29 Jim Gray : removed references to mdbm_data_$current_version, using
   a constant instead, to allow future db version expansion.

   81-03-27 Jim Gray : changed dbi to dbcb_ptr parameter for mu_store, as part
   of getting rid of mus_ptr_man module.

   81-05-06   Rickie   E.   Brinegar:  modified  to  make  use  of  a  changed
   rm_domain_info structure.

   81-06-01 Jim Gray : modified to use new resultant structures.

   81-06-18  Roger  Lackey  : modified to use last_store_rel_name in dbdb.incl
   also to remove references to store_info.n36 n27 n18 and store_info.ht_len.

   81-06-19 Roger Lackey : Minor format cleanup for previous change.

   81-07-02  Jim  Gray  : added code to update the relation reference count in
   the new statistics section of rm_rel_info.

   81-07-07  Jim  Gray : added reset of the auto -another rel name in the dbcb
   to  the  clean up handler, so that errors do not cause the flag to get hung
   up.

   81-09-17  Rickie  E.   Brinegar: moved the seting of num_ptrs to a point in
   frong  of  the  first reference of arg_list.arg_ptrs to eliminate subscript
   range faults.

   81-10-30 Davids: Modified so that the internal procedure error is
   not  called  if the error returned by mu_store is dup_store. This
   allows the -another (either explicit or automatic  (by  specifing
   the  same  rel  name)) to be used after the dup_store error. this
   answers tr11808

   81-12-15 R. Lackey : Modify to search rm_rel_array for full name. TR11887.

   81-12-18 Davids: Modified so that rel_name if not  found  in  the
   list  of permanent relations will be considered a temp rel index.
   Scopes are not checked for temporary relations. This so that temp
   rels can be updateable.

   82-01-08 R. Lackey : Added check to detect relation names longer
   then 30 characters.

   82-08-19 Mike Kubicar : Removed all reference to the tuple structure;
   changed mrds_dsl_store to use a simple_typed_vector instead.

   83-01-18 Davids: Added transaction code

   83-01-24 Davids: modifed to set mstxn_txn_id = "0"b as the first thing, so that
   it is set incase an error occurs in argument processing or getting the 
   database index.
   
   83-03-35 Roger Lackey : Modified to check scope on all calls

   83-03-28 Roger Lackey : Changed place where move_list was allocated to be in
                           do  new store.

   83-03-30 Davids: Changes to improve preformance - replaced multiple
   references to "fixed (arg_list.code = SPECIAL)" with a reference to an
   automatic variable and reference the above code fragment 1 to set the
   variable (environment_pointer_offset). Also replaced references to the
   "/" infix operator with the divide builtin.

   83-03-31 Davids: More changes to improve performance - removed excess
   if-then-else nesting, removed extraneous setup of a cleanup condition
   handler, shortened test for a relation name over 30 characters by first
   testing the actual length of the relname and only if thats greater than
   30 then determining if the first space occurs within the limit, this
   replaced always doing a length (rtrim (relname)), shortened all the code
   that assignes the move_list.item_user_desc_ptr to just an assignment
   from the desc_ptr instead of lots of hairy ifs that checked to see if
   the descriptor was for a structure (at this point it never could be) or
   an array (again at this point point it couldn't be). Removed include files
   mdbm_rm_attr_info, mdbm_rm_domain_info and vu_typed_vector.

   83-04-04 Davids: Added view, and security level checking
   which used to be in mu_store. Added variables mdbm_error_$view_prevent,
   and inc_rel_acc. Note that ready_mode checking was not copied from 
   mu_store since ready_mode is no longer needed, if scopes are ok ready_mode
   will always be ok. Also it is not necessary to check the read permission
   access on the key attributes for security checking since you cannot create
   a submodel with append access on a relation unless all of its key attrs
   have read access so the check was redundant.

   83-04-05 Davids: Replaced the call to mu_store with calls to mu_build_tuple
   mu_cursor_manager_$get and dbcb.relmgr_entries.put_tuple (the calls that
   mu_store used to make). The call to mu_cursor_manager_$get is done only for
   a "new" store, the cursor_ptr is saved in the store_info structure. The
   variable unused_tuple_id was added since the call to put_tuple returns the
   tuple_id. The variable t_ptr was deleted since it was not needed and a
   check to be sure that the dbi_ptr was non-null was deleted since the
   argument list cannot have null argument pointers.

   83-04-06 Davids: modified the scope checking code to use the new
   scope_flags_ptr in the rm_rel_info structure instead of sequentially
   looking through the scope_info array. Deleted declaration to variable j
   which is no longer used. Moved the transaction start include file to right
   before the if statement that determines if this is a "new" store. This was
   needed becuase cursors for protected data files must be created in a
   transaction.

   83-04-07 Davids: Replaced the use of the val_args array with an array of just
   the argument pointers and an array of just the argument descriptors. For the
   case of a structure these new arrays are based on the val_args array. For
   the non-structure case they are based on the original argument list. This
   eliminated the allocation of the val_args array and the loop setting each
   element of the array from the argument list for the non-structure case. It
   also eliminates additions in the index calculation when the move_list is
   built. The new variables arg_val_ptr_array_ptr, arg_val_ptr_array,
   arg_desc_ptr_array_ptr, arg_desc_ptr_array were added. The variables doffset
   work_area are no longer used and were deleted.

   83-05-04 Davids: Modified so that mu_define_area is called with a name
   of MRDS || dbi_pic. This will allow closes to be faster since all
   temp_segments with the name MRDS || dbi_pic can be deleted/freed in 1 call.
   the variable dbi_pic was created as an easy way to convert from fixed bin
   to character.

   83-05-23 Mike Kubicar : relation manager calling sequence change

   83-06-20 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)

   84-05-21 Moberg:  Fixed check for long relation names which had an off by
   one error.
*/

	icode, num_dims = 0;
	dbcb_ptr, arg_ptr = null;
	mstxn_txn_id = "0"b;

	call cu_$arg_list_ptr (al_ptr);
	num_ptrs = arg_list.arg_count;
	if arg_list.arg_count < 8
	then signal arg_err;			/* must be at least four arguments */

/* get ptr to return code argument */
	n_args = divide (arg_list.arg_count, 2, 17, 0);
	c_ptr = arg_list.arg_des_ptr (n_args);
	code = 0;					/* in case things work make sure to return 0. */
	dbi_ptr = arg_list.arg_des_ptr (1);		/* get the index value to the
						   data base which is to be stored into */

/* translate it into a ptr to th database control block */
	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
	if dbcb_ptr = null then
	     call error (mrds_error_$invalid_db_index);

	rdbi_ptr = dbcb.rdbi_ptr;

	mstxn_transactions_needed = dbcb.transactions_needed;

	on cleanup begin;
		call mstxn_cleanup;
		call clean_up;
	     end;

	on any_other call mstxn_any_other;

	dbi_pic = dbcb.dbi;
	call
	     mu_define_area$define_temp_dir_area (dbcb.store_area_ptr, db_index, (sys_info$max_seg_size),
	     "MRDS" || dbi_pic, "0"b /* not extensible */,
	     "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, icode);
	if icode ^= 0 then
	     call error (icode);
	area_ptr = dbcb.store_area_ptr;

	rn_ptr = arg_list.arg_des_ptr (2);
	environment_pointer_offset = fixed (arg_list.code = SPECIAL);
	desc_ptr = arg_list.arg_des_ptr (2 + n_args + environment_pointer_offset);
	rn_len = fixed (string (descriptor.size));
	if rn_len > 30
	then do;
		first_space = index (rel_name, " ");
		if first_space = 0 | first_space > 31
		then call error (mrds_error_$rel_name_too_long);
	     end;

%include mrds_start_transaction;

	if mstxn_code ^= 0
	then call error (mstxn_code);

	dbcb.user_started_transaction = user_started_transaction;

	if rel_name = "-another" | dbcb.last_store_rel_name = rel_name then do;

		if dbcb.sti_ptr = null then
		     call error (mrds_error_$no_prev_store);
		sti_ptr = dbcb.sti_ptr;		/* pick up info from prev. store */
		rmri_ptr = store_info.ri_ptr;
		ml_ptr = store_info.ml_ptr;
	     end;
	else do;					/* if new store */

		dbcb.last_store_rel_name = "!!!!!!!... ...!!!!!"; /*  Temparory store bad rel name so it won't compare if this store fails */

		call free_store_info;
		allocate store_info in (dbcb.static_area); /* set up store information */
		dbcb.sti_ptr = sti_ptr;
		store_info.ml_ptr = null ();
		store_info.temp_rel = "0"b;		/* Until we find out */
		rmra_ptr = rm_db_info.ra_ptr;		/* find rel info */

		rel_name_32 = rel_name;		/* Get proper length for search */
		i = index (string (rm_rel_array.name), "!" || rel_name_32);

		if i = 0 then do;			/* if not found - could be temp rel index */
			rmra_ptr = rm_db_info.tra_ptr;
			i = cv_dec_check_ (rel_name, icode); /* if number it must be a temp rel */
			if icode ^= 0
			then call error (mrds_error_$unknown_relation_name);
			else
			     if i < 1 | i > mrds_data_$max_temp_rels /* must be a number within range */
			then call error (mrds_error_$undefined_temp_rel_index);
			else
			     if rm_rel_array.rel_data.ri_ptr (i) = null () /* must be a defined temp rel */
			then call error (mrds_error_$undefined_temp_rel_index);
			else do;
				rmri_ptr = rm_rel_array.rel_data.ri_ptr (i);
				store_info.temp_rel = "1"b;
			     end;
		     end;
		else do;
			i = divide ((i - 1), 33, 17, 0) + 1; /* convert from char to array index */
			rmri_ptr = rm_rel_array.rel_data.ri_ptr (i);
			store_info.temp_rel = "0"b;
		     end;

		call mu_cursor_manager_$get (dbcb.dbi, rmri_ptr, 0, /* tuple variable = 0 for stores */
		     rm_rel_info.rel_id, dbcb.relmgr_entries.create_cursor, /* so that retrieve-store-retrieve */
		     dbcb.relmgr_entries.open, dbcb.cursor_ptrs_storage_ptr, /* can be done without screwups */
		     dbcb.cursor_storage_area_ptr, store_info.cursor_ptr, icode);
		if icode ^= 0
		then call error (icode);

		if rm_rel_info.last_statistics_update_count ^= 0 & /* 0 => staticstics not ever set */
		     rm_rel_info.last_statistics_update_count
		     <= mrds_data_$statistics_update_count_interval then
		     rm_rel_info.last_statistics_update_count =
			rm_rel_info.last_statistics_update_count + 1;
						/* add to reference count for this rel */

		store_info.ri_ptr = rmri_ptr;
		store_info.num_atts = rm_rel_info.model_num_attr;
						/* allocate space for tuple */
		ml_nitems_init = rm_rel_info.num_attr;	/* allocate and set up move list */
		allocate move_list in (dbcb.static_area) set (store_info.ml_ptr);
		ml_ptr = store_info.ml_ptr;
		do i = 1 to move_list.nitems;
		     move_list.item.attr_index (i) = i;
		end;

	     end;					/* if new store */

	if ^store_info.temp_rel
	then do;
		if ^rm_rel_info.scope_flags_ptr -> scope_flags.permits.append_tuple
		then do;				/* if scope not set for append_tuple */
			call sub_err_ (mrds_error_$scope_viol, caller_name, continue, info_ptr, return_value,
			     "^/The relation ""^a"" needs a scope permission of ""append tuple"" in order to perform this operation",
			     rm_rel_info.name);
			call error (mrds_error_$scope_viol);
		     end;

		if ^rm_rel_info.store		/* verify submodel view valid for store */
		then call error (mrds_error_$view_prevent);

		if rm_rel_info.mdbm_secured		/* verify security access if necessary */
		then do;
			if ^rm_rel_info.append_tuple_perm /* check access to rel. */
			then call error (mrds_error_$inc_rel_acc);
		     end;

	     end;					/* check scope, view, security access */

	desc_ptr = arg_list.arg_des_ptr (n_args + environment_pointer_offset + 3);
	if descriptor.type = STRUCTURE_TYPE & n_args = 4 then do;
						/* if values in structure */
		data_ptr = arg_list.arg_des_ptr (3);	/* ptr to the third argument */
		descr_ptr = desc_ptr;		/* ptr to
						   the descriptor of the third argument */
		call
		     mu_break_structure (area_ptr, data_ptr, descr_ptr, arg_ptr,
		     val_arg_count, icode);		/* break_structure procedure implicitly sets arg_ptr by allocating
						   val_args in static_area */
		if icode ^= 0 then
		     call error (icode);

		arg_val_ptr_array_ptr = addr (val_args (1));
		arg_desc_ptr_array_ptr = addr (val_args (val_arg_count + 1));

		was_structure = "1"b;
	     end;

	else do;					/* third arg was not a structure */
		val_arg_count = n_args - 3;		/* this is the number of values passed
						   by the caller */

		arg_val_ptr_array_ptr = addr (arg_list.arg_des_ptr (3));
		arg_desc_ptr_array_ptr = addr (arg_list.arg_des_ptr (environment_pointer_offset + 3 + n_args));

		was_structure = "0"b;
	     end;

	if val_arg_count ^= rm_rel_info.num_attr
	then call error (error_table_$wrong_no_of_args);

	do i = 1 to val_arg_count;			/* build move_list */
	     desc_ptr = arg_desc_ptr_array (i);
	     if ^mu_valid_data_type$valid_scalar_data_type (desc_ptr -> descriptor_overlay)
	     then call error (mrds_error_$invalid_dm_descriptor);

	     move_list.item.user_ptr (i) = arg_val_ptr_array (i);
	     if ^was_structure then
		if descriptor.type = VAR_CHAR | descriptor.type = VAR_BIT then
		     move_list.item.user_ptr (i) =
			addrel (move_list.item.user_ptr (i), -1);
	     move_list.item.user_desc_ptr (i) = desc_ptr;
	end;

	call mu_build_tuple (rmri_ptr, area_ptr, dbcb.store_vector_ptr, ml_ptr, "0"b, icode); /* build the tuple */
	if icode ^= 0
	then call error (icode);

	call dbcb.relmgr_entries.put_tuple (store_info.cursor_ptr,
	     dbcb.store_vector_ptr, unused_tuple_id, icode);
	if icode = dm_error_$key_duplication then do;
		icode = mrds_error_$dup_store;	/* The error code everyone is expecting */
		mftxn_code = 0;
	     end;
	else mftxn_code = icode;

%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then call error (mftxn_code);

	if icode ^= 0 then do;
		if icode = mrds_error_$dup_store	/* do not call the clean up procedure */
		then code = icode;			/* in the event of a duplicate key error */
		else call error (icode);
	     end;

	dbcb.last_store_rel_name = rel_name;		/* Save the relation name for next call to store */

exit:
	if dbcb_ptr = null () then
	     ;
	else if dbcb.store_area_ptr ^= null () then
	     call mu_release_area (dbcb.store_area_ptr);
	return;


should_rollback: proc () returns (bit (1));

	return ("0"b);

/* There are no circumstances under which a rollback is desired here */

     end should_rollback;



restore_significant_data: proc;

	return;					/* no data need be restored before a retry */

     end restore_significant_data;
%page;
clean_up:
     proc;


	if dbcb_ptr ^= null then do;
		call free_store_info;
		dbcb.last_store_rel_name = "!!!!!!!!  !!!!!!!"; /* reset so errors don't
						   leave this in a state implying that
						   -another can automatically be forced */
	     end;

     end clean_up;


free_store_info:
     proc;

	if dbcb.sti_ptr ^= null then do;		/* clean out store info */
		sti_ptr = dbcb.sti_ptr;
		if store_info.ml_ptr ^= null then do;
			free store_info.ml_ptr -> move_list in (dbcb.static_area);
			store_info.ml_ptr = null ();
		     end;
		free store_info in (dbcb.static_area);
		dbcb.sti_ptr = null ();
	     end;

     end free_store_info;
%page;
error:
     proc (err_code);
	dcl     err_code		 fixed bin (35);
	code = err_code;
	call clean_up;
	go to exit;
     end error;
%page;
	dcl     mu_valid_data_type$valid_scalar_data_type entry (bit (36)) returns (bit (1) aligned);
	dcl     descriptor_overlay	 bit (36) unal based; /* overlay for descriptor */
	dcl     area_ptr		 ptr;
	dcl     mu_release_area	 entry (ptr);
	dcl     mu_define_area$define_temp_dir_area
				 entry (ptr, fixed bin (35), fixed bin (18), char (11), bit (1) aligned,
				 bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     sub_err_		 entry options (variable); /* reports errors */
	dcl     continue		 char (1) init ("c"); /* dont stop after printing mesg */
	dcl     caller_name		 char (32) init ("mrds_dsl_store"); /* name of calling routine */
	dcl     info_ptr		 ptr init (null ());/* unused */
	dcl     return_value	 fixed bin (35) init (0); /* unused */
	dcl     environment_pointer_offset fixed bin;	/* 1 if the argument list contains an environment pointer */
						/* 0 if the arg list doesn't contain the environment pointer */
	dcl     SPECIAL		 fixed bin static internal init (8) options (constant);
	dcl     STRUCTURE_TYPE	 fixed bin static internal init (17) options (constant);
						/* data type for a structure */
	dcl     VAR_BIT		 fixed bin (5) static internal init (20) options (constant);
	dcl     VAR_CHAR		 fixed bin (5) internal static init (22) options (constant);
	dcl     (
	        n_args,				/* number of arguments passed to store */
	        rn_len,				/* length of relation name parameter */
	        val_arg_count,			/* the number of values specified for this tuple */
	        i,
	        first_space				/* index of first space in relation name */
	        /* 0 implies no spaces */
	        )			 fixed bin;	/* index used within the store procedure */

	dcl     rel_name		 char (rn_len) based (rn_ptr); /* relation name passed by caller */
	dcl     rel_name_32		 char (32);	/* Rel_name 32 characters long used for searching */
	dcl     db_index		 fixed bin (35) based (dbi_ptr); /* database_index passed by caller */
	dcl     code		 fixed bin (35) based (c_ptr); /* code returned to caller */

	dcl     was_structure	 bit (1) unal;	/* on if user views as a structure */
	dcl     icode		 fixed bin (35);	/* internal error return code */
	dcl     val_args		 (2 * val_arg_count) ptr based (arg_ptr); /* an array of pointers to
						   user supplied values followed by pointers to
						   the descriptors for those values returned by mu_break_structure */
	dcl     arg_val_ptr_array	 (val_arg_count) ptr based (arg_val_ptr_array_ptr);
						/* array of pointers to user supplied argument values */
	dcl     arg_val_ptr_array_ptr	 ptr;
	dcl     arg_desc_ptr_array	 (val_arg_count) ptr based (arg_desc_ptr_array_ptr);
						/* array of pointers to the descriptors of the user supplied argument values */
	dcl     arg_desc_ptr_array_ptr ptr;

	dcl     unused_tuple_id	 bit (36) aligned;	/* tuple id of the tuple just stored - not used */
	dcl     (rn_ptr, c_ptr, dbi_ptr, data_ptr, descr_ptr, sti_ptr,
	        arg_ptr)		 ptr;

	dcl     (null, addr, addrel, string, divide, fixed) builtin;
	dcl     (index, rel)	 builtin;

	dcl     1 store_info	 aligned based (sti_ptr), /* static store information */
		2 ri_ptr		 ptr,
		2 ml_ptr		 ptr,
		2 num_atts	 fixed bin,
		2 nvar_atts	 fixed bin,
		2 cursor_ptr	 ptr,
		2 temp_rel	 bit (1);		/* On = storeing in to a temp rel */

%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_move_list;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_arg_list;
%page;
%include mdbm_scope_info;
%page;
/* dbm subroutines */

	dcl     mu_break_structure	 entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mu_build_tuple	 entry (ptr, ptr, ptr, ptr, bit (1) aligned, fixed bin (35));
	dcl     mu_cursor_manager_$get entry (fixed bin (35), ptr, fixed bin (35), bit (36) aligned, entry, entry, ptr,
				 ptr, ptr, fixed bin (35));

	dcl     error_table_$wrong_no_of_args fixed bin (35) ext;

	dcl     mrds_data_$max_temp_rels fixed bin (35) ext;

	dcl     dm_error_$key_duplication fixed bin (35) ext static;

	dcl     mrds_error_$dup_store	 fixed bin (35) external static;
	dcl     mrds_error_$invalid_db_index fixed bin (35) ext;
	dcl     mrds_error_$invalid_dm_descriptor fixed bin (35) ext;
	dcl     mrds_error_$no_prev_store fixed bin (35) ext;
	dcl     mrds_error_$rel_name_too_long fixed bin (35) ext;
	dcl     mrds_error_$scope_viol fixed bin (35) ext;
	dcl     mrds_error_$undefined_temp_rel_index fixed bin (35) ext;
	dcl     mrds_error_$unknown_relation_name fixed bin (35) ext;

	dcl     mrds_error_$view_prevent fixed bin (35) external static;
	dcl     mrds_error_$inc_rel_acc fixed bin (35) external static;

	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

/*    Multics subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));

	dcl     arg_err		 condition;
	dcl     cleanup		 condition;
	dcl     any_other		 condition;
	dcl     mrds_data_$statistics_update_count_interval fixed bin (35) ext;
	dcl     dbi_pic		 picture "999";

     end mrds_dsl_store;





		    mrds_dsl_tables.alm             08/01/88  1421.8rew 08/01/88  1300.0      772011



" ********************************************
" *                                          *
" * Copyright, (C) Honeywell Bull Inc., 1988 *
" *                                          *
" ********************************************

" HISTORY COMMENTS:
"  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
"     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
"     Generated from mrds_dsl.lalr for new parser.
"                                                      END HISTORY COMMENTS

"
" SCANNER AND PARSER TABLES FROM SEGMENT
"
"	>udd>auto>Hergert>mrds_dsl.grammar
"
"   Generated by: Hergert.AUTO.a using LALR LALR 7.3f of Tuesday, January 19, 1988
"   Generated at: Honeywell Bull, Phoenix AZ, SysM
"   Generated on: 06/27/88  1513.8 edt Mon
"   Generated from: >udd>auto>Hergert>mrds_dsl.lalr
"
	equ	strd,0
	equ	look,1
	equ	strds,2
	equ	looks,3
	equ	aply,4
	equ	aply1,5
	equ	aplys,6
	equ	nulls,7
	equ	final,8
	equ	nsrd,9
	equ	nsrds,10
	equ	aplyp,11
	equ	aplyp1,12
	equ	aplyps,13
	equ	lookd,14
	equ	nsrdd,15
	equ	lookc,16
	equ	nsrdc,17
	equ	aplyr,18
	equ	aplyr1,19
	equ	aplyrs,20
	equ	t0,0
	equ	st0,0
"
"
"	Terminals Hash List
"
	use	uthl
thl: terminals_hash_list:
	zero	,1021
	segdef	terminals_hash_list
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/54,12/1,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/20,12/0,12/0
	vfd	12/0,12/0,12/57
	vfd	12/0,12/0,12/26
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/44,12/0,12/0
	vfd	12/0,12/37,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/55,12/0,12/0
	vfd	12/0,12/0,12/71
	vfd	12/64,12/0,12/0
	vfd	12/68,12/3,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/52
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/49,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/41,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/62,12/0
	vfd	12/0,12/17,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/40,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/39,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/24,12/0
	vfd	12/0,12/53,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/15,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/9,12/12,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/27,12/0
	vfd	12/0,12/10,12/0
	vfd	12/0,12/0,12/0
	vfd	12/56,12/0,12/0
	vfd	12/0,12/70,12/28
	vfd	12/0,12/0,12/0
	vfd	12/0,12/66,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/2
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/74
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/59,12/0
	vfd	12/0,12/67,12/0
	vfd	12/0,12/0,12/46
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/18
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/4,12/0
	vfd	12/0,12/0,12/61
	vfd	12/0,12/0,12/0
	vfd	12/45,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/22,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/73,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/5,12/0,12/0
	vfd	12/0,12/65,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/43,12/0,12/0
	vfd	12/0,12/0,12/6
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/38,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/13,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/11,12/30
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/47,12/0,12/21
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/19,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/69,12/0,12/0
	vfd	12/0,12/0,12/29
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/58,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/25,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/7,12/0
	vfd	12/0,12/0,12/32
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/63,12/0,12/0
	vfd	12/60,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/51
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/42,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/23
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/34,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/36,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/50,12/0
	vfd	12/0,12/0,12/0
	vfd	12/8,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/35,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/48,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/14
	vfd	12/0,12/0,12/0
	vfd	12/31,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/0,12/0
	vfd	12/0,12/72,12/0
	vfd	12/0,12/0,12/0
"
"
"	Terminals List         
"
	use	utc
tc: terminal_characters:
	zero	0,4*terminal_characters_size
	segdef	terminal_characters
	use	utl
tl: terminals_list:
	zero	0,terminals_list_size
	segdef	terminals_list
"
"	Terminal 1
	use	utc
	set	tsl,*-tc-1
	aci	"&   "
	use	utl
	equ	t1,1
	zero	0,4*tsl+1
	zero	1,1
"
"	Terminal 2
	use	utc
	set	tsl,*-tc-1
	aci	"(   "
	use	utl
	equ	t2,2
	zero	0,4*tsl+1
	zero	1,2
"
"	Terminal 3
	use	utc
	set	tsl,*-tc-1
	aci	"(+) "
	use	utl
	equ	t3,3
	zero	0,4*tsl+1
	zero	3,3
"
"	Terminal 4
	use	utc
	set	tsl,*-tc-1
	aci	")   "
	use	utl
	equ	t4,4
	zero	0,4*tsl+1
	zero	1,4
"
"	Terminal 5
	use	utc
	set	tsl,*-tc-1
	aci	"*   "
	use	utl
	equ	t5,5
	zero	0,4*tsl+1
	zero	1,5
"
"	Terminal 6
	use	utc
	set	tsl,*-tc-1
	aci	"+   "
	use	utl
	equ	t6,6
	zero	0,4*tsl+1
	zero	1,6
"
"	Terminal 7
	use	utc
	set	tsl,*-tc-1
	aci	",   "
	use	utl
	equ	t7,7
	zero	0,4*tsl+1
	zero	1,7
"
"	Terminal 8
	use	utc
	set	tsl,*-tc-1
	aci	"-   "
	use	utl
	equ	t8,8
	zero	0,4*tsl+1
	zero	1,8
"
"	Terminal 9
	use	utc
	set	tsl,*-tc-1
	aci	"-all"
	aci	"_of "
	use	utl
	equ	t9,9
	zero	0,4*tsl+1
	zero	7,9
"
"	Terminal 10
	use	utc
	set	tsl,*-tc-1
	aci	"-any"
	aci	"_of "
	use	utl
	equ	t10,10
	zero	0,4*tsl+1
	zero	7,10
"
"	Terminal 11
	use	utc
	set	tsl,*-tc-1
	aci	"-asc"
	aci	"endi"
	aci	"ng  "
	use	utl
	equ	t11,11
	zero	0,4*tsl+1
	zero	10,11
"
"	Terminal 12
	use	utc
	set	tsl,*-tc-1
	aci	"-cur"
	aci	"rent"
	use	utl
	equ	t12,12
	zero	0,4*tsl+1
	zero	8,12
"
"	Terminal 13
	use	utc
	set	tsl,*-tc-1
	aci	"-des"
	aci	"cend"
	aci	"ing "
	use	utl
	equ	t13,13
	zero	0,4*tsl+1
	zero	11,13
"
"	Terminal 14
	use	utc
	set	tsl,*-tc-1
	aci	"-dif"
	aci	"fer "
	use	utl
	equ	t14,14
	zero	0,4*tsl+1
	zero	7,14
"
"	Terminal 15
	use	utc
	set	tsl,*-tc-1
	aci	"-dis"
	aci	"tinc"
	aci	"t   "
	use	utl
	equ	t15,15
	zero	0,4*tsl+1
	zero	9,15
"
"	Terminal 16
	use	utc
	set	tsl,*-tc-1
	aci	"-dup"
	use	utl
	equ	t16,16
	zero	0,4*tsl+1
	zero	4,16
"
"	Terminal 17
	use	utc
	set	tsl,*-tc-1
	aci	"-gro"
	aci	"up_b"
	aci	"y   "
	use	utl
	equ	t17,17
	zero	0,4*tsl+1
	zero	9,17
"
"	Terminal 18
	use	utc
	set	tsl,*-tc-1
	aci	"-hav"
	aci	"ing "
	use	utl
	equ	t18,18
	zero	0,4*tsl+1
	zero	7,18
"
"	Terminal 19
	use	utc
	set	tsl,*-tc-1
	aci	"-int"
	aci	"er  "
	use	utl
	equ	t19,19
	zero	0,4*tsl+1
	zero	6,19
"
"	Terminal 20
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"betw"
	aci	"een "
	use	utl
	equ	t20,20
	zero	0,4*tsl+1
	zero	11,20
"
"	Terminal 21
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"in  "
	use	utl
	equ	t21,21
	zero	0,4*tsl+1
	zero	6,21
"
"	Terminal 22
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"like"
	use	utl
	equ	t22,22
	zero	0,4*tsl+1
	zero	8,22
"
"	Terminal 23
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"not_"
	aci	"betw"
	aci	"een "
	use	utl
	equ	t23,23
	zero	0,4*tsl+1
	zero	15,23
"
"	Terminal 24
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"not_"
	aci	"in  "
	use	utl
	equ	t24,24
	zero	0,4*tsl+1
	zero	10,24
"
"	Terminal 25
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"not_"
	aci	"like"
	use	utl
	equ	t25,25
	zero	0,4*tsl+1
	zero	12,25
"
"	Terminal 26
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"not_"
	aci	"null"
	use	utl
	equ	t26,26
	zero	0,4*tsl+1
	zero	12,26
"
"	Terminal 27
	use	utc
	set	tsl,*-tc-1
	aci	"-is_"
	aci	"null"
	use	utl
	equ	t27,27
	zero	0,4*tsl+1
	zero	8,27
"
"	Terminal 28
	use	utc
	set	tsl,*-tc-1
	aci	"-no_"
	aci	"opti"
	aci	"mize"
	use	utl
	equ	t28,28
	zero	0,4*tsl+1
	zero	12,28
"
"	Terminal 29
	use	utc
	set	tsl,*-tc-1
	aci	"-no_"
	aci	"ot  "
	use	utl
	equ	t29,29
	zero	0,4*tsl+1
	zero	6,29
"
"	Terminal 30
	use	utc
	set	tsl,*-tc-1
	aci	"-ord"
	aci	"er_b"
	aci	"y   "
	use	utl
	equ	t30,30
	zero	0,4*tsl+1
	zero	9,30
"
"	Terminal 31
	use	utc
	set	tsl,*-tc-1
	aci	"-pri"
	aci	"nt_s"
	aci	"earc"
	aci	"h_or"
	aci	"der "
	use	utl
	equ	t31,31
	zero	0,4*tsl+1
	zero	19,31
"
"	Terminal 32
	use	utc
	set	tsl,*-tc-1
	aci	"-pso"
	use	utl
	equ	t32,32
	zero	0,4*tsl+1
	zero	4,32
"
"	Terminal 33
	use	utc
	set	tsl,*-tc-1
	aci	"-ran"
	aci	"ge  "
	use	utl
	equ	t33,33
	zero	0,4*tsl+1
	zero	6,33
"
"	Terminal 34
	use	utc
	set	tsl,*-tc-1
	aci	"-sel"
	aci	"ect "
	use	utl
	equ	t34,34
	zero	0,4*tsl+1
	zero	7,34
"
"	Terminal 35
	use	utc
	set	tsl,*-tc-1
	aci	"-uni"
	aci	"on  "
	use	utl
	equ	t35,35
	zero	0,4*tsl+1
	zero	6,35
"
"	Terminal 36
	use	utc
	set	tsl,*-tc-1
	aci	"-whe"
	aci	"re  "
	use	utl
	equ	t36,36
	zero	0,4*tsl+1
	zero	6,36
"
"	Terminal 37
	use	utc
	set	tsl,*-tc-1
	aci	".   "
	use	utl
	equ	t37,37
	zero	0,4*tsl+1
	zero	1,37
"
"	Terminal 38
	use	utc
	set	tsl,*-tc-1
	aci	".V. "
	use	utl
	equ	t38,38
	zero	0,4*tsl+1
	zero	3,38
"
"	Terminal 39
	use	utc
	set	tsl,*-tc-1
	aci	".X. "
	use	utl
	equ	t39,39
	zero	0,4*tsl+1
	zero	3,39
"
"	Terminal 40
	use	utc
	set	tsl,*-tc-1
	aci	"/   "
	use	utl
	equ	t40,40
	zero	0,4*tsl+1
	zero	1,40
"
"	Terminal 41
	use	utc
	set	tsl,*-tc-1
	aci	"::  "
	use	utl
	equ	t41,41
	zero	0,4*tsl+1
	zero	2,41
"
"	Terminal 42
	use	utc
	set	tsl,*-tc-1
	aci	"<   "
	use	utl
	equ	t42,42
	zero	0,4*tsl+1
	zero	1,42
"
"	Terminal 43
	use	utc
	set	tsl,*-tc-1
	aci	"<=  "
	use	utl
	equ	t43,43
	zero	0,4*tsl+1
	zero	2,43
"
"	Terminal 44
	use	utc
	set	tsl,*-tc-1
	aci	"<bit"
	aci	"_str"
	aci	"ing>"
	use	utl
	equ	t44,44
	zero	0,4*tsl+1
	zero	12,44
"
"	Terminal 45
	use	utc
	set	tsl,*-tc-1
	aci	"<int"
	aci	"eger"
	aci	">   "
	use	utl
	equ	t45,45
	zero	0,4*tsl+1
	zero	9,45
"
"	Terminal 46
	use	utc
	set	tsl,*-tc-1
	aci	"<str"
	aci	"ing>"
	use	utl
	equ	t46,46
	zero	0,4*tsl+1
	zero	8,46
"
"	Terminal 47
	use	utc
	set	tsl,*-tc-1
	aci	"<sym"
	aci	"bol>"
	use	utl
	equ	t47,47
	zero	0,4*tsl+1
	zero	8,47
"
"	Terminal 48
	use	utc
	set	tsl,*-tc-1
	aci	"=   "
	use	utl
	equ	t48,48
	zero	0,4*tsl+1
	zero	1,48
"
"	Terminal 49
	use	utc
	set	tsl,*-tc-1
	aci	">   "
	use	utl
	equ	t49,49
	zero	0,4*tsl+1
	zero	1,49
"
"	Terminal 50
	use	utc
	set	tsl,*-tc-1
	aci	">=  "
	use	utl
	equ	t50,50
	zero	0,4*tsl+1
	zero	2,50
"
"	Terminal 51
	use	utc
	set	tsl,*-tc-1
	aci	"[   "
	use	utl
	equ	t51,51
	zero	0,4*tsl+1
	zero	1,51
"
"	Terminal 52
	use	utc
	set	tsl,*-tc-1
	aci	"]   "
	use	utl
	equ	t52,52
	zero	0,4*tsl+1
	zero	1,52
"
"	Terminal 53
	use	utc
	set	tsl,*-tc-1
	aci	"^   "
	use	utl
	equ	t53,53
	zero	0,4*tsl+1
	zero	1,53
"
"	Terminal 54
	use	utc
	set	tsl,*-tc-1
	aci	"^=  "
	use	utl
	equ	t54,54
	zero	0,4*tsl+1
	zero	2,54
"
"	Terminal 55
	use	utc
	set	tsl,*-tc-1
	aci	"|   "
	use	utl
	equ	t55,55
	zero	0,4*tsl+1
	zero	1,55
"
"	Terminal 56
	use	utc
	set	tsl,*-tc-1
	aci	"||  "
	use	utl
	equ	t56,56
	zero	0,4*tsl+1
	zero	2,56
"
"	Terminal 57
	use	utc
	set	tsl,*-tc-1
	aci	"=<  "
	use	utl
	zero	0,4*tsl+1
	zero	2,43
"
"	Terminal 58
	use	utc
	set	tsl,*-tc-1
	aci	"^>  "
	use	utl
	zero	16,4*tsl+1
	zero	2,43
"
"	Terminal 59
	use	utc
	set	tsl,*-tc-1
	aci	"^<> "
	use	utl
	zero	0,4*tsl+1
	zero	3,48
"
"	Terminal 60
	use	utc
	set	tsl,*-tc-1
	aci	"^>< "
	use	utl
	zero	0,4*tsl+1
	zero	3,48
"
"	Terminal 61
	use	utc
	set	tsl,*-tc-1
	aci	"<>  "
	use	utl
	zero	0,4*tsl+1
	zero	2,54
"
"	Terminal 62
	use	utc
	set	tsl,*-tc-1
	aci	"><  "
	use	utl
	zero	0,4*tsl+1
	zero	2,54
"
"	Terminal 63
	use	utc
	set	tsl,*-tc-1
	aci	"^<= "
	use	utl
	zero	0,4*tsl+1
	zero	3,49
"
"	Terminal 64
	use	utc
	set	tsl,*-tc-1
	aci	"^=< "
	use	utl
	zero	0,4*tsl+1
	zero	3,49
"
"	Terminal 65
	use	utc
	set	tsl,*-tc-1
	aci	"=>  "
	use	utl
	zero	0,4*tsl+1
	zero	2,50
"
"	Terminal 66
	use	utc
	set	tsl,*-tc-1
	aci	"^<  "
	use	utl
	zero	0,4*tsl+1
	zero	2,50
"
"	Terminal 67
	use	utc
	set	tsl,*-tc-1
	aci	"^>= "
	use	utl
	zero	0,4*tsl+1
	zero	3,42
"
"	Terminal 68
	use	utc
	set	tsl,*-tc-1
	aci	"^=> "
	use	utl
	zero	0,4*tsl+1
	zero	3,42
"
"	Terminal 69
	use	utc
	set	tsl,*-tc-1
	aci	".v. "
	use	utl
	zero	0,4*tsl+1
	zero	3,38
"
"	Terminal 70
	use	utc
	set	tsl,*-tc-1
	aci	".x. "
	use	utl
	zero	0,4*tsl+1
	zero	3,39
"
"	Terminal 71
	use	utc
	set	tsl,*-tc-1
	aci	"-fro"
	aci	"m   "
	use	utl
	zero	0,4*tsl+1
	zero	5,33
"
"	Terminal 72
	use	utc
	set	tsl,*-tc-1
	aci	"-and"
	use	utl
	zero	0,4*tsl+1
	zero	4,1
"
"	Terminal 73
	use	utc
	set	tsl,*-tc-1
	aci	"-or "
	use	utl
	zero	33,4*tsl+1
	zero	3,55
"
"	Terminal 74
	use	utc
	set	tsl,*-tc-1
	aci	"-not"
	use	utl
	zero	0,4*tsl+1
	zero	4,53
"
	use	utc
	equ	terminal_characters_size,*-tc-1
	use	utl
	equ	terminals_list_size,*-tl-1

	use	text
"
"
"	DPDA Table
dpda:	zero	0,dpda_size
	segdef	dpda
"
" State 1
	equ	st1,*-dpda
	zero	strd,ln1
	zero	t2,st55	"(
	zero	t12,st60	"-current
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	equ	ln1,*-dpda-st1-1
"
" State 6
	equ	st6,*-dpda
	zero	strd,ln6
	zero	t2,st110	"(
	zero	t5,st124	"*
	zero	t47,st131	"<symbol>
	equ	ln6,*-dpda-st6-1
"
" State 10
	equ	st10,*-dpda
	zero	strd,ln10
	zero	t33,st63	"-range
	equ	ln10,*-dpda-st10-1
"
" State 12
	equ	st12,*-dpda
	zero	strd,ln12
	zero	t34,st67	"-select
	equ	ln12,*-dpda-st12-1
"
" State 14
	equ	st14,*-dpda
	zero	nsrd,ln14
	zero	t0,-st1484	"EOI
	zero	t4,-st1484	")
	zero	t14,-st1484	"-differ
	zero	t17,-st1481	"-group_by
	zero	t19,-st1484	"-inter
	zero	t30,-st1484	"-order_by
	zero	t35,-st1484	"-union
	zero	t36,-st1481	"-where
	equ	ln14,*-dpda-st14-1
"
" State 23
	equ	st23,*-dpda
	zero	aplyp,ln23
	zero	0,0   sd/RFU
	zero	12,st30	prod/val
	zero	st59,st37
	equ	ln23,*-dpda-st23-1
"
" State 27
	equ	st27,*-dpda
	zero	aplyps,ln27
	zero	2,2   sd/RFU
	zero	13,st23	prod/val
	equ	ln27,*-dpda-st27-1
"
" State 30
	equ	st30,*-dpda
	zero	aplyp,ln30
	zero	0,0   sd/RFU
	zero	7,st1040	prod/val
	zero	st1,st40
	zero	st55,st193
	zero	st745,st1320
	zero	st1385,st193
	equ	ln30,*-dpda-st30-1
"
" State 37
	equ	st37,*-dpda
	zero	aplyps,ln37
	zero	2,2   sd/RFU
	zero	8,st30	prod/val
	equ	ln37,*-dpda-st37-1
"
" State 40
	equ	st40,*-dpda
	zero	nsrd,ln40
	zero	t0,-st1492	"EOI
	zero	t14,-st1487	"-differ
	zero	t19,-st1487	"-inter
	zero	t30,-st1487	"-order_by
	zero	t35,-st1487	"-union
	equ	ln40,*-dpda-st40-1
"
" State 46
	equ	st46,*-dpda
	zero	nsrd,ln46
	zero	t0,-st1500	"EOI
	zero	t2,-st1495	"(
	zero	t47,-st1495	"<symbol>
	equ	ln46,*-dpda-st46-1
"
" State 50
	equ	st50,*-dpda
	zero	aplyp1,ln50
	zero	0,0   sd/RFU
	zero	1,st53	prod/val
	equ	ln50,*-dpda-st50-1
"
" State 53
	equ	st53,*-dpda
	zero	strd,ln53
	zero	t0,st0	"EOI
	equ	ln53,*-dpda-st53-1
"
" State 55
	equ	st55,*-dpda
	zero	strd,ln55
	zero	t2,st55	"(
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	equ	ln55,*-dpda-st55-1
"
" State 59
	equ	st59,*-dpda
	zero	strds,st55

"
" State 60
	equ	st60,*-dpda
	zero	aplyp1,ln60
	zero	0,0   sd/RFU
	zero	6,st46	prod/val
	equ	ln60,*-dpda-st60-1
"
" State 63
	equ	st63,*-dpda
	zero	strd,ln63
	zero	t2,st268	"(
	zero	t38,st271	".V.
	zero	t47,st290	"<symbol>
	equ	ln63,*-dpda-st63-1
"
" State 67
	equ	st67,*-dpda
	zero	nsrd,ln67
	zero	t2,-st1506	"(
	zero	t5,-st1506	"*
	zero	t15,-st1503	"-distinct
	zero	t16,-st1503	"-dup
	zero	t47,-st1506	"<symbol>
	equ	ln67,*-dpda-st67-1
"
" State 73
	equ	st73,*-dpda
	zero	aplyp1,ln73
	zero	0,0   sd/RFU
	zero	53,st78	prod/val
	equ	ln73,*-dpda-st73-1
"
" State 76
	equ	st76,*-dpda
	zero	strd,ln76
	zero	t37,st310	".
	equ	ln76,*-dpda-st76-1
"
" State 78
	equ	st78,*-dpda
	zero	nsrd,ln78
	zero	t0,-st830	"EOI
	zero	t2,-st830	"(
	zero	t4,-st830	")
	zero	t14,-st830	"-differ
	zero	t17,-st830	"-group_by
	zero	t19,-st830	"-inter
	zero	t30,-st830	"-order_by
	zero	t33,-st830	"-range
	zero	t35,-st830	"-union
	zero	t36,-st830	"-where
	zero	t41,-st1509	"::
	zero	t47,-st830	"<symbol>
	equ	ln78,*-dpda-st78-1
"
" State 91
	equ	st91,*-dpda
	zero	aplyp,ln91
	zero	0,0   sd/RFU
	zero	49,st98	prod/val
	zero	st1495,st189
	equ	ln91,*-dpda-st91-1
"
" State 95
	equ	st95,*-dpda
	zero	aplyps,ln95
	zero	1,1   sd/RFU
	zero	50,st91	prod/val
	equ	ln95,*-dpda-st95-1
"
" State 98
	equ	st98,*-dpda
	zero	nsrd,ln98
	zero	t0,-st128	"EOI
	zero	t2,-st1498	"(
	zero	t4,-st128	")
	zero	t14,-st128	"-differ
	zero	t17,-st128	"-group_by
	zero	t19,-st128	"-inter
	zero	t30,-st128	"-order_by
	zero	t33,-st128	"-range
	zero	t35,-st128	"-union
	zero	t36,-st128	"-where
	zero	t47,-st1498	"<symbol>
	equ	ln98,*-dpda-st98-1
"
" State 110
	equ	st110,*-dpda
	zero	strd,ln110
	zero	t2,st120	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln110,*-dpda-st110-1
"
" State 118
	equ	st118,*-dpda
	zero	strds,st110

"
" State 119
	equ	st119,*-dpda
	zero	strds,st110

"
" State 120
	equ	st120,*-dpda
	zero	strds,st110

"
" State 121
	equ	st121,*-dpda
	zero	strds,st110

"
" State 122
	equ	st122,*-dpda
	zero	strds,st110

"
" State 123
	equ	st123,*-dpda
	zero	strds,st110

"
" State 124
	equ	st124,*-dpda
	zero	aplyp,ln124
	zero	1,1   sd/RFU
	zero	44,st10	prod/val
	zero	st12,st148
	equ	ln124,*-dpda-st124-1
"
" State 128
	equ	st128,*-dpda
	zero	aplyps,ln128
	zero	1,1   sd/RFU
	zero	45,st124	prod/val
	equ	ln128,*-dpda-st128-1
"
" State 131
	equ	st131,*-dpda
	zero	nsrd,ln131
	zero	t0,-st814	"EOI
	zero	t2,-st814	"(
	zero	t4,-st814	")
	zero	t14,-st814	"-differ
	zero	t17,-st814	"-group_by
	zero	t19,-st814	"-inter
	zero	t30,-st814	"-order_by
	zero	t33,-st814	"-range
	zero	t35,-st814	"-union
	zero	t36,-st814	"-where
	zero	t37,-st1110	".
	zero	t41,-st814	"::
	zero	t47,-st814	"<symbol>
	equ	ln131,*-dpda-st131-1
"
" State 145
	equ	st145,*-dpda
	zero	aplyp1,ln145
	zero	1,1   sd/RFU
	zero	17,st14	prod/val
	equ	ln145,*-dpda-st145-1
"
" State 148
	equ	st148,*-dpda
	zero	aplyp1,ln148
	zero	1,1   sd/RFU
	zero	16,st14	prod/val
	equ	ln148,*-dpda-st148-1
"
" State 151
	equ	st151,*-dpda
	zero	nsrd,ln151
	zero	t0,-st1513	"EOI
	zero	t4,-st1513	")
	zero	t14,-st1513	"-differ
	zero	t17,-st1511	"-group_by
	zero	t19,-st1513	"-inter
	zero	t30,-st1513	"-order_by
	zero	t35,-st1513	"-union
	equ	ln151,*-dpda-st151-1
"
" State 159
	equ	st159,*-dpda
	zero	aplyp1,ln159
	zero	0,0   sd/RFU
	zero	19,st162	prod/val
	equ	ln159,*-dpda-st159-1
"
" State 162
	equ	st162,*-dpda
	zero	aplyp1,ln162
	zero	1,1   sd/RFU
	zero	15,st23	prod/val
	equ	ln162,*-dpda-st162-1
"
" State 165
	equ	st165,*-dpda
	zero	strd,ln165
	zero	t2,st731	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	zero	t51,st756	"[
	zero	t53,st764	"^
	equ	ln165,*-dpda-st165-1
"
" State 177
	equ	st177,*-dpda
	zero	strds,st165

"
" State 178
	equ	st178,*-dpda
	zero	strds,st165

"
" State 179
	equ	st179,*-dpda
	zero	strds,st165

"
" State 180
	equ	st180,*-dpda
	zero	aplyp1,ln180
	zero	0,0   sd/RFU
	zero	11,st59	prod/val
	equ	ln180,*-dpda-st180-1
"
" State 183
	equ	st183,*-dpda
	zero	aplyp1,ln183
	zero	0,0   sd/RFU
	zero	10,st59	prod/val
	equ	ln183,*-dpda-st183-1
"
" State 186
	equ	st186,*-dpda
	zero	aplyp1,ln186
	zero	0,0   sd/RFU
	zero	9,st59	prod/val
	equ	ln186,*-dpda-st186-1
"
" State 189
	equ	st189,*-dpda
	zero	nsrd,ln189
	zero	t0,-st1516	"EOI
	zero	t2,-st1499	"(
	zero	t47,-st1499	"<symbol>
	equ	ln189,*-dpda-st189-1
"
" State 193
	equ	st193,*-dpda
	zero	strd,ln193
	zero	t4,st27	")
	zero	t14,st180	"-differ
	zero	t19,st183	"-inter
	zero	t35,st186	"-union
	equ	ln193,*-dpda-st193-1
"
" State 198
	equ	st198,*-dpda
	zero	strds,st193

"
" State 199
	equ	st199,*-dpda
	zero	aplyp,ln199
	zero	0,0   sd/RFU
	zero	41,st211	prod/val
	zero	st799,st1127
	equ	ln199,*-dpda-st199-1
"
" State 203
	equ	st203,*-dpda
	zero	aplyps,ln203
	zero	0,0   sd/RFU
	zero	42,st199	prod/val
	equ	ln203,*-dpda-st203-1
"
" State 206
	equ	st206,*-dpda
	zero	aplyps,ln206
	zero	2,2   sd/RFU
	zero	43,st199	prod/val
	equ	ln206,*-dpda-st206-1
"
" State 209
	equ	st209,*-dpda
	zero	strd,ln209
	zero	t37,st777	".
	equ	ln209,*-dpda-st209-1
"
" State 211
	equ	st211,*-dpda
	zero	nsrd,ln211
	zero	t0,-st1519	"EOI
	zero	t3,-st1519	"(+)
	zero	t4,-st1519	")
	zero	t7,-st1519	",
	zero	t14,-st1519	"-differ
	zero	t17,-st1519	"-group_by
	zero	t19,-st1519	"-inter
	zero	t30,-st1519	"-order_by
	zero	t34,-st1519	"-select
	zero	t35,-st1519	"-union
	zero	t36,-st1519	"-where
	zero	t47,-st270	"<symbol>
	equ	ln211,*-dpda-st211-1
"
" State 224
	equ	st224,*-dpda
	zero	aplyp1,ln224
	zero	0,0   sd/RFU
	zero	38,st227	prod/val
	equ	ln224,*-dpda-st224-1
"
" State 227
	equ	st227,*-dpda
	zero	nsrd,ln227
	zero	t0,-st1524	"EOI
	zero	t2,-st1522	"(
	zero	t4,-st1524	")
	zero	t14,-st1524	"-differ
	zero	t17,-st1524	"-group_by
	zero	t19,-st1524	"-inter
	zero	t30,-st1524	"-order_by
	zero	t34,-st1524	"-select
	zero	t35,-st1524	"-union
	zero	t36,-st1524	"-where
	equ	ln227,*-dpda-st227-1
"
" State 238
	equ	st238,*-dpda
	zero	nsrd,ln238
	zero	t0,-st793	"EOI
	zero	t3,-st1527	"(+)
	zero	t4,-st793	")
	zero	t7,-st793	",
	zero	t14,-st793	"-differ
	zero	t17,-st793	"-group_by
	zero	t19,-st793	"-inter
	zero	t30,-st793	"-order_by
	zero	t34,-st793	"-select
	zero	t35,-st793	"-union
	zero	t36,-st793	"-where
	equ	ln238,*-dpda-st238-1
"
" State 250
	equ	st250,*-dpda
	zero	aplyp1,ln250
	zero	0,0   sd/RFU
	zero	32,st253	prod/val
	equ	ln250,*-dpda-st250-1
"
" State 253
	equ	st253,*-dpda
	zero	nsrd,ln253
	zero	t0,-st1531	"EOI
	zero	t4,-st1531	")
	zero	t7,-st1529	",
	zero	t14,-st1531	"-differ
	zero	t17,-st1531	"-group_by
	zero	t19,-st1531	"-inter
	zero	t30,-st1531	"-order_by
	zero	t34,-st1531	"-select
	zero	t35,-st1531	"-union
	zero	t36,-st1531	"-where
	equ	ln253,*-dpda-st253-1
"
" State 264
	equ	st264,*-dpda
	zero	aplyp,ln264
	zero	1,1   sd/RFU
	zero	29,st12	prod/val
	zero	st10,st145
	equ	ln264,*-dpda-st264-1
"
" State 268
	equ	st268,*-dpda
	zero	strd,ln268
	zero	t47,st782	"<symbol>
	equ	ln268,*-dpda-st268-1
"
" State 270
	equ	st270,*-dpda
	zero	strds,st268

"
" State 271
	equ	st271,*-dpda
	zero	aplyp,ln271
	zero	0,0   sd/RFU
	zero	162,st529	prod/val
	zero	st63,st203
	zero	st731,st980
	zero	st745,st980
	zero	st756,st1049
	zero	st763,st1049
	zero	st796,st203
	zero	st799,st203
	zero	st1088,st1049
	zero	st1095,st1049
	zero	st1096,st1049
	zero	st1282,st980
	zero	st1294,st1379
	zero	st1313,st1379
	zero	st1319,st1379
	zero	st1325,st1406
	zero	st1425,st1406
	equ	ln271,*-dpda-st271-1
"
" State 290
	equ	st290,*-dpda
	zero	nsrd,ln290
	zero	t0,-st1110	"EOI
	zero	t3,-st1110	"(+)
	zero	t4,-st1110	")
	zero	t7,-st1110	",
	zero	t14,-st1110	"-differ
	zero	t17,-st1110	"-group_by
	zero	t19,-st1110	"-inter
	zero	t30,-st1110	"-order_by
	zero	t34,-st1110	"-select
	zero	t35,-st1110	"-union
	zero	t36,-st1110	"-where
	zero	t37,-st1534	".
	zero	t47,-st1110	"<symbol>
	equ	ln290,*-dpda-st290-1
"
" State 304
	equ	st304,*-dpda
	zero	aplyp1,ln304
	zero	1,1   sd/RFU
	zero	47,st6	prod/val
	equ	ln304,*-dpda-st304-1
"
" State 307
	equ	st307,*-dpda
	zero	aplyp1,ln307
	zero	1,1   sd/RFU
	zero	48,st6	prod/val
	equ	ln307,*-dpda-st307-1
"
" State 310
	equ	st310,*-dpda
	zero	strd,ln310
	zero	t47,st814	"<symbol>
	equ	ln310,*-dpda-st310-1
"
" State 312
	equ	st312,*-dpda
	zero	strd,ln312
	zero	t47,st833	"<symbol>
	equ	ln312,*-dpda-st312-1
"
" State 314
	equ	st314,*-dpda
	zero	strd,ln314
	zero	t2,st836	"(
	equ	ln314,*-dpda-st314-1
"
" State 316
	equ	st316,*-dpda
	zero	aplyp,ln316
	zero	0,0   sd/RFU
	zero	142,st537	prod/val
	zero	st110,st355
	zero	st118,st355
	zero	st119,st355
	zero	st120,st355
	zero	st121,st355
	zero	st122,st355
	zero	st123,st355
	zero	st165,st565
	zero	st177,st565
	zero	st178,st565
	zero	st179,st565
	zero	st343,st355
	zero	st349,st355
	zero	st546,st565
	zero	st731,st565
	zero	st745,st565
	equ	ln316,*-dpda-st316-1
"
" State 335
	equ	st335,*-dpda
	zero	aplyps,ln335
	zero	2,2   sd/RFU
	zero	143,st316	prod/val
	equ	ln335,*-dpda-st335-1
"
" State 338
	equ	st338,*-dpda
	zero	aplyps,ln338
	zero	4,4   sd/RFU
	zero	144,st316	prod/val
	equ	ln338,*-dpda-st338-1
"
" State 341
	equ	st341,*-dpda
	zero	strd,ln341
	zero	t37,st851	".
	equ	ln341,*-dpda-st341-1
"
" State 343
	equ	st343,*-dpda
	zero	strd,ln343
	zero	t2,st120	"(
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln343,*-dpda-st343-1
"
" State 349
	equ	st349,*-dpda
	zero	strds,st343

"
" State 350
	equ	st350,*-dpda
	zero	aplyp,ln350
	zero	0,0   sd/RFU
	zero	112,st364	prod/val
	zero	st343,st368
	zero	st349,st371
	equ	ln350,*-dpda-st350-1
"
" State 355
	equ	st355,*-dpda
	zero	aplyps,ln355
	zero	0,0   sd/RFU
	zero	109,st350	prod/val
	equ	ln355,*-dpda-st355-1
"
" State 358
	equ	st358,*-dpda
	zero	aplyps,ln358
	zero	0,0   sd/RFU
	zero	110,st350	prod/val
	equ	ln358,*-dpda-st358-1
"
" State 361
	equ	st361,*-dpda
	zero	aplyps,ln361
	zero	2,2   sd/RFU
	zero	111,st350	prod/val
	equ	ln361,*-dpda-st361-1
"
" State 364
	equ	st364,*-dpda
	zero	aplyp,ln364
	zero	0,0   sd/RFU
	zero	106,st374	prod/val
	zero	st121,st1142
	equ	ln364,*-dpda-st364-1
"
" State 368
	equ	st368,*-dpda
	zero	aplyps,ln368
	zero	1,1   sd/RFU
	zero	108,st364	prod/val
	equ	ln368,*-dpda-st368-1
"
" State 371
	equ	st371,*-dpda
	zero	aplyps,ln371
	zero	2,2   sd/RFU
	zero	107,st364	prod/val
	equ	ln371,*-dpda-st371-1
"
" State 374
	equ	st374,*-dpda
	zero	nsrd,ln374
	zero	t0,-st1543	"EOI
	zero	t4,-st1543	")
	zero	t5,-st1543	"*
	zero	t6,-st1543	"+
	zero	t7,-st1543	",
	zero	t8,-st1543	"-
	zero	t11,-st1543	"-ascending
	zero	t13,-st1543	"-descending
	zero	t14,-st1543	"-differ
	zero	t18,-st1543	"-having
	zero	t19,-st1543	"-inter
	zero	t30,-st1543	"-order_by
	zero	t35,-st1543	"-union
	zero	t40,-st1543	"/
	zero	t56,-st1540	"||
	equ	ln374,*-dpda-st374-1
"
" State 390
	equ	st390,*-dpda
	zero	nsrd,ln390
	zero	t0,-st1556	"EOI
	zero	t4,-st1556	")
	zero	t5,-st1550	"*
	zero	t6,-st1556	"+
	zero	t7,-st1556	",
	zero	t8,-st1556	"-
	zero	t11,-st1556	"-ascending
	zero	t13,-st1556	"-descending
	zero	t14,-st1556	"-differ
	zero	t18,-st1556	"-having
	zero	t19,-st1556	"-inter
	zero	t30,-st1556	"-order_by
	zero	t35,-st1556	"-union
	zero	t40,-st1550	"/
	equ	ln390,*-dpda-st390-1
"
" State 405
	equ	st405,*-dpda
	zero	strd,ln405
	zero	t4,st862	")
	zero	t6,st409	"+
	zero	t8,st434	"-
	equ	ln405,*-dpda-st405-1
"
" State 409
	equ	st409,*-dpda
	zero	aplyp,ln409
	zero	0,0   sd/RFU
	zero	155,st557	prod/val
	zero	st110,st343
	zero	st118,st343
	zero	st119,st343
	zero	st120,st343
	zero	st121,st343
	zero	st122,st343
	zero	st123,st343
	zero	st405,st122
	zero	st876,st122
	zero	st1071,st1339
	zero	st1184,st847
	zero	st1239,st847
	zero	st1614,st122
	zero	st1661,st847
	zero	st1683,st122
	zero	st1688,st122
	zero	st1722,st847
	zero	st1732,st847
	zero	st1735,st847
	zero	st1736,st847
	zero	st1737,st847
	zero	st1738,st847
	equ	ln409,*-dpda-st409-1
"
" State 434
	equ	st434,*-dpda
	zero	aplyps,ln434
	zero	0,0   sd/RFU
	zero	156,st409	prod/val
	equ	ln434,*-dpda-st434-1
"
" State 437
	equ	st437,*-dpda
	zero	aplyp,ln437
	zero	0,0   sd/RFU
	zero	152,st534	prod/val
	zero	st110,st350
	zero	st118,st350
	zero	st119,st350
	zero	st120,st350
	zero	st121,st350
	zero	st122,st350
	zero	st123,st350
	zero	st343,st350
	zero	st349,st350
	zero	st731,st998
	zero	st745,st998
	zero	st756,st1053
	zero	st763,st1053
	zero	st1088,st1053
	zero	st1095,st1053
	zero	st1096,st1053
	zero	st1282,st998
	zero	st1294,st1382
	zero	st1313,st1382
	zero	st1319,st1382
	zero	st1325,st1410
	zero	st1425,st1410
	equ	ln437,*-dpda-st437-1
"
" State 462
	equ	st462,*-dpda
	zero	aplyps,ln462
	zero	0,0   sd/RFU
	zero	151,st437	prod/val
	equ	ln462,*-dpda-st462-1
"
" State 465
	equ	st465,*-dpda
	zero	aplyps,ln465
	zero	0,0   sd/RFU
	zero	150,st437	prod/val
	equ	ln465,*-dpda-st465-1
"
" State 468
	equ	st468,*-dpda
	zero	nsrd,ln468
	zero	t0,-st814	"EOI
	zero	t1,-st814	"&
	zero	t2,-st1568	"(
	zero	t4,-st814	")
	zero	t5,-st814	"*
	zero	t6,-st814	"+
	zero	t7,-st814	",
	zero	t8,-st814	"-
	zero	t11,-st814	"-ascending
	zero	t13,-st814	"-descending
	zero	t14,-st814	"-differ
	zero	t17,-st814	"-group_by
	zero	t18,-st814	"-having
	zero	t19,-st814	"-inter
	zero	t20,-st814	"-is_between
	zero	t21,-st814	"-is_in
	zero	t22,-st814	"-is_like
	zero	t23,-st814	"-is_not_between
	zero	t24,-st814	"-is_not_in
	zero	t25,-st814	"-is_not_like
	zero	t26,-st814	"-is_not_null
	zero	t27,-st814	"-is_null
	zero	t30,-st814	"-order_by
	zero	t35,-st814	"-union
	zero	t37,-st1578	".
	zero	t40,-st814	"/
	zero	t42,-st814	"<
	zero	t43,-st814	"<=
	zero	t48,-st814	"=
	zero	t49,-st814	">
	zero	t50,-st814	">=
	zero	t54,-st814	"^=
	zero	t55,-st814	"|
	zero	t56,-st814	"||
	equ	ln468,*-dpda-st468-1
"
" State 503
	equ	st503,*-dpda
	zero	aplyp1,ln503
	zero	1,1   sd/RFU
	zero	20,st162	prod/val
	equ	ln503,*-dpda-st503-1
"
" State 506
	equ	st506,*-dpda
	zero	nsrd,ln506
	zero	t0,-st1618	"EOI
	zero	t4,-st1618	")
	zero	t6,-st1614	"+
	zero	t8,-st1614	"-
	zero	t14,-st1618	"-differ
	zero	t18,-st1614	"-having
	zero	t19,-st1618	"-inter
	zero	t30,-st1618	"-order_by
	zero	t35,-st1618	"-union
	equ	ln506,*-dpda-st506-1
"
" State 516
	equ	st516,*-dpda
	zero	aplyp,ln516
	zero	0,0   sd/RFU
	zero	75,st682	prod/val
	zero	st926,st1279
	equ	ln516,*-dpda-st516-1
"
" State 520
	equ	st520,*-dpda
	zero	aplyps,ln520
	zero	2,2   sd/RFU
	zero	72,st516	prod/val
	equ	ln520,*-dpda-st520-1
"
" State 523
	equ	st523,*-dpda
	zero	aplyps,ln523
	zero	2,2   sd/RFU
	zero	73,st516	prod/val
	equ	ln523,*-dpda-st523-1
"
" State 526
	equ	st526,*-dpda
	zero	aplyps,ln526
	zero	0,0   sd/RFU
	zero	74,st516	prod/val
	equ	ln526,*-dpda-st526-1
"
" State 529
	equ	st529,*-dpda
	zero	aplyp,ln529
	zero	0,0   sd/RFU
	zero	124,st605	prod/val
	zero	st557,st609
	zero	st564,st612
	equ	ln529,*-dpda-st529-1
"
" State 534
	equ	st534,*-dpda
	zero	aplyps,ln534
	zero	0,0   sd/RFU
	zero	123,st529	prod/val
	equ	ln534,*-dpda-st534-1
"
" State 537
	equ	st537,*-dpda
	zero	aplyps,ln537
	zero	0,0   sd/RFU
	zero	120,st529	prod/val
	equ	ln537,*-dpda-st537-1
"
" State 540
	equ	st540,*-dpda
	zero	aplyps,ln540
	zero	0,0   sd/RFU
	zero	121,st529	prod/val
	equ	ln540,*-dpda-st540-1
"
" State 543
	equ	st543,*-dpda
	zero	aplyps,ln543
	zero	2,2   sd/RFU
	zero	122,st529	prod/val
	equ	ln543,*-dpda-st543-1
"
" State 546
	equ	st546,*-dpda
	zero	strd,ln546
	zero	t2,st731	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	zero	t51,st756	"[
	equ	ln546,*-dpda-st546-1
"
" State 557
	equ	st557,*-dpda
	zero	strd,ln557
	zero	t2,st845	"(
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln557,*-dpda-st557-1
"
" State 564
	equ	st564,*-dpda
	zero	strds,st557

"
" State 565
	equ	st565,*-dpda
	zero	nsrd,ln565
	zero	t4,-st537	")
	zero	t5,-st537	"*
	zero	t6,-st537	"+
	zero	t8,-st537	"-
	zero	t20,-st537	"-is_between
	zero	t21,-st537	"-is_in
	zero	t22,-st1628	"-is_like
	zero	t23,-st537	"-is_not_between
	zero	t24,-st537	"-is_not_in
	zero	t25,-st1628	"-is_not_like
	zero	t26,-st1625	"-is_not_null
	zero	t27,-st1625	"-is_null
	zero	t40,-st537	"/
	zero	t42,-st537	"<
	zero	t43,-st537	"<=
	zero	t48,-st537	"=
	zero	t49,-st537	">
	zero	t50,-st537	">=
	zero	t54,-st537	"^=
	zero	t56,-st537	"||
	equ	ln565,*-dpda-st565-1
"
" State 586
	equ	st586,*-dpda
	zero	nsrd,ln586
	zero	t4,-st540	")
	zero	t5,-st540	"*
	zero	t6,-st540	"+
	zero	t8,-st540	"-
	zero	t20,-st540	"-is_between
	zero	t21,-st540	"-is_in
	zero	t22,-st1631	"-is_like
	zero	t23,-st540	"-is_not_between
	zero	t24,-st540	"-is_not_in
	zero	t25,-st1631	"-is_not_like
	zero	t40,-st540	"/
	zero	t42,-st540	"<
	zero	t43,-st540	"<=
	zero	t48,-st540	"=
	zero	t49,-st540	">
	zero	t50,-st540	">=
	zero	t54,-st540	"^=
	zero	t56,-st540	"||
	equ	ln586,*-dpda-st586-1
"
" State 605
	equ	st605,*-dpda
	zero	aplyp,ln605
	zero	0,0   sd/RFU
	zero	117,st615	prod/val
	zero	st846,st1188
	equ	ln605,*-dpda-st605-1
"
" State 609
	equ	st609,*-dpda
	zero	aplyps,ln609
	zero	1,1   sd/RFU
	zero	119,st605	prod/val
	equ	ln609,*-dpda-st609-1
"
" State 612
	equ	st612,*-dpda
	zero	aplyps,ln612
	zero	2,2   sd/RFU
	zero	118,st605	prod/val
	equ	ln612,*-dpda-st612-1
"
" State 615
	equ	st615,*-dpda
	zero	nsrd,ln615
	zero	t0,-st1637	"EOI
	zero	t1,-st1637	"&
	zero	t4,-st1637	")
	zero	t5,-st1637	"*
	zero	t6,-st1637	"+
	zero	t7,-st1637	",
	zero	t8,-st1637	"-
	zero	t14,-st1637	"-differ
	zero	t17,-st1637	"-group_by
	zero	t19,-st1637	"-inter
	zero	t20,-st1637	"-is_between
	zero	t21,-st1637	"-is_in
	zero	t23,-st1637	"-is_not_between
	zero	t24,-st1637	"-is_not_in
	zero	t30,-st1637	"-order_by
	zero	t35,-st1637	"-union
	zero	t40,-st1637	"/
	zero	t42,-st1637	"<
	zero	t43,-st1637	"<=
	zero	t48,-st1637	"=
	zero	t49,-st1637	">
	zero	t50,-st1637	">=
	zero	t54,-st1637	"^=
	zero	t55,-st1637	"|
	zero	t56,-st1634	"||
	equ	ln615,*-dpda-st615-1
"
" State 641
	equ	st641,*-dpda
	zero	nsrd,ln641
	zero	t0,-st1644	"EOI
	zero	t1,-st1644	"&
	zero	t4,-st1644	")
	zero	t5,-st1553	"*
	zero	t6,-st1644	"+
	zero	t7,-st1644	",
	zero	t8,-st1644	"-
	zero	t14,-st1644	"-differ
	zero	t17,-st1644	"-group_by
	zero	t19,-st1644	"-inter
	zero	t20,-st1644	"-is_between
	zero	t21,-st1644	"-is_in
	zero	t23,-st1644	"-is_not_between
	zero	t24,-st1644	"-is_not_in
	zero	t30,-st1644	"-order_by
	zero	t35,-st1644	"-union
	zero	t40,-st1553	"/
	zero	t42,-st1644	"<
	zero	t43,-st1644	"<=
	zero	t48,-st1644	"=
	zero	t49,-st1644	">
	zero	t50,-st1644	">=
	zero	t54,-st1644	"^=
	zero	t55,-st1644	"|
	equ	ln641,*-dpda-st641-1
"
" State 666
	equ	st666,*-dpda
	zero	nsrd,ln666
	zero	t6,-st1661	"+
	zero	t8,-st1661	"-
	zero	t20,-st1661	"-is_between
	zero	t21,-st526	"-is_in
	zero	t23,-st1661	"-is_not_between
	zero	t24,-st526	"-is_not_in
	zero	t42,-st526	"<
	zero	t43,-st526	"<=
	zero	t48,-st526	"=
	zero	t49,-st526	">
	zero	t50,-st526	">=
	zero	t54,-st526	"^=
	equ	ln666,*-dpda-st666-1
"
" State 679
	equ	st679,*-dpda
	zero	strd,ln679
	zero	t22,st907	"-is_like
	zero	t25,st910	"-is_not_like
	equ	ln679,*-dpda-st679-1
"
" State 682
	equ	st682,*-dpda
	zero	strd,ln682
	zero	t21,st939	"-is_in
	zero	t24,st942	"-is_not_in
	zero	t42,st945	"<
	zero	t43,st948	"<=
	zero	t48,st951	"=
	zero	t49,st954	">
	zero	t50,st957	">=
	zero	t54,st960	"^=
	equ	ln682,*-dpda-st682-1
"
" State 691
	equ	st691,*-dpda
	zero	aplyp,ln691
	zero	0,0   sd/RFU
	zero	65,st698	prod/val
	zero	st546,st702
	equ	ln691,*-dpda-st691-1
"
" State 695
	equ	st695,*-dpda
	zero	aplyps,ln695
	zero	2,2   sd/RFU
	zero	66,st691	prod/val
	equ	ln695,*-dpda-st695-1
"
" State 698
	equ	st698,*-dpda
	zero	aplyp,ln698
	zero	0,0   sd/RFU
	zero	63,st705	prod/val
	zero	st178,st709
	equ	ln698,*-dpda-st698-1
"
" State 702
	equ	st702,*-dpda
	zero	aplyps,ln702
	zero	1,1   sd/RFU
	zero	64,st698	prod/val
	equ	ln702,*-dpda-st702-1
"
" State 705
	equ	st705,*-dpda
	zero	aplyp,ln705
	zero	0,0   sd/RFU
	zero	61,st712	prod/val
	zero	st179,st1303
	equ	ln705,*-dpda-st705-1
"
" State 709
	equ	st709,*-dpda
	zero	aplyps,ln709
	zero	2,2   sd/RFU
	zero	62,st705	prod/val
	equ	ln709,*-dpda-st709-1
"
" State 712
	equ	st712,*-dpda
	zero	nsrd,ln712
	zero	t0,-st1669	"EOI
	zero	t1,-st1666	"&
	zero	t4,-st1669	")
	zero	t14,-st1669	"-differ
	zero	t17,-st1669	"-group_by
	zero	t19,-st1669	"-inter
	zero	t30,-st1669	"-order_by
	zero	t35,-st1669	"-union
	zero	t55,-st1669	"|
	equ	ln712,*-dpda-st712-1
"
" State 722
	equ	st722,*-dpda
	zero	nsrd,ln722
	zero	t0,-st1680	"EOI
	zero	t4,-st1680	")
	zero	t14,-st1680	"-differ
	zero	t17,-st1680	"-group_by
	zero	t19,-st1680	"-inter
	zero	t30,-st1680	"-order_by
	zero	t35,-st1680	"-union
	zero	t55,-st1677	"|
	equ	ln722,*-dpda-st722-1
"
" State 731
	equ	st731,*-dpda
	zero	strd,ln731
	zero	t2,st745	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	zero	t51,st756	"[
	zero	t53,st764	"^
	equ	ln731,*-dpda-st731-1
"
" State 745
	equ	st745,*-dpda
	zero	strds,st731

"
" State 746
	equ	st746,*-dpda
	zero	aplyp,ln746
	zero	0,0   sd/RFU
	zero	163,st516	prod/val
	zero	st731,st970
	zero	st745,st970
	zero	st897,st1243
	zero	st1282,st1374
	zero	st1294,st1374
	zero	st1313,st1374
	zero	st1319,st1374
	equ	ln746,*-dpda-st746-1
"
" State 756
	equ	st756,*-dpda
	zero	strd,ln756
	zero	t2,st1088	"(
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st1097	"<symbol>
	equ	ln756,*-dpda-st756-1
"
" State 763
	equ	st763,*-dpda
	zero	strds,st756

"
" State 764
	equ	st764,*-dpda
	zero	aplyp1,ln764
	zero	0,0   sd/RFU
	zero	161,st546	prod/val
	equ	ln764,*-dpda-st764-1
"
" State 767
	equ	st767,*-dpda
	zero	nsrd,ln767
	zero	t0,-st1689	"EOI
	zero	t6,-st1683	"+
	zero	t7,-st1689	",
	zero	t8,-st1683	"-
	zero	t11,-st1683	"-ascending
	zero	t13,-st1683	"-descending
	equ	ln767,*-dpda-st767-1
"
" State 774
	equ	st774,*-dpda
	zero	nsrd,ln774
	zero	t0,-st1694	"EOI
	zero	t7,-st1692	",
	equ	ln774,*-dpda-st774-1
"
" State 777
	equ	st777,*-dpda
	zero	strd,ln777
	zero	t47,st1110	"<symbol>
	equ	ln777,*-dpda-st777-1
"
" State 779
	equ	st779,*-dpda
	zero	aplyp1,ln779
	zero	1,1   sd/RFU
	zero	37,st238	prod/val
	equ	ln779,*-dpda-st779-1
"
" State 782
	equ	st782,*-dpda
	zero	aplyp,ln782
	zero	0,0   sd/RFU
	zero	166,st799	prod/val
	zero	st270,st779
	equ	ln782,*-dpda-st782-1
"
" State 786
	equ	st786,*-dpda
	zero	aplyp1,ln786
	zero	1,1   sd/RFU
	zero	39,st227	prod/val
	equ	ln786,*-dpda-st786-1
"
" State 789
	equ	st789,*-dpda
	zero	aplyp,ln789
	zero	1,1   sd/RFU
	zero	35,st250	prod/val
	zero	st796,st1124
	equ	ln789,*-dpda-st789-1
"
" State 793
	equ	st793,*-dpda
	zero	aplyps,ln793
	zero	0,0   sd/RFU
	zero	34,st789	prod/val
	equ	ln793,*-dpda-st793-1
"
" State 796
	equ	st796,*-dpda
	zero	strd,ln796
	zero	t38,st271	".V.
	zero	t47,st290	"<symbol>
	equ	ln796,*-dpda-st796-1
"
" State 799
	equ	st799,*-dpda
	zero	strds,st796

"
" State 800
	equ	st800,*-dpda
	zero	nsrd,ln800
	zero	t0,-st1699	"EOI
	zero	t2,-st1699	"(
	zero	t4,-st1699	")
	zero	t5,-st1697	"*
	zero	t14,-st1699	"-differ
	zero	t17,-st1699	"-group_by
	zero	t19,-st1699	"-inter
	zero	t30,-st1699	"-order_by
	zero	t33,-st1699	"-range
	zero	t35,-st1699	"-union
	zero	t36,-st1699	"-where
	zero	t41,-st1699	"::
	zero	t47,-st1699	"<symbol>
	equ	ln800,*-dpda-st800-1
"
" State 814
	equ	st814,*-dpda
	zero	aplyp,ln814
	zero	0,0   sd/RFU
	zero	167,st316	prod/val
	zero	st6,st73
	zero	st310,st800
	zero	st1332,st1059
	zero	st1334,st338
	zero	st1335,st1416
	zero	st1495,st73
	zero	st1498,st73
	zero	st1499,st73
	equ	ln814,*-dpda-st814-1
"
" State 825
	equ	st825,*-dpda
	zero	aplyp,ln825
	zero	2,2   sd/RFU
	zero	52,st91	prod/val
	zero	st1498,st95
	zero	st1499,st95
	equ	ln825,*-dpda-st825-1
"
" State 830
	equ	st830,*-dpda
	zero	aplyps,ln830
	zero	0,0   sd/RFU
	zero	51,st825	prod/val
	equ	ln830,*-dpda-st830-1
"
" State 833
	equ	st833,*-dpda
	zero	aplyp1,ln833
	zero	0,0   sd/RFU
	zero	169,st825	prod/val
	equ	ln833,*-dpda-st833-1
"
" State 836
	equ	st836,*-dpda
	zero	strd,ln836
	zero	t2,st845	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln836,*-dpda-st836-1
"
" State 845
	equ	st845,*-dpda
	zero	strds,st836

"
" State 846
	equ	st846,*-dpda
	zero	strds,st836

"
" State 847
	equ	st847,*-dpda
	zero	strds,st836

"
" State 848
	equ	st848,*-dpda
	zero	strds,st836

"
" State 849
	equ	st849,*-dpda
	zero	strds,st836

"
" State 850
	equ	st850,*-dpda
	zero	strds,st836

"
" State 851
	equ	st851,*-dpda
	zero	strd,ln851
	zero	t47,st1110	"<symbol>
	equ	ln851,*-dpda-st851-1
"
" State 853
	equ	st853,*-dpda
	zero	aplyp,ln853
	zero	0,0   sd/RFU
	zero	157,st121	prod/val
	zero	st1071,st1336
	zero	st1553,st846
	zero	st1555,st846
	equ	ln853,*-dpda-st853-1
"
" State 859
	equ	st859,*-dpda
	zero	aplyps,ln859
	zero	0,0   sd/RFU
	zero	158,st853	prod/val
	equ	ln859,*-dpda-st859-1
"
" State 862
	equ	st862,*-dpda
	zero	nsrd,ln862
	zero	t0,-st1704	"EOI
	zero	t2,-st1704	"(
	zero	t4,-st1704	")
	zero	t5,-st1702	"*
	zero	t14,-st1704	"-differ
	zero	t17,-st1704	"-group_by
	zero	t19,-st1704	"-inter
	zero	t30,-st1704	"-order_by
	zero	t33,-st1704	"-range
	zero	t35,-st1704	"-union
	zero	t36,-st1704	"-where
	zero	t41,-st1704	"::
	zero	t47,-st1704	"<symbol>
	equ	ln862,*-dpda-st862-1
"
" State 876
	equ	st876,*-dpda
	zero	strd,ln876
	zero	t4,st361	")
	zero	t6,st409	"+
	zero	t8,st434	"-
	equ	ln876,*-dpda-st876-1
"
" State 880
	equ	st880,*-dpda
	zero	strd,ln880
	zero	t47,st335	"<symbol>
	equ	ln880,*-dpda-st880-1
"
" State 882
	equ	st882,*-dpda
	zero	aplyp1,ln882
	zero	1,1   sd/RFU
	zero	70,st691	prod/val
	equ	ln882,*-dpda-st882-1
"
" State 885
	equ	st885,*-dpda
	zero	aplyp1,ln885
	zero	0,0   sd/RFU
	zero	88,st882	prod/val
	equ	ln885,*-dpda-st885-1
"
" State 888
	equ	st888,*-dpda
	zero	aplyp1,ln888
	zero	0,0   sd/RFU
	zero	87,st882	prod/val
	equ	ln888,*-dpda-st888-1
"
" State 891
	equ	st891,*-dpda
	zero	aplyp1,ln891
	zero	0,0   sd/RFU
	zero	89,st848	prod/val
	equ	ln891,*-dpda-st891-1
"
" State 894
	equ	st894,*-dpda
	zero	aplyp1,ln894
	zero	0,0   sd/RFU
	zero	90,st848	prod/val
	equ	ln894,*-dpda-st894-1
"
" State 897
	equ	st897,*-dpda
	zero	strd,ln897
	zero	t2,st845	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln897,*-dpda-st897-1
"
" State 907
	equ	st907,*-dpda
	zero	aplyp1,ln907
	zero	0,0   sd/RFU
	zero	85,st897	prod/val
	equ	ln907,*-dpda-st907-1
"
" State 910
	equ	st910,*-dpda
	zero	aplyp1,ln910
	zero	0,0   sd/RFU
	zero	86,st897	prod/val
	equ	ln910,*-dpda-st910-1
"
" State 913
	equ	st913,*-dpda
	zero	nsrd,ln913
	zero	t2,-st1710	"(
	zero	t6,-st1710	"+
	zero	t8,-st1710	"-
	zero	t9,-st1707	"-all_of
	zero	t10,-st1707	"-any_of
	zero	t38,-st1710	".V.
	zero	t39,-st1710	".X.
	zero	t44,-st1710	"<bit_string>
	zero	t45,-st1710	"<integer>
	zero	t46,-st1710	"<string>
	zero	t47,-st1710	"<symbol>
	zero	t51,-st1710	"[
	equ	ln913,*-dpda-st913-1
"
" State 926
	equ	st926,*-dpda
	zero	strd,ln926
	zero	t2,st1282	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	zero	t51,st756	"[
	equ	ln926,*-dpda-st926-1
"
" State 937
	equ	st937,*-dpda
	zero	strd,ln937
	zero	t2,st1294	"(
	equ	ln937,*-dpda-st937-1
"
" State 939
	equ	st939,*-dpda
	zero	aplyp1,ln939
	zero	0,0   sd/RFU
	zero	83,st937	prod/val
	equ	ln939,*-dpda-st939-1
"
" State 942
	equ	st942,*-dpda
	zero	aplyp1,ln942
	zero	0,0   sd/RFU
	zero	84,st937	prod/val
	equ	ln942,*-dpda-st942-1
"
" State 945
	equ	st945,*-dpda
	zero	aplyp1,ln945
	zero	0,0   sd/RFU
	zero	98,st913	prod/val
	equ	ln945,*-dpda-st945-1
"
" State 948
	equ	st948,*-dpda
	zero	aplyp1,ln948
	zero	0,0   sd/RFU
	zero	99,st913	prod/val
	equ	ln948,*-dpda-st948-1
"
" State 951
	equ	st951,*-dpda
	zero	aplyp1,ln951
	zero	0,0   sd/RFU
	zero	94,st913	prod/val
	equ	ln951,*-dpda-st951-1
"
" State 954
	equ	st954,*-dpda
	zero	aplyp1,ln954
	zero	0,0   sd/RFU
	zero	96,st913	prod/val
	equ	ln954,*-dpda-st954-1
"
" State 957
	equ	st957,*-dpda
	zero	aplyp1,ln957
	zero	0,0   sd/RFU
	zero	97,st913	prod/val
	equ	ln957,*-dpda-st957-1
"
" State 960
	equ	st960,*-dpda
	zero	aplyp1,ln960
	zero	0,0   sd/RFU
	zero	95,st913	prod/val
	equ	ln960,*-dpda-st960-1
"
" State 963
	equ	st963,*-dpda
	zero	aplyp,ln963
	zero	0,0   sd/RFU
	zero	159,st178	prod/val
	zero	st1239,st850
	equ	ln963,*-dpda-st963-1
"
" State 967
	equ	st967,*-dpda
	zero	aplyp1,ln967
	zero	0,0   sd/RFU
	zero	160,st179	prod/val
	equ	ln967,*-dpda-st967-1
"
" State 970
	equ	st970,*-dpda
	zero	nsrd,ln970
	zero	t7,-st1374	",
	zero	t21,-st516	"-is_in
	zero	t24,-st516	"-is_not_in
	zero	t42,-st516	"<
	zero	t43,-st516	"<=
	zero	t48,-st516	"=
	zero	t49,-st516	">
	zero	t50,-st516	">=
	zero	t54,-st516	"^=
	equ	ln970,*-dpda-st970-1
"
" State 980
	equ	st980,*-dpda
	zero	nsrd,ln980
	zero	t4,-st529	")
	zero	t5,-st529	"*
	zero	t6,-st529	"+
	zero	t7,-st1379	",
	zero	t8,-st529	"-
	zero	t20,-st529	"-is_between
	zero	t21,-st529	"-is_in
	zero	t23,-st529	"-is_not_between
	zero	t24,-st529	"-is_not_in
	zero	t40,-st529	"/
	zero	t42,-st529	"<
	zero	t43,-st529	"<=
	zero	t48,-st529	"=
	zero	t49,-st529	">
	zero	t50,-st529	">=
	zero	t54,-st529	"^=
	zero	t56,-st529	"||
	equ	ln980,*-dpda-st980-1
"
" State 998
	equ	st998,*-dpda
	zero	nsrd,ln998
	zero	t4,-st534	")
	zero	t5,-st534	"*
	zero	t6,-st534	"+
	zero	t7,-st1382	",
	zero	t8,-st534	"-
	zero	t20,-st534	"-is_between
	zero	t21,-st534	"-is_in
	zero	t23,-st534	"-is_not_between
	zero	t24,-st534	"-is_not_in
	zero	t40,-st534	"/
	zero	t42,-st534	"<
	zero	t43,-st534	"<=
	zero	t48,-st534	"=
	zero	t49,-st534	">
	zero	t50,-st534	">=
	zero	t54,-st534	"^=
	zero	t56,-st534	"||
	equ	ln998,*-dpda-st998-1
"
" State 1016
	equ	st1016,*-dpda
	zero	strd,ln1016
	zero	t7,st1313	",
	equ	ln1016,*-dpda-st1016-1
"
" State 1018
	equ	st1018,*-dpda
	zero	nsrd,ln1018
	zero	t4,-st1715	")
	zero	t7,-st1713	",
	equ	ln1018,*-dpda-st1018-1
"
" State 1021
	equ	st1021,*-dpda
	zero	nsrd,ln1021
	zero	t4,-st1722	")
	zero	t6,-st1722	"+
	zero	t8,-st1722	"-
	zero	t20,-st1722	"-is_between
	zero	t21,-st526	"-is_in
	zero	t23,-st1722	"-is_not_between
	zero	t24,-st526	"-is_not_in
	zero	t42,-st526	"<
	zero	t43,-st526	"<=
	zero	t48,-st526	"=
	zero	t49,-st526	">
	zero	t50,-st526	">=
	zero	t54,-st526	"^=
	equ	ln1021,*-dpda-st1021-1
"
" State 1035
	equ	st1035,*-dpda
	zero	strd,ln1035
	zero	t4,st520	")
	equ	ln1035,*-dpda-st1035-1
"
" State 1037
	equ	st1037,*-dpda
	zero	strd,ln1037
	zero	t4,st695	")
	zero	t55,st967	"|
	equ	ln1037,*-dpda-st1037-1
"
" State 1040
	equ	st1040,*-dpda
	zero	nsrd,ln1040
	zero	t4,-st1719	")
	zero	t14,-st1728	"-differ
	zero	t19,-st1728	"-inter
	zero	t35,-st1728	"-union
	equ	ln1040,*-dpda-st1040-1
"
" State 1045
	equ	st1045,*-dpda
	zero	strd,ln1045
	zero	t2,st1325	"(
	equ	ln1045,*-dpda-st1045-1
"
" State 1047
	equ	st1047,*-dpda
	zero	strd,ln1047
	zero	t37,st1332	".
	equ	ln1047,*-dpda-st1047-1
"
" State 1049
	equ	st1049,*-dpda
	zero	aplyp,ln1049
	zero	0,0   sd/RFU
	zero	130,st1071	prod/val
	zero	st1095,st1433
	equ	ln1049,*-dpda-st1049-1
"
" State 1053
	equ	st1053,*-dpda
	zero	aplyps,ln1053
	zero	0,0   sd/RFU
	zero	128,st1049	prod/val
	equ	ln1053,*-dpda-st1053-1
"
" State 1056
	equ	st1056,*-dpda
	zero	aplyps,ln1056
	zero	0,0   sd/RFU
	zero	127,st1049	prod/val
	equ	ln1056,*-dpda-st1056-1
"
" State 1059
	equ	st1059,*-dpda
	zero	aplyps,ln1059
	zero	2,2   sd/RFU
	zero	126,st1049	prod/val
	equ	ln1059,*-dpda-st1059-1
"
" State 1062
	equ	st1062,*-dpda
	zero	aplyps,ln1062
	zero	2,2   sd/RFU
	zero	129,st1049	prod/val
	equ	ln1062,*-dpda-st1062-1
"
" State 1065
	equ	st1065,*-dpda
	zero	nsrd,ln1065
	zero	t5,-st1056	"*
	zero	t6,-st1056	"+
	zero	t8,-st1056	"-
	zero	t40,-st1056	"/
	zero	t52,-st1080	"]
	equ	ln1065,*-dpda-st1065-1
"
" State 1071
	equ	st1071,*-dpda
	zero	strd,ln1071
	zero	t5,st853	"*
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t40,st859	"/
	equ	ln1071,*-dpda-st1071-1
"
" State 1076
	equ	st1076,*-dpda
	zero	aplyp,ln1076
	zero	0,0   sd/RFU
	zero	79,st1086	prod/val
	zero	st763,st1479
	equ	ln1076,*-dpda-st1076-1
"
" State 1080
	equ	st1080,*-dpda
	zero	aplyps,ln1080
	zero	0,0   sd/RFU
	zero	78,st1076	prod/val
	equ	ln1080,*-dpda-st1080-1
"
" State 1083
	equ	st1083,*-dpda
	zero	aplyps,ln1083
	zero	2,2   sd/RFU
	zero	80,st1076	prod/val
	equ	ln1083,*-dpda-st1083-1
"
" State 1086
	equ	st1086,*-dpda
	zero	strd,ln1086
	zero	t52,st523	"]
	equ	ln1086,*-dpda-st1086-1
"
" State 1088
	equ	st1088,*-dpda
	zero	strd,ln1088
	zero	t2,st1096	"(
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st1097	"<symbol>
	equ	ln1088,*-dpda-st1088-1
"
" State 1095
	equ	st1095,*-dpda
	zero	strds,st1088

"
" State 1096
	equ	st1096,*-dpda
	zero	strds,st1088

"
" State 1097
	equ	st1097,*-dpda
	zero	nsrd,ln1097
	zero	t2,-st1568	"(
	zero	t37,-st1110	".
	equ	ln1097,*-dpda-st1097-1
"
" State 1100
	equ	st1100,*-dpda
	zero	aplyp1,ln1100
	zero	1,1   sd/RFU
	zero	24,st774	prod/val
	equ	ln1100,*-dpda-st1100-1
"
" State 1103
	equ	st1103,*-dpda
	zero	aplyp,ln1103
	zero	0,0   sd/RFU
	zero	27,st1100	prod/val
	zero	st1688,st1446
	equ	ln1103,*-dpda-st1103-1
"
" State 1107
	equ	st1107,*-dpda
	zero	aplyps,ln1107
	zero	0,0   sd/RFU
	zero	28,st1103	prod/val
	equ	ln1107,*-dpda-st1107-1
"
" State 1110
	equ	st1110,*-dpda
	zero	aplyp,ln1110
	zero	0,0   sd/RFU
	zero	165,st1047	prod/val
	zero	st6,st76
	zero	st63,st199
	zero	st777,st206
	zero	st796,st199
	zero	st799,st199
	zero	st851,st1140
	zero	st1325,st1404
	zero	st1425,st1404
	zero	st1495,st76
	zero	st1498,st76
	zero	st1499,st76
	equ	ln1110,*-dpda-st1110-1
"
" State 1124
	equ	st1124,*-dpda
	zero	aplyp1,ln1124
	zero	2,2   sd/RFU
	zero	33,st253	prod/val
	equ	ln1124,*-dpda-st1124-1
"
" State 1127
	equ	st1127,*-dpda
	zero	strd,ln1127
	zero	t4,st1351	")
	equ	ln1127,*-dpda-st1127-1
"
" State 1129
	equ	st1129,*-dpda
	zero	aplyp1,ln1129
	zero	3,3   sd/RFU
	zero	57,st78	prod/val
	equ	ln1129,*-dpda-st1129-1
"
" State 1132
	equ	st1132,*-dpda
	zero	strd,ln1132
	zero	t4,st1355	")
	zero	t7,st849	",
	equ	ln1132,*-dpda-st1132-1
"
" State 1135
	equ	st1135,*-dpda
	zero	nsrd,ln1135
	zero	t4,-st1739	")
	zero	t6,-st1732	"+
	zero	t7,-st1739	",
	zero	t8,-st1732	"-
	equ	ln1135,*-dpda-st1135-1
"
" State 1140
	equ	st1140,*-dpda
	zero	strd,ln1140
	zero	t37,st1334	".
	equ	ln1140,*-dpda-st1140-1
"
" State 1142
	equ	st1142,*-dpda
	zero	nsrd,ln1142
	zero	t0,-st1547	"EOI
	zero	t4,-st1547	")
	zero	t5,-st1547	"*
	zero	t6,-st1547	"+
	zero	t7,-st1547	",
	zero	t8,-st1547	"-
	zero	t11,-st1547	"-ascending
	zero	t13,-st1547	"-descending
	zero	t14,-st1547	"-differ
	zero	t18,-st1547	"-having
	zero	t19,-st1547	"-inter
	zero	t30,-st1547	"-order_by
	zero	t35,-st1547	"-union
	zero	t40,-st1547	"/
	zero	t56,-st1542	"||
	equ	ln1142,*-dpda-st1142-1
"
" State 1158
	equ	st1158,*-dpda
	zero	nsrd,ln1158
	zero	t0,-st1563	"EOI
	zero	t4,-st1563	")
	zero	t5,-st1554	"*
	zero	t6,-st1563	"+
	zero	t7,-st1563	",
	zero	t8,-st1563	"-
	zero	t11,-st1563	"-ascending
	zero	t13,-st1563	"-descending
	zero	t14,-st1563	"-differ
	zero	t18,-st1563	"-having
	zero	t19,-st1563	"-inter
	zero	t30,-st1563	"-order_by
	zero	t35,-st1563	"-union
	zero	t40,-st1554	"/
	equ	ln1158,*-dpda-st1158-1
"
" State 1173
	equ	st1173,*-dpda
	zero	aplyp1,ln1173
	zero	3,3   sd/RFU
	zero	55,st78	prod/val
	equ	ln1173,*-dpda-st1173-1
"
" State 1176
	equ	st1176,*-dpda
	zero	nsrd,ln1176
	zero	t0,-st1622	"EOI
	zero	t4,-st1622	")
	zero	t14,-st1622	"-differ
	zero	t19,-st1622	"-inter
	zero	t30,-st1622	"-order_by
	zero	t35,-st1622	"-union
	zero	t55,-st1679	"|
	equ	ln1176,*-dpda-st1176-1
"
" State 1184
	equ	st1184,*-dpda
	zero	strd,ln1184
	zero	t4,st543	")
	zero	t6,st409	"+
	zero	t8,st434	"-
	equ	ln1184,*-dpda-st1184-1
"
" State 1188
	equ	st1188,*-dpda
	zero	nsrd,ln1188
	zero	t0,-st1641	"EOI
	zero	t1,-st1641	"&
	zero	t4,-st1641	")
	zero	t5,-st1641	"*
	zero	t6,-st1641	"+
	zero	t7,-st1641	",
	zero	t8,-st1641	"-
	zero	t14,-st1641	"-differ
	zero	t17,-st1641	"-group_by
	zero	t19,-st1641	"-inter
	zero	t20,-st1641	"-is_between
	zero	t21,-st1641	"-is_in
	zero	t23,-st1641	"-is_not_between
	zero	t24,-st1641	"-is_not_in
	zero	t30,-st1641	"-order_by
	zero	t35,-st1641	"-union
	zero	t40,-st1641	"/
	zero	t42,-st1641	"<
	zero	t43,-st1641	"<=
	zero	t48,-st1641	"=
	zero	t49,-st1641	">
	zero	t50,-st1641	">=
	zero	t54,-st1641	"^=
	zero	t55,-st1641	"|
	zero	t56,-st1636	"||
	equ	ln1188,*-dpda-st1188-1
"
" State 1214
	equ	st1214,*-dpda
	zero	nsrd,ln1214
	zero	t0,-st1658	"EOI
	zero	t1,-st1658	"&
	zero	t4,-st1658	")
	zero	t5,-st1555	"*
	zero	t6,-st1658	"+
	zero	t7,-st1658	",
	zero	t8,-st1658	"-
	zero	t14,-st1658	"-differ
	zero	t17,-st1658	"-group_by
	zero	t19,-st1658	"-inter
	zero	t20,-st1658	"-is_between
	zero	t21,-st1658	"-is_in
	zero	t23,-st1658	"-is_not_between
	zero	t24,-st1658	"-is_not_in
	zero	t30,-st1658	"-order_by
	zero	t35,-st1658	"-union
	zero	t40,-st1555	"/
	zero	t42,-st1658	"<
	zero	t43,-st1658	"<=
	zero	t48,-st1658	"=
	zero	t49,-st1658	">
	zero	t50,-st1658	">=
	zero	t54,-st1658	"^=
	zero	t55,-st1658	"|
	equ	ln1214,*-dpda-st1214-1
"
" State 1239
	equ	st1239,*-dpda
	zero	strd,ln1239
	zero	t1,st963	"&
	zero	t6,st409	"+
	zero	t8,st434	"-
	equ	ln1239,*-dpda-st1239-1
"
" State 1243
	equ	st1243,*-dpda
	zero	aplyp1,ln1243
	zero	0,0   sd/RFU
	zero	101,st1258	prod/val
	equ	ln1243,*-dpda-st1243-1
"
" State 1246
	equ	st1246,*-dpda
	zero	nsrd,ln1246
	zero	t0,-st1742	"EOI
	zero	t1,-st1742	"&
	zero	t4,-st1742	")
	zero	t6,-st1735	"+
	zero	t8,-st1735	"-
	zero	t14,-st1742	"-differ
	zero	t17,-st1742	"-group_by
	zero	t19,-st1742	"-inter
	zero	t30,-st1742	"-order_by
	zero	t35,-st1742	"-union
	zero	t55,-st1742	"|
	equ	ln1246,*-dpda-st1246-1
"
" State 1258
	equ	st1258,*-dpda
	zero	aplyp1,ln1258
	zero	2,2   sd/RFU
	zero	69,st691	prod/val
	equ	ln1258,*-dpda-st1258-1
"
" State 1261
	equ	st1261,*-dpda
	zero	aplyp1,ln1261
	zero	1,1   sd/RFU
	zero	93,st926	prod/val
	equ	ln1261,*-dpda-st1261-1
"
" State 1264
	equ	st1264,*-dpda
	zero	aplyp1,ln1264
	zero	1,1   sd/RFU
	zero	92,st926	prod/val
	equ	ln1264,*-dpda-st1264-1
"
" State 1267
	equ	st1267,*-dpda
	zero	nsrd,ln1267
	zero	t0,-st526	"EOI
	zero	t1,-st526	"&
	zero	t4,-st526	")
	zero	t6,-st1736	"+
	zero	t8,-st1736	"-
	zero	t14,-st526	"-differ
	zero	t17,-st526	"-group_by
	zero	t19,-st526	"-inter
	zero	t30,-st526	"-order_by
	zero	t35,-st526	"-union
	zero	t55,-st526	"|
	equ	ln1267,*-dpda-st1267-1
"
" State 1279
	equ	st1279,*-dpda
	zero	aplyp1,ln1279
	zero	2,2   sd/RFU
	zero	67,st691	prod/val
	equ	ln1279,*-dpda-st1279-1
"
" State 1282
	equ	st1282,*-dpda
	zero	strd,ln1282
	zero	t2,st1385	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln1282,*-dpda-st1282-1
"
" State 1294
	equ	st1294,*-dpda
	zero	strd,ln1294
	zero	t2,st55	"(
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	equ	ln1294,*-dpda-st1294-1
"
" State 1303
	equ	st1303,*-dpda
	zero	nsrd,ln1303
	zero	t0,-st1674	"EOI
	zero	t1,-st1668	"&
	zero	t4,-st1674	")
	zero	t14,-st1674	"-differ
	zero	t17,-st1674	"-group_by
	zero	t19,-st1674	"-inter
	zero	t30,-st1674	"-order_by
	zero	t35,-st1674	"-union
	zero	t55,-st1674	"|
	equ	ln1303,*-dpda-st1303-1
"
" State 1313
	equ	st1313,*-dpda
	zero	strd,ln1313
	zero	t38,st271	".V.
	zero	t39,st746	".X.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	equ	ln1313,*-dpda-st1313-1
"
" State 1319
	equ	st1319,*-dpda
	zero	strds,st1313

"
" State 1320
	equ	st1320,*-dpda
	zero	nsrd,ln1320
	zero	t4,-st1745	")
	zero	t14,-st198	"-differ
	zero	t19,-st198	"-inter
	zero	t35,-st198	"-union
	equ	ln1320,*-dpda-st1320-1
"
" State 1325
	equ	st1325,*-dpda
	zero	strd,ln1325
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st1097	"<symbol>
	zero	t51,st763	"[
	equ	ln1325,*-dpda-st1325-1
"
" State 1332
	equ	st1332,*-dpda
	zero	strd,ln1332
	zero	t47,st814	"<symbol>
	equ	ln1332,*-dpda-st1332-1
"
" State 1334
	equ	st1334,*-dpda
	zero	strds,st1332

"
" State 1335
	equ	st1335,*-dpda
	zero	strds,st1332

"
" State 1336
	equ	st1336,*-dpda
	zero	aplyp1,ln1336
	zero	0,0   sd/RFU
	zero	153,st1095	prod/val
	equ	ln1336,*-dpda-st1336-1
"
" State 1339
	equ	st1339,*-dpda
	zero	aplyp1,ln1339
	zero	0,0   sd/RFU
	zero	154,st1095	prod/val
	equ	ln1339,*-dpda-st1339-1
"
" State 1342
	equ	st1342,*-dpda
	zero	strd,ln1342
	zero	t4,st1438	")
	equ	ln1342,*-dpda-st1342-1
"
" State 1344
	equ	st1344,*-dpda
	zero	nsrd,ln1344
	zero	t0,-st1758	"EOI
	zero	t6,-st1688	"+
	zero	t7,-st1758	",
	zero	t8,-st1688	"-
	zero	t11,-st1688	"-ascending
	zero	t13,-st1688	"-descending
	equ	ln1344,*-dpda-st1344-1
"
" State 1351
	equ	st1351,*-dpda
	zero	aplyp,ln1351
	zero	3,3   sd/RFU
	zero	40,st224	prod/val
	zero	st1522,st786
	equ	ln1351,*-dpda-st1351-1
"
" State 1355
	equ	st1355,*-dpda
	zero	aplyp,ln1355
	zero	3,3   sd/RFU
	zero	139,st540	prod/val
	zero	st110,st358
	zero	st118,st358
	zero	st119,st358
	zero	st120,st358
	zero	st121,st358
	zero	st122,st358
	zero	st123,st358
	zero	st165,st586
	zero	st177,st586
	zero	st178,st586
	zero	st179,st586
	zero	st343,st358
	zero	st349,st358
	zero	st546,st586
	zero	st731,st586
	zero	st745,st586
	equ	ln1355,*-dpda-st1355-1
"
" State 1374
	equ	st1374,*-dpda
	zero	aplyp,ln1374
	zero	0,0   sd/RFU
	zero	149,st1016	prod/val
	zero	st1313,st1398
	zero	st1319,st1401
	equ	ln1374,*-dpda-st1374-1
"
" State 1379
	equ	st1379,*-dpda
	zero	aplyps,ln1379
	zero	0,0   sd/RFU
	zero	148,st1374	prod/val
	equ	ln1379,*-dpda-st1379-1
"
" State 1382
	equ	st1382,*-dpda
	zero	aplyps,ln1382
	zero	0,0   sd/RFU
	zero	147,st1374	prod/val
	equ	ln1382,*-dpda-st1382-1
"
" State 1385
	equ	st1385,*-dpda
	zero	strd,ln1385
	zero	t2,st1385	"(
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t33,st63	"-range
	zero	t34,st67	"-select
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st468	"<symbol>
	equ	ln1385,*-dpda-st1385-1
"
" State 1396
	equ	st1396,*-dpda
	zero	strd,ln1396
	zero	t4,st1466	")
	equ	ln1396,*-dpda-st1396-1
"
" State 1398
	equ	st1398,*-dpda
	zero	aplyp1,ln1398
	zero	2,2   sd/RFU
	zero	145,st1018	prod/val
	equ	ln1398,*-dpda-st1398-1
"
" State 1401
	equ	st1401,*-dpda
	zero	aplyp1,ln1401
	zero	2,2   sd/RFU
	zero	146,st1018	prod/val
	equ	ln1401,*-dpda-st1401-1
"
" State 1404
	equ	st1404,*-dpda
	zero	strd,ln1404
	zero	t37,st1335	".
	equ	ln1404,*-dpda-st1404-1
"
" State 1406
	equ	st1406,*-dpda
	zero	aplyp,ln1406
	zero	0,0   sd/RFU
	zero	138,st1422	prod/val
	zero	st1425,st1469
	equ	ln1406,*-dpda-st1406-1
"
" State 1410
	equ	st1410,*-dpda
	zero	aplyps,ln1410
	zero	0,0   sd/RFU
	zero	137,st1406	prod/val
	equ	ln1410,*-dpda-st1410-1
"
" State 1413
	equ	st1413,*-dpda
	zero	aplyps,ln1413
	zero	0,0   sd/RFU
	zero	135,st1406	prod/val
	equ	ln1413,*-dpda-st1413-1
"
" State 1416
	equ	st1416,*-dpda
	zero	aplyps,ln1416
	zero	2,2   sd/RFU
	zero	136,st1406	prod/val
	equ	ln1416,*-dpda-st1416-1
"
" State 1419
	equ	st1419,*-dpda
	zero	aplyps,ln1419
	zero	2,2   sd/RFU
	zero	134,st1406	prod/val
	equ	ln1419,*-dpda-st1419-1
"
" State 1422
	equ	st1422,*-dpda
	zero	aplyp1,ln1422
	zero	0,0   sd/RFU
	zero	132,st1425	prod/val
	equ	ln1422,*-dpda-st1422-1
"
" State 1425
	equ	st1425,*-dpda
	zero	strd,ln1425
	zero	t4,st1472	")
	zero	t38,st271	".V.
	zero	t44,st437	"<bit_string>
	zero	t45,st462	"<integer>
	zero	t46,st465	"<string>
	zero	t47,st1097	"<symbol>
	zero	t51,st763	"[
	equ	ln1425,*-dpda-st1425-1
"
" State 1433
	equ	st1433,*-dpda
	zero	aplyp,ln1433
	zero	2,2   sd/RFU
	zero	125,st1076	prod/val
	zero	st1088,st1342
	zero	st1096,st1444
	equ	ln1433,*-dpda-st1433-1
"
" State 1438
	equ	st1438,*-dpda
	zero	nsrd,ln1438
	zero	t5,-st1062	"*
	zero	t6,-st1062	"+
	zero	t8,-st1062	"-
	zero	t40,-st1062	"/
	zero	t52,-st1083	"]
	equ	ln1438,*-dpda-st1438-1
"
" State 1444
	equ	st1444,*-dpda
	zero	strd,ln1444
	zero	t4,st1062	")
	equ	ln1444,*-dpda-st1444-1
"
" State 1446
	equ	st1446,*-dpda
	zero	aplyp1,ln1446
	zero	3,3   sd/RFU
	zero	26,st774	prod/val
	equ	ln1446,*-dpda-st1446-1
"
" State 1449
	equ	st1449,*-dpda
	zero	nsrd,ln1449
	zero	t4,-st1761	")
	zero	t6,-st1737	"+
	zero	t7,-st1761	",
	zero	t8,-st1737	"-
	equ	ln1449,*-dpda-st1449-1
"
" State 1454
	equ	st1454,*-dpda
	zero	nsrd,ln1454
	zero	t0,-st1764	"EOI
	zero	t1,-st1764	"&
	zero	t4,-st1764	")
	zero	t6,-st1738	"+
	zero	t8,-st1738	"-
	zero	t14,-st1764	"-differ
	zero	t17,-st1764	"-group_by
	zero	t19,-st1764	"-inter
	zero	t30,-st1764	"-order_by
	zero	t35,-st1764	"-union
	zero	t55,-st1764	"|
	equ	ln1454,*-dpda-st1454-1
"
" State 1466
	equ	st1466,*-dpda
	zero	aplyp1,ln1466
	zero	4,4   sd/RFU
	zero	68,st691	prod/val
	equ	ln1466,*-dpda-st1466-1
"
" State 1469
	equ	st1469,*-dpda
	zero	aplyp1,ln1469
	zero	1,1   sd/RFU
	zero	133,st1425	prod/val
	equ	ln1469,*-dpda-st1469-1
"
" State 1472
	equ	st1472,*-dpda
	zero	aplyp,ln1472
	zero	3,3   sd/RFU
	zero	131,st1056	prod/val
	zero	st756,st1065
	zero	st763,st1065
	zero	st1325,st1413
	zero	st1425,st1413
	equ	ln1472,*-dpda-st1472-1
"
" State 1479
	equ	st1479,*-dpda
	zero	strd,ln1479
	zero	t52,st1419	"]
	equ	ln1479,*-dpda-st1479-1
"
" State 1481
	equ	st1481,*-dpda
	zero	strd,ln1481
	zero	t17,st118	"-group_by
	zero	t36,st165	"-where
	equ	ln1481,*-dpda-st1481-1
"
" State 1484
	equ	st1484,*-dpda
	zero	aplyp1,ln1484
	zero	0,0   sd/RFU
	zero	14,st23	prod/val
	equ	ln1484,*-dpda-st1484-1
"
" State 1487
	equ	st1487,*-dpda
	zero	strd,ln1487
	zero	t14,st180	"-differ
	zero	t19,st183	"-inter
	zero	t30,st119	"-order_by
	zero	t35,st186	"-union
	equ	ln1487,*-dpda-st1487-1
"
" State 1492
	equ	st1492,*-dpda
	zero	aplyp1,ln1492
	zero	0,0   sd/RFU
	zero	3,st53	prod/val
	equ	ln1492,*-dpda-st1492-1
"
" State 1495
	equ	st1495,*-dpda
	zero	strd,ln1495
	zero	t2,st110	"(
	zero	t47,st131	"<symbol>
	equ	ln1495,*-dpda-st1495-1
"
" State 1498
	equ	st1498,*-dpda
	zero	strds,st1495

"
" State 1499
	equ	st1499,*-dpda
	zero	strds,st1495

"
" State 1500
	equ	st1500,*-dpda
	zero	aplyp1,ln1500
	zero	0,0   sd/RFU
	zero	4,st50	prod/val
	equ	ln1500,*-dpda-st1500-1
"
" State 1503
	equ	st1503,*-dpda
	zero	strd,ln1503
	zero	t15,st304	"-distinct
	zero	t16,st307	"-dup
	equ	ln1503,*-dpda-st1503-1
"
" State 1506
	equ	st1506,*-dpda
	zero	aplyp1,ln1506
	zero	0,0   sd/RFU
	zero	46,st6	prod/val
	equ	ln1506,*-dpda-st1506-1
"
" State 1509
	equ	st1509,*-dpda
	zero	strd,ln1509
	zero	t41,st312	"::
	equ	ln1509,*-dpda-st1509-1
"
" State 1511
	equ	st1511,*-dpda
	zero	strd,ln1511
	zero	t17,st118	"-group_by
	equ	ln1511,*-dpda-st1511-1
"
" State 1513
	equ	st1513,*-dpda
	zero	aplyp1,ln1513
	zero	0,0   sd/RFU
	zero	18,st162	prod/val
	equ	ln1513,*-dpda-st1513-1
"
" State 1516
	equ	st1516,*-dpda
	zero	aplyp1,ln1516
	zero	1,1   sd/RFU
	zero	5,st50	prod/val
	equ	ln1516,*-dpda-st1516-1
"
" State 1519
	equ	st1519,*-dpda
	zero	aplyp1,ln1519
	zero	0,0   sd/RFU
	zero	36,st238	prod/val
	equ	ln1519,*-dpda-st1519-1
"
" State 1522
	equ	st1522,*-dpda
	zero	strd,ln1522
	zero	t2,st268	"(
	equ	ln1522,*-dpda-st1522-1
"
" State 1524
	equ	st1524,*-dpda
	zero	aplyp1,ln1524
	zero	0,0   sd/RFU
	zero	31,st264	prod/val
	equ	ln1524,*-dpda-st1524-1
"
" State 1527
	equ	st1527,*-dpda
	zero	strd,ln1527
	zero	t3,st789	"(+)
	equ	ln1527,*-dpda-st1527-1
"
" State 1529
	equ	st1529,*-dpda
	zero	strd,ln1529
	zero	t7,st796	",
	equ	ln1529,*-dpda-st1529-1
"
" State 1531
	equ	st1531,*-dpda
	zero	aplyp1,ln1531
	zero	0,0   sd/RFU
	zero	30,st264	prod/val
	equ	ln1531,*-dpda-st1531-1
"
" State 1534
	equ	st1534,*-dpda
	zero	aplyp,ln1534
	zero	0,0   sd/RFU
	zero	164,st341	prod/val
	zero	st63,st209
	zero	st796,st209
	zero	st799,st209
	equ	ln1534,*-dpda-st1534-1
"
" State 1540
	equ	st1540,*-dpda
	zero	strd,ln1540
	zero	t56,st349	"||
	equ	ln1540,*-dpda-st1540-1
"
" State 1542
	equ	st1542,*-dpda
	zero	strds,st1540

"
" State 1543
	equ	st1543,*-dpda
	zero	aplyp,ln1543
	zero	0,0   sd/RFU
	zero	104,st390	prod/val
	zero	st122,st1158
	equ	ln1543,*-dpda-st1543-1
"
" State 1547
	equ	st1547,*-dpda
	zero	aplyps,ln1547
	zero	2,2   sd/RFU
	zero	105,st1543	prod/val
	equ	ln1547,*-dpda-st1547-1
"
" State 1550
	equ	st1550,*-dpda
	zero	strd,ln1550
	zero	t5,st853	"*
	zero	t40,st859	"/
	equ	ln1550,*-dpda-st1550-1
"
" State 1553
	equ	st1553,*-dpda
	zero	strds,st1550

"
" State 1554
	equ	st1554,*-dpda
	zero	strds,st1550

"
" State 1555
	equ	st1555,*-dpda
	zero	strds,st1550

"
" State 1556
	equ	st1556,*-dpda
	zero	aplyp,ln1556
	zero	0,0   sd/RFU
	zero	102,st405	prod/val
	zero	st118,st506
	zero	st119,st767
	zero	st120,st876
	zero	st123,st1344
	equ	ln1556,*-dpda-st1556-1
"
" State 1563
	equ	st1563,*-dpda
	zero	aplyps,ln1563
	zero	2,2   sd/RFU
	zero	103,st1556	prod/val
	equ	ln1563,*-dpda-st1563-1
"
" State 1566
	equ	st1566,*-dpda
	zero	strd,ln1566
	zero	t37,st880	".
	equ	ln1566,*-dpda-st1566-1
"
" State 1568
	equ	st1568,*-dpda
	zero	aplyp,ln1568
	zero	0,0   sd/RFU
	zero	168,st314	prod/val
	zero	st756,st1045
	zero	st763,st1045
	zero	st1088,st1045
	zero	st1095,st1045
	zero	st1096,st1045
	zero	st1325,st1045
	zero	st1425,st1045
	equ	ln1568,*-dpda-st1568-1
"
" State 1578
	equ	st1578,*-dpda
	zero	look,ln1578
	zero	t47,-st1580	"<symbol>
	equ	ln1578,*-dpda-st1578-1
"
" State 1580
	equ	st1580,*-dpda
	zero	look,ln1580
	zero	t0,-st1566	"EOI
	zero	t1,-st1566	"&
	zero	t4,-st1566	")
	zero	t5,-st1566	"*
	zero	t6,-st1566	"+
	zero	t7,-st1566	",
	zero	t8,-st1566	"-
	zero	t11,-st1566	"-ascending
	zero	t13,-st1566	"-descending
	zero	t14,-st1566	"-differ
	zero	t17,-st1566	"-group_by
	zero	t18,-st1566	"-having
	zero	t19,-st1566	"-inter
	zero	t20,-st1566	"-is_between
	zero	t21,-st1566	"-is_in
	zero	t22,-st1566	"-is_like
	zero	t23,-st1566	"-is_not_between
	zero	t24,-st1566	"-is_not_in
	zero	t25,-st1566	"-is_not_like
	zero	t26,-st1566	"-is_not_null
	zero	t27,-st1566	"-is_null
	zero	t30,-st1566	"-order_by
	zero	t35,-st1566	"-union
	zero	t37,-st1534	".
	zero	t40,-st1566	"/
	zero	t42,-st1566	"<
	zero	t43,-st1566	"<=
	zero	t48,-st1566	"=
	zero	t49,-st1566	">
	zero	t50,-st1566	">=
	zero	t54,-st1566	"^=
	zero	t55,-st1566	"|
	zero	t56,-st1566	"||
	equ	ln1580,*-dpda-st1580-1
"
" State 1614
	equ	st1614,*-dpda
	zero	strd,ln1614
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t18,st177	"-having
	equ	ln1614,*-dpda-st1614-1
"
" State 1618
	equ	st1618,*-dpda
	zero	aplyp,ln1618
	zero	1,1   sd/RFU
	zero	21,st159	prod/val
	zero	st1511,st503
	equ	ln1618,*-dpda-st1618-1
"
" State 1622
	equ	st1622,*-dpda
	zero	aplyps,ln1622
	zero	3,3   sd/RFU
	zero	22,st1618	prod/val
	equ	ln1622,*-dpda-st1622-1
"
" State 1625
	equ	st1625,*-dpda
	zero	strd,ln1625
	zero	t26,st885	"-is_not_null
	zero	t27,st888	"-is_null
	equ	ln1625,*-dpda-st1625-1
"
" State 1628
	equ	st1628,*-dpda
	zero	aplyp1,ln1628
	zero	0,0   sd/RFU
	zero	81,st679	prod/val
	equ	ln1628,*-dpda-st1628-1
"
" State 1631
	equ	st1631,*-dpda
	zero	aplyp1,ln1631
	zero	0,0   sd/RFU
	zero	82,st679	prod/val
	equ	ln1631,*-dpda-st1631-1
"
" State 1634
	equ	st1634,*-dpda
	zero	strd,ln1634
	zero	t56,st564	"||
	equ	ln1634,*-dpda-st1634-1
"
" State 1636
	equ	st1636,*-dpda
	zero	strds,st1634

"
" State 1637
	equ	st1637,*-dpda
	zero	aplyp,ln1637
	zero	0,0   sd/RFU
	zero	115,st641	prod/val
	zero	st847,st1214
	equ	ln1637,*-dpda-st1637-1
"
" State 1641
	equ	st1641,*-dpda
	zero	aplyps,ln1641
	zero	2,2   sd/RFU
	zero	116,st1637	prod/val
	equ	ln1641,*-dpda-st1641-1
"
" State 1644
	equ	st1644,*-dpda
	zero	aplyp,ln1644
	zero	0,0   sd/RFU
	zero	113,st666	prod/val
	zero	st731,st1021
	zero	st745,st1021
	zero	st836,st1135
	zero	st845,st1184
	zero	st848,st1239
	zero	st849,st1449
	zero	st850,st1454
	zero	st897,st1246
	zero	st926,st1267
	zero	st1282,st1184
	zero	st1385,st1184
	equ	ln1644,*-dpda-st1644-1
"
" State 1658
	equ	st1658,*-dpda
	zero	aplyps,ln1658
	zero	2,2   sd/RFU
	zero	114,st1644	prod/val
	equ	ln1658,*-dpda-st1658-1
"
" State 1661
	equ	st1661,*-dpda
	zero	strd,ln1661
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t20,st891	"-is_between
	zero	t23,st894	"-is_not_between
	equ	ln1661,*-dpda-st1661-1
"
" State 1666
	equ	st1666,*-dpda
	zero	strd,ln1666
	zero	t1,st963	"&
	equ	ln1666,*-dpda-st1666-1
"
" State 1668
	equ	st1668,*-dpda
	zero	strds,st1666

"
" State 1669
	equ	st1669,*-dpda
	zero	aplyp,ln1669
	zero	0,0   sd/RFU
	zero	59,st1037	prod/val
	zero	st165,st722
	zero	st177,st1176
	equ	ln1669,*-dpda-st1669-1
"
" State 1674
	equ	st1674,*-dpda
	zero	aplyps,ln1674
	zero	2,2   sd/RFU
	zero	60,st1669	prod/val
	equ	ln1674,*-dpda-st1674-1
"
" State 1677
	equ	st1677,*-dpda
	zero	strd,ln1677
	zero	t55,st967	"|
	equ	ln1677,*-dpda-st1677-1
"
" State 1679
	equ	st1679,*-dpda
	zero	strds,st1677

"
" State 1680
	equ	st1680,*-dpda
	zero	aplyp1,ln1680
	zero	1,1   sd/RFU
	zero	58,st151	prod/val
	equ	ln1680,*-dpda-st1680-1
"
" State 1683
	equ	st1683,*-dpda
	zero	strd,ln1683
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t11,st1103	"-ascending
	zero	t13,st1107	"-descending
	equ	ln1683,*-dpda-st1683-1
"
" State 1688
	equ	st1688,*-dpda
	zero	strds,st1683

"
" State 1689
	equ	st1689,*-dpda
	zero	aplyp1,ln1689
	zero	0,0   sd/RFU
	zero	23,st774	prod/val
	equ	ln1689,*-dpda-st1689-1
"
" State 1692
	equ	st1692,*-dpda
	zero	strd,ln1692
	zero	t7,st123	",
	equ	ln1692,*-dpda-st1692-1
"
" State 1694
	equ	st1694,*-dpda
	zero	aplyp1,ln1694
	zero	2,2   sd/RFU
	zero	2,st53	prod/val
	equ	ln1694,*-dpda-st1694-1
"
" State 1697
	equ	st1697,*-dpda
	zero	strd,ln1697
	zero	t5,st1129	"*
	equ	ln1697,*-dpda-st1697-1
"
" State 1699
	equ	st1699,*-dpda
	zero	aplyp1,ln1699
	zero	2,2   sd/RFU
	zero	56,st78	prod/val
	equ	ln1699,*-dpda-st1699-1
"
" State 1702
	equ	st1702,*-dpda
	zero	strd,ln1702
	zero	t5,st1173	"*
	equ	ln1702,*-dpda-st1702-1
"
" State 1704
	equ	st1704,*-dpda
	zero	aplyp1,ln1704
	zero	2,2   sd/RFU
	zero	54,st78	prod/val
	equ	ln1704,*-dpda-st1704-1
"
" State 1707
	equ	st1707,*-dpda
	zero	strd,ln1707
	zero	t9,st1261	"-all_of
	zero	t10,st1264	"-any_of
	equ	ln1707,*-dpda-st1707-1
"
" State 1710
	equ	st1710,*-dpda
	zero	aplyp1,ln1710
	zero	0,0   sd/RFU
	zero	91,st926	prod/val
	equ	ln1710,*-dpda-st1710-1
"
" State 1713
	equ	st1713,*-dpda
	zero	strd,ln1713
	zero	t7,st1319	",
	equ	ln1713,*-dpda-st1713-1
"
" State 1715
	equ	st1715,*-dpda
	zero	aplyp,ln1715
	zero	0,0   sd/RFU
	zero	77,st1035	prod/val
	zero	st1294,st1396
	equ	ln1715,*-dpda-st1715-1
"
" State 1719
	equ	st1719,*-dpda
	zero	aplyps,ln1719
	zero	0,0   sd/RFU
	zero	76,st1715	prod/val
	equ	ln1719,*-dpda-st1719-1
"
" State 1722
	equ	st1722,*-dpda
	zero	strd,ln1722
	zero	t4,st543	")
	zero	t6,st409	"+
	zero	t8,st434	"-
	zero	t20,st891	"-is_between
	zero	t23,st894	"-is_not_between
	equ	ln1722,*-dpda-st1722-1
"
" State 1728
	equ	st1728,*-dpda
	zero	strd,ln1728
	zero	t14,st180	"-differ
	zero	t19,st183	"-inter
	zero	t35,st186	"-union
	equ	ln1728,*-dpda-st1728-1
"
" State 1732
	equ	st1732,*-dpda
	zero	strd,ln1732
	zero	t6,st409	"+
	zero	t8,st434	"-
	equ	ln1732,*-dpda-st1732-1
"
" State 1735
	equ	st1735,*-dpda
	zero	strds,st1732

"
" State 1736
	equ	st1736,*-dpda
	zero	strds,st1732

"
" State 1737
	equ	st1737,*-dpda
	zero	strds,st1732

"
" State 1738
	equ	st1738,*-dpda
	zero	strds,st1732

"
" State 1739
	equ	st1739,*-dpda
	zero	aplyp1,ln1739
	zero	0,0   sd/RFU
	zero	140,st1132	prod/val
	equ	ln1739,*-dpda-st1739-1
"
" State 1742
	equ	st1742,*-dpda
	zero	aplyp1,ln1742
	zero	0,0   sd/RFU
	zero	100,st1258	prod/val
	equ	ln1742,*-dpda-st1742-1
"
" State 1745
	equ	st1745,*-dpda
	zero	look,ln1745
	zero	t4,-st198	")
	zero	t14,-st198	"-differ
	zero	t19,-st198	"-inter
	zero	t21,-st1719	"-is_in
	zero	t24,-st1719	"-is_not_in
	zero	t35,-st198	"-union
	zero	t42,-st1719	"<
	zero	t43,-st1719	"<=
	zero	t48,-st1719	"=
	zero	t49,-st1719	">
	zero	t50,-st1719	">=
	zero	t54,-st1719	"^=
	equ	ln1745,*-dpda-st1745-1
"
" State 1758
	equ	st1758,*-dpda
	zero	aplyp1,ln1758
	zero	2,2   sd/RFU
	zero	25,st774	prod/val
	equ	ln1758,*-dpda-st1758-1
"
" State 1761
	equ	st1761,*-dpda
	zero	aplyp1,ln1761
	zero	2,2   sd/RFU
	zero	141,st1132	prod/val
	equ	ln1761,*-dpda-st1761-1
"
" State 1764
	equ	st1764,*-dpda
	zero	aplyp1,ln1764
	zero	4,4   sd/RFU
	zero	71,st691	prod/val
	equ	ln1764,*-dpda-st1764-1
	equ	dpda_size,*-dpda-1

"
"
"	Skip Table
skip:	zero	0,skip_size
	segdef	skip

	zero	0,0
	zero	0,0
	equ	skip_size,*-skip-1

	segdef	standard_prelude
standard_prelude:
	zero	0,0
"
"
"	Production Names Table
pn: production_names:
	zero	0,169
	segdef	production_names
	zero	-1,-1
	zero	-1,-2
	zero	-2,-3
	zero	-4,-4
	zero	-5,-5
	zero	-5,-6
	zero	-6,-7
	zero	-7,-8
	zero	-8,-9
	zero	-9,-9
	zero	-10,-10
	zero	-11,-11
	zero	-11,-11
	zero	-12,-12
	zero	-13,-14
	zero	-14,-15
	zero	-15,-16
	zero	-16,-17
	zero	-17,-18
	zero	-18,-19
	zero	-20,-20
	zero	-20,-21
	zero	-21,-22
	zero	-22,-22
	zero	-23,-23
	zero	-24,-24
	zero	-25,-25
	zero	-25,-25
	zero	-25,-26
	zero	-27,-27
	zero	-28,-28
	zero	-29,-29
	zero	-30,-30
	zero	-31,-31
	zero	-31,-31
	zero	-31,-32
	zero	-32,-32
	zero	-32,-33
	zero	-33,-34
	zero	-34,-34
	zero	-35,-35
	zero	-36,-36
	zero	-37,-37
	zero	-38,-38
	zero	-39,-39
	zero	-40,-40
	zero	-40,-41
	zero	-41,-41
	zero	-41,-41
	zero	-41,-42
	zero	-42,-43
	zero	-43,-44
	zero	-44,-45
	zero	-45,-45
	zero	-46,-46
	zero	-46,-46
	zero	-47,-47
	zero	-48,-48
	zero	-49,-49
	zero	-49,-50
	zero	-50,-50
	zero	-50,-50
	zero	-51,-52
	zero	-52,-52
	zero	-52,-52
	zero	-53,-54
	zero	-54,-55
	zero	-55,-55
	zero	-55,-55
	zero	-56,-57
	zero	-57,-58
	zero	-58,-58
	zero	-59,-59
	zero	-60,-60
	zero	-60,-61
	zero	-61,-61
	zero	-62,-62
	zero	-63,-63
	zero	-64,-64
	zero	-65,-66
	zero	-67,-68
	zero	-69,-70
	zero	-71,-72
	zero	-73,-74
	zero	-75,0
"
"
"	Variables Tables       
"
	use	uvc
vc: variable_characters:
	zero	0,4*variable_characters_size
	segdef	variable_characters
"
	use	uvl
vl: variables_list:
	zero	0,variables_list_size
	segdef	variables_list
"
"	Variable 1 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ecti"
	aci	"on_e"
	aci	"xpre"
	aci	"ssio"
	aci	"n>  "
	use	uvl
	equ	v1,*-vl
	zero	4*vsl+1,22
"
"	Variable 2 
	use	uvc
	set	vsl,*-vc-1
	aci	"<cur"
	aci	"rent"
	aci	"_cla"
	aci	"use>"
	use	uvl
	equ	v2,*-vl
	zero	4*vsl+1,16
"
"	Variable 3 
	use	uvc
	set	vsl,*-vc-1
	aci	"<cur"
	aci	"rent"
	aci	"_hea"
	aci	"der>"
	use	uvl
	equ	v3,*-vl
	zero	4*vsl+1,16
"
"	Variable 4 
	use	uvc
	set	vsl,*-vc-1
	aci	"<que"
	aci	"ry> "
	use	uvl
	equ	v4,*-vl
	zero	4*vsl+1,7
"
"	Variable 5 
	use	uvc
	set	vsl,*-vc-1
	aci	"<set"
	aci	"_op>"
	use	uvl
	equ	v5,*-vl
	zero	4*vsl+1,8
"
"	Variable 6 
	use	uvc
	set	vsl,*-vc-1
	aci	"<que"
	aci	"ry_e"
	aci	"xpre"
	aci	"ssio"
	aci	"n>  "
	use	uvl
	equ	v6,*-vl
	zero	4*vsl+1,18
"
"	Variable 7 
	use	uvc
	set	vsl,*-vc-1
	aci	"<que"
	aci	"ry_c"
	aci	"laus"
	aci	"e>  "
	use	uvl
	equ	v7,*-vl
	zero	4*vsl+1,14
"
"	Variable 8 
	use	uvc
	set	vsl,*-vc-1
	aci	"<req"
	aci	"uire"
	aci	"d_cl"
	aci	"ause"
	aci	">   "
	use	uvl
	equ	v8,*-vl
	zero	4*vsl+1,17
"
"	Variable 9 
	use	uvc
	set	vsl,*-vc-1
	aci	"<opt"
	aci	"iona"
	aci	"l_cl"
	aci	"ause"
	aci	"s>  "
	use	uvl
	equ	v9,*-vl
	zero	4*vsl+1,18
"
"	Variable 10 
	use	uvc
	set	vsl,*-vc-1
	aci	"<gro"
	aci	"up_c"
	aci	"laus"
	aci	"e>  "
	use	uvl
	equ	v10,*-vl
	zero	4*vsl+1,14
"
"	Variable 11 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ord"
	aci	"er_s"
	aci	"pec_"
	aci	"list"
	aci	">   "
	use	uvl
	equ	v11,*-vl
	zero	4*vsl+1,17
"
"	Variable 12 
	use	uvc
	set	vsl,*-vc-1
	aci	"<dir"
	aci	"ecti"
	aci	"on> "
	use	uvl
	equ	v12,*-vl
	zero	4*vsl+1,11
"
"	Variable 13 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ran"
	aci	"ge_c"
	aci	"laus"
	aci	"e>  "
	use	uvl
	equ	v13,*-vl
	zero	4*vsl+1,14
"
"	Variable 14 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ran"
	aci	"ge_d"
	aci	"ef_l"
	aci	"ist>"
	use	uvl
	equ	v14,*-vl
	zero	4*vsl+1,16
"
"	Variable 15 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sql"
	aci	"_ran"
	aci	"ge_d"
	aci	"ef_l"
	aci	"ist>"
	use	uvl
	equ	v15,*-vl
	zero	4*vsl+1,20
"
"	Variable 16 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sql"
	aci	"_ran"
	aci	"ge> "
	use	uvl
	equ	v16,*-vl
	zero	4*vsl+1,11
"
"	Variable 17 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sql"
	aci	"_ran"
	aci	"ge_i"
	aci	"tem>"
	use	uvl
	equ	v17,*-vl
	zero	4*vsl+1,16
"
"	Variable 18 
	use	uvc
	set	vsl,*-vc-1
	aci	"<dsl"
	aci	"_ran"
	aci	"ge_d"
	aci	"ef_l"
	aci	"ist>"
	use	uvl
	equ	v18,*-vl
	zero	4*vsl+1,20
"
"	Variable 19 
	use	uvc
	set	vsl,*-vc-1
	aci	"<dsl"
	aci	"_ran"
	aci	"ge_i"
	aci	"tem>"
	use	uvl
	equ	v19,*-vl
	zero	4*vsl+1,16
"
"	Variable 20 
	use	uvc
	set	vsl,*-vc-1
	aci	"<rel"
	aci	"atio"
	aci	"n_id"
	aci	">   "
	use	uvl
	equ	v20,*-vl
	zero	4*vsl+1,13
"
"	Variable 21 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ect_"
	aci	"clau"
	aci	"se> "
	use	uvl
	equ	v21,*-vl
	zero	4*vsl+1,15
"
"	Variable 22 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ect_"
	aci	"head"
	aci	"er> "
	use	uvl
	equ	v22,*-vl
	zero	4*vsl+1,15
"
"	Variable 23 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ect_"
	aci	"list"
	aci	">   "
	use	uvl
	equ	v23,*-vl
	zero	4*vsl+1,13
"
"	Variable 24 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ect_"
	aci	"item"
	aci	">   "
	use	uvl
	equ	v24,*-vl
	zero	4*vsl+1,13
"
"	Variable 25 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sel"
	aci	"ect_"
	aci	"id> "
	use	uvl
	equ	v25,*-vl
	zero	4*vsl+1,11
"
"	Variable 26 
	use	uvc
	set	vsl,*-vc-1
	aci	"<whe"
	aci	"re_c"
	aci	"laus"
	aci	"e>  "
	use	uvl
	equ	v26,*-vl
	zero	4*vsl+1,14
"
"	Variable 27 
	use	uvc
	set	vsl,*-vc-1
	aci	"<qua"
	aci	"lifi"
	aci	"er> "
	use	uvl
	equ	v27,*-vl
	zero	4*vsl+1,11
"
"	Variable 28 
	use	uvc
	set	vsl,*-vc-1
	aci	"<qua"
	aci	"lifi"
	aci	"er_t"
	aci	"erm>"
	use	uvl
	equ	v28,*-vl
	zero	4*vsl+1,16
"
"	Variable 29 
	use	uvc
	set	vsl,*-vc-1
	aci	"<qua"
	aci	"lifi"
	aci	"er_f"
	aci	"acto"
	aci	"r>  "
	use	uvl
	equ	v29,*-vl
	zero	4*vsl+1,18
"
"	Variable 30 
	use	uvc
	set	vsl,*-vc-1
	aci	"<pre"
	aci	"dica"
	aci	"te> "
	use	uvl
	equ	v30,*-vl
	zero	4*vsl+1,11
"
"	Variable 31 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ter"
	aci	"m>  "
	use	uvl
	equ	v31,*-vl
	zero	4*vsl+1,6
"
"	Variable 32 
	use	uvc
	set	vsl,*-vc-1
	aci	"<exp"
	aci	"r_or"
	aci	"_que"
	aci	"ry> "
	use	uvl
	equ	v32,*-vl
	zero	4*vsl+1,15
"
"	Variable 33 
	use	uvc
	set	vsl,*-vc-1
	aci	"<que"
	aci	"ry_l"
	aci	"iter"
	aci	"al> "
	use	uvl
	equ	v33,*-vl
	zero	4*vsl+1,15
"
"	Variable 34 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_fun"
	aci	"c_or"
	aci	"_exp"
	aci	"r>  "
	use	uvl
	equ	v34,*-vl
	zero	4*vsl+1,18
"
"	Variable 35 
	use	uvc
	set	vsl,*-vc-1
	aci	"<lik"
	aci	"e_it"
	aci	"em> "
	use	uvl
	equ	v35,*-vl
	zero	4*vsl+1,11
"
"	Variable 36 
	use	uvc
	set	vsl,*-vc-1
	aci	"<is_"
	aci	"in> "
	use	uvl
	equ	v36,*-vl
	zero	4*vsl+1,7
"
"	Variable 37 
	use	uvc
	set	vsl,*-vc-1
	aci	"<lik"
	aci	"e>  "
	use	uvl
	equ	v37,*-vl
	zero	4*vsl+1,6
"
"	Variable 38 
	use	uvc
	set	vsl,*-vc-1
	aci	"<is_"
	aci	"null"
	aci	">   "
	use	uvl
	equ	v38,*-vl
	zero	4*vsl+1,9
"
"	Variable 39 
	use	uvc
	set	vsl,*-vc-1
	aci	"<bet"
	aci	"ween"
	aci	">   "
	use	uvl
	equ	v39,*-vl
	zero	4*vsl+1,9
"
"	Variable 40 
	use	uvc
	set	vsl,*-vc-1
	aci	"<com"
	aci	"p_op"
	aci	">   "
	use	uvl
	equ	v40,*-vl
	zero	4*vsl+1,9
"
"	Variable 41 
	use	uvc
	set	vsl,*-vc-1
	aci	"<rel"
	aci	"_op>"
	use	uvl
	equ	v41,*-vl
	zero	4*vsl+1,8
"
"	Variable 42 
	use	uvc
	set	vsl,*-vc-1
	aci	"<reg"
	aci	"ular"
	aci	"_exp"
	aci	"r>  "
	use	uvl
	equ	v42,*-vl
	zero	4*vsl+1,14
"
"	Variable 43 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sim"
	aci	"ple_"
	aci	"expr"
	aci	">   "
	use	uvl
	equ	v43,*-vl
	zero	4*vsl+1,13
"
"	Variable 44 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sim"
	aci	"ple_"
	aci	"arit"
	aci	"h_te"
	aci	"rm> "
	use	uvl
	equ	v44,*-vl
	zero	4*vsl+1,19
"
"	Variable 45 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sim"
	aci	"ple_"
	aci	"arit"
	aci	"h_fa"
	aci	"ctor"
	aci	">   "
	use	uvl
	equ	v45,*-vl
	zero	4*vsl+1,21
"
"	Variable 46 
	use	uvc
	set	vsl,*-vc-1
	aci	"<sim"
	aci	"ple_"
	aci	"prim"
	aci	"ary>"
	use	uvl
	equ	v46,*-vl
	zero	4*vsl+1,16
"
"	Variable 47 
	use	uvc
	set	vsl,*-vc-1
	aci	"<exp"
	aci	"r>  "
	use	uvl
	equ	v47,*-vl
	zero	4*vsl+1,6
"
"	Variable 48 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ari"
	aci	"th_t"
	aci	"erm>"
	use	uvl
	equ	v48,*-vl
	zero	4*vsl+1,12
"
"	Variable 49 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ari"
	aci	"th_f"
	aci	"acto"
	aci	"r>  "
	use	uvl
	equ	v49,*-vl
	zero	4*vsl+1,14
"
"	Variable 50 
	use	uvc
	set	vsl,*-vc-1
	aci	"<pri"
	aci	"mary"
	aci	">   "
	use	uvl
	equ	v50,*-vl
	zero	4*vsl+1,9
"
"	Variable 51 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_exp"
	aci	"r>  "
	use	uvl
	equ	v51,*-vl
	zero	4*vsl+1,10
"
"	Variable 52 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_pri"
	aci	"mary"
	aci	">   "
	use	uvl
	equ	v52,*-vl
	zero	4*vsl+1,13
"
"	Variable 53 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_fun"
	aci	"ctio"
	aci	"n>  "
	use	uvl
	equ	v53,*-vl
	zero	4*vsl+1,14
"
"	Variable 54 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_arg"
	aci	"_lis"
	aci	"t>  "
	use	uvl
	equ	v54,*-vl
	zero	4*vsl+1,14
"
"	Variable 55 
	use	uvc
	set	vsl,*-vc-1
	aci	"<old"
	aci	"_arg"
	aci	">   "
	use	uvl
	equ	v55,*-vl
	zero	4*vsl+1,9
"
"	Variable 56 
	use	uvc
	set	vsl,*-vc-1
	aci	"<fun"
	aci	"ctio"
	aci	"n>  "
	use	uvl
	equ	v56,*-vl
	zero	4*vsl+1,10
"
"	Variable 57 
	use	uvc
	set	vsl,*-vc-1
	aci	"<arg"
	aci	"_lis"
	aci	"t>  "
	use	uvl
	equ	v57,*-vl
	zero	4*vsl+1,10
"
"	Variable 58 
	use	uvc
	set	vsl,*-vc-1
	aci	"<att"
	aci	"ribu"
	aci	"te_s"
	aci	"pec>"
	use	uvl
	equ	v58,*-vl
	zero	4*vsl+1,16
"
"	Variable 59 
	use	uvc
	set	vsl,*-vc-1
	aci	"<con"
	aci	"stan"
	aci	"t_li"
	aci	"st> "
	use	uvl
	equ	v59,*-vl
	zero	4*vsl+1,15
"
"	Variable 60 
	use	uvc
	set	vsl,*-vc-1
	aci	"<con"
	aci	"stan"
	aci	"t_it"
	aci	"em> "
	use	uvl
	equ	v60,*-vl
	zero	4*vsl+1,15
"
"	Variable 61 
	use	uvc
	set	vsl,*-vc-1
	aci	"<con"
	aci	"stan"
	aci	"t>  "
	use	uvl
	equ	v61,*-vl
	zero	4*vsl+1,10
"
"	Variable 62 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ari"
	aci	"th_o"
	aci	"p>  "
	use	uvl
	equ	v62,*-vl
	zero	4*vsl+1,10
"
"	Variable 63 
	use	uvc
	set	vsl,*-vc-1
	aci	"<add"
	aci	"_op>"
	use	uvl
	equ	v63,*-vl
	zero	4*vsl+1,8
"
"	Variable 64 
	use	uvc
	set	vsl,*-vc-1
	aci	"<mul"
	aci	"t_op"
	aci	">   "
	use	uvl
	equ	v64,*-vl
	zero	4*vsl+1,9
"
"	Variable 65 
	use	uvc
	set	vsl,*-vc-1
	aci	"<and"
	aci	"_op>"
	use	uvl
	equ	v65,*-vl
	zero	4*vsl+1,8
"
"	Variable 66 
	use	uvc
	set	vsl,*-vc-1
	aci	"<or_"
	aci	"op> "
	use	uvl
	equ	v66,*-vl
	zero	4*vsl+1,7
"
"	Variable 67 
	use	uvc
	set	vsl,*-vc-1
	aci	"<not"
	aci	"_op>"
	use	uvl
	equ	v67,*-vl
	zero	4*vsl+1,8
"
"	Variable 68 
	use	uvc
	set	vsl,*-vc-1
	aci	"<v_a"
	aci	"rg_s"
	aci	"ubst"
	aci	"itut"
	aci	"ion>"
	use	uvl
	equ	v68,*-vl
	zero	4*vsl+1,20
"
"	Variable 69 
	use	uvc
	set	vsl,*-vc-1
	aci	"<x_a"
	aci	"rg_s"
	aci	"ubst"
	aci	"itut"
	aci	"ion>"
	use	uvl
	equ	v69,*-vl
	zero	4*vsl+1,20
"
"	Variable 70 
	use	uvc
	set	vsl,*-vc-1
	aci	"<db_"
	aci	"labe"
	aci	"l>  "
	use	uvl
	equ	v70,*-vl
	zero	4*vsl+1,10
"
"	Variable 71 
	use	uvc
	set	vsl,*-vc-1
	aci	"<rel"
	aci	"atio"
	aci	"n>  "
	use	uvl
	equ	v71,*-vl
	zero	4*vsl+1,10
"
"	Variable 72 
	use	uvc
	set	vsl,*-vc-1
	aci	"<rel"
	aci	"atio"
	aci	"n_la"
	aci	"bel>"
	use	uvl
	equ	v72,*-vl
	zero	4*vsl+1,16
"
"	Variable 73 
	use	uvc
	set	vsl,*-vc-1
	aci	"<att"
	aci	"ribu"
	aci	"te> "
	use	uvl
	equ	v73,*-vl
	zero	4*vsl+1,11
"
"	Variable 74 
	use	uvc
	set	vsl,*-vc-1
	aci	"<fn_"
	aci	"name"
	aci	">   "
	use	uvl
	equ	v74,*-vl
	zero	4*vsl+1,9
"
"	Variable 75 
	use	uvc
	set	vsl,*-vc-1
	aci	"<ali"
	aci	"as> "
	use	uvl
	equ	v75,*-vl
	zero	4*vsl+1,7
"
	use	uvc
	equ	variable_characters_size,*-vc-1
	use	uvl
	equ	variables_list_size,*-vl-1

	use	text
	segdef	object_def
object_def:
	aci	"lpio001",8
	zero	-1,terminals_hash_list-object_def
	zero	-1,terminals_list-object_def
	zero	-1,terminal_characters-object_def
	zero	-1,dpda-object_def
	zero	-1,skip-object_def
	zero	-1,standard_prelude-object_def
	zero	-1,production_names-object_def
	zero	-1,variables_list-object_def
	zero	-1,variable_characters-object_def
	zero	0,0
	end




		    mrds_dsl_thread_fn_list.pl1     08/01/88  1347.6r w 08/01/88  1315.0       49356



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

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

mrds_dsl_thread_fn_list: proc (dbcb_ptr, fn_entry, code);

/* NOTES:

   Procedure to fill in a scalfn_info block for a builtin or declared scalar
   function, given a pointer to the entry in the text portion of the object
   segment.
*/

/* HISTORY:

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

   80-11-17 Rickie E. Brinegar: Modified to accept an initiated entry in the
   form of fn_entry instead of a pointer to the initiated segment.
*/

%include mrds_dbcb;

%include definition;

%include entry_sequence_info;

%include object_info;

%include mrds_scalfn_info;

%include mdbm_seg_area;

	dcl     (b_ptr,				/* pointer to base of object */
	        d_ptr,				/* ptr to definition block */
	        e_ptr,				/* pointer to entry sequence */
	        pd_ptr,				/* pointer to parameter descriptor offsets */
	        s_ptr)		 ptr;		/* pointer to seg. definition block */

	dcl     fn_entry		 entry variable;	/* Input: initiated function entry */

	dcl     i			 fixed bin;	/* internal index */

	dcl     (code,				/* Output: status code */
	        icode)		 fixed bin (35);	/* internal status code */

	dcl     name		 char (32) var;	/* function name */
	dcl     1 obj_info		 aligned like object_info; /* place for object information */
	dcl     bc		 fixed bin (24);	/* bit count of object seg */
	dcl     stype		 fixed bin (2);	/* type code of object seg */
	dcl     1 acc		 aligned based,	/* template for acc string */
		2 len		 fixed bin (8) unal,
		2 string		 char (0 refer (acc.len)) unal;
	dcl     bit36		 bit (36) based;	/* template for descriptor */

	dcl     mrds_error_$cant_ref_fun fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

	dcl     (addr,
	        addrel,
	        codeptr,
	        fixed,
	        null,
	        ptr,
	        rel)		 builtin;

	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	dcl     get_definition_	 entry (ptr, char (*), char (*), ptr, fixed bin (35));

	sfi_ptr = null;				/* initiallize */


	b_ptr = ptr (codeptr (fn_entry), 0);		/* point to base of object */
	call hcs_$status_mins (b_ptr, stype, bc, icode);	/* get bit count of object */
	if icode ^= 0 then call error (mrds_error_$cant_ref_fun);
	call object_info_$brief (b_ptr, bc, addr (obj_info), icode); /* get info on obj seg */
	if icode ^= 0 then call error (mrds_error_$cant_ref_fun);
	e_ptr = addrel (codeptr (fn_entry), -2);	/* point to entry sequence */
	if e_ptr -> entry_sequence.flags.has_descriptors then do; /* if have args */
		pd_ptr = addrel (obj_info.textp, e_ptr -> entry_sequence.descr_relp_offset); /* point to parameter descriptors */
		nsfi_args_init = fixed (pd_ptr -> parm_desc_ptrs.n_args) - 1; /* no. input args */
	     end;
	else nsfi_args_init = 0;
	allocate scalfn_info in (dbcb.static_area);	/* allocate. an info block */
	scalfn_info.fwd_ptr = dbcb.sfi_ptr;		/* fill in the block */
	scalfn_info.entry_ptr = codeptr (fn_entry);
	d_ptr = addrel (obj_info.defp, e_ptr -> entry_sequence.def_relp); /* point to def. block */
	name = addrel (obj_info.defp, d_ptr -> definition.symbol) -> acc.string; /* function name */
	scalfn_info.name = name;

	if e_ptr -> entry_sequence.flags.has_descriptors then do; /* if fixed input */
		scalfn_info.info_ent_ptr = null;	/* no info entry in this case */
		scalfn_info.rslt_desc = addrel (obj_info.textp, pd_ptr -> parm_desc_ptrs.descriptor_relp
		     (nsfi_args_init + 1)) -> bit36;	/* last arg is result */
		do i = 1 to scalfn_info.nargs;	/* fill in input descriptors */
		     scalfn_info.arg_desc (i) = addrel (obj_info.textp, pd_ptr -> parm_desc_ptrs.descriptor_relp (i)) -> bit36;
		end;
	     end;					/* if fixed args */

	else do;					/* no descriptors, variable args */
		scalfn_info.rslt_desc = "0"b;
		scalfn_info.nargs = 0;
		s_ptr = addrel (obj_info.defp, d_ptr -> definition.segname); /* point to def. block for seg. */
		call get_definition_ (obj_info.defp, addrel (obj_info.defp, s_ptr -> definition.symbol) -> acc.string,
		     name || "_info", d_ptr, icode);	/* definition of corr. info entry */
		if icode ^= 0 then call error (mrds_error_$cant_ref_fun);
		scalfn_info.info_ent_ptr = addrel (obj_info.textp, d_ptr -> definition.value);
	     end;					/* if variable args */

	dbcb.sfi_ptr = sfi_ptr;			/* put block at head of list */
	code = 0;
exit:	return;

error: proc (cd);

/* error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;

     end mrds_dsl_thread_fn_list;




		    mrds_dsl_translate.pl1          10/24/88  1651.7r w 10/24/88  1359.3      222363



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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     Added a call to the error procedure for the else clause error
     checking after the call to
     transaction_manager_$get_current_txn_id (mrds #143).
  2) change(85-11-20,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-11-15 by
     Hergert.
  3) change(86-07-16,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     85-11-22 Hergert: Removed all references to var_exists_ptr. Moved
     variable var_exists into select_list structure.  This was done to
     fix the bug where compiled set expressions that referenced a different
     set of relations would fail to execute properly. (mrds #158)
  4) change(86-07-16,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     86-02-18 Hergert: Added code to fix bug where compiling a selection
     expression using relations that have zero populations generated a
     null search program. The effect of this was that any future use
     of the compiled se resulted in tuple_not_found regardless if it
     existed or not. (mrds #159)
  5) change(86-09-22,Dupuis), approve(86-09-30,MCR7554), audit(86-10-10,Blair),
     install(86-10-13,MR12.0-1184):
     Initialized dbcb.non_shared_to_shared and dbcb.scopes_changed to "0"b
     (phx20565).
  6) change(87-08-17,Dupuis), approve(87-09-01,MCR7764), audit(87-09-04,Blair),
     install(87-09-09,MR12.1-1100):
     For char and bit varying literals, the pointer was being set to the
     beginning of the string instead of to the length word. (This fix was
     provided by John Hergert.)
  7) change(87-09-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-08,Dupuis), install(88-08-01,MR12.2-1073):
     Rewritten for new parser.
  8) change(88-09-07,Dupuis), approve(88-09-20,MCR7995), audit(88-09-21,Blair),
     install(88-09-26,MR12.2-1119):
     Added code that initializes the transaction id.
                                                   END HISTORY COMMENTS */


mrds_dsl_translate: proc (dbcb_ptr, area_ptr, caller, se_ptr, se_len, argp_ptr, descp_ptr, num_args, code);

/* NOTES:

   This procedure translates a given selection expression into a tabular form which can be efficiently utilized by
   the data base search procedure.
*/

/* HISTORY:

   Initially written by J. A. Weeldreyer -- January, 1976.

   Modified by J. A. Weeldreyer to incorporate  set  operations  for
   MR6.0 -- April, 1977.

   Modified to  recognize  previous  store  operation,  by  Oris  D.
   Friesen -- Dec. 1977

   Modified by JA Weeldreyer to correct error in diagnosing  missing
   select clause -- March, 1978.

   Modified by O Friesen to set retrieve_flag -- April 1978.

   Modified by JA Weeldreyer to free old current  select  clause  in
   case of consecutive -currents -- August, 1978.

   Modified  by  JA  Weeldreyer  to  incorporate  MR7.0  changes  --
   September, 1978.

   Modified by Al Kepner, May  1  1979,  to  add  db_on  and  db_off
   entries for debugging.

   Modified by Al Kepner, June 1, 1979 to use select_area.

   Modified by Rickie E.  Brinegar  on  November  30,  1979  to  use
   mrds_debug_tool  switches  instead  of the entry points db_on and
   db_off.

   Modified by Jim Gray - - Feb. 1980, to add area_ptr parameter, to
   pass on to both select and where clause routines.

   Modified by Jim Gray - - April 1980, to capture  case  where  too
   many arguments were given in call to dsl_$retrieve/modify/delete.

   81-06-23 Jim Gray : changed trans_block to always call  optimize,
   even  if  where clause is present, instead of having where clause
   do it, in order to clarify module structure and program logic.

   81-06-26 Roger Lackey : to add code to  support  no_optimize  and
   print_search_order

   81-07-02    Jim     Gray     :     added     internal     routine
   get_relation_statistics   to   initialize   the   new  population
   statistics now saved in the rm_rel_info structure, to reduce  the
   number of calls made to mu_get_rel_size.

   81-07-06 Jim Gray : changed stategy for  updating  statistics  to
   take  into account number of S.E.'s, rather than tuple variables,
   and to update small relations on a per S.E. basis.

   81-11-03 Davids: Added  code  to  make  sure  that  a  non-simple
   selection expression, i.e. one containing set operations contains
   the correct number of simple SEs and set operators. This fixes TR
   11350

   82-09-24 Davids: Replaced the call to mu_get_rel_size with a call
   to mu_rel_statistics$record_statistics.

   82-10-18 Davids: modified to use the corrected parameter list for
   mu_rel_statistics$record_statistics

   83-02-21 Moberg: Fixed bug where -current always allowed modify and delete

   83-04-07 Davids: Explicitly declared the mod builtin function. Deleted
   declarations to the unused varaibles dup_keys, total_keys, and tuple_count.

   83-05-23 Harvey: Added code to support a shortened simple_typed_vector by
   keepting track of when a new retrieve happens (-another)

   84-07-19 Hergert: Modified call to set_user_vals because we pulled that
   routine out of mrds_dsl_select_clause and made it an external procedure.
   This was done as part of a performance improvement in the handling
   of retrieves with -another.

   84-07-26 Thanh Nguyen: Turn the valid retrieval bit (dbcb.val_rtrv) on
   for the retrieve with "-another", because this bit may be turned off by the
   previous delete with "-current".  This is the fix for TR #17643, problem
   number 122 in the mrds error list.

   84-08-24 Hergert: Added variable sex to use as template to overlay
   the selection expression. This was done so we could do a simple compare
   for "-another" (if sex="-another") instead of having to call
   mrds_dsl_get_token.

   84-09-15 Hergert: Added code to handle new keyword "-compiled" and 
   also code to handle the initial compiling of select expressions.

   85-04-14 Thanh Nguyen: Added code to save the transaction id (only when 
   DM file in used) for any new select expression and user started his own
   transaction.

   85-11-15 Hergert: Added code that saved txn_id when parsing
   a select set. This allows the user to use -another with a DM relation
   and select set.
/* INPUT CONDITIONS:

   dbcb_ptr points to a valid DBCB.

   se_ptr points to the beginning of the selection  expression to be translated.

   se_len is the number of characters in the selection expression.

   argp_ptr points to the first of a list of argument pointers for values to be plugged into the selection
   expression and to be used for the select list.

   descp_ptr points to a list of descriptor pointers corresponding to the argp_ptrs.

   num_args is the number of values specified.
*/

/* OUTPUT DEFINITIONS:

   If there are no errors, dbcb.pred_ptr, dbcb.select_ptr, dbcb.range_ptr, and dbcb.lit_ptr will point to tabular
   representations of the selection expression predicate, -select clause, -range clause, and literals, respectively.

   If an error is detected, any previous selection expression tables will be deleted, and dbcb.pred_ptr, dbcb.select_ptr,
   dbcb.range_ptr, and dbcb.lit_ptr will be set to null.

   argp_ptr, descp_ptr, and num_args will be updated to point to the first value not used by the selection
   expression, if there are no errors; else they will be undefined.

   code = 0;  if no errors are detected.

   code = mrds_error_$no_prior_se;  if "-another" was specified and no valid selection expression has been previously
   specified.

   code = mrds_error_$incomp_se; if -another has been specified for any caller other than retrieve.

   code = mrds_error_$missing_pred;  if no predicate was found where one was expected.

   code = mrds_error_$missing_select;  if no -select clause was found where one was expected.

   code = mrds_error_$missing_range;  if no -range clause was found where one was expected.

   code = something else;  if another error was detected by a subroutine.
*/

        if first_time_thru then do;			/* initialize options */
	  first_time_thru = "0"b;
	  unspec(options) = "0"b;				/* quickie init */
	  options.ot, options.error = "1"b;
        end;

        dbcb.no_optimize, dbcb.print_search_order, dbcb.another_flag,
	   dbcb.current_flag = "0"b;
        compiled_se_info_ptr = dbcb.compiled_se_info_ptr;
        x_pred_leaf_ptr = null;

        on cleanup call mrds_dsl_delete_se (dbcb_ptr, (caller), icode);

        i = verify (sex, white_space);
        if i ^= 0
        then
	   if index (substr (sex, i), "-another") = 1 then do;
						/* check for -another w/o whitespace */
	       if caller = mrds_data_$caller_compile
	       then call error (mrds_error_$inval_comp_expr);

	       if dbcb.range_ptr = null
	       then /* if no existing s.e. */
		  call error (mrds_error_$no_prior_se);
	       call mrds_dsl_set_user_vals$another (dbcb_ptr, area_ptr,
		  argp_ptr,
		  descp_ptr, num_args, icode);	/* reset select list */
	       if icode ^= 0 then call error (icode);
	       dbcb.another_flag = "1"b;		/* let everyone know this is -another */
	       dbcb.val_rtrv = "1"b;			/* and for sure this is a valid expression */
	       do i = 1 to dbcb.range_ptr -> range.num_vars;
		 dbcb.range_ptr -> range.tup_var (i).copy_for_current =
		      "0"b;
		 dbcb.range_ptr -> range.tup_var (i).copied_for_current =
		      "0"b;
	       end;
	       code = 0;				/* be nice to caller */
	       return;				/* nothing more to do */
	   end;					/* if -another */


	   else if index (substr (sex, i), "-compiled") = 1 then do;
						/* already translated */

		  if dbcb.compiled_se_info_ptr = null
		  then call error (mrds_error_$no_prior_se);

		  if caller = mrds_data_$caller_compile
		  then call error (mrds_error_$inval_comp_expr);

/* restore the saved  dbcb pointers */

		  se_index_ptr = argp_ptr -> ptr_template;
						/* get se_index; It better be the first arg in arg list */
		  argp_ptr = addrel (argp_ptr, 2);	/* adjust arglist to pass over se_iindex */
		  descp_ptr = addrel (descp_ptr, 2);	/* and descriptor list*/
		  num_args = num_args - 1;		/* one less argument now */
		  current_flag = "0"b;

						/* make sure we have good index */
		  if se_index > compiled_se_info.number_of_compiled_se |
		     se_index <= 0 then call error (mrds_error_$no_sel_exp);
		  if compiled_se_info.free (se_index)
		       then call error (mrds_error_$no_sel_exp);

		  dbcb.select_area_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .select_area_ptr (se_index);
		  dbcb.range_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .range_ptr (se_index);
		  dbcb.select_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .select_ptr (se_index);
		  dbcb.ti_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .ti_ptr (se_index);
		  dbcb.ss_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .ss_ptr (se_index);
		  dbcb.so_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .so_ptr (se_index);
		  dbcb.lit_ptr =
		       compiled_se_info.se_info.saved_ptrs
		       .lit_ptr (se_index);
		  dbcb.last_s_e_id_num =
		       compiled_se_info.se_info.se_id_num (se_index);
		  dbcb.dup_retain =
		       compiled_se_info.se_info.dup_retain (se_index);

		  dbcb.val_rtrv,			/* init valid. flags */
		       dbcb.val_dtr,
		       dbcb.new_select_expr = "1"b;

		  dbcb.non_shared_to_shared, dbcb.scopes_changed = "0"b;

		  if dbcb.ss_ptr ^= null
		  then dbcb.val_mod, dbcb.val_del = "0"b;
		  else dbcb.val_mod, dbcb.val_del = "1"b;


		  if compiled_se_info.x_leaf_ptr (se_index) ^= null
		  then do;			/* we have .x.s to fill in */
		      x_pred_leaf_ptr =
			 compiled_se_info.x_leaf_ptr (se_index);
						/* find the right predicate list */
		      if num_args < x_pred_leaf.number_of_x
		      then /* make sure we have enough args */
			 call error (mrds_error_$insuff_args);

		      str_size = "0"b;
		      on stringsize str_size = "1"b;

		      do i = 1 to x_pred_leaf.number_of_x;
			desc_ptr, x_pred_leaf.lit_desc_ptr = descp_ptr -> ptr_template;
			if descriptor.type = varying_bit_dtype
			     | descriptor.type = varying_char_dtype
			     then x_pred_leaf.lit_arg_ptr = addrel(argp_ptr -> ptr_template,-1); /* get the length too */
			else x_pred_leaf.lit_arg_ptr = argp_ptr -> ptr_template;
			argp_ptr = addrel (argp_ptr, 2);
						/* adjust arglist */
			descp_ptr = addrel (descp_ptr, 2);
						/* and descriptor list*/
			num_args = num_args - 1;	/* and arg count */

			if ^mu_valid_data_type$valid_scalar_data_type
			     (x_pred_leaf.lit_desc_ptr -> bit36)
			then call error (mrds_error_$inv_literal_type);

			lit_length = x_pred_leaf.info.lit_val_len (i);
			if x_pred_leaf.info.encode_proc (i) then do;
						/* if must encode */
			    if x_pred_leaf.lit_desc_ptr -> bit36 ^=
			         x_pred_leaf.info.encode_in_desc_ptr (i)
			         -> bit36 then do;	/* if must convert also */

			        if x_pred_leaf.info.encode_bit_len (i)
				   > 2376
			        then /* get some space */
				   /* 2376 = length of work_space in bits */
				   allocate encode_space
				        in (select_area);
			        else es_ptr = addr (work_space);
			        encode_space = "0"b;

			        call mu_convert$convert_data (x_pred_leaf
				   .lit_arg_ptr,
				   x_pred_leaf.lit_desc_ptr, es_ptr,
				   x_pred_leaf.info
				   .encode_in_desc_ptr (i), icode);
			        if icode ^= 0 then call error (icode);
			        if str_size
			        then call error (
				        mrds_error_$inv_comparison);

			        encode_arg_list.user_val_ptr = es_ptr;
			    end;
			    else encode_arg_list.user_val_ptr =
				    x_pred_leaf.lit_arg_ptr;

			    encode_arg_list.user_desc_ptr =
			         x_pred_leaf.encode_in_desc_ptr (i);

			    if x_pred_leaf.info.encode_in_desc_ptr (i)
			         -> descriptor.type =
			         varying_char_dtype
			         /* see if need to adjust ptr */
			         | x_pred_leaf.info
			         .encode_in_desc_ptr (i)
			         -> descriptor.type = varying_bit_dtype
			    then
			         encode_arg_list.user_val_ptr =
				    addr (encode_arg_list.user_val_ptr
				    -> varying.string);

			    encode_arg_list.db_desc_ptr =
			         x_pred_leaf.info
			         .encode_out_desc_ptr (i);

			    encode_arg_list.db_val_ptr =
			         x_pred_leaf.info.lit_val_ptr (i);

			    encode_arg_list.code_ptr = addr (icode);
			    encode_arg_list.coded_ptr = addr (FB35_DESC);
			    call cu_$generate_call (x_pred_leaf
			         .encode_entry (i),
			         addr (encode_arg_list));
			    if icode ^= 0 then call error (icode);
						/* encode the value */
			end;

			else do;			/* if not encoding */
			    if x_pred_leaf.lit_desc_ptr -> bit36 ^=
			         x_pred_leaf.info.encode_out_desc_ptr (i)
			         -> bit36 then do;	/* must convert */

			        call mu_convert$convert_data (x_pred_leaf
				   .lit_arg_ptr,
				   x_pred_leaf.lit_desc_ptr,
				   x_pred_leaf.info.lit_val_ptr (i),
				   x_pred_leaf.info
				   .encode_out_desc_ptr (i), icode);
			        if icode ^= 0 then call error (icode);
			        if str_size
			        then call error (
				        mrds_error_$inv_comparison);
			    end;
			    else x_pred_leaf.info.lit_val_ptr (i)
				    -> literal_bit_string =
				    x_pred_leaf.lit_arg_ptr
				    -> literal_bit_string;
			end;			/* if not encoding */
		      end;			/* do loop */
		      revert stringsize;
		  end;				/* if we have .x.'s */

		  call mrds_dsl_select_clause_$compiled_clause (dbcb_ptr,
		       area_ptr, (caller), argp_ptr, descp_ptr, num_args,
		       compiled_se_info.temp_rel_list_ptr (se_index),
		       current_flag, icode);
		  if icode ^= 0 then call error (icode);

		  if dbcb.ss_ptr = null
		  then dbcb.so_ptr -> search_ops.ic = 1;/* make sure the search program is reset */
		  else do;
		      ss_ptr = dbcb.ss_ptr;
		      do i = 1 to select_sets.nitems;
			select_sets.items.so_ptr (i) -> search_ops.ic =
			     1;
		      end;
		  end;
		  if dbcb.transactions_needed & dbcb.user_started_transaction then do;
		       call transaction_manager_$get_current_txn_id (mstxn_txn_id, icode);
		       if icode ^= dm_error_$no_current_transaction then
			  dbcb.se_transaction_id = mstxn_txn_id;
		       else call error (icode);
		  end;
		  else dbcb.se_transaction_id = "0"b;

		  return;
	        end;				/* -compiled */


	        else do;				/* process a selection expression */

		  if index (substr (sex, i), "-current") ^= 1 then do;
		      current_flag = "0"b;
		      call mrds_dsl_delete_se (dbcb_ptr, (caller), icode);
						/* delete prev. s.e. tables */
		      if icode ^= 0 then call error (icode);
		  end;
		  else current_flag = "1"b;

		  dbcb.val_rtrv,			/* init valid. flags */
		       dbcb.val_dtr,
		       dbcb.val_mod,
		       dbcb.val_del = "1"b;

		  if dbcb.transactions_needed
		       & dbcb.user_started_transaction then do;
		      call transaction_manager_$get_current_txn_id (
			 mstxn_txn_id, icode);
		      if icode ^= dm_error_$no_current_transaction
		      then
			 dbcb.se_transaction_id = mstxn_txn_id;
		      else call error(icode);
		  end;
		  else dbcb.se_transaction_id = "0"b;

		  call mrds_dsl_parser (dbcb_ptr, area_ptr, caller,
		       addr (options), se_ptr, se_len, argp_ptr, descp_ptr,
		       num_args, current_flag, icode);
		  if icode ^= 0 then call error (icode);

		  if options.pse
		  then call mu_print_error$print_se (se_ptr, se_len);

	        end;

        dbcb.prev_select = "0"b;			/* so as not to mess up -current */
        code = 0;					/* be nice to caller */

exit:
        return;

error:
    proc (cd);

/* Internal error procedure */

dcl     cd		 fixed bin (35);		/* internal status code */

        call mrds_dsl_delete_se (dbcb_ptr, (caller), code); /* if error, don't leave incomplete tables */
        code = cd;					/* pass bad news back to caller */
        go to exit;

    end error;

set_options:
    entry (mode_flags_ptr);

/* entry to set options from command level. pso_sw controls -pso in select
    expression. ot_sw controls -no_ot in select expression. pse_sw controls
    whether or not the selection expression gets printed out.
 */

        if first_time_thru then do;			/* initialize options */
	  first_time_thru = "0"b;
	  unspec(options) = "0"b;				/* quickie init */
	  options.ot, options.error = "1"b;
        end;

        if mode_flags.list_sw then do;			/* listing modes */
	  mode_flags.value.pso = options.pso;
	  mode_flags.value.pse = options.pse;
	  mode_flags.value.ot = options.ot;
	  mode_flags.value.force = options.force;
	  mode_flags.value.error = options.error;
        end;
        else do;					/* setting modes */
	  if mode_flags.selected.pso then options.pso = mode_flags.value.pso;
	  if mode_flags.selected.pse then options.pse = mode_flags.value.pse;
	  if mode_flags.selected.ot then options.ot = mode_flags.value.ot;
	  if mode_flags.selected.force
	  then options.force = mode_flags.value.force;
	  if mode_flags.selected.error
	  then options.error = mode_flags.value.error;
        end;

        return;

%include mrds_dbcb;
%page;
%include mrds_range;
%page;
%include mrds_select_sets;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_compiled_se_info;
%page;
%include mrds_search_ops;
%page;
%include mdbm_descriptor;
%page;
%include std_descriptor_types;
%page;
%include mrds_se_options;

dcl     FB35_DESC		 bit (36) aligned static options (constant)
			 init ("404000000043"b3);	/* descriptor for decode return code */
dcl     addr		 builtin;
dcl     addrel		 builtin;
dcl     area_ptr		 ptr;
dcl     argp_ptr		 ptr;			/* Input -- pointer to arg pointers */
dcl     bit36		 bit (36) based;
dcl     caller		 fixed bin (35) parameter;
dcl     cleanup		 condition;
dcl     code		 fixed bin (35);		/* Output -- return code */
dcl     cu_$generate_call	 entry (entry, ptr);
dcl     current_flag	 bit (1) aligned;
dcl     descp_ptr		 ptr;			/* Input -- pointer to arg descriptor pointers */
dcl     dm_error_$no_current_transaction
			 fixed bin (35) external static;
dcl     1 encode_arg_list	 aligned,			/* arg list for encode proc. */
	2 nargs		 fixed bin (17) unal init (6),
	2 code		 fixed bin (17) unal init (4),
	2 ndescs		 fixed bin (17) unal init (6),
	2 pad		 fixed bin (17) unal init (0),
	2 user_val_ptr	 ptr,
	2 db_val_ptr	 ptr,
	2 code_ptr	 ptr,
	2 user_desc_ptr	 ptr,
	2 db_desc_ptr	 ptr,
	2 coded_ptr	 ptr;
dcl     encode_space	 bit (x_pred_leaf.info.encode_bit_len (i))
			 based (es_ptr);		/* for conversions before encoding */
dcl     es_ptr		 ptr;
dcl     first_time_thru	 bit (1) aligned internal static init ("1"b);
dcl     fixed		 builtin;
dcl     i			 fixed bin;		/* standard loop variable */
dcl     icode		 fixed bin (35);		/* internal status code */
dcl     index		 builtin;
dcl     lit_length		 fixed bin;		/* length of the literal in lit pool */
dcl     literal_bit_string	 bit (lit_length) based;	/* used to install the .x. literal at run time */
dcl     mrds_data_$caller_compile
			 fixed bin (35) external static;
dcl     mrds_data_$max_attributes
			 fixed bin (35) external static;
dcl     mrds_data_$max_id_len	 fixed bin (35) ext;	/* longest tuple variable length */
dcl     mrds_data_$max_select_items
			 fixed bin (35) external static;
dcl     mrds_dsl_delete_se	 entry (ptr, fixed bin (35), fixed bin (35));
dcl     mrds_dsl_parser	 entry (ptr, ptr, fixed bin (35), ptr, ptr,
			 fixed bin, ptr, ptr, fixed bin, bit (1) aligned,
			 fixed bin (35));
dcl     mrds_dsl_select_clause_$compiled_clause
			 entry (ptr, ptr, fixed bin (35), ptr, ptr,
			 fixed bin, ptr, bit (1) aligned, fixed bin (35))
			 ;
dcl     mrds_dsl_set_user_vals$another
			 entry (ptr, ptr, ptr, ptr, fixed bin,
			 fixed bin (35));
dcl     mrds_error_$insuff_args
			 fixed bin (35) external static;
dcl     mrds_error_$inv_comparison
			 fixed bin (35) external static;
dcl     mrds_error_$inv_literal_type
			 fixed bin (35) external static;
dcl     mrds_error_$inval_comp_expr
			 fixed bin (35) external static;
dcl     mrds_error_$no_prior_se
			 fixed bin (35) external static;
dcl     mrds_error_$no_sel_exp fixed bin (35) external static;
dcl     mstxn_txn_id	 bit (36) aligned;
dcl     mu_convert$convert_data
			 entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl     mu_print_error$print_se
			 entry (ptr, fixed bin);
dcl     mu_valid_data_type$valid_scalar_data_type
			 entry (bit (36)) returns (bit (1) aligned);
dcl     null		 builtin;
dcl     num_args		 fixed bin;		/* Input -- number of value args */
dcl     1 options		 aligned like option_list internal static;
dcl     ptr_template	 ptr based;		/* template for getting args off arglist */
dcl     rel		 builtin;
dcl     se_index		 fixed bin (35) based (se_index_ptr);
						/* se_index specified by caller */
dcl     se_index_ptr	 ptr;			/* pointer to selection expression index for compiled se */
dcl     se_len		 fixed bin;		/* Input -- char. length of selection expression */
dcl     se_ptr		 ptr;			/* Input -- pointer to selection expression */
dcl     sex		 char (se_len) based (se_ptr);/* template to overlay the se */
dcl     str_size		 bit;
dcl     stringsize		 condition;
dcl     substr		 builtin;
dcl     sys_info$max_seg_size	 fixed bin (35) external static;
dcl     transaction_manager_$get_current_txn_id
			 entry (bit (36) aligned, fixed bin (35));
dcl     unspec		 builtin;
dcl     1 varying		 unaligned based,		/* template of varying string */
	2 length		 fixed bin (35),		/* length word */
	2 string		 char (0);		/* string begins here */
dcl     verify		 builtin;
dcl     white_space		 char (3) aligned internal static
			 options (constant) init (" 	
");						/* SP TAB NL */
dcl     work_space		 (33) fixed bin (71);

    end mrds_dsl_translate;




		    mrds_dsl_where_clause_.pl1      08/01/88  1421.7rew 08/01/88  1300.0      230283



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-08,Dupuis), install(88-08-01,MR12.2-1073):
     Written.
                                                   END HISTORY COMMENTS */


mrds_dsl_where_clause_:
    proc ();

/* NOTES:

   This  procedure  translates  the  -where  clause  within  a  DSL  selection
   expression  into  a  tabular form which cam be efficiently processed by the
   data base search procedures.


   INPUT CONDITIONS:

   dbcb_ptr points to a valid DBCB which contains the -range clause tables and
   the -select clause tables for the current selection expression.

   se_ptr points to the beginning of the selection expression.

   se_len is the number of characters in the selection expression.

   start_pos  is  the  index of the character immediately following the -where
   keyword.

   argp_ptr points to the next in a list of argument pointers for values to be
   pluffed into the selection expression.

   descp_ptr  points  to  the  next  in  the  list of corresponding descriptor
   pointers.

   num_args is the number of unused values.

   OUTPUT DEFINITIONS:

   output_pred_ptr - - (output) ptr, to root of predicate tree


   start_pos, argp_ptr, descp_ptr, and num_args are undefined.

   code = 0;  if there are no errors.

   code = mrds_error_$where_syntax; if a syntax error occurs within the -where
   clause.

   code  =  mrds_error_$unbal_parens;  if the number of right parentheses does
   not match the number of left parentheses.

   code = mrds_error_$op_stack_ovfl;  if the operator stack has overflowed.

   code = mrds_error_$node_stack_ovfl;  if the node stack has overflowed.

   code  =  mrds_error_$undef_quant;  if  a  tuple variable is neither free no
   quantified.

   code =  mrds_error_$empty where;  if nothing followed the -where keyword.

   code  =  mrds_error_$not_leaf;  if  a  "not"  operation  is specified for a
   constant or a tuple attribute.

   code  =  mrds_error_$bool_leaf;  if an "and" of "or" operation is specified
   for a constant of tuple attribute.

   code  =  mrds_error_$rel_node;  if a relational operator has been specified
   for a term or group of terms.

   code   =   mrds_error_$quant_stack_ovfl;   if   the  quantifier  stack  has
   overflowed.

   code = mrds_error_$mult_quant; if a quantification has been specified for a
   tuple  variable  within  the  scope of another quantification for that same
   variable.

   code   =   mrds_error_$quant_free_conflict;   if  quantification  has  been
   specified for a typle variable which also appears in the select list.

   code  =  mrds_error_$ill_constant_occur;  if  a  literal  constant has been
   designated for comparison to a term or group of terms.

   code  = mrds_error_$inv_literal_type; if a literal value is not a string or
   arithmetic data type.

   code = mrds_error_$lit_string_ovfl;  if the literal area has overflowed.

   code = something else;  if another error is detected by a subroutine.

   HISTORY:

   76-02-01 J. A. Weeldreyer : Initially written.

   76-11-01 J. A. Weeldreyer: Modified to incorporate inverted attributes.

   77-04-01 J. A. Weeldreyer: Modified to catch undetected illegal terms.

   77-04-02  J.  A.  Weeldreyer: Modified to handle expressions, and to remove
   explicit quantification.

   77-11-01  J.   A.   Weeldreyer:  Modified  to  eliminate  concept  of bound
   variables.

   78-01-01  J.   A.   Weeldreyer:  Modified  to zero pad bits when allocating
   literals.

   78-02-01  J.   A.   Weeldreyer: Modified to properly handle exprs.  without
   variables.

   78-07-01 J. A. Weeldreyer: Modified to fix error in cleanup handler.

   79-02-01 J. A. Weeldreyer for MR7.0.

   79-06-01 Al Kepner: Modified to use select_area.

   79-08-28  NSDavids:  Modified  to  skip evaluation of the expression if the
   pointer  to  the  expreession  structure  is  null (hopefully that means we
   already have the expression value.) Exactly how all the modules communicate
   i don't know - i doubt if god does !

   79-11-01  Jim  Gray  : Modified to make comparisons of attrs from different
   domains  a  warning  error  message,  instead  of  a fatal error.  However,
   comparison  of  different  data types is still a fatal error(see comment in
   code).

   80-02-01  Jim  Gray  :  Modified  to  add  area_ptr parameter, passed on to
   mrds_dsl_eval_expr.

   80-09-24  Davids: added to the code that processes ATTR type tokens a check
   to  be  sure the user has r_perm on the attribute.  if he/she does not then
   processing  can  stop  with  an  incorrect  access error.  Also removed the
   include files mrds_expressions and mdbm_arg_list which were not used.  this
   will  improved  performance  slightly  since variables were initialized but
   never  referenced.   also removed a couple of declared but never referenced
   variables  that  were  not  in  include  files.

   80-11-05  Jim Gray : Modified to "and" the mdbm_secured bit with the r_perm
   bit in rm_attr_info so that secure_mrds_db turns this check on.

   81-05-06  Rickie  E.   Brinegar:  Modified  to  make  use  of  the  changed
   rm_domain_info structure.

   81-05-19  Jim  Gray  :  changed comparing of different domain data types to
   non-fatal  error,  leaving  in  the  sub_err_ message, for test purposes in
   working  on  the  domain_compare  proposal,  that will allow any two domain
   types to be used in where clause comparisons.


   81-05-20  Jim  Gray  :  changed  where clause domain comparison error to be
   controlable by a mrds debug switch bit 1 for this routine.

   81-05-20  Rickie  E.   Brinegar: Added to the code to reset the encode proc
   switch in the li structure for each attribute.

   81-06-23 Jim Gray : changed where clause to not call optimize,
   but to return pred tree root pointer instead. translate now calls optimize
   whether there is a where clause or not.

   81-09-21 Davids: modified an if statement so that the index value
   was  checked  before  the  index  was used as a subscript into an
   array. This prevents a subscriptrange condition.

   83-02-28 Moberg: made comparsions of different domains illegal if one of
   the domains has an encode proc.  This is because the compare code has no
   idea of how to deal with this case.  When compare is fixed, this check
   should be removed, but until then this is better than giving the wrong
   answer.

   83-04-04 Davids increased the length of difference_mesg from 10 to 11
   to accommodate "encode proc" and prevent a stringsize condition from
   occuring. deleted declarations to so_ptr and descr_overly which were
   never referenced

   84-09-13 Hergert: added check for -compiled keyword and code to handle
   new substituion argmunet .X. Basically a call to mrds_dsl_make_literal$alloc
   instead of mrds_dsl_make_literal, because we dont have a value for .x.
   at this time.

   84-11-01 Hergert: added call to mu_print_error for reporting errors.

   85-08-22 Hergert Turned off error printing when in domain procs.
*/

build_attribute:
    entry (psi_ptr,dbcb_ptr, a_select_area_ptr, rel_index, ai_ptr, code);
						/* tuple attribute */

dcl     rel_index		 fixed bin;		/* relation index */
dcl     ai_ptr		 ptr;			/* attribute_info ptr */

        if parser_static_info.ns_ptr = null then do;
	   allocate ns in (parser_work_area);
	   top_node = 0;
        end;

        code = 0;
        select_area_ptr = a_select_area_ptr;
        if top_node >= mrds_data_$max_pred_nodes
        then					/* if node stack overflow */
	   call error (mrds_error_$node_stack_ovfl, LOUD, 0, WC_TYPE,
	        "Too many items have been specified in the where clause.");

        else do;					/* if still room,  build tuple attr. leaf */

	  allocate pred_leaf in (select_area);		/* make a place for it */
						/* Allocations in select_area are never freed.
						   This area is reinitialized
						   at the beginning of each new selection expression. */
	  rai_ptr = ai_ptr;				/* for rm_attr_info */
	  if rm_attr_info.mdbm_secured & ^(rm_attr_info.read_perm)
						/* if you don't have read access to an attribute */
	  then call error (mrds_error_$inc_attr_acc, LOUD, 0, AV_TYPE,
		  "You must have read permission on this attribute to use it as a qualifier."
		  );
						/* it shouldn't be in the where clause */

	  pred_leaf.id.var_id = "0"b || bit (rel_index);
						/* fill in data */
	  pred_leaf.id.attr_id = "0"b || bit (rm_attr_info.defn_order);
	  pred_leaf.type = LEAF;
	  pred_leaf.ai_ptr = ai_ptr;
	  pred_leaf.lit_offset,
	       pred_leaf.lit_length = 0;
	  pred_leaf.dummy,
	       pred_leaf.rslt_desc = "0"b;
	  pred_leaf.lit_desc_ptr,
	       pred_leaf.lit_ptr,
	       pred_leaf.expr_ptr,
	       pred_leaf.parent = null;

	  pred_leaf.data_type = ATTR;

	  top_node = top_node + 1;			/* increment node counter */
	  node_stack (top_node) = pl_ptr;		/* add leaf to node stack */
        end;					/* if room in stack */

        return;

build_expr:
    entry (psi_ptr,efd_ptr, a_select_area_ptr, code);

        if parser_static_info.ns_ptr = null then do;
	   allocate ns in (parser_work_area);
	   top_node = 0;
        end;

        code = 0;
        select_area_ptr = a_select_area_ptr;
        if top_node >= mrds_data_$max_pred_nodes
        then					/* if node stack overflow */
	   call error (mrds_error_$node_stack_ovfl, LOUD, 0, WC_TYPE,
	        "Too many items have been specified in the where clause.");


        allocate pred_leaf in (select_area);		/* Allocations in select_area are never freed.
						   This area is reinitialized
						   at the beginning of each new selection expression. */
        pred_leaf.id.var_id = "0"b || bit (exp_fun_data.var_index);
						/* fill in the pred_leaf */
        pred_leaf.type = LEAF;
        pred_leaf.data_type = EXPRES;
        pred_leaf.dummy,
	   pred_leaf.id.attr_id = "0"b;
        pred_leaf.lit_offset = exp_fun_data.loc_index;
        pred_leaf.lit_length = exp_fun_data.bit_length;
        pred_leaf.rslt_desc = exp_fun_data.descriptor;
        pred_leaf.lit_ptr = exp_fun_data.assn_ptr;
        pred_leaf.lit_desc_ptr = addr (pred_leaf.rslt_desc);
        pred_leaf.expr_ptr = exp_fun_data.ef_ptr;
        pred_leaf.ai_ptr,
	   pred_leaf.parent = null;

        top_node = top_node + 1;
        node_stack (top_node) = pl_ptr;			/* add to stack */


        return;

finish:
    entry (psi_ptr,output_pred_ptr);

        node_stack (top_node) -> pred_node.root = "1"b;	/* set root flag in top node */
        output_pred_ptr = node_stack (top_node);
        top_node = 0;

        return;

build_node:
    entry (psi_ptr,dbcb_ptr, a_select_area_ptr, operator_id, logical_node, not_node,
         code);

/* Build a node from the top one or two items in the node stack,
   Pop them from the stack and replace them with it. */

dcl     operator_id		 fixed bin;
dcl     logical_node	 bit (1) aligned;
dcl     not_node		 bit (1) aligned;

        code = 0;
        select_area_ptr = a_select_area_ptr;

        allocate pred_node in (select_area);		/* make place for new node */

        pred_node.parent = null;
        pred_node.type = NODE;
        pred_node.id.op_code = op_array (operator_id);
        pred_node.determined, pred_node.root = "0"b;

        if logical_node then do;			/* if node is logical operator & | ^ */

	  string (pred_node.id.lleaf_id),
	       string (pred_node.id.rleaf_id),
	       pred_node.term = "0"b;
	  pred_node.term_type = 0;

	  if not_node then do;

	      pred_node.rbr = null;			/* if only one branch, the right will be null */
	      pred_node.lbr = node_stack (top_node);	/* existing node placed under new one */

	      node_stack (top_node) -> pred_node.parent = pn_ptr;
						/* fill in parent pointer for child */

	  end;					/* if not_node */

	  else do;				/* node will have two branches & or | */

	      pred_node.lbr = node_stack (top_node - 1);
	      pred_node.rbr = node_stack (top_node);

	      node_stack (top_node) -> pred_node.parent,	/* let the bastards know who their father is */
		 node_stack (top_node - 1) -> pred_node.parent = pn_ptr;

	      top_node = top_node - 1;		/* replace top 2 nodes with new one */

	  end;					/* else & or | */
        end;					/* if logical_node */

        else do;					/* if not logical, must be relational = < > ...  */

	  pred_node.term = "1"b;

	  pred_node.lbr = node_stack (top_node - 1);
	  pred_node.rbr = node_stack (top_node);

	  pred_node.id.lleaf_id = pred_node.lbr -> pred_leaf.id;
	  pred_node.id.rleaf_id = pred_node.rbr -> pred_leaf.id;

	  pred_node.term_type =
	       term_type_array (node_stack (top_node - 1)
	       -> pred_leaf.data_type,
	       node_stack (top_node) -> pred_leaf.data_type);

	  if pred_node.term_type = 0
	  then					/* cant have a constant as first leaf for some odd reason */
	       call error (mrds_error_$ill_term, LOUD, 2, WC_TYPE,
		  "A constant is not allowed as the first item in a qualifier."
		  );

	  if pred_node.lbr -> pred_leaf.data_type = ATTR
	       & pred_node.rbr -> pred_leaf.data_type = ATTR
	  then					/* if both leaves are attrs */

	       if substr (db_mrds_dsl_where_clause, 1, 1)
						/* debug bit 1 on => give details of cross domain compare */
						/* cannot do cross domain compares when encode procs are involved */
		  | pred_node.rbr -> pred_leaf.ai_ptr ->
		  rm_attr_info.domain_ptr -> rm_domain_info.encd_proc
		  | pred_node.lbr -> pred_leaf.ai_ptr ->
		  rm_attr_info.domain_ptr -> rm_domain_info.encd_proc
	       then do;

/*  check for a comparison of non-comparable domains, a possible
   semantic oversight(e.g.  age char(6) shouldn't be compared to
   employee_num char(6) ) or an invalid use of comparisons, since
   comparing of different data types can not be allowed in general, due
   to the "non-conversion of keys" prior to compares.  (e.g.  a fixed
   dec(4) compared to a char(6) in a vfile_ key will not work) this is
   due to the use of select/exclude in the new architecture note: it
   would be possible to allow comparing of differing data types, if the
   types were not keys or secondary indexes or involved in a link.  this
   is because the vanilla attributes left would not(in the new
   architecture) be involved in any use of vfile_ keys, and thus not use
   key comparisons, instead mu_comapre_values would be invoked, which
   does conversions prior to comparing values.  it still
   limits(currently) the comparisons to 1) real to real, 2) complex to
   complex, 3) bit to bit, and 4) char to char data types, but at least
   a fixed bin (17) unal could be compared to a fixed dec(5) However
   allowing these comparisons would essentially be encouraging an
   inappropriate use of a relational interface, and been decided
   against.
*/

		 if pred_node.rbr -> pred_leaf.ai_ptr ->
		      rm_attr_info.domain_ptr -> rm_domain_info.name ^=
		      pred_node.lbr -> pred_leaf.ai_ptr ->
		      rm_attr_info.domain_ptr -> rm_domain_info.name
		 then do;

/* domains are different, check for different data types */

		     if pred_node.rbr -> pred_leaf.ai_ptr
			-> rm_attr_info.domain_ptr ->
			rm_domain_info.encd_proc
			| pred_node.lbr -> pred_leaf.ai_ptr
			-> rm_attr_info.domain_ptr ->
			rm_domain_info.encd_proc then do;
		         fatal_flag = "1"b;
		         difference_mesg = "encode proc";
		         reason_mesg =
			    """, comparing of different encode procs is not allowed."
			    ;
		     end;
		     else if pred_node.rbr -> pred_leaf.ai_ptr
			     -> rm_attr_info.domain_ptr ->
			     rm_domain_info.db_desc ^=
			     pred_node.lbr -> pred_leaf.ai_ptr
			     -> rm_attr_info.domain_ptr ->
			     rm_domain_info.db_desc then do;
			    fatal_flag = "1"b;
			    difference_mesg = "data type";
			    reason_mesg =
			         """, comparing of different data types is not allowed."
			         ;
			end;
			else do;
			    fatal_flag = "0"b;
			    difference_mesg = "domain";
			    reason_mesg =
			         """, this may be an invalid comparison of semantically different domains."
			         ;
			end;

/* issue the warning or error */

		     call sub_err_ (mrds_error_$diff_comp_domain,
			caller_name,
			continue, info_ptr, return_value,
			"^/^a^a^a ^a ^a^a^a^/",
			"The attribute """,
			pred_node.rbr -> pred_leaf.ai_ptr
			-> rm_attr_info.name,
			""" does not have the same", difference_mesg,
			"as the attribute """,
			pred_node.lbr -> pred_leaf.ai_ptr
			-> rm_attr_info.name,
			reason_mesg);


		     if fatal_flag
		     then
			call error (mrds_error_$diff_comp_domain,
			     ^LOUD, 0, "", "");

		 end;

	       end;


	  node_stack (top_node) -> pred_leaf.parent,
	       node_stack (top_node - 1) -> pred_leaf.parent = pn_ptr;
						/* set parent ptrs in leaves */

	  top_node = top_node - 1;			/* replace top two nodes with new node */

        end;					/* if relat. op. */

        node_stack (top_node) = pn_ptr;

        return;					/* build_node */

build_literal:
    entry (psi_ptr,dbcb_ptr, a_select_area_ptr, a_ptr, d_ptr, x_pred_leaf_ptr,
         dot_x_dot, code);

/* Build a pred leaf for any literal we have found. These are .V., .X.,
   and any actual literal constant found in the where clause */


dcl     (
        a_ptr,					/* Input -- pointer to literal value */
        d_ptr
        )			 ptr;			/* Input -- pointer to literal descriptor */
dcl     dot_x_dot		 bit (1) aligned;		/* literal is a .X. */

        if parser_static_info.ns_ptr = null then do;
	   allocate ns in (parser_work_area);
	   top_node = 0;
        end;

        code = 0;
        select_area_ptr = a_select_area_ptr;
        if top_node >= mrds_data_$max_pred_nodes		/* if about to overflow the node stack */
        then call error (mrds_error_$node_stack_ovfl, LOUD, 0, WC_TYPE,
	        "Too many items have been specified in the where clause.");

        if top_node < 1
        then call error (mrds_error_$ill_term, LOUD, 0, WC_TYPE, "");
						/* if no prev leaf */

        allocate pred_leaf in (select_area);		/* make place for leaf */
						/* Allocations in select_area are never freed.
						   This area is reinitialized
						   at the beginning of each new selection expression. */

        pred_leaf.expr_ptr,
	   pred_leaf.ai_ptr,
	   pred_leaf.parent = null;			/* fill it in */
        pred_leaf.type = LEAF;
        pred_leaf.data_type = CONST;
        pred_leaf.dummy,
	   pred_leaf.rslt_desc,
	   pred_leaf.id.var_id = "0"b;

        go to set_li (node_stack (top_node) -> pred_leaf.data_type);
set_li (1):					/* constant */
        call error (mrds_error_$ill_term, LOUD, 0, WC_TYPE,
	   "Two constants cannot be compared.");	/* cant compare two constants */

set_li (2):					/* db. attr. */
        rai_ptr = node_stack (top_node) -> pred_leaf.ai_ptr;/* pick up attr info ptr */
        rdi_ptr = rm_attr_info.domain_ptr;

        if rm_domain_info.encd_proc then do;
	  li.encd_entry = rm_domain_info.encd_proc_entry;
	  li.encd_proc = "1"b;
        end;
        else li.encd_proc = "0"b;

        li.encdd_ptr = addr (rm_domain_info.user_desc);
        li.litd_ptr = addr (rm_domain_info.db_desc);
        li.encd_blen = rm_domain_info.user_bit_len;
        li.lit_blen = rm_attr_info.bit_length;
        go to set_done;

set_li (3):					/* expr */
        li.encd_proc = "0"b;
        li.encdd_ptr = null;
        li.litd_ptr = node_stack (top_node) -> pred_leaf.lit_desc_ptr;
        li.encd_blen,
	   li.lit_blen = 0;

set_done:
        li.src_ptr = a_ptr;				/* fill in info for make_literal */
        li.srcd_ptr = d_ptr;

        if dot_x_dot then do;				/* since this is a .x. we need to save the place where we
						   have to plug in the  proper value when we finally know it later */
	  if x_pred_leaf_ptr = null then do;
	      allocate x_pred_leaf in (select_area);
	      x_pred_leaf.number_of_x = 0;
	  end;
	  x_pred_leaf.number_of_x = x_pred_leaf.number_of_x + 1;

	  call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), code);
	  if code ^= 0 then call error (code, LOUD, 0, WC_TYPE, "");

	  x_pred_leaf.info.encode_bit_len (x_pred_leaf.number_of_x) =
	       li.encd_blen;
	  x_pred_leaf.info.lit_val_ptr (x_pred_leaf.number_of_x) =
	       li.lit_ptr;
	  x_pred_leaf.info.lit_val_len (x_pred_leaf.number_of_x) =
	       li.lit_blen;
	  x_pred_leaf.info.encode_in_desc_ptr (x_pred_leaf.number_of_x) =
	       li.encdd_ptr;
	  x_pred_leaf.info.encode_out_desc_ptr (x_pred_leaf.number_of_x) =
	       li.litd_ptr;
	  if li.encd_proc then do;
	      x_pred_leaf.info.encode_proc (x_pred_leaf.number_of_x) = "1"b;
	      x_pred_leaf.info.encode_entry (x_pred_leaf.number_of_x) =
		 li.encd_entry;
	  end;
	  else x_pred_leaf.info.encode_proc (x_pred_leaf.number_of_x) = "0"b;

        end;
        else do;
	  call mrds_dsl_make_literal (dbcb_ptr, addr (li), code);
	  if code ^= 0
	  then call error (code, ^LOUD, 0, WC_TYPE,
		  "The data type of the supplied constant can not be converted to that of the attribute."
		  );
        end;

        pred_leaf.lit_offset = li.lit_offset;
        pred_leaf.lit_length = li.lit_blen;
        pred_leaf.lit_ptr = li.lit_ptr;
        pred_leaf.lit_desc_ptr = li.litd_ptr;
        pred_leaf.id.attr_id = substr (bit (li.lit_offset), 18);

        top_node = top_node + 1;			/* add new leaf to stack */
        node_stack (top_node) = pl_ptr;

        return;					/* build_literal */

error:
    proc (cd, loud, stack_offset, error_type, message);

dcl     cd		 fixed bin (35);		/* standard error code */
dcl     loud		 bit (1) aligned;		/* OFF => dont print or signal error */
dcl     stack_offset	 fixed bin;		/* offset from ls_top of where token is in lex stack */
dcl     error_type		 char (*);
dcl     message		 char (*);

        se_info_ptr = dbcb.se_info_ptr;

        code = cd;

        se_info.loud = loud;
        se_info.error_type = error_type;
        se_info.token_start = 0;
        se_info.stack_offset = stack_offset;		/* save this for semantics */
        se_info.error_msg = message;
        se_info.error_info_supplied = "1"b;		/* so no one else handles it */

        goto exit;

    end error;

%include mrds_dbcb;
%page;
%include mrds_predicate_tree;
%page;
%include mrds_se_info;
%page;
%include mrds_exp_fun_data;
%page;
%include mrds_compiled_se_info;
%page;
%include mrds_lit_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_range;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_debug_names;

dcl     LOUD		 bit init ("1"b) aligned internal static
			 options (constant);
dcl     a_select_area_ptr	 ptr;
dcl     addr		 builtin;
dcl     bit		 builtin;
dcl     caller_name		 char (21) init ("mrds_dsl_where_clause")
			 int static options (constant);
dcl     code		 fixed bin (35);		/* Output -- return code */
dcl     continue		 char (1) init ("c") int static
			 options (constant);	/* don't stop after printing error */
dcl     difference_mesg	 char (11) varying;		/* either "domain" or "datr type" differs */
dcl     fatal_flag		 bit (1);			/* on => fatal non-comparable domain comparison attempt */
dcl     fixed		 builtin;
dcl     info_ptr		 ptr init (null ());	/* unused */
dcl     1 li		 aligned like lit_info;
dcl     mrds_data_$max_pred_nodes
			 fixed bin (35) external static;
dcl     mrds_dsl_make_literal	 entry (ptr, ptr, fixed bin (35));
dcl     mrds_dsl_make_literal$alloc
			 entry (ptr, ptr, fixed bin (35));
dcl     mrds_error_$diff_comp_domain
			 fixed bin (35) external static;
dcl     mrds_error_$ill_term	 fixed bin (35) external static;
dcl     mrds_error_$inc_attr_acc
			 fixed bin (35) external static;
dcl     mrds_error_$node_stack_ovfl
			 fixed bin (35) external static;
dcl    1 ns aligned based (parser_static_info.ns_ptr),
         2 top_node fixed bin(35),
         2 node_stack (mrds_data_$max_pred_nodes) ptr; /* stack of pending nodes;  */
dcl     null		 builtin;
dcl     op_array		 (1:55) bit (6) unal int static
			 options (constant) init (
			 "02"b3,			/* 1 and */
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3, "00"b3, "00"b3,
			 "00"b3, "00"b3, "00"b3, "00"b3,
			 "07"b3,			/* 42 lt */
			 "11"b3,			/* 43 le */
			 "00"b3, "00"b3, "00"b3, "00"b3,
			 "05"b3,			/* 48 eq */
			 "10"b3,			/* 49 gt */
			 "12"b3,			/* 50 ge */
			 "00"b3, "00"b3,
			 "04"b3,			/* 53 not */
			 "06"b3,			/* 54 ne */
			 "03"b3);			/* 55 or */
dcl     output_pred_ptr	 ptr;			/* to root of pred tree */
dcl     reason_mesg		 char (80) varying;		/* reason for warning/error */
dcl     rel		 builtin;
dcl     return_value	 fixed bin (35) init (0);	/* unused */
dcl     se_info_ptr		 ptr;
dcl     string		 builtin;
dcl     sub_err_		 entry options (variable);	/* reports specifics of subroutine error */
dcl     substr		 builtin;
dcl     sys_info$max_seg_size	 fixed bin (35) external static;
dcl     term_type_array	 (3, 3) fixed bin int static
			 options (constant) init (
			 0, 0, 0,			/* const <op> * */
			 1, 2, 2,			/* var <op> * */
			 1, 2, 2);		/* expr <op> * */

exit:
    end mrds_dsl_where_clause_;




		    mu_break_structure.pl1          04/18/85  1437.3re  04/18/85  0907.9      112374



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

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

/* HISTORY:

   Originally written by J. A. Weeldreyer - - December 1975

   Completely rewritten by Jim Gray - - January 1980, to
   1) correct handling of arrays
   2) generalize the structure handling to any number of levels
   3) put the data length/alignment routines in common code
   4) redo the handling of settting/getting bit offsets in pointers
   5) make a call to a  common  valid_data_type  routine  so  packed
   .   decimal cound be handled

   81-10-28 Davids: modified to call bit_offset_ and set_bit_offset_
   (new  system  routines  that  came  out  with  MR9.0)  instead of
   mu_pointer_bit_offset$get  and  $set.  Also   changed   to   call
   set_bit_offset_ only if needed (i.e. if there are pad bits before
   the next data bit, i.e. needed_bits = 0)  instead  of  of  always
   calling it.

   83-04-11 Davids: Changed calls to the system procedure bit_offset_
   and set_bit_offset_ to references to the new pl1 builtins bitno and
   setbitno.
*/

mu_break_structure: break_structure: procedure (area_ptr, input_data_ptr, input_desc_ptr,
	arg_array_ptr, argument_count, error_code);

/* DESCRIPTION:

   the purpose of this routine is to make it possible for  the  user
   to  specify  a  structure  with  all attributes contained in that
   structure, when doing a store/retrieve/etc., rather  than  having
   to  give individual variables for each attribute in the relation.
   the function of this routine is to take the structure declaration
   argument  list  of  a  data pointer and a descriptor pointer, and
   convert them into an equivalent list of data/descriptor pointers,
   like  in  an  argument  list,  with individual structure elements
   described by each entry in this list, so that it looks  like  the
   user   actually  did  give  individual  variables  in  his  entry
   options(variable) call  to  store,  retrieve,  etc.  an  area  of
   sufficient  size  to  hold the new argument list to be built must
   have it's pointer passed in, and a pointer  to  the  arg_list  is
   returned,  along with the total argument count. SEE PARAMETERS ON
   NEXT PAGE.

   Note 1 difference, data pointer to varying data  types  point  to
   the length word instead of the first word of data.
*/

/* PARAMETERS:

   area_ptr - - (input) pointer, points to  an  area  of  sufficient
   size  to  hold the new argument list, appoxiamately 2 * number of
   individual variables words of storage + 4 words of overhead.

   input_data_ptr - - (input) pointer,  points  the  the  structures
   data,  this  is  taken  from  the  original arg_list of the entry
   options(variable) callee

   input_desc_ptr - - (input)  pointer,  points  to  the  structures
   descriptor, taken from the original arg_list as above.

   arg_array_ptr - - (output) pointer, points to the  array  portion
   of  the newly built argument list that contains the array of data
   and descriptor pointers.

   argument_count - - (output) fixed bin, the number of  data  items
   decribed by the newly built argument list.

   error_code - - (output) fixed bin(35), 0  unless  an  unsupported
   data type was encountered.
*/

/* initialize */

	error_code = 0;

	last_data_ptr = input_data_ptr;
	last_desc_ptr = input_desc_ptr;

/* get space for the new argument list */

	argument_count = get_arg_count ();

	num_ptrs = 2 * argument_count;

	allocate arg_array set (arg_array_ptr) in (work_area);

	al_ptr = addrel (arg_array_ptr, -2);		/* use arg_list overlay for convenience */

/* fill in the descriptor and data pointers in the new argument list */

	arg_list_index = 1;

	call fill_arg_list ();

/* the argument list header would look like this,
   if we were going to fill it in, but it is unused
   and in fact would destory block headers in the work area if used

   arg_list.arg_count, arg_list.desc_count = 2 * argument_count ;
   arg_list.code = 4 ;  arg_list.pad = 0 ;				/* normal arg list */


/* give the user back the broken down argument list we built
   pointed to by arg_array_ptr, with size of argument_count * 2 */

	return;

fill_arg_list: procedure ();

/* this is a recursive procedure to procede through the list
   of descriptors describing, the input structure, and to fill in
   an argument list with data and descriptor pointers, that is
   equivalent to the user making the call, not with a structure name,
   but with individual structure qualified references. */

	number_of_elements = fixed (string (last_desc_ptr -> descriptor.size));
	last_desc_ptr = addrel (last_desc_ptr, 1);	/* skip over structure descriptor to first element descriptor */
	element_index = 1;

/* go through all elements in this structure */

	do while (element_index <= number_of_elements & error_code = 0);

	     desc_ptr = last_desc_ptr;

/* exit if unsupported data type found */

	     if ^mu_valid_data_type$structures_arrays_ok (desc_ptr -> descriptor_overlay) then
		error_code = mrds_error_$invalid_dm_descriptor;
	     else do;

/* make a recursive call if this is a lower level structure */

		     if descriptor.type = STRUCTURE then
			call fill_arg_list ();
		     else do;

/* set the position of the data pointer to correctly reflect
   the required alignment on bit/char/word boundary according to it's type */

			     bit_offset = bitno (last_data_ptr);
			     needed_bits = mu_data_align (desc_ptr, bit_offset);
			     if needed_bits = 0
			     then next_bit_offset = bit_offset;
			     else do;
				     next_bit_offset = bit_offset + needed_bits;
				     last_data_ptr = setbitno (last_data_ptr, next_bit_offset);
				end;

/* fill in the next slot in the new argument list we are building,
   with the descriptor and data pointers for this datum,
   then set up the index for the next slot in the list */

			     arg_list.arg_des_ptr (arg_list_index) = last_data_ptr;
			     arg_list.arg_des_ptr (arg_list_index + argument_count) = desc_ptr;
			     arg_list_index = arg_list_index + 1;

/* compute the space needed for this data, and advance the pointer
   to the current end of data, so we can do proper alignment next time */

			     array_elements = get_array_size ();
			     data_length = mu_data_length (desc_ptr -> descriptor_overlay);

			     if array_elements = 0 then
				new_offset = next_bit_offset + data_length;
			     else do;
				     align_bits = mu_data_align (desc_ptr, next_bit_offset + data_length);
				     new_offset = next_bit_offset + data_length +
					((array_elements - 1) * (data_length + align_bits));
				end;

			     last_data_ptr = setbitno (last_data_ptr, new_offset);

/* advance to next descriptor for next structure element,
   this will require skipping bounds info, if this was an array */

			     last_desc_ptr = addrel (last_desc_ptr, 1 + (fixed (descriptor.number_dims) * 3));

			end;

/* go on to next structure element */

		     element_index = element_index + 1;

		end;

	end;



	declare element_index	 fixed bin;	/* number of structure element under consideration */
	declare number_of_elements	 fixed bin (35);	/* number of elements in this structure */

     end;

get_arg_count: procedure () returns (fixed bin (35));

/* routine to calculate the total number of data items that
   are include in all levels of a structure declaration
   this requires an additional recursive pass through
   the structure declaration, in order to count all
   levels of structure elements that will occupy an arg_list slot */

	number_of_args = 0;
	desc_ptr = last_desc_ptr;

	call count_elements ();

	return (number_of_args);



	declare number_of_args	 fixed bin (35);	/* number of entries needed in new arg list */

count_elements: procedure ();

/* this is a recursive routine, that will increment the
   number of arg_list slots needed, once for every non-structure
   declaration element in all levels of this structure descriptor */

	structure_size = fixed (string (descriptor.size));
	desc_ptr = addrel (desc_ptr, 1);		/* skip structure descriptor */
	element_count = 1;

/* count all non-structure declarations, making recursive calls
   for any lower level structures. note that an array counts only
   as one entry needed in the arg_list */

	do while (element_count <= structure_size);

	     if descriptor.type = STRUCTURE then
		call count_elements ();
	     else do;

/* non-structure element, count it, and advance to next descriptor */

		     number_of_args = number_of_args + 1;

		     desc_ptr = addrel (desc_ptr, 1 + (fixed (descriptor.number_dims) * 3));

		end;

/* advance to next element in structure */

	     element_count = element_count + 1;

	end;



	declare element_count	 fixed bin (35);	/* current position in structure descriptor */
	declare structure_size	 fixed bin (35);	/* total number of structure elements */

     end;

     end;

get_array_size: procedure () returns (fixed bin (35));

/* routine to find the total number of elements involved in an array */

	num_dims = fixed (descriptor.number_dims);

	if num_dims = 0 then
	     element_count = 0;			/* not an array, scalar variable */
	else do;

		element_count = 1;			/* init to multiplicative identity */

		do i = 1 to num_dims;

		     element_count = element_count * ((upper_bound (i) - lower_bound (i) + 1));

		end;

	     end;

	return (element_count);



	declare element_count	 fixed bin (35);	/* current count of number of array elements */

     end;

	declare input_data_ptr	 ptr;		/* input pointer to structure data */
	declare input_desc_ptr	 ptr;		/* input pointer to structure descriptor */
	declare arg_list_index	 fixed bin;	/* index into array of data/desc ptrs in arg list being built */
	declare area_ptr		 ptr;		/* pointer to area where arg list is allocated */
	declare work_area		 area based (area_ptr); /* area for arg list to be built in */
	declare new_offset		 fixed bin (35);	/* updated offset for end of data pointer */
	declare align_bits		 fixed bin;	/* needed padding for array data elements */
	declare mu_data_length	 entry (bit (36)) returns (fixed bin (35)); /* calculates storage bits */
	declare data_length		 fixed bin (35);	/* required storage bit length */
	declare array_elements	 fixed bin (35);	/* number of elements in an array */
	declare needed_bits		 fixed bin;	/* number of bits to get proper alignment */
	declare mu_data_align	 entry (ptr, fixed bin (35)) returns (fixed bin); /* gets padding for proper alignment */
	declare bit_offset		 fixed bin (35);	/* true bit offset of data */
	declare STRUCTURE		 fixed bin int static options (constant) init (17); /* data type for structure */
	declare mrds_error_$invalid_dm_descriptor fixed bin (35) ext; /* unsupported data type */
	declare mu_valid_data_type$structures_arrays_ok entry (bit (36)) returns (bit (1) aligned); /* decides if type supported */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare last_desc_ptr	 ptr;		/* pointer to last descriptor pointer looked at */
	declare last_data_ptr	 ptr;		/* last pointer to end of data */
	declare argument_count	 fixed bin;	/* number of data items in structure */
	declare arg_array_ptr	 ptr;		/* points to start of array of data/desc pointers */
	declare descriptor_overlay	 bit (36) unal based; /* overlay for descriptor */
	declare i			 fixed bin;	/* dimension loop index */
	declare next_bit_offset	 fixed bin (35);	/* bit offset after data alignment */
	declare arg_array		 (num_ptrs) ptr based (arg_array_ptr); /* array of desc/data ptrs to be passed back */
	dcl     (bitno, setbitno, addrel, fixed, string) builtin;

%include mdbm_descriptor;
%page;
%include mdbm_arg_list;

     end;




		    mu_build_tuple.pl1              04/18/85  1437.3re  04/18/85  0908.0      195615



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



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

mu_build_tuple:
     proc (rmri_ptr, area_ptr, vector_ptr, ml_ptr, mod_flag, code);

/* NOTES:

		      BEGIN_DESCRIPTION

   This  procedure  inserts user values into the supplied tuple.  Encoding and
   domain  integrity  checking are performed if specified.

		       END_DESCRIPTION


   HISTORY:

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

   79-05-19  Al  Kepner:  Modified  to  provide  a  handler for the conversion
   condition.

   79-06-09   Al   Kepner:  Modified  to  align  varying  attributes  on  word
   boundaries.

   79-11-16  Davids:  Corrected  calculation of offset in the tuple of varying
   strings  which  always assumed that the lengths were bit when they may have
   been character.  This could result in losing characters.

   79-12-12  Mary  Ward: Modified to correctly initialize icode and to provide
   some  measure  of  integrity checking on the data returned from user encode
   and check procedures.

   80-02-01 Jim Gray : Modified to add area_ptr parameter.

   80-02-02  Jim Gray : Modified to change the check_proc accept_flag to fixed
   bin(35), to comply with cobol interface capability.


   80-05-07 Davids: modified assignments of tuple_num_atts and tuple_nvar_atts
   to  take  values from rm_rel_info.model_num_attr and model_nvar_atts rather
   than  rm_rel_info.num_attr  and  nvar_atts.  This was to fix a problem with
   submodels were the submodel view did not contain a varying string attribute
   and the model did.

   80-09-18  Jim  Gray  :  Modified  to correct problem with modifying varying
   character string attributes.  The routine shift_attr was not converting the
   shift  length  to bit from char before shifting attributes to make room for
   the modified attribute value.

   80-09-18  Jim  Gray  :  Modified to make sure that padding space in aligned
   data  types  was  always  handled  the same, regardless of who, or how this
   module  was  called.  This was a critical bug because it caused compares to
   fail  where  they should have suceeded, and requires the user to reload his
   database, using the new version of this routine.

   80-09-19  Jim  Gray  :  Modified  to  make  padding  fix work for only byte
   oriented  data  (i.e.   strings  types  like  bit or char, and decimal data
   types) since binary arith types which are handled by word oriented hardware
   instructions  will  be  right justified, and not contain garbage in padding
   space.   Also  complex  types (binary) have there padding split between the
   real and imag parts.  (this all apllies to aligned data only)

   80-12-08 Davids: modified so that the pointer passed to Check_out points to
   the  begining  of  the  variable  in  all  cases.   It used to point to the
   begining  of  the  character  string  instead  of the length word in varing
   string  types.  This was because the pointer is used in a gen_call in which
   case  it  must  point  to  the characters not the length - but it was never
   changed back.  This was done in response to TR8572.

   81-01-17 Jim Gray : made same changes as made to mus_mod_ubtup for TR 8670,
   see that module for details.

   81-01-23 Jim Gray : corrected problem with modifying a varying attribute in
   the  case  that  the  new  size was smaller than the old size.  the routine
   shift_insert  was  causing attributes to the left of the modified attribute
   to  be  moved, when for either positive or negative shifts, only attributes
   to the right of the modified attribute in the tuple have to be moved.

   81-02-17  Jim  Gray  :  change A, for TR 9133, changed if statement in case
   where  a  new  tuple  with varying attrs is being built, and the attr being
   added to the tuple is the last varying attr so far, but of a different type
   (char versus bit) from that of the previous varying attr.  Previously a bit
   varying following a char varying caused the char varying to be overwritten,
   because  the char length was not multiplied by 9 to get a bit length.  Note
   that  for  dsl_$store  calls,  the  attrs will always be in order, thus the
   current  attr  is  the last one defined so far, only temp rel will possibly
   have the attrs differ from definition order.

   81-02-17  Jim Gray : change B, corrected second parameter to compute shift,
   to correctly be a bit rather than char length.  The effect previously, when
   the count field of the varying attr was passed was to either undershift for
   negative  shift_delta,  or overshift for positive shift_delta.  Thus either
   space  was  not recovered, or space was used when not needed.  This was for
   TR 9136, the shift_len part of that TR fix was done 80-09-19.

   81-02-17  Jim Gray : change C, for TR 9138, pointing out problem with doing
   in  place  moves  of tuple data during a modify, that can cause part of the
   string  to  overwrite  itself.   The temp_string is placed on the stack for
   this case, since only one attr is done at a time, and the largest attr is <
   1300  words.  Note that to make this fail previously required at least a 16
   character string, since the hardware works on double word pairs (i.e.  four
   words).

   81-05-06   Rickie  E.   Brinegar:  Changed  the  use  of  cu_$gen_call  for
   check_procs and encode_procs to cu_$generate_call.  This was done to permit
   check_procs and encode_procs to be written in other than pl1.

   81-05-23 Jim Gray : commented out references to threads in the tuple structure,
   as part of removing unused parts in the include file.

   81-06-01 Jim Gray : changed to use new version of resultant.

   81-08-11 Jim Gray : fixed trashed tuple problem that occurs  when
   a submodel re-orders the relation from (kh* ht* indx data) to (kh
   data indx kt) with all attributes varying strings  and  the  data
   values  are "kh1", "data1", "indx1", "kt1" for a store operation.
   The problem was that when moving attributes that are to appear to
   the  right of the current attr (say indx which arrives 3rd in the
   move list), the length of the current attribute being replaced is
   really  -36 not 0, so that the not yet existing attrs count field
   is considered for the length of the move for attrs to the right.

   81-10-22 Davids: Have converted references of the form:
   .          ptr = addr (bit_array (large_offset))
   .	              to
   .          ptr = add_bit_offset (bit_array_ptr, large_offset - 1)
   This gets around a pl1 bug (tr11784) that causes the first method
   to  produce  the  wrong  value  when  the code is compiled with a
   subscriptrange condition. The "-1" is needed because  bit_array's
   first element is 1 not 0.

   82-09-14 Mike Kubicar : Converted to use the vector structure.

   83-03-28 Davids: Modified so the general and simple typed_vectors
   only have the type and number_of_dimensions elements set correctly.
   The value_ptr and identifier (general vector only) elements are
   left un-initialized. This was done to improve the performance
   of this module which was terrible before the change. 
*/

	wa_ptr = area_ptr;				/* initialize */
	icode = 0;
	ub_alloc = "0"b;
	on conversion go to conversion_error;

	if mod_flag then do;
		general_typed_vector_ptr = vector_ptr;
		general_typed_vector.type = GENERAL_TYPED_VECTOR_TYPE;
		general_typed_vector.number_of_dimensions = move_list.nitems;
	     end;
	else do;
		simple_typed_vector_ptr = vector_ptr;
		simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
		simple_typed_vector.number_of_dimensions = move_list.nitems;
	     end;

	do i = 1 to move_list.nitems;			/* beginning of attribute value insertion loop */

	     rai_ptr = rm_rel_info.attr_ptrs (move_list.item.attr_index (i));
						/* pick up info ptrs */
	     rdi_ptr = rm_attr_info.domain_ptr;

	     if rm_domain_info.encd_proc then do;	/* if value must be encoded */
		     allocate value_for_db in (work_area) set (db_val_ptr);

		     value_for_db = "0"b;		/* clear space */

		     if move_list.item.user_desc_ptr (i) -> bit36 ^= /* if must convert prior to encoding */
			rm_domain_info.user_desc then do;

			     if rm_domain_info.user_bit_len > 2376 then do;
						/* if long, alloc. space */
				     allocate value_for_user in (work_area) set (user_val_ptr);
				     ub_alloc = "1"b;
				end;
			     else user_val_ptr = addr (wksp); /* else use stack */

			     value_for_user = "0"b;	/* clear area */

			     call
				mu_convert (move_list.item.user_ptr (i),
				move_list.item.user_desc_ptr (i), user_val_ptr,
				addr (rm_domain_info.user_desc), icode);
			     if icode ^= 0 then
				call error (icode);

			     encode_list.uv_ptr = user_val_ptr; /* put ptr in arg list */
			end;			/* if needed to convert */
		     else encode_list.uv_ptr = move_list.item.user_ptr (i);
						/* if no need to convert */

		     user_descriptor = rm_domain_info.user_desc; /* get descriptor for encode input */
		     encode_list.ud_ptr = addr (user_descriptor); /* put addr in arg list */

		     if encode_list.ud_ptr -> descriptor.type = VAR_CHAR
			/* if varying, reset arg ptr */
			| encode_list.ud_ptr -> descriptor.type = VAR_BIT then
			/* to point to string, not length */
			encode_list.uv_ptr =
			     addr (encode_list.uv_ptr -> varying.string);

		     encode_list.dbv_ptr = db_val_ptr;	/* will be output from encode */
		     db_descriptor = rm_domain_info.db_desc; /* move descriptor into local storage */
		     encode_list.dbd_ptr = addr (db_descriptor); /* and put in arg list */

		     if encode_list.dbd_ptr -> descriptor.type = VAR_CHAR
			| encode_list.dbd_ptr -> descriptor.type = VAR_BIT then
			encode_list.dbv_ptr =
			     addr (encode_list.dbv_ptr -> varying.string);

		     encode_list.code_ptr = addr (icode); /* move return code info into arg list */
		     encode_list.coded_ptr = addr (FB35_DESC);

/* 81-05-06 Rickie E. Brinegar: Start changed code ************************* */

		     call cu_$generate_call /* call user's encode proc with three arguments */
			(rm_domain_info.encd_proc_entry, addr (encode_list));
						/* call encode_proc(val_for_user,val_for_db,icode) */

/* 81-05-06 Rickie E. Brinegar: End changed code *************************** */

		     if icode ^= 0 then
			call error (icode);

		     if encode_list.dbd_ptr -> descriptor.type = VAR_CHAR
			/* move the pointer back to the length word */
			| encode_list.dbd_ptr -> descriptor.type = VAR_BIT
						/* this should be ok because varing */
		     then encode_list.dbv_ptr = addrel (encode_list.dbv_ptr, -1);
						/* strings aligned so no bit offset */

		     call Check_out (encode_list.dbd_ptr, encode_list.dbv_ptr, icode);
						/* make sure no hanky-panky */
		     if icode ^= 0 then
			call error (icode);		/* some sort of trouble */

		     if ub_alloc then do;		/* finished with user bit string */
			     ub_alloc = "0"b;
			end;

		end;				/* if encoding */

	     else do;				/* if not encoding */

		     if move_list.item.user_desc_ptr (i) -> bit36 ^= /* if must convert */
			rm_domain_info.db_desc then do;

			     allocate value_for_db in (work_area);

			     value_for_db = "0"b;	/* clear space */

			     call
				mu_convert (move_list.item.user_ptr (i),
				move_list.item.user_desc_ptr (i), db_val_ptr,
				addr (rm_domain_info.db_desc), icode);
			     if icode ^= 0 then
				call error (icode);
			end;			/* if converting */

		     else /* if no conversion required */
			db_val_ptr = move_list.item.user_ptr (i); /* point to user value as given */
		end;				/* if not encoding */

	     if rm_domain_info.ck_proc then do;		/* if there is domain integ. check proc. */

		     check_list.val_ptr = db_val_ptr;	/* set up arg list */

		     db_descriptor = rm_domain_info.db_desc; /* move descriptor into stack */
		     check_list.vd_ptr = addr (db_descriptor); /* and pass to arg list */

		     if check_list.vd_ptr -> descriptor.type = VAR_CHAR
			| check_list.vd_ptr -> descriptor.type = VAR_BIT then
			check_list.val_ptr =
			     addr (check_list.val_ptr -> varying.string);

		     accept_flag = 0;
		     check_list.af_ptr = addr (accept_flag); /* move return val stuff into arg list */
		     check_list.afd_ptr = addr (FB35_DESC);

/* 81-05-06 Rickie E. Brinegar: Start changed code ************************* */

		     call
			cu_$generate_call (rm_domain_info.ck_proc_entry,
			addr (check_list));		/* check_proc(val_for_db, accept_flag); */

/* 81-05-06 Rickie E. Brinegar: End changed code *************************** */

		     if accept_flag = 0 then /* was not acceptable */
			call error (mdbm_error_$dom_integ);

		     if check_list.vd_ptr -> descriptor.type = VAR_CHAR
			/* move the pointer back to the length word */
			| check_list.vd_ptr -> descriptor.type = VAR_BIT
						/* this should be ok because varing */
		     then check_list.val_ptr = addrel (check_list.val_ptr, -1);
						/* strings aligned so no bit offset */
		     call Check_out (check_list.vd_ptr, check_list.val_ptr, icode);
						/* make sure no hanky-panky */
		     if icode ^= 0 then
			call error (icode);
		end;				/* checking domain via proc. */

/* When boolean integrity checking is implemented, it should be inserted here */


	     if mod_flag then do;
		     general_typed_vector.dimension (i).identifier =
			rm_attr_info.model_defn_order;
		     general_typed_vector.dimension (i).value_ptr =
			db_val_ptr;
		end;
	     else simple_typed_vector.dimension (rm_attr_info.model_defn_order)
		     .value_ptr = db_val_ptr;

	end;					/* attribute value insertion loop */

	code = 0;

exit:
	return;

conversion_error:
	;
	code = mdbm_error_$conversion_condition;
	go to exit;

Check_out:
     procedure (user_desc_ptr, user_data_ptr, code);

/* This procedure makes a few simple test to determine if data returned
   from a user's encode/check procedure is what it claims to be.  Four checks
   are made:
   1) The descriptor is compared to the original descriptor.  A difference
   is deemed to be the result of deliberate misrepresentation and cause an error
   to be returned indicating an inconsistent database.
   2) Decimal data is checked for validity.  If invalidly formatted decimal
   data gets into the database, it can cause problems later.  Checking it now is
   easy.
   3) Varying strings are checked to make sure that they aren't too long.
   4) Character data is verified to contain legitimate ascii data. */

	dcl     (
	        user_desc_ptr,			/* points to returned user_descriptor */
	        user_data_ptr
	        )			 ptr;		/* points to returned user data */
	dcl     code		 fixed bin (35);	/* will be returned as non-zero if some problem with data */

	dcl     (dtype, dprec)	 fixed bin;
	dcl     (char_len, OK_char)	 fixed bin (21);
	dcl     OK_dec		 bit (1);

	dcl     var_char_str	 char (char_len) varying based;
	dcl     char_str		 char (char_len) based;
	dcl     length		 fixed bin (35) based unaligned;

	dcl     1 arithmetic_desc	 aligned based,
		2 fill		 bit (12) unaligned,
		(
		2 scale		 fixed bin (12),	/* for arithmetic data types */
		2 precision	 fixed bin (12)
		) /* size is divided into scale & precision */
				 unsigned unaligned;

	dcl     desc_overlay	 bit (36) based;	/* used for comparison purposes */

	code = 0;					/* init */

	if user_desc_ptr -> desc_overlay ^= rm_domain_info.db_desc then
	     code = mdbm_error_$incons_db;		/* this is verboten */

	else do;					/* user meant well, but double check anyway */
		dtype = user_desc_ptr -> descriptor.type; /* get type into convenient location */

		if (dtype >= FIXED_DEC & dtype <= CMPLX_FLT_DEC) /* standard decimal data types */
		     | (dtype >= PACKED_FIXED_DEC & dtype <= PACKED_CMPLX_FLT_DEC)
						/* packed decimal data types */
		then do;				/* verify that it really is decimal data */
			dprec = user_desc_ptr -> arithmetic_desc.precision;
						/* get precision for call */
			OK_dec = valid_decimal_ (dtype, user_data_ptr, dprec);
						/* check it out */
			if ^OK_dec then
			     code = error_table_$improper_data_format; /* never make it */
		     end;

		else if dtype = VAR_BIT then do;	/* varying bit string */
			if user_data_ptr -> length > rm_attr_info.bit_length then
			     code = error_table_$improper_data_format; /* too long */
		     end;

		else if dtype = CHAR | dtype = VAR_CHAR then do; /* character string */
			OK_char = 0;		/* assume the best */
			if dtype = VAR_CHAR then do;	/* varying string */
				char_len = user_data_ptr -> length; /* get length out of string */
				if (char_len * 9) > rm_attr_info.bit_length then
				     OK_char = 1;
				else OK_char =
					verify (user_data_ptr -> var_char_str, collate ());
			     end;
			else do;
				char_len = user_desc_ptr -> descriptor.size;
				OK_char = verify (user_data_ptr -> char_str, collate ());
			     end;
			if OK_char ^= 0 then
			     code = error_table_$improper_data_format;
		     end;
	     end;

     end Check_out;

error:
     proc (cd);

/* Error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_move_list;
%page;
%include vu_typed_vector;
%page;
	dcl     (
	        wa_ptr,				/* pointer to work area */
	        db_val_ptr,				/* pointer to converted value, ready for tuple */
	        vector_ptr,				/* pointer to vector */
	        user_val_ptr
	        )			 ptr;		/* pointer to converted value, prior to encoding */
	dcl     wksp		 (33) fixed bin (71);

	dcl     (
	        mod_flag,				/* Input: on indicats modify rather than store */
	        ub_alloc
	        )			 bit (1) aligned;

	dcl     i			 fixed bin;	/* internal indexes */

	dcl     (
	        code,				/* Output: status code */
	        icode				/* internal status code */
	        )			 fixed bin (35);

	dcl     accept_flag		 fixed bin (35);
	dcl     db_descriptor	 bit (36) aligned;	/* temporary for database definition descriptor */
	dcl     user_descriptor	 bit (36) aligned;	/* temprorary for user proc descriptor */

	dcl     work_area		 area (sys_info$max_seg_size) based (wa_ptr); /* working area */
	dcl     value_for_db	 bit (rm_attr_info.bit_length) based (db_val_ptr);
						/* converted value, ready for tuple */
	dcl     value_for_user	 bit (rm_domain_info.user_bit_len) based (user_val_ptr);
						/* converted val., ready for encoding */
	dcl     bit36		 bit (36) based;	/* templates */
	dcl     1 varying		 based unaligned,	/* description of varying string - used for arg list building */
		2 length		 fixed bin (35),	/* length portion of varying string */
		2 string		 char (0);	/* string portion of varying string */

	dcl     1 descriptor	 aligned based,
	        (
		2 flag		 bit (1),
		2 type		 fixed bin (6) unsigned, /* data type */
		2 packed		 bit (1),		/* ON = unaligned */
		2 number_dims	 fixed bin (4) unsigned, /* non-zero for arrays */
		2 size		 fixed bin (24) unsigned
		)		 unaligned,	/* size of data */
		2 array_info	 (0 refer (descriptor.number_dims)),
		  3 lower_bound	 fixed bin (35),
		  3 upper_bound	 fixed bin (35),
		  3 multiplier	 fixed bin (35);

	dcl     1 encode_list	 aligned,		/* arg list for encode proc. */
		2 nargs		 fixed bin (17) unal init (6),
		2 code		 fixed bin (17) unal init (4),
		2 ndescs		 fixed bin (17) unal init (6),
		2 pad		 fixed bin (17) unal init (0),
		2 uv_ptr		 ptr,
		2 dbv_ptr		 ptr,
		2 code_ptr	 ptr,
		2 ud_ptr		 ptr,
		2 dbd_ptr		 ptr,
		2 coded_ptr	 ptr;

	dcl     1 check_list	 aligned,		/* arg list for integ. check proc. */
		2 nargs		 fixed bin (17) unal init (4),
		2 code		 fixed bin (17) unal init (4),
		2 ndescs		 fixed bin (17) unal init (4),
		2 pad		 fixed bin (17) unal init (0),
		2 val_ptr		 ptr,
		2 af_ptr		 ptr,
		2 vd_ptr		 ptr,
		2 afd_ptr		 ptr;

	dcl     FB35_DESC		 bit (36) aligned int static options (constant)
				 init ("100000100000000000000000000000100011"b);
	dcl /* interesting data types */
	        (
	        FIXED_DEC		 init (9),
	        CMPLX_FLT_DEC	 init (12),
	        VAR_BIT		 init (20),
	        CHAR		 init (21),
	        VAR_CHAR		 init (22),
	        PACKED_FIXED_DEC	 init (41),
	        PACKED_CMPLX_FLT_DEC	 init (46)
	        )			 unsigned binary (6) static options (constant);

	dcl     (
	        sys_info$max_seg_size,
	        mdbm_error_$dom_integ
	        )			 ext fixed bin (35);
	dcl     mdbm_error_$incons_db	 external fixed bin (35);
	dcl     error_table_$improper_data_format external fixed bin (35);
	dcl     mdbm_error_$conversion_condition ext fixed bin (35);

	dcl     conversion		 condition;

	dcl     (addr, addrel, collate, verify, null) builtin;

	dcl     mu_convert		 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     valid_decimal_	 entry (fixed bin, ptr, fixed bin) returns (bit (1));
	declare area_ptr		 ptr;
     end mu_build_tuple;




		    mu_check_conflict.pl1           10/23/86  1024.8r w 10/23/86  1009.3       54243



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

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

mu_check_conflict: check_conflict: procedure (set_or_del_scope, input_fil_list_ptr,
	permit_requests_ptr, prevent_requests_ptr, conflict_detail_ptr, conflict_sw);

/*
   DESCRIPTION:
   This procedure checks to see if there is a conflict between the scope
   being requested for a given file and the scope currently in force for
   each user of the file

   It also checks to see if the scope to be deleted is a proper subset
   of the scope which the user currently has in force

   ---------------------------------------------------------------------------

   HISTORY:

   Originally coded by Oris Friesen in July 1977
   Modified 24 July 1980 by M Pierret to make permit/prevent ops be 2 bits
   called bits instead of one for mod,del,store.. Also to do indexing on bits
   directly instead of whole structure, since garbage in fillers were causing
   incorrect results.

   80-12-10 Jim Gray : completely rewritten to
   1) change from r-u to r-s-m-d type scope modes
   2) provide a common include file for passing
   scope mode request parameter information
   3) add a parameter containg the details of
   exactly what conflict resulted in setting the switch.
   4) document the module more completely

*/

/* PARAMETERS:

   set_or_del_scope - - (input) bit (1), indicates whether this is a call
   from set_scope(ON), or delete_scope(OFF), so that the type
   of conflict to be checked for can be known.

   input_fil_list_ptr - - (input) ptr, points to the particular entry
   in the databsae control segment about which conflict is to be checked.
   This file/relation entry contains what scope other users already
   have had set.

   permit_requests_ptr - - (input) ptr, points to an overlay of the fixed bin
   encoding of the requested permit ops given to set/dl_scope.

   prevent_requests_ptr - - (input) ptr, same as above, but for prevent ops.

   conflict_detail_ptr - - (input) ptr, pointer to a structure which will be filled
   in giving the details of what the actual conflict was, that may have caused
   setting of the conflcit_sw.

   conflict_sw - - (output) bit(1), this will be ON if a scope conflict
   has been detected, else OFF.

*/

/* set up local variables and initialize */

	fl_ptr = input_fil_list_ptr;			/* use local variable */
	unspec (conflict_detail) = "0"b;		/* initialize */

	if set_or_del_scope = SET then do;

/* this is a set_scope request, thus we must make sure that the requested
   permit modes are not being prevented by some other user.
   Also, the requested prevent modes must not already be in effect by
   some other user on the relation/file under consideration */

		conflict_detail.permits.read_attr = (permit_requests.read_attr & fil_list.prevents.read_attr);
		conflict_detail.permits.modify_attr = (permit_requests.modify_attr & fil_list.prevents.modify_attr);
		conflict_detail.permits.append_tuple = (permit_requests.append_tuple & fil_list.prevents.append_tuple);
		conflict_detail.permits.delete_tuple = (permit_requests.delete_tuple & fil_list.prevents.delete_tuple);

		conflict_detail.prevents.read_attr = (prevent_requests.read_attr & fil_list.permits.read_attr);
		conflict_detail.prevents.modify_attr = (prevent_requests.modify_attr & fil_list.permits.modify_attr);
		conflict_detail.prevents.append_tuple = (prevent_requests.append_tuple & fil_list.permits.append_tuple);
		conflict_detail.prevents.delete_tuple = (prevent_requests.delete_tuple & fil_list.permits.delete_tuple);

	     end;

	else do;

/* the requested operation is a del_scope,
   thus we must check that the given permit and prevent modes
   given do in fact exist as already set on this file/relation */

		conflict_detail.permits.read_attr = (permit_requests.read_attr & ^(fil_list.permits.read_attr));
		conflict_detail.permits.modify_attr = (permit_requests.modify_attr & ^(fil_list.permits.modify_attr));
		conflict_detail.permits.append_tuple = (permit_requests.append_tuple & ^(fil_list.permits.append_tuple));
		conflict_detail.permits.delete_tuple = (permit_requests.delete_tuple & ^(fil_list.permits.delete_tuple));

		conflict_detail.prevents.read_attr = (prevent_requests.read_attr & ^(fil_list.prevents.read_attr));
		conflict_detail.prevents.modify_attr = (prevent_requests.modify_attr & ^(fil_list.prevents.modify_attr));
		conflict_detail.prevents.append_tuple = (prevent_requests.append_tuple & ^(fil_list.prevents.append_tuple));
		conflict_detail.prevents.delete_tuple = (prevent_requests.delete_tuple & ^(fil_list.prevents.delete_tuple));


	     end;

/* now we can set the conflict switch, since all the details are known */

	conflict_sw = ^((string (conflict_detail.permits) = "0"b) & (string (conflict_detail.prevents) = "0"b));

	return;


	dcl     input_fil_list_ptr	 ptr parm;

	dcl     null		 builtin;
	dcl     string		 builtin;
	dcl     unspec		 builtin;

	dcl     conflict_sw		 bit (1) unal;	/* ON => a conflict in scope requested has been detected */
	dcl     set_or_del_scope	 bit (1) unal;	/* ON => set_scope request; OFF => dl_scope request */

%include mdbm_users;
%include mdbm_scope_requests;

     end mu_check_conflict;





		    mu_check_scope.pl1              10/23/86  1024.8r w 10/23/86  1009.3       41445



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

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

mu_check_scope: check_scope: procedure (dbc_p, fle_ptr, this_ul_ptr, permit_requests_ptr, prevent_requests_ptr,
	conflict_detail_ptr, conflict_sw, conflict_ul_ptr);

/* this procedure checks to see if a requested scope can be granted to the user */

/* HISTORY:

   Originally written by O Friesen in July 1977
   Modified by M. Pierret 17 April 1980 to remove priority queue checking.

   80-12-10 Jim Gray : changed to use of mdbm_scope_requests include file
   to supprot change from r-u to r-s-m-d type scope modes.
   Also added conflict_detail_ptr parameter.
*/

/* first check the active scopes in force for this file */

	dbc_ptr = dbc_p;				/* use local variable */
	num_filns = 0;
	conflict_ul_ptr = null;
	ul_ptr = this_ul_ptr;
	this_user_id = user_list.process_id;

	ul_ptr = convert (dbc_ptr, dbc.active_users_ofs);

	conflict_sw = "0"b;


	do while (ul_ptr ^= null);

	     call check_files_scopes;
						/* conflict_sw and conflict_ul_ptr will be set by
						   check_files_scopes if necessary */

	     ul_ptr = convert (dbc_ptr, user_list.next_active_ofs); /* look at next active user */

	end;

/* must also examine all waiting processes whose event_signal_sw is ON, and
   *  processes who are high priority waiters.  To avoid deadlocks, if the process
   *  requesting scope is a high priority user, then high priority waiters are not
   *  checked */

	if ^conflict_sw then do;
		ul_ptr = convert (dbc_ptr, dbc.waiting_users_ofs);

		do while (ul_ptr ^= null);
		     if user_list.event_signal_sw
		     then call check_files_scopes;
		     else if ^(this_ul_ptr -> user_list.priority_high)
			     & user_list.priority_high
		     then call check_files_scopes;
		     else ;

		     ul_ptr = convert (dbc_ptr, user_list.next_waiting_ofs);
		end;

	     end;

	return;

check_files_scopes: proc;

	fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs); /* look at each list of files for each active user */
	do while (fl_ptr ^= null & ^conflict_sw);

	     if fil_name = fil_list.name
	     then if ul_ptr ^= this_ul_ptr
		then call mu_check_conflict (SET, fl_ptr, permit_requests_ptr, prevent_requests_ptr,
			conflict_detail_ptr, conflict_sw);
	     if conflict_sw then conflict_ul_ptr = ul_ptr;
	     fl_ptr = convert (dbc_ptr, fil_list.next_ofs); /* look at next file in this user's list */
	end;

     end check_files_scopes;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */


	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;


	dcl     dbc_p		 ptr parm;


	dcl     fil_name		 char (30) based (fle_ptr); /* name of file whose scope is being checked */

	dcl     fle_ptr		 ptr;		/* ptr to name of file whose scope is being checked */
	dcl     conflict_ul_ptr	 ptr;		/* pointer to a user causing a conflict with a scope request */
	dcl     this_ul_ptr		 ptr;		/* parameter ptr to user_list */

	dcl     this_user_id	 bit (36);	/* process id of this user */

	dcl     conflict_sw		 bit (1) unal;	/* ON => a scope conflict */

	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     null		 builtin;
	dcl     ptr		 builtin;
	dcl     rel		 builtin;

	dcl     mu_check_conflict	 entry (bit (1), ptr, ptr, ptr, ptr, bit (1));



	dcl     sys_info$max_seg_size	 fixed bin ext;

%include mdbm_dbc;
%include mdbm_scope_requests;

%include mdbm_users;

     end mu_check_scope;




		    mu_compare_values.pl1           04/18/85  1437.3re  04/18/85  0908.0      212877



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

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

mu_compare_values: compare_data_values: proc (value1_ptr, desc1_ptr, value2_ptr, desc2_ptr, operator, result, code);

/* DESCRIPTION */

/*
   This routine accepts two pointers to some data values and two pointers to the
   Multics descriptors describing those values, it compares them with respect
   to the input relational operator. Eithr a result ("1"b or "0"b) or an error code
   is returned. Character strings may be compared only against other character
   strings either or both of which may be varying. The same for bit strings. Complex
   numeric data types may be compared only against other complex data types, also
   only the operators equal and not_equal may be used, any other operator will
   cause an error. Real numeric data types may be compared only against other real
   numeric data types. Any other combination of data types will generate an error.
   Numeric comparisons are performed by converting the operands into complex/real
   float decimal (59).

   All errors are reported to the user via sub_err_ as well as in the returned
   error code.

   The internal procedure error performs a non-local goto to compare_values_exit
   to exit this routine.


   
   
   HISTORY:

   16-aug_79 NSDavids Original coding

   Modified by Jim Gray - - Dec. 1979, to add  packed  decimal  data
   type capability

   Modified  March  25,  1980  by  R.  Lackey  to  remove  calls  to
   mdbm_util_

   Modified November 24, 1980 by M.  Pierret  to  align  result  for
   efficiency

   81-05-19 Jim Gray : changed the "&" to "|"  in  the  complex  and
   real  data  type  cases,  so  that  any  complex  or  real number
   comparisons can be handled.

   81-05-20 Jim Gray : added a case for doing bit-char type compares
   by  converting  the  bit  operand  to char, and doing a char-char
   compare. Also added data type to  error  message  for  conversion
   errors.

   81-05-23 Jim Gray : added  special  case  for  fixed  bin,  equal
   scale, comaprisons, for performance improvment, by avoiding calls
   to mu_convert for this case. This  was  originally  coded  by  M.
   Pierret.  I adopted it, and made some corrections to the original
   code, and put it in the subroutine compare_fb_fb.

   81-05-23  B  Jim  Gray  :  added  special  case  for  float   bin
   comparisons,  done  in  a  manner  similar  to the fixed bin case
   above.

   83-06-13 Ron Harvey : changed addrel (addr (char_temp), 1)  to be
   addrel (char_temp_ptr, 1) instead. This alleviates a compiler bug
   (phx15402).

*/

/* PARAMETERS */

	dcl     value1_ptr		 ptr;		/* (input) pointer to first operand */
	dcl     desc1_ptr		 ptr;		/* (input) pointer to descriptor of first operand */
	dcl     value2_ptr		 ptr;		/* (input) ditto for the second operand */
	dcl     desc2_ptr		 ptr;		/* (input) ditto ditto */
	dcl     operator		 fixed bin;	/* (input) the relational operator */
						/* 1 = */
						/* 2 ^= */
						/* 3 < */
						/* 4 <= */
						/* 5 > */
						/* 6 >= */
	dcl     result		 bit (1) aligned;	/* (output) true if comparison was true */
	dcl     code		 fixed bin (35);	/* (output) error code */

/* BASED */

	dcl     01 varying_string	 based,
		02 size		 bit (36),	/* first word is length */
		02 data		 bit (36);	/* rest is data */

	dcl     01 desc		 based,		/* a multics descriptor */
		02 version	 bit (1) unal,
		02 type		 bit (6) unal,
		02 packed		 bit (1) unal,
		02 dims		 bit (4) unal,
		02 size,
		  03 scale	 bit (12) unal,
		  03 precision	 bit (12) unal;

	dcl     desc1_type		 unsigned fixed bin (6) based (addr (desc1.type)) unal;
	dcl     desc2_type		 unsigned fixed bin (6) based (addr (desc2.type)) unal;

	declare bit_temp		 bit (bit_temp_size) based; /* overlay for doing bit-char compares */

	declare 1 overlay		 based,		/* overlay for count field of varying string */
		2 unused		 bit (12),
		2 fb24		 bit (24);	/* only need 24 bits worth */

/* CONSTANTS */

	dcl     CHAR		 bit (6) init ("010101"b) internal static options (constant);
	dcl     CHAR_VAR		 bit (6) init ("010110"b) internal static options (constant);
	dcl     BIT		 bit (6) init ("010011"b) internal static options (constant);
	dcl     BIT_VAR		 bit (6) init ("010100"b) internal static options (constant);
	dcl     CFLD59A_DESC	 bit (36) init ("100110000000000000000000000000111011"b) internal static options (constant);
	dcl     RFLD59A_DESC	 bit (36) init ("100101000000000000000000000000111011"b) internal static options (constant);
	dcl     REAL		 (63) bit (1) internal static options (constant) /* true if tuple is real */
				 init ((4) ("1"b), (4) ("0"b), (2) ("1"b), (2) ("0"b), (30) ("0"b), (2) ("1"b), (19) ("0"b));
	dcl     COMPLEX		 (63) bit (1) internal static options (constant) /* true if type is complex */
				 init ((4) ("0"b), (4) ("1"b), (2) ("0"b), (2) ("1"b), (32) ("0"b), (2) ("1"b), (17) ("0"b));
	declare FIXED_BIN		 (63) bit (1) int static options (constant) /* true if fixed bin value */
				 init ((2) ("1"b), (61) ("0"b));
	declare FLOAT_BIN		 (63) bit (1) int static options (constant) /* true if float bin value */
				 init ((2) ("0"b), (2) ("1"b), (59) ("0"b));
	declare mu_display_descriptor	 entry (ptr) returns (char (120) varying);
	dcl     mrds_error_$inv_comparison fixed bin (35) external static;
	dcl     mrds_error_$inv_operator fixed bin (35) external static;

/* AUTOMATIC */

	dcl     01 desc1		 like desc;
	dcl     01 desc2		 like desc;
	dcl     operand1_ptr	 ptr;		/* pointer toward what will be used as first operand */
	dcl     operand2_ptr	 ptr;		/* pointer toward what will be used as second operand */
	dcl     cfld59a1		 complex float decimal (59) aligned; /* place for the first operand if its complex */
	dcl     cfld59a2		 complex float decimal (59) aligned; /* ditto for the second operand */
	dcl     rfld59a1		 real float decimal (59) aligned; /* place for the first operand if its real */
	dcl     rfld59a2		 real float decimal (59) aligned; /* ditto for the second operand */
	declare bit_temp_size	 fixed bin (24);	/* bit length of overlay for bit_char compare */
	declare char_temp		 char (4096) varying; /* place for char version of bit string */
	declare char_temp_ptr	 ptr;		/* will be address of char_temp */
	declare char_temp_size	 bit (24);	/* temp for char-char compare routine parameter */

/* MRDS ROUTINES */

	dcl     mu_convert		 entry (ptr, ptr, ptr, ptr, fixed bin (35));

	declare (addr, addrel, bin, char, copy, ltrim, null, string, substr, unspec) builtin;

	code = 0;					/* make sure we don't return garbage */
	result = "0"b;


	desc1 = desc1_ptr -> desc;			/* get our own copy of the descriptors */
	desc2 = desc2_ptr -> desc;

	if desc1.type = CHAR_VAR | desc1.type = BIT_VAR	/* make varying strings look like non-varying */
	then do;
		operand1_ptr = addr (value1_ptr -> varying_string.data); /* move operand pointer over one word */
		string (desc1.size) = substr (value1_ptr -> varying_string.size, 13);
						/* modify descriptor to show accutal string length */
		desc1_type = desc1_type - 1;		/* modify type to non-varying */
	     end;
	else operand1_ptr = value1_ptr;

	if desc2.type = CHAR_VAR | desc2.type = BIT_VAR
	then do;
		operand2_ptr = addr (value2_ptr -> varying_string.data);
		string (desc2.size) = substr (value2_ptr -> varying_string.size, 13);
		desc2_type = desc2_type - 1;
	     end;
	else operand2_ptr = value2_ptr;

	if operator < 1 | operator > 6		/* make sure we have a legal operator */
	then call error (mrds_error_$inv_operator, ltrim (char (operator)) || " is not a valid operator code");



/* Do the comparison */


	if desc1.type = CHAR & desc2.type = CHAR
	then call compare_char_char (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size),
		operator, result);


	else
	     if desc1.type = BIT & desc2.type = BIT
	then call compare_bit_bit (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size), operator, result);


	else
	     if COMPLEX (desc1_type) | COMPLEX (desc2_type) /* CHANGE 81-05-19 : allow any complex number comparison */
	then do;
		call mu_convert (operand1_ptr, addr (desc1), addr (cfld59a1), addr (CFLD59A_DESC), code);
		if code ^= 0
		then call error (code, "Could not convert a " || mu_display_descriptor (desc1_ptr) ||
			" value to a complex float decimal (59) data type");
		call mu_convert (operand2_ptr, addr (desc2), addr (cfld59a2), addr (CFLD59A_DESC), code);
		if code ^= 0
		then call error (code, "Could not convert a " ||
			mu_display_descriptor (desc2_ptr) || " value to a complex float decimal (59) data type");
		call compare_c59_c59 (cfld59a1, cfld59a2, operator, result);
	     end;


	else
	     if REAL (desc1_type) | REAL (desc2_type)	/* CHANGE 81-05-19 : allow any real number comparison */
	then do;

/* BEGIN CHANGE 81-05-23 ********************************************** */

		if FIXED_BIN (desc1_type) & FIXED_BIN (desc2_type) &
		     desc1.scale = desc2.scale then
		     call compare_fb_fb ();
		else if FLOAT_BIN (desc1_type) & FLOAT_BIN (desc2_type) then
		     call compare_flb_flb ();

/* END CHANGE 81-05-23 ************************************************ */

		else do;
			call mu_convert (operand1_ptr, addr (desc1), addr (rfld59a1), addr (RFLD59A_DESC), code);
			if code ^= 0
			then call error (code, "Could not convert a " || mu_display_descriptor (desc1_ptr) ||
				" value to a real float decimal (59) data type");
			call mu_convert (operand2_ptr, addr (desc2), addr (rfld59a2), addr (RFLD59A_DESC), code);
			if code ^= 0
			then call error (code, "Could not convert a " ||
				mu_display_descriptor (desc2_ptr) || " value to a real float decimal (59) data type");
			call compare_r59_r59 (rfld59a1, rfld59a2, operator, result);
		     end;
	     end;


/* BEGIN CHANGE 81-05-20 ******************************************** */

	else if (desc1.type = BIT & desc2.type = CHAR) | (desc1.type = CHAR & desc2.type = BIT) then do;

/* do bit-char comparisons as char-char comaprisons,
   after converting the bit oeprand to character */

		if desc1.type = BIT then do;
			bit_temp_size = bin (string (desc1.size));
			char_temp = char (operand1_ptr -> bit_temp);
			char_temp_size = addr (char_temp) -> overlay.fb24;
			char_temp_ptr = addr (char_temp);
			call compare_char_char (addrel (char_temp_ptr, 1), char_temp_size,
			     operand2_ptr, string (desc2.size),
			     operator, result);
		     end;
		else do;
			bit_temp_size = bin (string (desc2.size));
			char_temp = char (operand2_ptr -> bit_temp);
			char_temp_size = addr (char_temp) -> overlay.fb24;
			char_temp_ptr = addr (char_temp);
			call compare_char_char (operand1_ptr, string (desc1.size),
			     addrel (char_temp_ptr, 1), char_temp_size,
			     operator, result);
		     end;
	     end;

/* END CHANGE 81-05-20 *********************************************** */


	else call error (mrds_error_$inv_comparison, "The data types " || mu_display_descriptor (desc1_ptr) ||
		" and " || mu_display_descriptor (desc2_ptr) || " cannot be compared");


compare_values_exit:
	return;

compare_char_char: proc (c_operand1_ptr, c_operand1_size, c_operand2_ptr, c_operand2_size, c_operator, c_result);

/* PARAMETERS */

	dcl     c_operand1_ptr	 ptr;
	dcl     c_operand1_size	 bit (24);
	dcl     c_operand2_ptr	 ptr;
	dcl     c_operand2_size	 bit (24);
	dcl     c_operator		 fixed bin;
	dcl     c_result		 bit (1) aligned;

/* BASED */

	dcl     c_operand1		 char (bin (c_operand1_size)) based (c_operand1_ptr);
	dcl     c_operand2		 char (bin (c_operand2_size)) based (c_operand2_ptr);


	goto c_compare (c_operator);			/* value of c_operator was checked when
						   compare_values was entered */


c_compare (1):					/* operator: = */
	if c_operand1 = c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;

c_compare (2):					/* operator: ^= */
	if c_operand1 ^= c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;

c_compare (3):					/* operator: < */
	if c_operand1 < c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;

c_compare (4):					/* operator: <= */
	if c_operand1 <= c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;

c_compare (5):					/* operator: > */
	if c_operand1 > c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;

c_compare (6):					/* operator: >= */
	if c_operand1 >= c_operand2
	then c_result = "1"b;
	else c_result = "0"b;
	goto c_exit;


c_exit:	return;

     end /* compare_char_char */;

compare_bit_bit: proc (b_operand1_ptr, b_operand1_size, b_operand2_ptr, b_operand2_size, b_operator, b_result);

/* PARAMETERS */

	dcl     b_operand1_ptr	 ptr;
	dcl     b_operand1_size	 bit (24);
	dcl     b_operand2_ptr	 ptr;
	dcl     b_operand2_size	 bit (24);
	dcl     b_operator		 fixed bin;
	dcl     b_result		 bit (1) aligned;

/* BASED */

	dcl     b_operand1		 bit (bin (b_operand1_size)) based (b_operand1_ptr);
	dcl     b_operand2		 bit (bin (b_operand2_size)) based (b_operand2_ptr);


	goto b_compare (b_operator);			/* value of b_operator was checked when
						   compare_values was entered */


b_compare (1):					/* operator: = */
	if b_operand1 = b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;

b_compare (2):					/* operator: ^= */
	if b_operand1 ^= b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;

b_compare (3):					/* operator: < */
	if b_operand1 < b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;

b_compare (4):					/* operator: <= */
	if b_operand1 <= b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;

b_compare (5):					/* operator: > */
	if b_operand1 > b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;

b_compare (6):					/* operator: >= */
	if b_operand1 >= b_operand2
	then b_result = "1"b;
	else b_result = "0"b;
	goto b_exit;


b_exit:	return;

     end /* compare_bit_bit */;

compare_c59_c59: proc (cx_operand1, cx_operand2, cx_operator, cx_result);

/* PARAMETERS */

	dcl     cx_operand1		 complex float decimal (59) aligned;
	dcl     cx_operand2		 complex float decimal (59) aligned;
	dcl     cx_operator		 fixed bin;
	dcl     cx_result		 bit (1) aligned;



	goto cx_compare (cx_operator);		/* value of cx_operator was checked when
						   compare_values was entered */


cx_compare (1):					/* operator: = */
	if cx_operand1 = cx_operand2
	then cx_result = "1"b;
	else cx_result = "0"b;
	goto cx_exit;

cx_compare (2):					/* operator: ^= */
	if cx_operand1 ^= cx_operand2
	then cx_result = "1"b;
	else cx_result = "0"b;
	goto cx_exit;

cx_compare (3):					/* operator: < */
	call error (mrds_error_$inv_operator, "The relational operator < is not allowed for complex data types");
	goto cx_exit;

cx_compare (4):					/* operator: <= */
	call error (mrds_error_$inv_operator, "The relational operator <= is not allowed for complex data types");
	goto cx_exit;

cx_compare (5):					/* operator: > */
	call error (mrds_error_$inv_operator, "The relational operator > is not allowed for complex data types");
	goto cx_exit;

cx_compare (6):					/* operator: >= */
	call error (mrds_error_$inv_operator, "The relational operator >= is not allowed for complex data types");
	goto cx_exit;


cx_exit:	return;

     end /* compare_c59_c59 */;

compare_r59_r59: proc (r_operand1, r_operand2, r_operator, r_result);

/* PARAMETERS */

	dcl     r_operand1		 real float decimal (59) aligned;
	dcl     r_operand2		 real float decimal (59) aligned;
	dcl     r_operator		 fixed bin;
	dcl     r_result		 bit (1) aligned;



	goto r_compare (r_operator);			/* value of r_operator was checked when
						   compare_values was entered */


r_compare (1):					/* operator: = */
	if r_operand1 = r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;

r_compare (2):					/* operator: ^= */
	if r_operand1 ^= r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;

r_compare (3):					/* operator: < */
	if r_operand1 < r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;

r_compare (4):					/* operator: <= */
	if r_operand1 <= r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;

r_compare (5):					/* operator: > */
	if r_operand1 > r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;

r_compare (6):					/* operator: >= */
	if r_operand1 >= r_operand2
	then r_result = "1"b;
	else r_result = "0"b;
	goto r_exit;


r_exit:	return;

     end /* compare_r59_r59 */;

/* BEGIN CHANGE 81-05-23 **************************************************** */

compare_fb_fb: procedure ();

/* Comparison of special cased fixed binary values, with equal scales */

	declare fb35a		 fixed bin (35) aligned based; /* for picking up packed, with prec < 36 */
	declare fb71a		 fixed bin (71) aligned based; /* for picking up packed, with prec < 71, but >= 36 */
	declare fixed_bin_operand1	 fixed bin (71);	/* first value to compare */
	declare fixed_bin_operand2	 fixed bin (71);	/* second value to compare */
	declare bit_operand1	 bit (bit_operand1_len) based (operand1_ptr); /* gets significant digits */
	declare bit_operand2	 bit (bit_operand2_len) based (operand2_ptr); /* gets significant digits */
	declare bit_operand1_len	 fixed bin;	/* length of significant digit portion */
	declare bit_operand2_len	 fixed bin;	/* length of significant digit portion */

	if desc1.packed
	then do;
		bit_operand1_len = bin (desc1.precision) + 1;
		if substr (bit_operand1, 1, 1)
		then unspec (fixed_bin_operand1) = copy ("1"b, 71 - bin (desc1.precision)) || bit_operand1;
		else unspec (fixed_bin_operand1) = copy ("0"b, 71 - bin (desc1.precision)) || bit_operand1;
	     end;
	else if bin (desc1.precision) < 36
	then fixed_bin_operand1 = operand1_ptr -> fb35a;
	else fixed_bin_operand1 = operand1_ptr -> fb71a;

	if desc2.packed
	then do;
		bit_operand2_len = bin (desc2.precision) + 1;
		if substr (bit_operand2, 1, 1)
		then unspec (fixed_bin_operand2) = copy ("1"b, 71 - bin (desc2.precision)) || bit_operand2;
		else unspec (fixed_bin_operand2) = copy ("0"b, 71 - bin (desc2.precision)) || bit_operand2;
	     end;
	else if bin (desc2.precision) < 36
	then fixed_bin_operand2 = operand2_ptr -> fb35a;
	else fixed_bin_operand2 = operand2_ptr -> fb71a;



	goto FB_COMPARE (operator);

FB_COMPARE (1):					/* operator: = */
	if fixed_bin_operand1 = fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

FB_COMPARE (2):					/* operator: ^= */
	if fixed_bin_operand1 ^= fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

FB_COMPARE (3):					/* operator: < */
	if fixed_bin_operand1 < fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

FB_COMPARE (4):					/* operator: <= */
	if fixed_bin_operand1 <= fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

FB_COMPARE (5):					/* operator: > */
	if fixed_bin_operand1 > fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

FB_COMPARE (6):					/* operator: >= */
	if fixed_bin_operand1 >= fixed_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FB_COMPARE;

END_FB_COMPARE:

     end;

/* END CHANGE 81-05-23 ************************************************** */

/* BEGIN CHANGE 81-05-23 B **************************************************** */

compare_flb_flb: procedure ();

/* Comparison of special cased float binary values, with equal scales */

	declare flb27a		 float bin (27) aligned based; /* for picking up packed, with prec <= 27 */
	declare flb63a		 float bin (63) aligned based; /* for picking up packed, with prec < 63, but >= 27 */
	declare float_bin_operand1	 float bin (63);	/* first value to compare */
	declare float_bin_operand2	 float bin (63);	/* second value to compare */
	declare 1 bit_operand1	 unal based (operand1_ptr), /* gets significant digits */
		2 exponent	 bit (8) unal,
		2 mantissa	 bit (bit_operand1_len);
	declare 1 bit_operand2	 unal based (operand2_ptr), /* gets significant digits */
		2 exponent	 bit (8) unal,
		2 mantissa	 bit (bit_operand2_len);
	declare bit_operand1_len	 float bin;	/* length of significant digit portion */
	declare bit_operand2_len	 float bin;	/* length of significant digit portion */

	if desc1.packed
	then do;
		bit_operand1_len = bin (desc1.precision) + 1;
		if substr (bit_operand1.mantissa, 1, 1)
		then unspec (float_bin_operand1) = string (bit_operand1) || copy ("1"b, 63 - bin (desc1.precision));
		else unspec (float_bin_operand1) = string (bit_operand1) || copy ("0"b, 63 - bin (desc1.precision));
	     end;
	else if bin (desc1.precision) <= 27
	then float_bin_operand1 = operand1_ptr -> flb27a;
	else float_bin_operand1 = operand1_ptr -> flb63a;

	if desc2.packed
	then do;
		bit_operand2_len = bin (desc2.precision) + 1;
		if substr (bit_operand2.mantissa, 1, 1)
		then unspec (float_bin_operand2) = string (bit_operand2) || copy ("1"b, 63 - bin (desc2.precision));
		else unspec (float_bin_operand2) = string (bit_operand2) || copy ("0"b, 63 - bin (desc2.precision));
	     end;
	else if bin (desc2.precision) <= 27
	then float_bin_operand2 = operand2_ptr -> flb27a;
	else float_bin_operand2 = operand2_ptr -> flb63a;



	goto FLB_COMPARE (operator);

FLB_COMPARE (1):					/* operator: = */
	if float_bin_operand1 = float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

FLB_COMPARE (2):					/* operator: ^= */
	if float_bin_operand1 ^= float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

FLB_COMPARE (3):					/* operator: < */
	if float_bin_operand1 < float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

FLB_COMPARE (4):					/* operator: <= */
	if float_bin_operand1 <= float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

FLB_COMPARE (5):					/* operator: > */
	if float_bin_operand1 > float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

FLB_COMPARE (6):					/* operator: >= */
	if float_bin_operand1 >= float_bin_operand2
	then result = "1"b;
	else result = "0"b;
	goto END_FLB_COMPARE;

END_FLB_COMPARE:

     end;

/* END CHANGE 81-05-23 B ************************************************** */

error: proc (error_code, message);

/* PARAMETERS */

	dcl     error_code		 fixed bin (35);
	dcl     message		 char (*);


/* MULTICS ROUTINES */

	dcl     sub_err_		 entry options (variable);


/* AUTOMATIC */

	dcl     retval		 fixed bin (35);	/* needed to make sub_err_ happy */



	code = error_code;				/* code is global */

	call sub_err_ (error_code, "compare_value", "c", null (), retval, message);

	goto compare_values_exit;			/* NON LOCAL GOTO TO EXIT COMPARE_VALUES */

     end /* error */;






     end /* mu_compare_values */;




		    mu_concurrency_control.pl1      10/23/86  1024.8r w 10/23/86  1009.4      171396



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

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


mu_concurrency_control: procedure (); return;		/* not a valid entry */


/* HISTORY

   Originally written by Friesen in august 1977
   Modified by oris friesen in Aug. 1978 for new version data bases
   Modified by M. Pierret 17 April 1980 to remove priority_ofs and wakeup_ofs.
   (now dbc.obsolete)

   80-12-09 Jim Gray : completely rewritten to
   1) propoerly init the dbc structure including pad areas.
   2) change the interface into an abstract data type
   with 4 entries for use by AMDB, CMDB, DMDBS, and QMDB/OPEN.
   3) As part of the above change, implement r-u scope mode
   to r-s-m-d scope mode conversion.
   4) change the module name from mu_init_dbc to mu_concurrency_control
   5) provide more detailed documentation of module and it's enviornment

   80-12-24 Jim Gray : modified get_latest_dbc routine to return access violation
   message instead of version problem message, when null access on db control segment.

   80-12-24 Jim Gray : modified re_init_dbc to give detailed sub_err_ message
   if user does not have "w" access to control segment.

   81-01-15 Jim Gray : modified to fix loophole, where user could have two
   segments, one named dbc, the other db.control, or one segment with both names,
   and thus attempt to run both MR8 and MR9 mrds on the same database concurrenty,
   but without any real concurrent access protection.

   81-01-16 Jim Gray : moved access violation check to get_any_dbc so other
   than open gets sub_err_ details. Also added no control segment found
   sub_err_ to that routine, to compliment, 2 control segment sub_err_
   already there done as part of the last change fixing the loophole.

   81-01-16 Jim Gray : changed logic for handling bad bit count of control
   segment upon open. Now a bad version or a bit count less than the minimum strucutre
   size causes a message indicating that amdb -rs must be done on the db before using.

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

   83-06-13 Davids: Cleaned up declarations.
*/

/* DESCRIPTION:

   this routine handles initialization
   of the database control segment for several different needs.
   There are four entries:
   reset_control_segment is called by adjust_mrds_db when -reset is specified,
   in order to completely re-init the dbc structures,
   and possibly update the version of these, plus change the segments name.
   This is a DBA priviledged action.
   create_control_segment is called by create_mrds_db to create the
   control segment under the database at database creation time.
   open_control_segment is called by quiesce_mrds_db and dsl_$open, to get
   a pointer to the dbc, if it is the latest version dbc,
   otherwise a remedial action message is issued.
   get_control_segment is called by display_mrds_db_status to get any version
   dbc segment pointer, looking for latest version first,
   in order to be able to display it's info.

*/

/* PARAMETERS:

   db_path - - (input) char(168), the absolute pathname of the database.

   dbc_ptr_param - - (input/output) ptr, this is an output parameter for all entries
   except reset_control_segment, in which case it is an input parameter.
   This is a pointer the database control segment.

   bit_count - - (output) fixed bin(24), the bit count of the database control segment.

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

*/

create_control_segment: entry (db_path, dbc_ptr_param, bit_count, icode);

/* entry to create the database control segment */

	call make_control_seg ();
	dbc_ptr_param = dbc_ptr;
	return;


get_control_segment: entry (db_path, dbc_ptr_param, bit_count, icode);

/* entry to get a pointer to the database control segment,
   using any of the known names of versions for that segment,
   latest version names are tried first, only display or conversion routines should use this entry */

	call get_any_dbc ();
	dbc_ptr_param = dbc_ptr;
	return;


open_control_segment: entry (db_path, dbc_ptr_param, bit_count, icode);

/* entry to look only for the  latest version segment
   name for the datbase control segment. If not found, a message
   is issued, indicating AMDB -rs must be done to update the dbc version.
   This is the normal entry point to be used by any routine requiring the dbc ptr */

	call get_latest_dbc ();
	dbc_ptr_param = dbc_ptr;
	return;


reset_control_segment: entry (db_path, dbc_ptr_param, bit_count, icode);

/* entry to re-initialize the dbc. This may involve changing versions
   of the dbc structures and the control segment name. */

	dbc_ptr = dbc_ptr_param;
	call re_init_dbc ();
	return;

make_control_seg: procedure ();

/* this routine initially creates the database control segment
   in the  fashion determined by the latest version */

	call hcs_$make_seg (db_path, rtrim (mrds_data_$control_segment_name), "", 10, dbc_ptr, icode);
	if dbc_ptr = null () then ;
	else do;
		icode = 0;

		call init_dbc ();			/* fill in the dbc structures */
	     end;

     end;

re_init_dbc: procedure ();

/* this routine re-initializes the database control segment
   structures to the latest versions initial  values. */


/* zero out the control segment, then set it's bit count to 0 */

	call hcs_$truncate_seg (dbc_ptr, 0, icode);
	if icode = error_table_$moderr then do;
		entryname = mrds_data_$control_segment_name; /* default, in case can't get real name being used */
		call hcs_$fs_get_path_name (dbc_ptr, dir_name, ldn, entryname, discard);
		call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^a^a^a^a",
		     "Insufficient access to re-initialize the database control segment """, rtrim (db_path),
		     ">", rtrim (entryname), """.");
	     end;
	else if icode = 0 then do;
		call hcs_$set_bc_seg (dbc_ptr, 0, icode);

		if icode = 0 then do;

/* initialize dbc values */

			call init_dbc ();

			if icode = 0 then do;


/* change the name of the database control segment, so that r-u scope mode
   users will not concurrently be using a r-s-m-d scope mode version dbc. */

				call hcs_$chname_seg (dbc_ptr, "dbc", rtrim (mrds_data_$control_segment_name), icode);
				if icode = error_table_$segnamedup then
				     icode = 0;	/* ignore error, if name already changed */
			     end;

		     end;

	     end;
     end;

init_dbc: procedure ();

/* this routine sets the inital values in the dbc structure,
   and then sets the control segments bit count */

	dbc.version = VERSION_NBR;
	dbc.dtd_mrds = 0;				/* has never been dumped -- is a new data base */
	dbc.flags = OFF;
	dbc.quiesce_lock = OFF;
	dbc.wakeup_waiters = 0;
	dbc.user_counts = 0;
	dbc.open_lock = OFF;
	dbc.scope_lock = OFF;
	dbc.sa_size = sys_info$max_seg_size - fixed (rel (addr (dbc.static_area))) + 1;
	dbc.pad2 = OFF;
	dbc.offsets = NULL_OFS;
	dbc.offsets.obsolete = OFF;
	dbc.pad3 = OFF;
	dbc.static_area = empty ();

	bit_count = 36 * fixed (rel (addr (dbc.static_area)));
	call hcs_$set_bc_seg (dbc_ptr, bit_count, icode);

     end;

get_latest_dbc: procedure ();

/* this routine attempts to get a pointer to the
   latest version database control segment.
   If an unsupported version is detected, an error is issued.
   If an older or bad version is detected, a message is issued
   that indicates that AMDB -rs must be done to update the version. */

	old_version, cant_get_version, bad_version = OFF;

	call get_any_dbc ();

	if icode = mrds_error_$version_not_supported | dbc_ptr = null () then ;
	else do;

		call hcs_$fs_get_path_name (dbc_ptr, dir_name, ldn, entryname, icode);

		if icode ^= 0 then
		     cant_get_version = ON;
		else if entryname = "dbc" then
		     old_version = ON;
		else if dbc.version < 4 | dbc.version > 5 |
			bit_count < 36 * fixed (rel (addr (dbc.static_area))) then /* minimum allowable bit count */
		     bad_version = ON;
		else if dbc.version = 4 then
		     old_version = ON;

		if cant_get_version then do;

/* unable to get segment name, to determine if this is a proper
   new version control segment for open to accept */

			call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^p^a^a^a",
			     "Unable to get the segment name for the pointer """, dbc_ptr,
			     """ to the database control segment under the database """,
			     db_path, """.");

		     end;
		else if bad_version then do;

/* unknown dbc version, give up */

			icode = mrds_error_$version_not_supported;
			call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a ^d^a ^d^/^a ^a ^a",
			     "The database control segment has an unknown version =", dbc.version,
			     ", or a bad bit count =", bit_count,
			     """adjust_mrds_db", db_path, "-reset"" must be run before it can be used.");
		     end;
		else if old_version then do;
			debug_sw = OFF;
			if ^debug_sw then do;

/* old version dbc's must be updated to the latest version
   before we can let the suer set any scopes or open */

				icode = mrds_error_$version_not_supported;
				call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^/^a^/^a ^a ^a",
				     "The version of the control segment has changed,",
				     "to support r-m-a(s)-d instead of r-u scope modes.",
				     """adjust_mrds_db", db_path,
				     "-reset"" must be run before it can be used.");
			     end;
			else do;			/* unused test code for auto conversion of dbc version */

/* this code is for test purposes only and is not mormally executed.
   it causes r-u dbc's to be converted to r-s-m-d dbc's.
   concurrent r-u and r-s-m-d users can cause the dbc to become incosistent */

				call set_lock_$lock (dbc.scope_lock, (mrds_data_$lock_wait_time), icode);
				if icode = error_table_$invalid_lock_reset | icode = error_table_$locked_by_this_process then
				     icode = 0;	/* ignore these errors */

				if icode = error_table_$no_w_permission then
				     call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^a^a^a^a",
					"No permission to set scope lock on """, rtrim (db_path),
					">", rtrim (mrds_data_$control_segment_name), """.");
				else if icode ^= 0 then do;
					dbc.trouble_switch = ON; /* something messed up, lock against further opens */
				     end;
				else do;

/* convert fil_list structures from ru to rusmd codes usage */

					call process_user_list (pointer (dbc_ptr, dbc.active_users_ofs), "1"b);
					call process_user_list (pointer (dbc_ptr, dbc.waiting_users_ofs), "0"b);
					dbc.version = 5; /* now converted to version 5 dbc */
				     end;

				if icode = 0 then
				     call set_lock_$unlock (dbc.scope_lock, icode);

			     end;
		     end;


	     end;

     end;

get_any_dbc: procedure ();

/* routine to get a pointer to any version of the database control segment,
   starting with latest versions first. */

	call hcs_$initiate_count (db_path, rtrim (mrds_data_$control_segment_name), "",
	     bit_count, 0, first_dbc_ptr, icode);

	if icode = error_table_$moderr then do;

/* set access for the user and retry, if he is a DBA */

		call mrds_dm_authorization$set_needed_access (rtrim (db_path), icode); /* fails if user not DBA */
		if icode ^= 0 then
		     icode = error_table_$moderr;
		else call hcs_$initiate_count (db_path, rtrim (mrds_data_$control_segment_name), "",
			bit_count, 0, first_dbc_ptr, icode);

	     end;

	if icode = error_table_$moderr then

/* null access on database control segment */

	     call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^a^a^a^a",
		"Unable to get pointer to the database control segment """, rtrim (db_path),
		">", rtrim (mrds_data_$control_segment_name), """.");

	else do;

		call hcs_$initiate_count (db_path, "dbc", "", temp_bit_count, 0, second_dbc_ptr, temp_code);

/* on an access violation, set access for the user and retry, if he is a DBA */

		if temp_code = error_table_$moderr then do;
			call mrds_dm_authorization$set_needed_access (rtrim (db_path), temp_code);
			if temp_code ^= 0 then
			     temp_code = error_table_$moderr;
			else call hcs_$initiate_count (db_path, "dbc", "", temp_bit_count, 0, second_dbc_ptr, temp_code);
		     end;


/* check for foul deeds by the user, only debug tool users may pass */

		if first_dbc_ptr ^= null () & second_dbc_ptr ^= null () & /* too many control segments */
		     substr (db_mu_concurrency_control, 1, 1) ^= "1"b then do;
			dbc_ptr = null ();
			icode = mrds_error_$version_not_supported;
			call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^/^a^a^a^/^a",
			     "Unable to determine the database control segment version,",
			     "because both a ""dbc"" and a ""db.control"" segment were found under the database """,
			     db_path, """",
			     "either the old or new version may be present, not both!");
		     end;
		else do;

			if first_dbc_ptr = null () & second_dbc_ptr = null () then do; /* not enough control segments */
				dbc_ptr = null ();
				call sub_err_ (icode, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
				     "Neither a ""dbc"", nor a ""db.control"" control segment was found under the database """,
				     db_path, """.");
			     end;
			else if first_dbc_ptr = null () then do; /* old control segment - dbc */
				dbc_ptr = second_dbc_ptr;
				bit_count = temp_bit_count;
			     end;
			else dbc_ptr = first_dbc_ptr; /* new control segment - db.control */

		     end;

		if dbc_ptr ^= null () then
		     icode = 0;			/* ignore name_dup errors */

	     end;


	declare (first_dbc_ptr, second_dbc_ptr) ptr;	/* temporary copies of dbc pointer */

     end;

process_user_list: procedure (in_ul_ptr, active_list);

/* routine to trace through the linked user list */

	ul_ptr = in_ul_ptr;
	do while (rel (ul_ptr) ^= NULL_OFS);

	     call process_file_list (pointer (dbc_ptr, user_list.fil_list_ofs));
	     if active_list then
		ul_ptr = pointer (dbc_ptr, user_list.next_active_ofs);
	     else ul_ptr = pointer (dbc_ptr, user_list.next_waiting_ofs);

	end;

	declare in_ul_ptr		 ptr;		/* input to start of list */
	declare active_list		 bit (1);		/* on => active, off => waiting list of users */


     end;

process_file_list: procedure (in_fl_ptr);

/* routine to trace a list of file list structures  */

	fl_ptr = in_fl_ptr;
	do while (rel (fl_ptr) ^= NULL_OFS);

	     if fil_list.permits.update then do;
		     fil_list.permits.append_tuple = ON;
		     fil_list.permits.delete_tuple = ON;
		     fil_list.permits.modify_attr = ON;
		end;
	     else do;
		     fil_list.permits.append_tuple = OFF;
		     fil_list.permits.delete_tuple = OFF;
		     fil_list.permits.modify_attr = OFF;
		end;


	     if fil_list.prevents.update then do;
		     fil_list.prevents.append_tuple = ON;
		     fil_list.prevents.delete_tuple = ON;
		     fil_list.prevents.modify_attr = ON;
		end;
	     else do;
		     fil_list.prevents.append_tuple = OFF;
		     fil_list.prevents.delete_tuple = OFF;
		     fil_list.prevents.modify_attr = OFF;
		end;

	     fl_ptr = pointer (dbc_ptr, fil_list.next_ofs);

	end;

	declare in_fl_ptr		 ptr;		/* input to start of list */

     end;

	declare sub_err_		 entry options (variable); /* reports errors */
	declare hcs_$chname_seg	 entry (ptr, char (*), char (*), fixed bin (35)); /* changes seg name */
	declare error_table_$segnamedup fixed bin (35) ext; /* entry not found */
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin (18), fixed bin (35));

	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     (addr, empty, fixed, null, pointer, rel, rtrim, substr) builtin;
	declare set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));
	declare set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	declare error_table_$invalid_lock_reset fixed bin (35) ext;
	declare error_table_$locked_by_this_process fixed bin (35) ext;
	declare mrds_data_$lock_wait_time fixed bin (35) ext;
	declare mrds_data_$control_segment_name char (32) ext; /* name of control segment */
	declare debug_sw		 bit (1);		/* for testing purposes */
	declare continue		 char (1) init ("c"); /* dont stop after printing error */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unsued */
	declare caller_name		 char (32) init ("mu_concurrency_control"); /* name of calling routine */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* bad dbc version */
	declare db_path		 char (168);	/* input database path */
	declare temp_code		 fixed bin (35);	/* unused */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare old_version		 bit (1);		/* on => need to convert */
	declare bad_version		 bit (1);		/* on => unsupported version */
	declare hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); /* makes segmetn */
	declare hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24),
				 fixed bin (2), ptr, fixed bin (35)); /* gets seg ptr and bit count */
	declare error_table_$moderr	 fixed bin (35) ext;/* incorrect access on entry */
	declare error_table_$no_w_permission fixed bin (35) ext; /* no "w" acl */
	declare dir_name		 char (168);	/* name of dbc dir */
	declare discard		 fixed bin (35);	/* unused error code */
	declare ldn		 fixed bin;	/* length of dbc dir name */
	declare entryname		 char (32);	/* either dbc or db.control */
	declare hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); /* gets name from ptr */
	declare temp_bit_count	 fixed bin (24);	/* temporary for get dbc seg bit count */
	declare cant_get_version	 bit (1);		/* on => couldnt get segment name from dbc_ptr */
	declare mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets access for dba types */
	dcl     dbc_ptr_param	 ptr parm;	/* ptr to the data base control segment (input) */

	dcl     bit_count		 fixed bin (24);	/* bit count of dbc segment */

	dcl     icode		 fixed bin (35);	/* returrn code */

%include mdbm_dbc;

%include mdbm_users;

%include mrds_debug_names;
     end;





		    mu_convert.pl1                  04/18/85  1437.3re  04/18/85  0908.0       63261



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

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


/* BEGIN DESCRIPTION

   This procedure converts data located by the source_ptr with a descriptor
   located by source_desc_ptr, to the data located by target_ptr and described
   by the descriptor located by target_desc_ptr.

   The conversion is done using assign_round_.
   NOTE: assign_ currently only handles data types 1-12, 19-22, 33-34, & 41-46.

   Error conditions are returned as mrds_error codes, for example,
   the conversion condition is returned as the error code
   mrds_error_$conversion_condition.

   END DESCRIPTION
*/

/* HISTORY
   Written by R. D. Lackey June 1979
   Modified by Jim Gray  Oct. 1979 to add illegal_procedure condition capture.
   Modified by Rickie E. Brinegar December 8, 1979 to have each condition captured use its own error code.
   Modified by Jim Gray  Dec. 1979, to correct the length parameter handling
   for assign_, when the data type is string
   Modified by M Pierret 8 October 1980 to combine all condition handlers into one.
   Modified by D. Woodka 07/02/82 to change the any-other condition to continue
   instead of doing a goto EXIT. 
*/

mu_convert:
convert_data:
     proc (a_source_ptr, a_source_desc_ptr, a_target_ptr, a_target_desc_ptr,
	a_code);


/*    	PARAMETERS

   a_source_ptr	    ptr		Pointer to source data
   a_source_desc_ptr    ptr		Pointer to source descriptor
   a_target_ptr	    ptr		Pointer to targer data
   a_target_desc_ptr    ptr		Pointer to target descriptor
   a_code fixed bin (35) 		Error code
*/
%page;
	a_code = 0;
	source_ptr = a_source_ptr;			/* copy arguments */
	source_desc_ptr = a_source_desc_ptr;
	target_ptr = a_target_ptr;
	target_desc_ptr = a_target_desc_ptr;

	target_type =
	     2 * target_desc_ptr -> descriptor.type
	     + fixed (target_desc_ptr -> descriptor.packed);

	if target_desc_ptr -> descriptor.type >= 19
	     & target_desc_ptr -> descriptor.type <= 22 then
	     target_length = fixed (string (target_desc_ptr -> descriptor.size));
	else do;
		target_len.scale =
		     addr (target_desc_ptr -> descriptor.scale) -> signed_scale;
		target_len.precision = fixed (target_desc_ptr -> descriptor.precision);
	     end;

	source_type =
	     2 * source_desc_ptr -> descriptor.type
	     + fixed (source_desc_ptr -> descriptor.packed);

	if source_desc_ptr -> descriptor.type >= 19
	     & source_desc_ptr -> descriptor.type <= 22 then
	     source_length = fixed (string (source_desc_ptr -> descriptor.size));
	else do;
		source_len.scale =
		     addr (source_desc_ptr -> descriptor.scale) -> signed_scale;
		source_len.precision = fixed (source_desc_ptr -> descriptor.precision);
	     end;

	on any_other
	     begin;

		call find_condition_info_ ((null), addr (cond_info), a_code);
		do cond_idx = 1 to 7
		     while (cond_info.condition_name ^= cond_name (cond_idx));
		end;
		if cond_idx > 7 then
		     call continue_to_signal_ (a_code);

		goto COND (cond_idx);

COND (1):						/* size */
		a_code = mrds_error_$size_condition;
		goto EXIT;

COND (2):						/* conversion */
		a_code = mrds_error_$conversion_condition;
		goto EXIT;


COND (3):						/* fixedoverflow */
		a_code = mrds_error_$fixedoverflow_condition;
		goto EXIT;

COND (4):						/* error */
		a_code = mrds_error_$error_condition;
		goto EXIT;

COND (5):						/* illegal_procedure */
		a_code = mrds_error_$illegal_procedure_condition;
		goto EXIT;

COND (6):						/*  overflow */
		a_code = mrds_error_$overflow_condition;
		goto EXIT;

COND (7):						/* underflow */
		a_code = mrds_error_$underflow_condition;
		goto EXIT;

COND (8):						/* any other */
		call continue_to_signal_ (a_code);


	     end;					/* end of condition handler */


	call
	     assign_round_ (target_ptr, target_type, target_length, source_ptr,
	     source_type, source_length);

EXIT:
	return;

/*	PARAMETERS	*/

	dcl     a_source_ptr	 ptr;		/* (INPUT) Pointer to source data */
	dcl     a_source_desc_ptr	 ptr;		/* (INPUT) Pointer to source descriptor */
	dcl     a_target_ptr	 ptr;		/* (INPUT) Pointer to target data */
	dcl     a_target_desc_ptr	 ptr;		/* (INPUT) Pointer to target descriptor */
	dcl     a_code		 fixed bin (35);	/* (OUTPUT) Error code */

/*	OTHERS		*/

	dcl     source_desc_ptr	 ptr;
	dcl     target_desc_ptr	 ptr;

	dcl     source_ptr		 ptr;
	dcl     target_ptr		 ptr;

	dcl     source_type		 fixed bin;
	dcl     target_type		 fixed bin;
	dcl     cond_idx		 fixed bin;

	dcl     source_length	 fixed bin (35);

	dcl     1 source_len	 aligned based (addr (source_length)), /* Length of source */
		2 scale		 fixed bin (17) unal,
		2 precision	 fixed bin (17) unal;

	declare signed_scale	 fixed bin (11) unal based; /* signed fixed binary version of bit(12) */

	dcl     target_length	 fixed bin (35);

	dcl     1 target_len	 aligned based (addr (target_length)), /* Length of target */
		2 scale		 fixed bin (17) unal,
		2 precision	 fixed bin (17) unal;

	dcl     1 cond_info		 aligned,
		2 mc_ptr		 ptr,
		2 version		 fixed bin,
		2 condition_name	 char (32) varying,
		2 info_ptr	 ptr,
		2 wc_ptr		 ptr,
		2 loc_ptr		 ptr,
		2 flags		 aligned,
		  3 crawlout	 bit (1) unal,
		  3 mbz1		 bit (35) unal,
		2 mbz2		 bit (36) aligned,
		2 user_loc_ptr	 ptr,
		2 mbz		 (4) bit (36) aligned;

	dcl     cond_name		 (7) char (32) varying int static options (constant)
				 init ("size", "conversion", "fixedoverflow", "error",
				 "illegal_procedure", "overflow", "underflow");

/* Builtin */

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

/* External Entries */

	dcl     assign_round_
				 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     continue_to_signal_	 entry (fixed bin (35));

/* External */

	dcl     (
	        mrds_error_$conversion_condition,
	        mrds_error_$error_condition,
	        mrds_error_$fixedoverflow_condition,
	        mrds_error_$illegal_procedure_condition,
	        mrds_error_$overflow_condition,
	        mrds_error_$size_condition,
	        mrds_error_$underflow_condition
	        )			 ext fixed bin (35);
	dcl     any_other		 condition;

%include mdbm_descriptor;

     end mu_convert;




		    mu_convert_parameter.pl1        04/18/85  1437.3re  04/18/85  0908.1       66060



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - September 1979
   Modified by Jim Gray - - Dec. 1979, to change internal routine to call to
   mu_data_class$scalar so that packed decimal would be accepted.
   Modified March 25, 1980 by R. Lackey to remove calls to mdbm_util_  */

mu_convert_parameter: procedure (); return;		/* not valid entry */

/* DESCRIPTION:
   this routine was written to overcome documentation errors in the old MRDS
   (e.g. dsl_$open specifies mode as fixed bin, but examples use constants = fixed dec )
   and to make the input/output parameters acceptable by the various
   entries declared options(variable) more flexible.
   there are two entries, $input for converting the users input parameter
   to the data type needed by the particular dsl_ entry, and
   $output to assign from the internal dsl_ entry data type into
   the users given data type when outputting values.
   NOTE: no conversion or extra work is needed if data types agree
   with the ones specified in the dsl_ interface write up.
   NOTE: the internal data type is assumed to be mrds supported(types 1-12, 19-22, and dimension = 0),
   if the users data type is not mrds supported, mrds_error_$invalid_dm_descriptor is the error code
*/

/* PARAMETERS:
   user_data_ptr - - (input/output) pointer, for $input entry, points to source of input data parameter,
   for $output, points to target of output data parameter.

   actual_data_ptr - - (input/output) pointer, for $input entry, points to data to be used internally by dsl_ entry,
   for $output entry, points to data used internally by dsl_ entry,
   and source for any output conversion that may be needed.

   user_desc_ptr - - (input) pointer, points to bit(36) pl1 descriptor
   of data pointed to by the user_data_ptr.

   actual_desc_ptr - - (input) pointer, points to bit(36) pl1 descriptor
   of data pointed to by actual_data_ptr.

   work_area_ptr - - (input) pointer, for $input entry only,
   points to an area where a converted temporary version of the input
   parameter may be placed if necessary, preferrably a temp segment,
   overlayed with an area of segment size, that may be released when not needed.

   error_code - - (output) fixed bin(35), error status encoding, 0 unless an error occured.
*/

input: convert_input_parameter: entry (user_data_ptr, user_desc_ptr, actual_data_ptr, actual_desc_ptr,
	work_area_ptr, error_code);

/* this entry converts, if necessary, the user's data type, into that required
   internally by the dsl_ entry, as specified by the descriptor pointed to
   bu the actual_desc_ptr, with the data pointed to by actual_data_ptr.
   no conversion is necessary if the data types agree */

	error_code = 0;				/* initialize */

/* use the user's data as is, if descriptors agree */

	if user_desc_ptr -> desc_ovrly = actual_desc_ptr -> desc_ovrly then do;
		desc_ptr = user_desc_ptr;
		if ^mu_data_class$scalar (desc_ptr) then
		     error_code = mrds_error_$invalid_dm_descriptor;
		else actual_data_ptr = user_data_ptr;
	     end;
	else do;

/* conversion will be required, first check for mrds supported data type */

		desc_ptr = user_desc_ptr;
		if ^mu_data_class$scalar (desc_ptr) then
		     error_code = mrds_error_$invalid_dm_descriptor; /* not supported mrds data type */
		else do;

/* get some space for the required data type temporary, of length in bits,
   as specified by it's data type */

			num_dims = 0;
			data_bit_length = mu_data_length (actual_desc_ptr -> desc_ovrly);
			allocate data_space set (actual_data_ptr) in (work_area);

/* now convert from the user's parameter, into this new space,
   and with required data type */

			call mu_convert (user_data_ptr, user_desc_ptr, actual_data_ptr, actual_desc_ptr, error_code);
		     end;
	     end;
	return;

output: convert_output_parameter: entry (actual_data_ptr, actual_desc_ptr, user_data_ptr, user_desc_ptr,
	error_code);

/* this entry does assignment of output parameters from the data type needed
   internally by a particular dsl_ entry, using a bit move if data types aggree,
   or doing a conversion if the data types are different, but mrds supported */


	error_code = 0;				/* initialize */

/* a bit move will do, if descriptors agree */

	if actual_desc_ptr -> desc_ovrly = user_desc_ptr -> desc_ovrly then do;
		desc_ptr = user_desc_ptr;
		if ^mu_data_class$scalar (desc_ptr) then
		     error_code = mrds_error_$invalid_dm_descriptor;
		else do;

/* do the bit move after determining the datas bit length */

			num_dims = 0;
			data_bit_length = mu_data_length (desc_ptr -> desc_ovrly);
			user_data_ptr -> data_space = actual_data_ptr -> data_space;
		     end;
	     end;

/* descriptors disaree, we will have to use assign_ to output the parameter */

	else do;
		desc_ptr = user_desc_ptr;
		if ^mu_data_class$scalar (desc_ptr) then
		     error_code = mrds_error_$invalid_dm_descriptor;
		else call mu_convert (actual_data_ptr, actual_desc_ptr, user_data_ptr, user_desc_ptr, error_code);
	     end;

	return;

	declare mu_data_class$scalar	 entry (ptr) returns (bit (1) aligned); /* decides is data type supported */
	declare data_space		 bit (data_bit_length) unal based; /* overlay for data move or temporary */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare data_bit_length	 fixed bin (24);	/* bit length of data type */
	declare mu_data_length	 entry (bit (36)) returns (fixed bin (35)); /*  bit length from descriptor */
	declare mrds_error_$invalid_dm_descriptor fixed bin (35) ext; /* not mrds data type */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare desc_ovrly		 bit (36) based unal; /* overlay for multics pl1 descriptor */
	declare work_area_ptr	 ptr;		/* points to area in which converted parameer will reside */
	declare work_area		 area (sys_info$max_seg_size) based (work_area_ptr); /* space for converted parameter */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	declare actual_data_ptr	 ptr;		/* points to data used by internal routines */
	declare user_data_ptr	 ptr;		/* points to callers data */
	declare actual_desc_ptr	 ptr;		/* points to descriptor for internal data */
	declare user_desc_ptr	 ptr;		/* points to descriptor for users data */
	declare mu_convert		 entry (ptr, ptr, ptr, ptr, fixed bin (35)); /* does assign_ */

%include mdbm_descriptor;

     end;




		    mu_cursor_manager_.pl1          08/01/88  1347.6r w 08/01/88  1315.0      412677



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
mu_cursor_manager_: proc;

/*

                      BEGIN_DESCRIPTION
   This  routine  is used to manage the storage of cursors and their
   pointers.   Each cursor is associated with a relation-opening-id,
   a   collection-index   and  a  tuple-variable.  The  main   entry 
   mu_cursor_manager_$mu_cursor_manager_ should never be called

*******************************************************************************
*******************************************************************************
   Note that this entire module is now unnecessary with the advent of
   relation cursors.  The management of cursors has become simple enough
   that it can be handled in the same way that iocbs used to be handled.
   The only reason this module still exists is to expedite the conversion
   to relation cursors.  It will be deleted soon or significantly rewritten
   and simplified.
*******************************************************************************
*******************************************************************************

   The get entry  is  used to get the cursor associated with a given
   <rel_opening_id-collection_index-tupe-variable>.   If  the cursor
   has  not  yet been created a call to the relation_manager is made
   to  create  it.   After creation it is stored in the storage area
   for  future  reference.  The storage area will be either a simple
   array overlaid on a temp segment and sorted by <r-c-t> or a keyed
   sequential  file  with  keys  of <r-c-t>.  The first call to this
   procedure  on  behalf  of  a  database  index  should have a null
   storage pointer and a null area pointer input so that the storage
   and area will be created. This entry will also cause the relation
   to be opened if it is not already in the opened state.


   The  destroy_all_no_free  entry destroys the storage used to hold
   the  cursor  pointers,  and closes the relations that the cursors
   were  associated  with.  The  temp seg area where the cursors are
   stored is also deleted.


   The entry destroy_and_free_on_opening_id is used to  destroy  the
   storage   used   to   hold   the   cursor  pointers  for  cursors 
   associated  with a given opening id. It also destroys the cursors
   associated with the given opening id and closes the relation with
   the given opening id.


   The  cleanup_storage  entry  releases the temp segment area where
   the  cursors are allocated and destroyes the storage used to hold
   the  cursor  pointers.   It  assumes that the relations have been
   closed by some other means

   Known Bugs:

   Other Problems:

   History:
      82-09-13 Davids: written
    
      82-09-24 Donna Woodka : changed declaration of mcm_collection_index
      and cc_collection_id from fixed bin (35) to bit (36) aligned.

      82-09-29 Davids: added the destroy_and_free_on_opening_id
      entry and the move_chars internal proc. Changed the internal proc
      add_cursor_to_array to use move_chars instead of the faulty
      mu_mrl_. Also added the temp_space_begins element to the mcm_cursor_array
      structure and changed the size of the array to be a constant instead
      of a refers.

      82-10-15 Davids: Modified the get entry to create an area to alloacte
      the cursors in if the storage_ptr is null. Modified the 
      destroy_all_no_free entry to have the area_ptr as a parameter and to
      free the temp seg the area_ptr points to. Freeing is done via
      release_temp_segment_ because that is how mu_define_area creates the
      temp segment. All this makes the mcm_area_ptr an input/output
      parameter.

      82-10-18 Davids: Modified all entries to set the value of code to 0
      as the first thing they do so if no error occurs the code returned
      will be 0.

      82-11-24 Davids: Modified call to move_chars in delete_cursors_from_array
      to have the correct number of bytes to move.

      82-12-03 Davids: Modified to delete the temp seg that the cursor ptrs are
      stored in. This required storing a character representation of the dbi
      in the cursor_array structure so that only the temp seg associated with 
      the database being closed will be deleted.

      83-01-03 Davids: Added the cleanup_storage entry. The relations will be
      closed by running through the rm_rel_info structures and getting the
      opening_id instead of calling the destroy_all_no_free entry. The
      cleanup_storage entry was needed to neatly cleanup the storage used
      by mu_cursor_manager.
                      END_DESCRIPTION



       Naming  convension:  becuase  of the number of internal
       routines  and  the need for discriptive names variables
       declared  in  all  routines  (including the main entry)
       have  prefixes  that  are  the  initials of the routine
       name.   Global  variables  can be identified since they
       have  a  prefix  different  from  that derived from the
       routine  name.  Variables with the same name except for
       the  prefix  mean  the same thing.  Variables without a
       prefix  are  external to the module, i.e.  entry names,
       external  static,  builtins,  conditions,  etc.   These
       variables  are declared in the main routine.  Variables
       with  names  in  upper case (except for the prefix) are
       internal static constants.
*/

/* PARAMETERS */

	dcl     mcm_dbi		 fixed bin (35);	/* (input) database index */
	dcl     mcm_rmri_ptr	 ptr;		/* (input) pointer to the relation's rm_rel_info structure
                                                                       which contains the rel_opening_id and from which
                                                                       the path of the relation can be determined */
	dcl     mcm_opening_id	 bit (36) aligned;	/* (input) opening id for the relation */
	dcl     mcm_tuple_var_index	 fixed bin (35);	/* (input) tuple variable associated with the cursor */
	dcl     mcm_collection_index	 bit (36) aligned;	/* (input) this was used before the conversion to
						           relation cursors and is interm.  It is
							 not currently used by this routine. */
	dcl     mcm_relmgr_create_cursor entry;		/* (input) relation_manager entry for creating a cursor */
	dcl     mcm_relmgr_open	 entry;		/* (input) relation_manager entry for opening a relation */
	dcl     mcm_relmgr_close	 entry options (variable);
						/* (input) relation_manager entry for closing a relation */
	dcl     mcm_relmgr_destroy_cursor entry;	/* (input) relation_manager entry for destroying a cursor */
	dcl     mcm_area_ptr	 ptr;		/* (input / output) ptr to area where
                                                                                cursors are to be allocated */
	dcl     mcm_storage_ptr	 ptr;		/* (input / output) pointer to storage where the mapping
                                                                                between <r-c-t> and cursor_ptrs is kept */
	dcl     mcm_cursor_ptr	 ptr;		/* (output) pointer to a cursor */
	dcl     mcm_code		 fixed bin (35);	/* (output) standard error code */

/* AUTOMATIC */

	dcl     mcm_cursor_index	 fixed bin;	/* index in the cursor array of where the
                                                               cursor is (and wher it should be stored) */
	dcl     mcm_found		 bit (1);		/* "1"b ==> cursor was already in storage
                                                                        and may just be returned
                                                               "0"b ==> cursor not in storage and must be created */
	dcl     mcm_key		 char (12);	/* key identifing the cursor */
	dcl     mcm_unused1		 ptr;		/* unused output from vfile_search -
                                                               we know the value will be null */
	dcl     mcm_unused2		 bit (1);		/* unused output from vfile_search -
                                                               we know the cursor won't be found */

/* CONSTANTS */

	dcl     mcm_ARRAY		 fixed bin init (1) internal static options (constant);
						/* indicates that storage area is of type ARRAY */
	dcl     mcm_CURSOR_ARRAY_ELEMENT_SIZE fixed bin init (24) internal static options (constant);
						/* length in characters of a cursor element (key and pointer),
                                                               key is 12 chars or and the ptr 8 but there is a 4 char
                                                               (1 word) implicit pad to make the pointer
                                                               start on an even word */
	dcl     mcm_CURSOR_PTR_LENGTH	 fixed bin (21) init (8) internal static options (constant);
						/* length of a cursor ptr ==> 2 words or 8 bytes */
	dcl     mcm_MAX_NUM_FOR_ARRAY_STORAGE fixed bin init (1000) internal static options (constant);
						/* maximum number of cursors that can be stored as an
                                                               array before a keyed file becomes more efficient */
	dcl     mcm_PROC_NAME	 char (18) init ("mu_cursor_manager_") internal static options (constant);
	dcl     mcm_VFILE		 fixed bin init (2) internal static options (constant);
						/* indicates that storage area is of type VFILE */

/* BASED */

	dcl     mcm_b36b		 bit (36) unaligned based; /* bit 36 overlay */
	dcl     mcm_c4b		 char (4) based;	/* 4 character overlay */

	dcl     01 mcm_cursor_array	 unaligned based,
		02 version	 char (4),
		02 num		 fixed bin,
		02 dbi_char	 char (4),
		02 mbz		 bit (36),
		02 cursors	 (mcm_MAX_NUM_FOR_ARRAY_STORAGE),
		  03 key		 char (12),
		  03 cursor_ptr	 ptr aligned,
		02 temp_space_begins bit (1) aligned;

/* EXTERNAL STATIC */

	dcl     error_table_$end_of_info fixed bin (35) ext static;
	dcl     error_table_$no_record fixed bin (35) ext static;
	dcl     mrds_error_$unknown_cursor_storage fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

/* ENTRIES */

	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	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_$delete_record	 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     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     iox_$seek_key	 entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     mrds_dsl_resultant_storage$get_opening_temp_dir
				 entry (fixed bin (35), fixed bin (35)) returns (char (168));
	dcl     mu_define_area	 entry (ptr, fixed bin (18), char (11), bit (1) aligned, bit (1) aligned, bit (1) aligned,
				 bit (1) aligned, fixed bin (35));
	dcl     mu_temp_segments$get_temp_segment entry (fixed bin (35), char (*), ptr, fixed bin (35));
	dcl     mu_temp_segments$delete_all_temp_segments entry (char (*), fixed bin (35));
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     sub_err_		 entry options (variable);
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     char		 builtin;
	dcl     divide		 builtin;
	dcl     fixed		 builtin;
	dcl     ltrim		 builtin;
	dcl     null		 builtin;
	dcl     pointer		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;
	dcl     substr		 builtin;
	dcl     unspec		 builtin;

/* INCLUDES */
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_db_info;
%page;
%include iocb;

get: entry (mcm_dbi, mcm_rmri_ptr, mcm_tuple_var_index, mcm_collection_index,
	mcm_relmgr_create_cursor, mcm_relmgr_open, mcm_storage_ptr,
	mcm_area_ptr, mcm_cursor_ptr, mcm_code);





	mcm_code = 0;

	if mcm_rmri_ptr -> rm_rel_info.opening_id = "0"b
	then call open_relation (mcm_relmgr_open, mcm_rmri_ptr);

	if mcm_storage_ptr = null ()
	then do;
		call build_storage (mcm_dbi, mcm_ARRAY, mcm_storage_ptr);
		call mu_define_area (mcm_area_ptr, (sys_info$max_seg_size), "cursor_area",
		     "1"b, "0"b, "0"b, "0"b, mcm_code);
		if mcm_code ^= 0
		then call error_exit (mcm_code, "Could not get a temp seg for cursor storage.");
	     end;

	mcm_key = addr (mcm_rmri_ptr -> rm_rel_info.opening_id) -> mcm_c4b ||
	     addr (mcm_tuple_var_index) -> mcm_c4b;

	if storage_type (mcm_storage_ptr) = mcm_ARRAY
	then do;
		call array_search (mcm_key, mcm_storage_ptr, mcm_cursor_index, mcm_found);
		if ^mcm_found
		then do;
			call create_cursor (mcm_rmri_ptr -> rm_rel_info.opening_id, mcm_collection_index,
			     mcm_relmgr_create_cursor, mcm_area_ptr, mcm_cursor_ptr);
			if mcm_storage_ptr -> mcm_cursor_array.num = mcm_MAX_NUM_FOR_ARRAY_STORAGE
			then do;
				call convert_array_to_vfile (mcm_storage_ptr);
				call vfile_search (mcm_key, mcm_storage_ptr, mcm_unused1, mcm_unused2);
				call add_cursor_to_vfile (mcm_storage_ptr, mcm_cursor_ptr);
			     end;
			else call add_cursor_to_array (mcm_storage_ptr, mcm_key, mcm_cursor_ptr, mcm_cursor_index);
		     end;
		else mcm_cursor_ptr = mcm_storage_ptr -> mcm_cursor_array.cursors (mcm_cursor_index).cursor_ptr;
	     end;
	else do;
		call vfile_search (mcm_key, mcm_storage_ptr, mcm_cursor_ptr, mcm_found);
		if ^mcm_found
		then do;
			call create_cursor (mcm_rmri_ptr -> rm_rel_info.opening_id, mcm_collection_index,
			     mcm_relmgr_create_cursor, mcm_area_ptr, mcm_cursor_ptr);
			call add_cursor_to_vfile (mcm_storage_ptr, mcm_cursor_ptr);
		     end;
	     end;





	goto exit;

destroy_all_no_free: entry (mcm_storage_ptr, mcm_area_ptr, mcm_relmgr_close, mcm_code);





	mcm_code = 0;

	if storage_type (mcm_storage_ptr) = mcm_ARRAY
	then call close_rels_from_array (mcm_storage_ptr, mcm_relmgr_close);
	else call close_rels_from_vfile (mcm_storage_ptr, mcm_relmgr_close);

	call destroy_storage (mcm_storage_ptr);

/* mu_define_area uses get_temp_segment_ to get the temp seg the area is based on */

	call release_temp_segment_ ("cursor_area", mcm_area_ptr, mcm_code);
	if mcm_code ^= 0
	then call error_exit (mcm_code, "Could not release the temp seg used to store the cursors.");

	goto exit;













destroy_and_free_on_opening_id: entry (mcm_opening_id, mcm_area_ptr, mcm_storage_ptr,
	mcm_relmgr_destroy_cursor, mcm_relmgr_close, mcm_code);





	mcm_code = 0;

	if storage_type (mcm_storage_ptr) = mcm_ARRAY
	then call delete_cursors_from_array (mcm_opening_id, mcm_area_ptr, mcm_storage_ptr, mcm_relmgr_destroy_cursor);
	else call delete_cursors_from_vfile (mcm_opening_id, mcm_area_ptr, mcm_storage_ptr, mcm_relmgr_destroy_cursor);

	call mcm_relmgr_close (mcm_opening_id, mcm_code);
	if mcm_code ^= 0
	then call error_exit (mcm_code, "Could not close the open relation");

	goto exit;

cleanup_storage: entry (mcm_storage_ptr, mcm_area_ptr, mcm_code);





	mcm_code = 0;

	call destroy_storage (mcm_storage_ptr);

/* mu_define_area uses get_temp_segment_ to get the temp seg the area is based on */

	call release_temp_segment_ ("cursor_area", mcm_area_ptr, mcm_code);
	if mcm_code ^= 0
	then call error_exit (mcm_code, "Could not release the temp seg used to store the cursors.");

	goto exit;

exit:
	return;

open_relation: proc (or_relmgr_open, or_rmri_ptr);

/*
   This  procedure  calls  the  relation  manager  entry to open the
   relation.   it determines the path to the relation by obtaining a
   pointer  to  the rm_db_info structure which has as an element the
   database  path,  this  coupled  with the relation's name from the
   rm_rel_info  structure  gives  the  path.   The  pointer  to  the
   rm_db_info  structure  is  obtained by forming a pointer based on
   the  seg_no  of  the or_rmri_ptr pointer and a 0 bit offset, i.e.
   the  rm_rel_info structure is allocated in the static area set up
   in the rm_db_info structure.
*/

/* PARAMETERS */

	dcl     or_relmgr_open	 entry options (variable);
						/* (input) relation_manager entry used to open the realtion */
	dcl     or_rmri_ptr		 ptr;		/* (input) pointer to the relation's rm_rel_info structure */

/* AUTOMATIC */

	dcl     or_code		 fixed bin (35);	/* standard error code */
	dcl     or_rdbi_ptr		 ptr;		/* pointer to the database's rm_db_info structure */





	or_rdbi_ptr = pointer (or_rmri_ptr, 0);

	call or_relmgr_open (or_rdbi_ptr -> rm_db_info.db_path,
	     or_rmri_ptr -> rm_rel_info.model_name,
	     or_rmri_ptr -> rm_rel_info.opening_id,
	     or_code);
	if or_code ^= 0
	then call error_exit (or_code, "Could not open the relation " || or_rmri_ptr -> rm_rel_info.name);

	return;

     end /* open_relation */;

build_storage: proc (bs_dbi, bs_storage_type, bs_storage_ptr);

/* 
   This  procedure  goes out and gets the space that will be used to
   store the cursor pointers.  If the cursors are to be stored in an
   array  a  temp  segment  is  obtained  other wise a keyed file is
   attached  and  opened.   The location of the storage (temp seg or
   keyed  file)  will be in the opening temp dir.  If a temp segment
   is  used  than  this  routine  will also initialize the number of
   cursors to 0 and the version of the structure.  No initialization
   is needed for the keyed file.
*/

/* GLOBALS

   mcm_ARRAY		indicates a storage type of array
   mcm_PROC_NAME    	procedure's name
   mcm_dbi		data base index
   mcm_cursor_array	          structure containing the array of cursors to be overlaid on the temp_seg
*/

/* PARAMETERS */

	dcl     bs_dbi		 fixed bin (35);	/* (input) database index - used for array storage only */
	dcl     bs_storage_type	 fixed bin;	/* (input) indicates whether a temp_seg or
                                                                        keyed file is to be built */
	dcl     bs_storage_ptr	 ptr;		/* (output) either a ptr to the temp_seg or the file's iocb */

/* AUTOMATIC */

	dcl     bs_code		 fixed bin (35);	/* standard error code */
	dcl     bs_dbi_char		 char (4);	/* character representation of the database index */
	dcl     bs_temp_dir		 char (168);	/* path of the opening temp dir, dir
                                                               that will contain the storage area */

/* CONSTANTS */

	dcl     bs_KSQU		 fixed bin init (10) internal static options (constant);
						/* indicates an iox opening mode of keyed-sequential-update */

	if bs_storage_type = mcm_ARRAY
	then do;
		bs_dbi_char = ltrim (char (bs_dbi));
		call mu_temp_segments$get_temp_segment (mcm_dbi, mcm_PROC_NAME || bs_dbi_char, bs_storage_ptr, bs_code);
		if bs_code ^= 0
		then call error_exit (bs_code, "Could not get a temp_segment for cursor array storage");
		bs_storage_ptr -> mcm_cursor_array.num = 0;
		bs_storage_ptr -> mcm_cursor_array.version = "ARAY";
		bs_storage_ptr -> mcm_cursor_array.dbi_char = bs_dbi_char;
		bs_storage_ptr -> mcm_cursor_array.mbz = "0"b;
	     end;
	else do;
		bs_temp_dir = mrds_dsl_resultant_storage$get_opening_temp_dir (mcm_dbi, bs_code);
		if bs_code ^= 0
		then call error_exit (bs_code, "Could not get the opening temp dir");
		call iox_$attach_name (ltrim (char (mcm_dbi)) || ".mcm." || unique_chars_ ("0"b), bs_storage_ptr,
		     "vfile_ " || rtrim (bs_temp_dir) || ">" || ltrim (char (mcm_dbi)) ||
		     ".mcm." || unique_chars_ ("0"b),
		     null (), bs_code);
		if bs_code ^= 0
		then call error_exit (bs_code, "Could not attach a temp file for cursor storage");

		call iox_$open (bs_storage_ptr, bs_KSQU, "0"b, bs_code);
		if bs_code ^= 0
		then call error_exit (bs_code, "Could not open temp file for cursor storage");
	     end;

	return;

     end /* build_storage */;

destroy_storage: proc (ds_storage_ptr);

/*
This  procedure  destroys  the  storage space associated with the
cursor  pointer  storage.  For  array  storage  the  temp  seg is
delete. For  a  vfile,  it  closed  and  detached  and  the  iocb
destroyed and the MSF is deleted.
*/

/* GLOBALS

   mcm_ARRAY		indicates a storage type of array
   mcm_PROC_NAME		procedure's name
*/

/* PARAMETERS */

	dcl     ds_storage_ptr	 ptr;		/* (input / output) input => ptr to the storage structure */
						/*               output => null */

/* AUTOMATIC */

	dcl     ds_code		 fixed bin (35);	/* standard error code */
	dcl     ds_dir		 char (168);	/* path of dir containing the vfile that the
 cursor pointers were stored in */
	dcl     ds_entry		 char (32);	/* name of the vfile containing the cursor pointers */
	dcl     ds_path		 char (168);	/* path of the vfile containing the cursor pointers */

/* BASED */

	dcl     ds_c168b		 char (168) based;	/* path overlay */

	if storage_type (ds_storage_ptr) = mcm_ARRAY
	then do;
		call mu_temp_segments$delete_all_temp_segments
		     (mcm_PROC_NAME || ds_storage_ptr -> mcm_cursor_array.dbi_char, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not delete temp seg containing the cursor array.");
	     end;
	else do;
		ds_path = substr (ds_storage_ptr -> iocb.attach_descrip_ptr -> ds_c168b, 12);
		call expand_pathname_ (ds_path, ds_dir, ds_entry, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not get the path of the vfile containing the cursors.");
		call iox_$close (ds_storage_ptr, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not close the vfile containing the cursors.");
		call iox_$detach_iocb (ds_storage_ptr, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not detach the vfile containing the cursors.");
		call iox_$destroy_iocb (ds_storage_ptr, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not destroy the iocb for the vfile containing the cursors.");
		call delete_$path (ds_dir, ds_entry, "100100"b, mcm_PROC_NAME, ds_code);
		if ds_code ^= 0
		then call error_exit (ds_code, "Could not delete the vfile containing the cursors.");
	     end;

	ds_storage_ptr = null ();

	return;

     end /* destroy_storage */;

storage_type: proc (st_storage_ptr) returns (fixed bin);

/*
   This  procedure  determines  what type of storage the storage_ptr
   points  to.  If the storage type is a keyed file then storage_ptr
   points to an iocb, the first element in the iocb structure is a 4
   character  version  containing the string "IOX2".  If the storage
   type  is  an  array  then storage_ptr points to a structure whose
   first element is a 4 character version (to be compatable with the
   iocb) containing "ARAY".  Any thing else will generate an error.
*/

/* GLOBALS

   mcm_ARRAY		indicates a storage type of array
   mcm_VFILE		indicates a storage type of keyed file
*/

/* PARAMETERS */

	dcl     st_storage_ptr	 ptr;		/* (input) either a ptr to the temp_seg or the file's iocb */

/* AUTOMATIC */

	dcl     st_return_type	 fixed bin;	/* indicats the type of storage that storage_ptr points to */

/* BASED */

	dcl     st_c4b		 char (4) based;	/* 4 character overlay for the version element */





	if st_storage_ptr -> st_c4b = "IOX2"
	then st_return_type = mcm_VFILE;
	else
	     if st_storage_ptr -> st_c4b = "ARAY"
	then st_return_type = mcm_ARRAY;
	else call error_exit (mrds_error_$unknown_cursor_storage, "A cursor storage pointer is bad.");

	return (st_return_type);

     end /* storage_type */;

array_search: proc (as_key, as_storage_ptr, as_index, as_found);

/*
   This  procedure  performs  a binary search on the cursor array to
   locate  a  given  cursor  or  determine where it should be placed
   after it is gotten from the relation_manager.  The case of a zero
   length  array  is special cased because the search algorithm will
   not  return the correct index in which to put the new element for
   this condition.
*/

/* GLOBALS

   mcm_cursor_array          	structure containing the array of cursors to be overlaid on the temp_seg
*/

/* PARAMETERS */

	dcl     as_key		 char (12);	/* (input) the key identifing which cursor is wanted */
	dcl     as_storage_ptr	 ptr;		/* (input) ptr to the temp_seg containing the cursor array */
	dcl     as_index		 fixed bin;	/* (output) index in the array of the requested cursor or
                                                                        index of where it should placed. */
	dcl     as_found		 bit (1);		/* (output) "1"b ==> cursor was found,
                                                                        "0"b ==> it needs to be gotten */

/* AUTOMATIC */

	dcl     as_higher_index	 fixed bin;	/* highest element of the binary search */
	dcl     as_key_larger	 bit (1) aligned;	/* "1"b => if as_key > key at as_middle_index */
	dcl     as_lower_index	 fixed bin;	/* lower index of the binary search */
	dcl     as_middle_index	 fixed bin;	/* middle element of the search */





	as_found = "0"b;
	as_index = 0;

	if as_storage_ptr -> mcm_cursor_array.num = 0
	then as_index = 1;
	else do;
		as_lower_index = 1;
		as_higher_index = as_storage_ptr -> mcm_cursor_array.num;
		do while (^as_found & as_lower_index <= as_higher_index);
		     as_middle_index = divide ((as_higher_index + as_lower_index), 2, 35, 0);
		     if as_key > as_storage_ptr -> mcm_cursor_array.cursors (as_middle_index).key
		     then do;
			     as_lower_index = as_middle_index + 1;
			     as_key_larger = "1"b;
			end;
		     else
			if as_key = as_storage_ptr -> mcm_cursor_array.cursors (as_middle_index).key
		     then as_found = "1"b;
		     else do;
			     as_higher_index = as_middle_index - 1;
			     as_key_larger = "0"b;
			end;
		end;
		as_index = as_middle_index;
		if as_key_larger & ^as_found
		then as_index = as_index + 1;
	     end;

	return;

     end /* array_search */;

vfile_search: proc (vs_key, vs_storage_ptr, vs_cursor_ptr, vs_found);

/*
   This  procedure  searches  the  keyed file for the key associated
   with the requested cursor.  If the key is not found it leaves the
   vfile  in  a  state  where  cursor  record  can be added with the
   correct key.
*/

/* GLOBALS

   error_table_$no_record     error returned if seek_key cannot find the key
   mcm_CURSOR_PTR_LENGTH	length of a cursor_ptr in bytes
*/

/* PARAMETERS */

	dcl     vs_key		 char (12);	/* (input) key identifing which cursor is wanted */
	dcl     vs_storage_ptr	 ptr;		/* (input) points to the iocb for the
                                                                       file containing the cursors */
	dcl     vs_cursor_ptr	 ptr;		/* (output) null if the key wasn't found or a cursor_ptr */
	dcl     vs_found		 bit (1);		/* (output) "1"b => the key was found,
                                                                        "0"b => the key was not found */

/* AUTOMATIC */

	dcl     vs_code		 fixed bin (35);	/* standard error code */
	dcl     vs_unused1		 fixed bin (21);	/* unused output parameter from iox_ calls */
	dcl     vs_vfile_key	 char (256) varying;/* type of key used by vfile */





	vs_found = "0"b;
	vs_cursor_ptr = null ();

	vs_vfile_key = vs_key;

	call iox_$seek_key (vs_storage_ptr, vs_vfile_key, vs_unused1, vs_code);
	if vs_code ^= 0
	then do;
		if vs_code ^= error_table_$no_record
		then call error_exit (vs_code, "Error while adding key to vfile.");
	     end;
	else do;
		vs_found = "1"b;
		call iox_$read_record (vs_storage_ptr, addr (vs_cursor_ptr), mcm_CURSOR_PTR_LENGTH,
		     vs_unused1, vs_code);
		if vs_code ^= 0
		then call error_exit (vs_code, "Unable to read a cursor record.");
	     end;

	return;

     end /* vfile_search */;

add_cursor_to_array: proc (acta_storage_ptr, acta_key, acta_cursor_ptr, acta_index);

/*
   This routine adds a <key cursor_ptr> element to the cursor array.
*/

/* GLOBALS

   mcm_CURSOR_ARRAY_ELEMENT_SIZE   number of bits used for a cursor element (key and pointer)
   mcm_cursor_array                structure containing the array of cursors to be overlaid on the temp_seg

/* PARAMETERS */

	dcl     acta_storage_ptr	 ptr;		/* (input) pointer to the cursor array structure */
	dcl     acta_key		 char (12);	/* (input) the cursor_ptr's key */
	dcl     acta_cursor_ptr	 ptr;		/* (input) the cursor pointer */
	dcl     acta_index		 fixed bin;	/* (input) index where the cursor should be placed */

/* AUTOMATIC */

	dcl     acta_move_length	 fixed bin (21);	/* number of chars that need to be moved */




	if acta_storage_ptr -> mcm_cursor_array.num >= acta_index
	then do;
		acta_storage_ptr -> mcm_cursor_array.num = acta_storage_ptr -> mcm_cursor_array.num + 1;
		acta_move_length = mcm_CURSOR_ARRAY_ELEMENT_SIZE *
		     (acta_storage_ptr -> mcm_cursor_array.num - acta_index);
		call move_chars (addr (acta_storage_ptr -> mcm_cursor_array.cursors (acta_index)), acta_move_length,
		     addr (acta_storage_ptr -> mcm_cursor_array.cursors (acta_index + 1)),
		     addr (acta_storage_ptr -> mcm_cursor_array.temp_space_begins));
	     end;
	else acta_storage_ptr -> mcm_cursor_array.num = acta_storage_ptr -> mcm_cursor_array.num + 1;

	acta_storage_ptr -> mcm_cursor_array.cursors (acta_index).key = acta_key;
	acta_storage_ptr -> mcm_cursor_array.cursors (acta_index).cursor_ptr = acta_cursor_ptr;

	return;

     end /* add_cursor_to_array */;

move_chars: proc (mc_source_ptr, mc_length, mc_target_ptr, mc_temp_space_ptr);

/*
   This routine shifts a string  of  mc_length  characters  starting
   from  mc_source_ptr  to  a  point starting with mc_target_ptr. It
   does this by copying the string into a temp area and then copying
   it back, this way there are no problems with  source  and  target
   strings overlaping.
*/

/* GLOBALS

   mcm_cursor_array		structure containing the array of cursors, or in this
			case the string of chars to eb shifted
*/

/* PARAMETERS */

	dcl     mc_source_ptr	 ptr;		/* (input) location of the first character to be moved */
	dcl     mc_length		 fixed bin (21);	/* (input) number of characters to be moved */
	dcl     mc_target_ptr	 ptr;		/* (input) location of the first character after the move */
	dcl     mc_temp_space_ptr	 ptr;		/* (input) location ofthe first character of the temp space */

/* BASED */

	dcl     mc_chars		 char (mc_length) based unaligned;




	mc_temp_space_ptr -> mc_chars = mc_source_ptr -> mc_chars;
	mc_target_ptr -> mc_chars = mc_temp_space_ptr -> mc_chars;

	return;

     end /* move_chars */;

add_cursor_to_vfile: proc (actv_storage_ptr, actv_cursor_ptr);

/*
   This  procedure  adds  the  cursor_ptr  record  to the keyed file
   storage  structure.   The  position in the keyed file has already
   been set up by the vfile_search procedure.
*/

/* GLOBALS

   mcm_CURSOR_PTR_LENGTH	length of a cursor_ptr in bytes
*/

/* PARAMETERS */

	dcl     actv_storage_ptr	 ptr;		/* (input) pointer to the keyed file's iocb */
	dcl     actv_cursor_ptr	 ptr;		/* (input) pointer to the cursor - the record to be written */

/* AUTOMATIC */

	dcl     actv_code		 fixed bin (35);	/* standard error code */





	call iox_$write_record (actv_storage_ptr, addr (actv_cursor_ptr), mcm_CURSOR_PTR_LENGTH, actv_code);
	if actv_code ^= 0
	then call error_exit (actv_code, "Error while loading key into vfile.");

	return;

     end /* add_cursor_to_vfile */;

convert_array_to_vfile: proc (catv_storage_ptr);

/*
   This procedure converts from a array storage type to a keyed file
   storage  type.   It first builds the keyed file storage space and
   then copies each element from the cursor array and writes it into
   the    keyed    file.     The    procedures    vfile_search   and
   add_cursor_to_vfile  are  used to eliminate code duplication that
   would  otherwise  be  required.   When  all the cursors have been
   moved the storage space associated with the array is destroyed.
*/

/* GLOBALS

   mcm_cursor_array           structure containing the array of cursors to be overlaid on the temp_seg
   mcm_PROC_NAME	          procedure's name
   mcm_VFILE		indicates a storage type of keyed file
*/

/* PARAMETERS */

	dcl     catv_storage_ptr	 ptr;		/* (input/output) input => ptr to the array storage */
						/*                output => ptr to the keyed file's iocb */

/* AUTOMATIC */

	dcl     catv_array_storage_ptr ptr;		/* pointer to array storage */
	dcl     catv_i		 fixed bin;	/* loop index */
	dcl     catv_unused1	 ptr;		/* unused output from vfile_search -
                                                               we know the value will be null */
	dcl     catv_unused2	 bit (1);		/* unused output from vfile_search -
                                                               we know the cursor won't be found */
	dcl     catv_vfile_storage_ptr ptr;		/* pointer to keyed file's iocb */

	catv_array_storage_ptr = catv_storage_ptr;

	call build_storage (0, mcm_VFILE, catv_vfile_storage_ptr);

	do catv_i = 1 to catv_array_storage_ptr -> mcm_cursor_array.num;
	     call vfile_search (catv_array_storage_ptr -> mcm_cursor_array.cursors (catv_i).key,
		catv_vfile_storage_ptr, catv_unused1, catv_unused2);
	     call add_cursor_to_vfile (catv_vfile_storage_ptr,
		catv_array_storage_ptr -> mcm_cursor_array.cursors (catv_i).cursor_ptr);
	end;

	catv_storage_ptr = catv_vfile_storage_ptr;

	call destroy_storage (catv_array_storage_ptr);

	return;

     end /* convert_array_to_vfile */;

create_cursor: proc (cc_rel_opening_id, cc_collection_id, cc_relmgr_create_cursor, cc_area_ptr, cc_cursor_ptr);

/*
   This procedure calls the relation_manager to get a cursor.
*/

/* PARAMETERS */

	dcl     cc_rel_opening_id	 bit (36) aligned;	/* (input) relation manager opening id for the relation */
	dcl     cc_collection_id	 bit (36) aligned;	/* (input) collection id of the collection to
                                                                       be associated with the cursor */
	dcl     cc_relmgr_create_cursor entry options (variable);
						/* (input) entry used to get the cursor */
	dcl     cc_area_ptr		 ptr;		/* (input) pointer to area where cursor is to be allocated */
	dcl     cc_cursor_ptr	 ptr;		/* (output) pointer to the cursor */

/* AUTOMATIC */

	dcl     cc_code		 fixed bin (35);	/* standard error code */





	call cc_relmgr_create_cursor (cc_rel_opening_id,
	     cc_area_ptr, cc_cursor_ptr, cc_code);
	if cc_code ^= 0
	then call error_exit (cc_code, "Could not obtain a cursor.");

	return;

     end /* create_cursor */;

close_rels_from_array: proc (crfa_storage_ptr, crfa_relmgr_close);

/*
   This  procedure closes the relations that are associated with the
   cursors whose pointers are in the cursor array.
*/

/* GLOBALS 

   mcm_cursor_array		structure containing the array of cursors
   mcm_b36b                   b36 overlay
*/

/* PARAMETERS */

	dcl     crfa_storage_ptr	 ptr;		/* (input) pointer to the array storage */
	dcl     crfa_relmgr_close	 entry options (variable); /* (input) entry used to close a relation */

/* AUTOMATIC */

	dcl     crfa_close_code	 fixed bin (35);	/* last non-zero error code returned from crfa_relmgr_close */
	dcl     crfa_code		 fixed bin (35);	/* standard error code */
	dcl     crfa_i		 fixed bin;	/* loop index */
	dcl     crfa_last_opening_id	 bit (36);	/* opening id of the last relation closed */
	dcl     crfa_opening_id	 bit (36);	/* opening id of the relation to be closed next */






	crfa_last_opening_id = "0"b;
	crfa_close_code = 0;
	do crfa_i = 1 to crfa_storage_ptr -> mcm_cursor_array.num;
	     crfa_opening_id = addr (crfa_storage_ptr -> mcm_cursor_array.cursors (crfa_i).key) -> mcm_b36b;
	     if crfa_last_opening_id ^= crfa_opening_id
	     then do;
		     call crfa_relmgr_close (crfa_opening_id, crfa_code);
		     if crfa_code ^= 0
		     then crfa_close_code = crfa_code;
		     crfa_last_opening_id = crfa_opening_id;
		end;
	end;

	if crfa_close_code ^= 0
	then call error_exit (crfa_close_code, "Error while closing relations, not all relations have been closed.");

	return;

     end /* close_rels_from_array */;

close_rels_from_vfile: proc (crfv_storage_ptr, crfv_relmgr_close);

/*
   This  procedure closes the relations that are associated with the
   cursors whose pointers are in the vfile.
*/

/* GLOBALS

   mcm_cursor_array
   mcm_b36
*/

/* PARAMETERS */

	dcl     crfv_storage_ptr	 ptr;		/* (input) points to the iocb for
                                                                       the file containing the cursors */
	dcl     crfv_relmgr_close	 entry options (variable);
						/* (input) entry used to close the relations */

/* AUTOMATIC */

	dcl     crfv_close_code	 fixed bin (35);	/* last non-zero error code returned from crfv_relmgr_close */
	dcl     crfv_code		 fixed bin (35);	/* standard error code */
	dcl     crfv_last_opening_id	 bit (36);	/* opening id of last relation closed */
	dcl     crfv_key		 char (256) varying;/* cursor_key returned from the vfile */
	dcl     crfv_unused1	 fixed bin (21);	/* unused output from the call to iox_$read_key */
	dcl     crfv_opening_id	 bit (36);	/* opening id of the next relation to be closed */

/* CONSTANTS */

	dcl     crfv_BOF		 fixed bin init (-1) internal static options (constant);
						/* indicates that the file is to be
                                                               positioned to the first record */
	dcl     crfv_SKIP_RECORD	 fixed bin init (0) internal static options (constant);

/* indicates that the file is to be
						   positioned down 1 record */

	call iox_$position (crfv_storage_ptr, crfv_BOF, 0, crfv_code);
	if crfv_code ^= 0
	then call error_exit (crfv_code, "Could not position to begining of key tree when destroying cursor pointers.");

	call iox_$read_key (crfv_storage_ptr, crfv_key, crfv_unused1, crfv_code);
	if crfv_code ^= 0 & crfv_code ^= error_table_$end_of_info
	then call error_exit (crfv_code, "Could not read key from key tree.");

	crfv_last_opening_id = "0"b;
	crfv_close_code = 0;

	do while (crfv_code = 0);
	     crfv_opening_id = addr (crfv_key) -> mcm_b36b;
	     if crfv_last_opening_id ^= crfv_opening_id
	     then do;
		     call crfv_relmgr_close (crfv_opening_id, crfv_code);
		     if crfv_code ^= 0
		     then crfv_close_code = crfv_code;
		     crfv_last_opening_id = crfv_opening_id;
		end;
	     call iox_$position (crfv_storage_ptr, crfv_SKIP_RECORD, 1, crfv_code);
	     if crfv_code ^= 0 & crfv_code ^= error_table_$end_of_info
	     then call error_exit (crfv_code, "Could not position to next record while closing relations.");

	     call iox_$read_key (crfv_storage_ptr, crfv_key, crfv_unused1, crfv_code);
	     if crfv_code ^= 0 & crfv_code ^= error_table_$end_of_info
	     then call error_exit (crfv_code, "Could not read key from key tree.");
	end;

	if crfv_close_code ^= 0
	then call error_exit (crfv_close_code, "Error while closing relations, not all relations have been closed.");
	return;

     end /* close_rels_from_vfile */;

delete_cursors_from_array: proc (dcfa_opening_id, dcfa_area_ptr, dcfa_storage_ptr, dcfa_relmgr_destroy_cursor);

/*
   This procedure destroys all  cursors  assocaiated  with  a  given
   opening id and removes the cursor_ptrs from the array.
*/

/* GLOBAL

   mcm_c4b		     4 character overlay
   mcm_cursor_array		     structure containing the array of cursors
   mcm_CURSOR_ARRAY_ELEMENT_SIZE   number of bits used for cursor element (key and pointer)
*/

/* PARAMETERS */

	dcl     dcfa_opening_id	 bit (36) aligned;	/* (input) opening id of cursors to be deleted */
	dcl     dcfa_area_ptr	 ptr;		/* (input) pointer to area where the
                                                                       cursors have been allocated */
	dcl     dcfa_storage_ptr	 ptr;		/* (input) pointer to cursor ptr storage structure */
	dcl     dcfa_relmgr_destroy_cursor entry options (variable);
						/* (input) relation manager entry to destroy a cursor */

/* AUTOMATIC */

	dcl     dcfa_code		 fixed bin (35);	/* error code */
	dcl     dcfa_cursor_index_1	 fixed bin;	/* index into the array of the first
                                                               cursor with the opening id */
	dcl     dcfa_cursor_index_2	 fixed bin;	/* index into the array of the last
                                                               cursor with the opening id */
	dcl     dcfa_key		 char (12);	/* key containing only the opening id, so that
                                                               a search will find the first key with that opening id. */
	dcl     dcfa_num_cursors_being_deleted fixed bin; /* number of cursors being deleted from the array */
	dcl     dcfa_unused1	 bit (1);		/* output from array_search, we know the key won't be found */

	unspec (dcfa_key) = "0"b;
	substr (dcfa_key, 1, 4) = addr (dcfa_opening_id) -> mcm_c4b;
	call array_search (dcfa_key, dcfa_storage_ptr, dcfa_cursor_index_1, dcfa_unused1);
	dcfa_cursor_index_2 = dcfa_cursor_index_1;
	do while ((addr (dcfa_storage_ptr -> mcm_cursor_array.cursors (dcfa_cursor_index_2).key) -> mcm_c4b =
	     addr (dcfa_opening_id) -> mcm_c4b)
	     & (dcfa_cursor_index_2 <= dcfa_storage_ptr -> mcm_cursor_array.num));
	     call dcfa_relmgr_destroy_cursor (
		dcfa_storage_ptr -> mcm_cursor_array.cursors (dcfa_cursor_index_2).cursor_ptr,
		dcfa_area_ptr, dcfa_code);
	     if dcfa_code ^= 0
	     then call error_exit (dcfa_code, "Could not destroy a cursor.");
	     dcfa_cursor_index_2 = dcfa_cursor_index_2 + 1;
	end;
	dcfa_num_cursors_being_deleted = dcfa_cursor_index_2 - dcfa_cursor_index_1;
	call move_chars (addr (dcfa_storage_ptr -> mcm_cursor_array.cursors (dcfa_cursor_index_2)),
	     (dcfa_storage_ptr -> mcm_cursor_array.num - dcfa_cursor_index_2 + 1) * mcm_CURSOR_ARRAY_ELEMENT_SIZE,
	     addr (dcfa_storage_ptr -> mcm_cursor_array.cursors (dcfa_cursor_index_1)),
	     addr (dcfa_storage_ptr -> mcm_cursor_array.temp_space_begins));
	dcfa_storage_ptr -> mcm_cursor_array.num =
	     dcfa_storage_ptr -> mcm_cursor_array.num - dcfa_num_cursors_being_deleted;

	return;

     end /* delete_cursors_from_array */;

delete_cursors_from_vfile: proc (dcfv_opening_id, dcfv_area_ptr, dcfv_storage_ptr, dcfv_relmgr_destroy_cursor);

/*
   This procedure destroys all cursors associated with a given
   opening id and removes the cursors from the vfile.
*/

/* GLOBAL 

   mcm_c4b		4 character overlay
   mcm_CURSOR_PTR_LENGTH	length of a cursor_ptr ==> 2 words or 8 bytes
*/

/* PARAMETERS */

	dcl     dcfv_opening_id	 bit (36) aligned;	/* (input) opening id of cursors to be deleted */
	dcl     dcfv_area_ptr	 ptr;		/* (input) pointer to area where the
                                                                       cursors have been allocated */
	dcl     dcfv_storage_ptr	 ptr;		/* (input) pointer to cursor ptr storage
                                                                       structure, an iocb in this case */
	dcl     dcfv_relmgr_destroy_cursor entry options (variable);
						/* (input) relation manager entry to destroy a cursor */

/* AUTOMATIC */

	dcl     dcfv_code		 fixed bin (35);	/* standard error code */
	dcl     dcfv_stored_cursor_ptr ptr;		/* cursor pointer that was stored in the vfile */
	dcl     dcfv_stored_key	 char (256) varying;/* key that was stored in the vfile */
	dcl     dcfv_unused1	 fixed bin (21);	/* unused output from iox_$read_key and read_record */
	dcl     01 dcfv_seek_head_info,		/* structure to control vfile seek_head operation */
		02 relation_type	 fixed bin init (1),/* will seek first key with a head >= given key */
		02 n		 fixed bin init (4),/* key head is 45 characters long */
		02 key		 char (256);	/* key head character string */

	dcfv_seek_head_info.key = addr (dcfv_opening_id) -> mcm_c4b;
	call iox_$control (dcfv_storage_ptr, "seek_key", addr (dcfv_seek_head_info), dcfv_code);
	do while (dcfv_code = 0);
	     call iox_$read_key (dcfv_storage_ptr, dcfv_stored_key, dcfv_unused1, dcfv_code);
	     if dcfv_code = 0
	     then do;
		     if addr (dcfv_stored_key) -> mcm_c4b = addr (dcfv_opening_id) -> mcm_c4b
		     then do;

			     call iox_$read_record (dcfv_storage_ptr, addr (dcfv_stored_cursor_ptr),
				mcm_CURSOR_PTR_LENGTH, dcfv_unused1, dcfv_code);
			     if dcfv_code = 0
			     then do;
				     call dcfv_relmgr_destroy_cursor (
					dcfv_stored_cursor_ptr,
					dcfv_area_ptr, dcfv_code);
				     if dcfv_code = 0
				     then call iox_$delete_record (dcfv_storage_ptr, dcfv_code);
				end;
			end;
		end;
	end;

     end /* delete_cursors_from_vfile */;

error_exit: proc (ee_code, ee_message);

/*
   This  procedure  is  used  in  case an error occurs.  It sets the
   value  of  the  error code to be returned to the caller and calls
   sub_err_ to report more completely to the user.  It also performs
   a non-local goto to return to the caller of mu_cursor_manager_ so
   this procedure itself never returns to its caller.
*/

/* GLOBALS

   mcm_code		standard error code to be returned to the caller of mu_cursor_manager_
   mcm_PROC_NAME              procedure's name

/* PARAMETERS */

	dcl     ee_code		 fixed bin (35);	/* (input) standard error code */
	dcl     ee_message		 char (*);	/* (input) message of what went
                                                                       wrong to be sent to the user */





	mcm_code = ee_code;
	call sub_err_ (mcm_code, mcm_PROC_NAME, "c", null (), 0, ee_message);

	goto exit;

     end /* error_exit */;

     end /* mu_cursor_manager_ */;




		    mu_data_align.pl1               04/18/85  1437.3re  04/18/85  0908.1       45054



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - December 1979

*/

mu_data_align: align_data_item: procedure (desc_ptr, base_to_pad) returns (fixed bin);

/* DESCRIPTION:

   given a pointer to a standard multics pl1 data argument descriptor,
   and a current storage offset at which data is to be placed,
   this routine calculates from the data type, and the given address
   the number of padding bits needed to properly align the data
   on either a byte, word, or double word boundary, as required
   by the data type definition, and routines such as assign_.
   currently the data types that assign_ can handle are supported
   by this routine(i.e. 1-12, 19-22, 33-34, 43-46)

*/

/* PARAMETERS:

   desc_ptr - - (input) pointer, points to the standard multics pl1 argument
   descriptor for the data to be byte/word/even_word aligned using the given address

   base_to_pad - - (input) fixed bin(35), the current address(offset), of the last
   data item, after which the data item described by the input descriptor
   is to be placed, for the first data item, base_to_pad = 0.

   needed_bits - - (output) fixed bin, the number of bits to add to base_to_pad,
   in order to obtain the correct byte/word/even_word alignment for the
   data type as described by the input descriptor.

*/

/* using the declared alignment and data type for this attribute,
   return the number of bits necessary to put the data on a boundary
   as defined by pl1, such as byte, word or double word aligned, for using that type.
   directly in such operations as the any_to_any convert via assign_
   without having to do a bit move to get the proper alignment.
   this makes data storage in the tuple a true representation of the pl1
   attributes of unaligned and aligned for complete user choice
   in the trade off between speed and space. */

	needed_bits = 0;				/* initialize */

	if desc_ptr = null () then ;
	else if descriptor.packed then do;		/* unaligned */

		if ^(descriptor.type = 21 | (descriptor.type >= 9 & descriptor.type <= 12) /* char or decimal */
		     | (descriptor.type >= 43 & descriptor.type <= 46)) then ; /* packed decimal */
		else needed_bits = pad (BYTE, base_to_pad);

	     end;
	else do;					/* aligned */

		if (descriptor.type >= 9 & descriptor.type <= 12) | /* decimal */
		     (descriptor.type >= 43 & descriptor.type <= 46) | /* packed decimal */
		     (descriptor.type >= 19 & descriptor.type <= 22) | /* bit or char */
		     descriptor.type = 1 | descriptor.type = 3 | descriptor.type = 33 then /* binary short */
		     needed_bits = pad (WORD, base_to_pad);

		else if descriptor.type = 2 | descriptor.type = 34 | /* binary long */
			(descriptor.type >= 4 & descriptor.type <= 8) then /* binary complex */
		     needed_bits = pad (DOUBLE_WORD, base_to_pad);
		else ;				/* none needed otherwise */

	     end;

	return (needed_bits);


	declare needed_bits		 fixed bin;	/* number of bits needed to get the alignment */
	declare base_to_pad		 fixed bin (35);	/* original value to be padded out */

pad: procedure (pad_size, pad_base) returns (fixed bin);

/* routine to return the number of bits necessary to pad a bit count
   out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits
   as determined by the pad size input */

	if mod (pad_base, pad_size) = 0 then
	     number_of_bits = 0;
	else do;

		number_of_bits = pad_size - mod (pad_base, pad_size);

	     end;

	return (number_of_bits);


	declare pad_size		 fixed bin;	/* either 9 or 36 or 72 */
	declare pad_base		 fixed bin (35);	/* current bit length to be padded */
	declare number_of_bits	 fixed bin;	/* what has to be added to get to the desired boundary */

     end;

	declare mod		 builtin;
	declare null		 builtin;
	declare BYTE		 fixed bin init (9) internal static options (constant); /* byte boundary = 9 bits */
	declare WORD		 fixed bin init (36) int static options (constant); /* word boundary = 36 bits */
	declare DOUBLE_WORD		 fixed bin init (72) int static options (constant); /* double word boundary = 72 bits */

%include mdbm_descriptor;

     end;




		    mu_data_class.pl1               04/18/85  1437.3re  04/18/85  0908.1       66420



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - December 1979

*/

mu_data_class: procedure (); return;			/* not a valid entry */

/* DESCRIPTION:

   this routine, given a standard multics pl1 argument descriptor,
   will determine whether the descriptor refers to the class
   of data, that the particular entry refers to, and return
   either a true or false value. there are 12 entries:
   real - determines if the data type is real
   complex - determines if the data type is complex
   char - determines determines if the data type is character
   bit - determines if the data type is bit
   varying - determines if the data type is bit or character varying
   aligned - determines if the data type is unpacked
   fixed - determines if the data type is numeric and fixed point
   scalar - determines if the data is not an array
   string - determines if the data is a string type(bit or char)
   number - determines if the data is a number(real or complex)
   convertible - determines if the data can be converted to float decimal(59)
   binary - determines if the data is a binary number

*/

/* PARAMETERS:

   desc_ptr - - (input) pointer, points to the bit(36) standard
   multics pl1 descriptor for data, which is to be queried for it's data class

   valid - - (output) bit(1) aligned, either true or false, true if the
   descriptor refered to a data type in the class determined by the entry called,
   which is one of real, complex, char, bit, varying, aligned, fixed, scalar
   string, number, convertible, or binary

*/

/* check for data being numeric, and real */

real: real_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) = REAL then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being numeric, and complex */

complex: complex_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) = COMPLEX then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being character */

character: character_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) = CHAR then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being bit */

bit: bit_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) = BIT then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being varying character or bit */

varying: varying_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if class < VARYING then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being aligned or unaligned */

aligned: aligned_data_class: entry (desc_ptr) returns (bit (1) aligned);

	valid = ^(descriptor.packed);

	return (valid);

/* check for data being scalar */

scalar: scalar_data_class: entry (desc_ptr) returns (bit (1) aligned);

	if fixed (descriptor.number_dims) = 0 then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for number data being fixed point */

fixed: fixed_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if class > 0 & class <= FIXED then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data being a string type */

string: string_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) > STRING then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for  the data being any type of number */

number: number_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if class ^= 0 & abs (class) <= NUMBER then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data type being convertable to float decimal (59) */

convertible: convertible_data_class: entry (desc_ptr) returns (bit (1) aligned);

	class = type_to_class (descriptor.type);
	if abs (class) = REAL | abs (class) = CHAR then
	     valid = ON;
	else valid = OFF;

	return (valid);

/* check for data type being a binary number */

binary: binary_data_class: entry (desc_ptr) returns (bit (1) aligned);

	if (descriptor.type >= 1 & descriptor.type <= 8) |
	     descriptor.type = 33 | descriptor.type = 34 then
	     valid = ON;
	else valid = OFF;

	return (valid);

	declare class		 fixed bin;	/* class encoding taken from data type */
	declare STRING		 fixed bin int static options (constant) init (2); /* encoding for string check */
	declare NUMBER		 fixed bin int static options (constant) init (2); /* encoding for number check */
	declare REAL		 fixed bin internal static options (constant) init (1); /* encoding for real numerics */
	declare COMPLEX		 fixed bin internal static options (constant) init (2); /* encoding for complex numerics */
	declare BIT		 fixed bin internal static options (constant) init (3); /* encoding for bit strings */
	declare CHAR		 fixed bin internal static options (constant) init (4); /* encoding for character strings */
	declare VARYING		 fixed bin internal static options (constant) init (-2); /* encoding for varying string comparison */
	declare FIXED		 fixed bin internal static options (constant) init (2); /* encoding for varying string comparison */
	declare valid		 bit (1) aligned;	/* on => class matches entry called */
	declare ON		 bit (1) init ("1"b) internal static options (constant); /* true value */
	declare OFF		 bit (1) init ("0"b) internal static options (constant); /* false value */
	declare (abs, fixed)	 builtin;

/* the following encoding array, takes a data type as it's index,
   and returns as an element value, the following classifying values:
   real fixed = 1, real float = -1,
   complex fixed = 2, complex float = -2,
   bit = 3, bit varying = -3,
   character = 4, character varying = -4, no class = 0  */

	declare type_to_class	 (0:63) aligned internal static options (constant) fixed bin
				 init (0, (2) (1), (2) (-1), /* 0 - 4 */
				 (2) (2), (2) (-2), /* 5 - 8 */
				 1, -1, 2, -2, (6) (0), /* 9 - 12, 13 - 18 */
				 3, -3, 4, -4,	/* 19 - 22 */
				 (6) (0),		/* 23 - 28 */
				 (2) (1), (2) (0),	/* 29 - 32 */
				 (4) (1), 0,	/* 33 - 37 */
				 (4) (1),		/* 38 - 41 */
				 -1, 1, -1, 2, -2,	/* 42 - 46 */
				 (17) (0));	/* 47 - 63 */


%include mdbm_descriptor;

     end;




		    mu_data_length.pl1              04/18/85  1437.3re  04/18/85  0908.1      135450



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - April 1979
   Modified by Rickie E. Brinegar on December 28, 1979 to make code a non static
   variable as opposed to the declaration of int static options
   (constant) it was originally declared as.
   Modified by Rickie E. Brinegar on January 9, 1980 to change the declaration of
   return_value from in static options (constant) to automatic.
   Modified by Jim Gray - - 80-9-18, to add the $get_data_pad_length entry, so that mu_build_tuple
   count have a common data primitive routine to get the amount of padding for aligned
   data types from.
*/


mu_data_length: get_data_bit_length: procedure (input_descriptor) returns (fixed bin (35));

/* DESCRIPTION:
   given a 36-bit multics pl1 argument descriptor
   this routine determines the number of bits of storage
   that the data type, alignment, and precision or size
   requires when residing in memory, not counting words
   skipped to obtain even word boundaries.
   the descriptor is assumed to be valid, with correct values for
   scale, precision, size, etc. for that data type, since this is to
   be an efficient run-time routine having had error checks made elsewhere.
   also, the data is assumed to be scalar, i.e. that there are
   no array bounds, as this will be expanded elsewhere.
   decimal 4-bit non-byte aligned are treated as byte aligned data.
   The entry $get_data_pad_length returns instead of the storage bit length,
   the amount of padding that aligned data types needed.
*/

/* PARAMETERS:
   input_descriptor - - (input) bit(36) multics pl1 argument descriptor,
   see subsystem writers guide for format.

   bit_length - - (output) returned storage space needed in bits,
   declared fixed bin(35).

   pad_length - - (output) fixed bin(35), for the $get_data_pad_length only, this is the number
   of bits required to pad aligned data out to it's full size.
   it will be 0 for unaligned data types ;

   sub_error_ - - (output) condition, signaled upon occurence of error
*/

/* get local version of the descriptor */

	descriptor = input_descriptor;

	call common ();

	return (bit_length);






/* entry to return the amount of padding space used */

get_data_pad_length: entry (entry_descriptor) returns (fixed bin (35));

	descriptor = entry_descriptor;

	pad_length = 0;				/* for unaligned types */

	call common ();

	return (pad_length);

common: procedure ();

/* CASE STRUCTURE BASED ON THE DATA TYPE */

	goto case (type);

/* UNUSED */
case (0):
	call unimplemented_data_type ();
	goto end_case;

/* REAL FIXED BINARY SHORT */
case (1):
	bit_length = precision + SIGN;
	if packed then ;
	else do;
		pad_length = ONE_WORD - bit_length;
		bit_length = ONE_WORD;
	     end;
	goto end_case;

/* READ FIXED BINARY LONG */
case (2):
	bit_length = precision + SIGN;
	if packed then ;
	else do;
		pad_length = TWO_WORD - bit_length;
		bit_length = TWO_WORD;
	     end;
	goto end_case;

/* REAL FLOATING BINARY SHORT */
case (3):
	bit_length = precision + ONE_BYTE;
	if packed then ;
	else do;
		pad_length = ONE_WORD - bit_length;
		bit_length = ONE_WORD;
	     end;
	goto end_case;

/*  REAL FLOATING BINARY LONG */
case (4):
	bit_length = precision + ONE_BYTE;
	if packed then ;
	else do;
		pad_length = TWO_WORD - bit_length;
		bit_length = TWO_WORD;
	     end;
	goto end_case;

/* COMPLEX FIXED BINARY SHORT */
case (5):
	bit_length = DOUBLE * (precision + SIGN);
	if packed then ;
	else do;
		pad_length = TWO_WORD - bit_length;
		bit_length = TWO_WORD;
	     end;
	goto end_case;

/* COMPLEX FIXED BINARY LONG */
case (6):
	bit_length = DOUBLE * (precision + SIGN);
	if packed then ;
	else do;
		pad_length = FOUR_WORD - bit_length;
		bit_length = FOUR_WORD;
	     end;
	goto end_case;

/* COMPLEX FLOATING BINARY SHORT */
case (7):
	bit_length = DOUBLE * (precision + ONE_BYTE);
	if packed then ;
	else do;
		pad_length = TWO_WORD - bit_length;
		bit_length = TWO_WORD;
	     end;
	goto end_case;

/* COMPLEX FLOATING BINARY LONG */
case (8):
	bit_length = DOUBLE * (precision + ONE_BYTE);
	if packed then ;
	else do;
		pad_length = FOUR_WORD - bit_length;
		bit_length = FOUR_WORD;
	     end;
	goto end_case;

/* REAL FIXED DECIMAL */
case (9):
	bit_length = ONE_BYTE * (precision + SIGN);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FLOATING DECIMAL */
case (10):
	bit_length = ONE_BYTE * (precision + SIGN_AND_EXPONENT);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* COMPLEX FIXED DECIMAL */
case (11):
	bit_length = DOUBLE * ONE_BYTE * (precision + SIGN);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* COMPLEX FLOATING DECIMAL */
case (12):
	bit_length = DOUBLE * ONE_BYTE * (precision + SIGN_AND_EXPONENT);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* POINTER */
case (13):
	if packed then
	     bit_length = ONE_WORD;
	else bit_length = TWO_WORD;
	goto end_case;

/* OFFSET */
case (14):
	if packed then
	     call invalid_alignment ();
	else bit_length = ONE_WORD;
	goto end_case;

/* LABEL */
case (15):
	if packed then
	     call invalid_alignment ();
	else bit_length = FOUR_WORD;
	goto end_case;

/* ENTRY */
case (16):
	if packed then
	     call invalid_alignment ();
	else bit_length = FOUR_WORD;
	goto end_case;

/* NOTE: this length is correct for structures declared
   without arrays only. (i.e. only scalar elements) */

/* STRUCTURE */
case (17):
	bit_length = ONE_WORD * size;
	goto end_case;

/* AREA */
case (18):
	bit_length = ONE_WORD * size;
	goto end_case;

/* BIT STRING */
case (19):
	bit_length = size;
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* VARYING BIT STRING */
case (20):
	bit_length = size + ONE_WORD;
	if packed then
	     call invalid_alignment ();
	else call pad_to_word_boundary ();
	goto end_case;

/* CHARACTER STRING */
case (21):
	bit_length = ONE_BYTE * size;
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* VARYING CHARACTER STRING */
case (22):
	bit_length = (ONE_BYTE * size) + ONE_WORD;
	if packed then
	     call invalid_alignment ();
	else call pad_to_word_boundary ();
	goto end_case;

/* FILE */
case (23):
	bit_length = FOUR_WORD;
	goto end_case;

/* UNUSED */
case (24):
case (25):
case (26):
case (27):
case (28):
	call unimplemented_data_type ();
	goto end_case;

/* REAL FIXED DECIMAL LEADING OVERPUNCHED SIGN 9-BIT */
case (29):
	bit_length = ONE_BYTE * precision;
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FIXED DECIMAL TRAILING OVERPUNCHED SIGN 9-BIT */
case (30):
	bit_length = ONE_BYTE * precision;
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* UNUSED */
case (31):
case (32):
	call unimplemented_data_type ();
	goto end_case;

/* REAL FIXED BINARY SHORT UNSIGNED */
case (33):
	bit_length = precision;
	if packed then ;
	else do;
		pad_length = ONE_WORD - bit_length;
		bit_length = ONE_WORD;
	     end;
	goto end_case;

/* REAL FIXED BINARY LONG UNSIGNED */
case (34):
	bit_length = precision;
	if packed then ;
	else do;
		pad_length = TWO_WORD - bit_length;
		bit_length = TWO_WORD;
	     end;
	goto end_case;

/* REAL FIXED DECIMAL UNSIGNED 9-BIT */
case (35):
	bit_length = ONE_BYTE * precision;
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FIXED DECIMAL TRAILING SIGN 9-BIT */
case (36):
	bit_length = ONE_BYTE * (precision + SIGN);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* UNUSED */
case (37):
	call unimplemented_data_type ();
	goto end_case;

/* NOTE: non-byte-aligned decimal 4-bit requires knowledge of
   physical 1/2 byte alignment to determine actual bit length,
   thus it is unsupported by pl1, and MRDS, and the returned
   bit length will be the same as if it were the corresponding
   byte aligned decimal 4-bit data type. */

/* REAL FIXED DECIMAL UNSIGNED 4-BIT */
case (38):
	bit_length = ONE_BYTE * floor ((precision + PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FIXED DECIMAL TRAILING SIGN 4-BIT */
case (39):
	bit_length = ONE_BYTE * floor ((precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* UNUSED */
case (40):
	call unimplemented_data_type ();
	goto end_case;

/* REAL FIXED DECIMAL LEADING SIGN 4-BIT */
case (41):
	bit_length = ONE_BYTE * floor ((precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FLOATING DECIMAL 4-BIT */
case (42):
	bit_length = ONE_BYTE * floor ((precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */
case (43):
	bit_length = ONE_BYTE * floor ((precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* REAL FLOATING DECIMAL 4-BIT BYTE-ALIGNED */
case (44):
	bit_length = ONE_BYTE * floor ((precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* COMPLEX FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */
case (45):
	bit_length = DOUBLE * ONE_BYTE * floor ((precision + SIGN_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* COMPLEX FLOATING DECIMAL 4-BIT BYTE-ALIGNED */
case (46):
	bit_length = DOUBLE * ONE_BYTE * floor ((precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR);
	if packed then ;
	else call pad_to_word_boundary ();
	goto end_case;

/* UNUSED */
case (47):
case (48):
case (49):
case (50):
case (51):
case (52):
case (53):
case (54):
case (55):
case (56):
case (57):
case (58):
case (59):
case (60):
case (61):
case (62):
case (63):
	call unimplemented_data_type ();
	goto end_case;

/* END OF DESCRIPTOR TYPE CASE STATEMENT */
end_case:

     end;

pad_to_word_boundary: procedure ();

/* fill out the bit length to reflect a word boundary aligned,
   integral number of words storage space */

	if mod (bit_length, ONE_WORD) = 0 then ;
	else do;
		pad_length = (ONE_WORD - mod (bit_length, ONE_WORD));
		bit_length = bit_length + pad_length;
	     end;

     end;

unimplemented_data_type: procedure ();

/* report that an unused data type was given in the descriptor */

	code = mrds_error_$invalid_dm_descriptor;

	call sub_err_ (code, caller_name, continue, info_ptr, return_value,
	     "^/An invalid data type = ^d, ""^a"", was given in the descriptor.",
	     type, mu_display_descriptor (addr (descriptor)));

	bit_length, pad_length = 0;

     end;

invalid_alignment: procedure ();

/* report incorrect use of the packed feature */

	code = mrds_error_$invalid_dm_descriptor;

	call sub_err_ (code, caller_name, continue, info_ptr, return_value,
	     "^/The unaligned (packed) attribute can not be used with the data type = ""^a"".",
	     mu_display_descriptor (addr (descriptor)));

	bit_length, pad_length = 0;

     end;

	declare SIGN_AND_PAD	 fixed bin init (2) int static options (constant); /* sign digit + 1/2 byte padding */
	declare SIGN_EXPONENT_AND_PAD	 fixed bin init (4) int static options (constant); /* sign digit, exp byte, + 1/2 byte pad */
	declare PAD		 fixed bin init (1) int static options (constant); /* 1/2 byte padding */
	declare PER_BYTE_FACTOR	 fixed bin init (2) int static options (constant); /* number of digits per byte */
	declare SIGN_AND_EXPONENT	 fixed bin init (2) int static options (constant); /* float decimal exp and sign char space */
	declare DOUBLE		 fixed bin init (2) int static options (constant); /* multiplier for complex numbers */
	declare SIGN		 fixed bin init (1) int static options (constant); /* space for sign */
	declare input_descriptor	 bit (36);	/* users descriptor parameter */
	declare code		 fixed bin (35) init (0); /* error encoding */
	declare caller_name		 char (14) init ("mu_data_length") int static options (constant); /* name of calling routine */
	declare continue		 char (1) init ("c") int static options (constant); /* after printing, keep going */
	declare info_ptr		 ptr init (null ()) int static options (constant); /* unused */
	declare return_value	 fixed bin (35) init (0);
	declare bit_length		 fixed bin (35);	/* returned storage length */
	declare sub_err_		 entry options (variable); /* error reporting routine */
	declare (mod, addr, floor)	 builtin;
	declare descriptor		 bit (36);	/* basic multics pl1 descriptor */
	declare ONE_WORD		 fixed bin init (36) int static options (constant); /* bit length of a word */
	declare TWO_WORD		 fixed bin init (72) int static options (constant); /* bit length of two words */
	declare FOUR_WORD		 fixed bin init (144) int static options (constant); /* bit length of four words */
	declare ONE_BYTE		 fixed bin init (9) int static options (constant); /* bit length of a byte (character) */
	declare 1 descriptor_precision unal based (addr (descriptor)), /* overlay for arith precision */
		2 unused		 bit (24) unal,	/* skip over first part */
		2 precision	 unsigned fixed bin (12) unal; /* arith precision */
	declare 1 descriptor_packed_flag unal based (addr (descriptor)), /* overlay for packed */
		2 unused_1	 bit (7) unal,
		2 packed		 bit (1) unal,	/* ON => unaligned */
		2 unused_2	 bit (28) unal;
	declare 1 descriptor_type	 unal based (addr (descriptor)), /* overlay for descriptor type */
		2 unused_1	 bit (1) unal,
		2 type		 unsigned fixed bin (6) unal, /* descriptor type code */
		2 unused_2	 bit (29) unal;
	declare mrds_error_$invalid_dm_descriptor fixed bin (35) ext; /* bad data type */
	declare mu_display_descriptor	 entry (ptr) returns (char (120) varying); /* for trouble reporting */
	declare 1 descriptor_size	 unal based (addr (descriptor)), /* string/area/structure size overlay */
		2 unused		 bit (12) unal,
		2 size		 unsigned fixed bin (24) unal; /* size field */
	declare pad_length		 fixed bin (35);	/* length to pad aligned data types */
	declare entry_descriptor	 bit (36);	/* descriptor paramter for pad length entry */
     end;




		    mu_database_index.pl1           08/01/88  1347.6r w 08/01/88  1314.3       86895



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

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

mu_database_index: procedure (index, dbcb_ptr); index = 0; dbcb_ptr = null (); return; /* invalid entry */

/* DESCRIPTION:

   this routine manages the  database  opening  index  table,  which
   contains  pointers  to the resultant models created at open time.
   the database index is the  array  address  of  the  corresponding
   dbcb_ptr(database  control block pointer in the resultant model).
   their are six entries, set_dbcb_ptr to enter a dbcb_ptr into  the
   table  and  get  a  new opening index. clear_dbcb_ptr to remove a
   dbcb_ptr from the table and make it's index reusable get_dbcb_ptr
   to  get  the resultant model dbcb pointer given an opening index.
   num_db_open to return the number of databases open by the calling
   process.  any_new_open to return true if any new version database
   is open. set_dbcb_flag to set a flag in  the  table  and  reserve
   that  slot  from  use  by a new version database, once a database
   index for an old version has been obtained.  NOTE:  this  routine
   needs  to  be  rewritten  to  avoid  the  critical  region due to
   recursion via a quit/re-invoke

*/

/* PARAMETERS:

   index - - (input for clear, get, set_flag and output for set_ptr)
   fixed bin(35) database opening index.

   dbcb_ptr - - (output for clear and get/ input for set) pointer to
   the  resultant  model  non_secure  segment known as dbcb(database
   control block).

   num_dbcb - - (output  for  num_db_open)  the  current  number  of
   databases open for this process, declared fixed bin(17).

   new_db_open - - (output) bit(1) aligned, output from any_new_open
   entry, on if any new version database is open.

*/

/* HISTORY:

   rewritten by Jim Gray - - August 1979 to 1) document module logic
   2)  correct  num_db_open entry to reflect current table status 3)
   correct logic of set_dbcb_ptr 4) make name change so calls are of
   form db_index$set, db_index$get, etc.

   Modified by  Jim  Gray  -  -  March  1980,  to  add  the  entries
   any_new_open,  set_dbcb_flag,  to build the logic for determining
   old/new version databases from their database index.

   Modified by Jim Gray - - June 1980, to pass  back  paths  of  old
   version   databases   in  phony  version  of  resultant  used  by
   dsl_$list_dbs.

   81-1-9 Jim Gray : changed to use actual include files for old and
   new  resultant  structures, also added more info to phony version
   of new version resultant, that  is  taken  from  an  old  version
   resultant  for  old  version  databases. This included open_mode,
   dbc_ptr,  db_version.  Thus  the  legimate  values  that  can  be
   obtained  from  the  phony  resultant,  for  old version database
   openings are: in the dbcb open_mode - dbc_ptr - rdbi_ptr  in  the
   rm_db_info  db_path - sm_path(always = db_path) - db_version This
   solves the problem with  DMOD  not  being  able  to  display  old
   version   databases   open   modes,  and  provides  for  the  new
   display_mrds_scope_settings  to  be  able  to  display  the   dbc
   structure version (as concurrency control version)

   81-04-24 Jim Gray :  changed  internal  static  tables  to  based
   arrays  in  a  temp  segment,  so  that  mrds_data_$max_dbs could
   automatically change the maximum number of openings allowed.

   81-04-27 Jim Gray :  extended  old  resultant  to  hold  submodel
   opening  information,  thus the phony resultant now has good info
   for dbcb.dsm_sw, rm_db_info.sm_ath & sm_version

   83-06-21 Davids: Eliminated the dbcb_flag_table which kept track of
   old/new version database openings (old version databases can no longer
   be opened). This eliminated a lot of overhead two entries were also
   deleted - set_dbcb_flag and any_new_open. 
*/

set_dbcb_ptr: get_database_index: entry (index, dbcb_ptr);

	if ^index_table_ready then
	     call init_index_table ();

/* given a dbcb pointer(resultant model control block segment pointer),
   find an empty space in the database index table, put the pointer
   their, and return the index value as the database index for this opening.
   0 is returned as an index, if the table is full. */

	index = 0;
	found = OFF;
	i = 1;

	do while (^found);

/* note: the flag table says whether an old version db_index is using the slot */

	     if dbcb_ptr_table (i) = null () then do;
		     found = ON;
		     dbcb_ptr_table (i) = dbcb_ptr;
		     index = i;
		end;

	     else if i < mrds_data_$max_dbs then /* not an empty slot */
		i = i + 1;			/* go to next slot */
	     else found = ON;			/* end of table reached, => table full */

	end;

	return;

clear_dbcb_ptr: reset_resultant_model_pointer: entry (index, dbcb_ptr);

	if ^index_table_ready then
	     call init_index_table ();

/* given a database index, find the corresponding resultant
   model control block segment pointer in the table, and
   set the dbcb_ptr to the value found their, at the same
   time setting that table entry to null, thus deleting
   that database index as a valid entry.
   an index outside the table limits returns a null pointer. */


	if index < 1 | index > mrds_data_$max_dbs then
	     dbcb_ptr = null ();
	else do;
		dbcb_ptr = dbcb_ptr_table (index);
		dbcb_ptr_table (index) = null ();
	     end;

	return;

get_dbcb_ptr: get_resultant_model_pointer: entry (index, dbcb_ptr);

	if ^index_table_ready then
	     call init_index_table ();

/* given a database index, look
   in the dbcb pointer table for the
   resultant model control block segment
   pointer corresponding to that index.
   a index beyond table limits results
   in a null pointer being returned. */


	if index < 1 | index > mrds_data_$max_dbs
	then dbcb_ptr = null ();			/* not valid index */
	else dbcb_ptr = dbcb_ptr_table (index);		/* new version */

	return;

num_db_open: get_number_open_dbs: entry returns (fixed bin);

	if ^index_table_ready then
	     call init_index_table ();

/* count the number of "good" database indexes already used in the
   dbcb pointer table, and return this as number of
   databases open by the caller process */


	num_dbcb = 0;
	do i = 1 by 1 to mrds_data_$max_dbs;
	     if dbcb_ptr_table (i) ^= null ()
	     then num_dbcb = num_dbcb + 1;
	end;

	return (num_dbcb);

init_index_table: procedure ();

/* this routine gets temp space for the db_index arrays,
   and initializes the two arrays involved.
   The arrays are made based, rather than internal static,
   so that the mrds_data_$max_dbs can be changed to automatically
   change the limit on the number of permissible openings.
   This temp space will remain around for the life of the process. */

	call get_temp_segment_ (caller_name, temp_seg_ptr, code);
	if code ^= 0 then
	     call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a",
		"Unable to get a temp segment for managing the database opening indexes.");
	else do;

		temp_seg_ptr -> index_area = empty ();

		allocate dbcb_ptr_table set (dbcb_ptr_table_ptr) in (index_area);

		do i = 1 to mrds_data_$max_dbs;

		     dbcb_ptr_table (i) = null ();

		end;

		index_table_ready = ON;

	     end;

     end;

	declare OFF		 bit (1) init ("0"b) int static options (constant); /* false value */
	declare ON		 bit (1) init ("1"b) int static options (constant); /* true value */
	declare caller_name		 char (20) init ("mu_database_index"); /* name of calling routine */
	declare code		 fixed bin (35);	/* for sub_err_ */
	declare continue		 char (1) init ("c") int static options (constant); /* dont stop after printing mesg */
	declare dbcb_ptr_table	 (1:mrds_data_$max_dbs) ptr based (dbcb_ptr_table_ptr); /* table of dbcb ptrs */
	declare dbcb_ptr_table_ptr	 ptr init (null ()) int static; /* points to dbcb_ptr_table */
	declare found		 bit (1);		/* on => can exit search loop */
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets index space */
	declare i			 fixed bin;
	declare index		 fixed bin (35);	/* index into table of dbcb pointers */
	declare index_area		 area (sys_info$max_seg_size) based (temp_seg_ptr); /* space for index tables */
	declare index_table_ready	 bit (1) int static init ("0"b); /* on => index arrays already init */
	declare info_ptr		 ptr init (null ());/* unused */
	declare mrds_data_$max_dbs	 fixed bin ext;	/* max number of openings allowed */
	declare num_dbcb		 fixed bin;	/* num dbcb pointers in table */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare sub_err_		 entry options (variable); /* reports subroutine errors */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	declare temp_seg_ptr	 ptr;		/* points to temp index space */
	declare (empty, null)	 builtin;

%include mrds_dbcb;

%include mdbm_rm_db_info;

     end;




		    mu_db_inconsistent.pl1          10/16/86  1551.4r w 10/16/86  1145.0       44892



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
mu_db_inconsistent: proc (db_model_ptr, name, message, undo_request);

/*
                   BEGIN_DESCRIPTION
   This procedure manipulates the consistancy bit in the  db  model.
   This  bit  is  used  to  indicate  that  the  database  is  in an
   inconsistent state due to  restructuring  operations.  Associated
   with  the  bit is a message structure that contains space for the
   name of the operation that set  the  bit,  text  for  a  more
   detailed explaination and an rmdb request that can be executed to
   undo the operation that set the bit and cause the database to become
   consistent.

   At the moment the message structure is allocated  only  once  for
   the  life  of  the  database. Allocation can not done during data
   base creation since there  are  already  existing  databases  out
   there  without  the  structure.  Allocation takes place the first
   time the message structure is needed, which is when the data base
   is set to inconsistent. Once the structure exists it is reused.

   There are three entry points:
   .	     inconsistent_set
   .	     inconsistent_reset
   .	     inconsistent_get_info


   The set entry point sets the database to inconsistent and  loads
   the message structure, allocating it if need be.
                   END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-04-15 Davids: Written

   82-04-27 Davids: added the undo_request element to the message structure
   and changed the interfaces to accept and return the value for it.

   82-04-30  R. Lackey : added the set entry point

   82-07-01 Roger Lackey : changed entry point names to include inconsistent_
   for binding

   83-02-24 Davids: explicitly declared variables that were declared by
   context or implication. Deleted declarations to variables that were
   never referenced.
*/
%page;
/* PARAMETERS */

	dcl     db_model_ptr	 ptr;		/* (input) points to the data model for the data base */
	dcl     name		 char (*);	/* (input) name of request associated with the message
						   truncated to 32 chars */
	dcl     message		 char (*);	/* (input) explainatory message, truncated to 200 chars */
	dcl     undo_request	 char (*);	/* (input) rmdb request that can be used to undo the request that
						   .       is setting the database inconsistent, executing it
						   .       will cause the database to be consistent again */
	dcl     O_value		 bit (1);		/* (output) true ==> db is inconsistent */
	dcl     O_name		 char (*);	/* (output) same as name */
	dcl     O_message		 char (*);	/* (output) same as message */
	dcl     O_undo_request	 char (*);	/* (output) same as undo_request */

/* CONSTANTS */

	dcl     NULL_OFFSET		 bit (18) unal init ("111111111111111111"b);

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     pointer		 builtin;
	dcl     rel		 builtin;

/* EXTERNAL */

	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

/* INCLUDES */
%page;
%include mdbm_db_model;

inconsistent_set: entry (db_model_ptr, name, message, undo_request);

/* set entry point */

	if db_model_ptr -> db_model.inconsistent_message_offset = NULL_OFFSET
	then do;
		message_str_len = 500;
		allocate message_str set (message_str_ptr) in (db_model_ptr -> db_model.dbm_area);
	     end;
	else message_str_ptr = pointer (db_model_ptr, db_model_ptr -> db_model.inconsistent_message_offset);

	message_str.len = length (message);
	message_str.text = message;
	message_str.name = name;
	message_str.undo_request = undo_request;
	message_str.mbz = "0"b;

	db_model_ptr -> db_model.inconsistent_message_offset = rel (message_str_ptr);
	db_model_ptr -> db_model.consistant = "0"b;

	return;

inconsistent_reset: entry (db_model_ptr);

	if db_model_ptr -> db_model.inconsistent_message_offset ^= NULL_OFFSET
	then do;
		message_str_ptr = pointer (db_model_ptr, db_model_ptr -> db_model.inconsistent_message_offset);
		message_str.len = 0;
		message_str.text = "";
		message_str.name = "";
		message_str.undo_request = "";
	     end;

	db_model_ptr -> db_model.consistant = "1"b;
	return;

inconsistent_get_info: entry (db_model_ptr, O_value, O_name, O_message, O_undo_request);

	O_value = ^db_model_ptr -> db_model.consistant;

	if db_model_ptr -> db_model.inconsistent_message_offset = NULL_OFFSET
	then do;
		O_name = "";
		O_message = "";
		O_undo_request = "";
	     end;
	else do;
		message_str_ptr = pointer (db_model_ptr, db_model_ptr -> db_model.inconsistent_message_offset);
		O_name = message_str.name;
		O_message = message_str.text;
		O_undo_request = message_str.undo_request;
	     end;

	return;

     end mu_db_inconsistent;




		    mu_db_xref.pl1                  10/16/86  1527.1rew 10/16/86  1525.9      253008



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

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

/*DESCRIPTION
  This set of routines manages a temporary keyed vfile. This file contains the
  database crossreference (ie., which domains are used by which attributes or
  which attributes are used by which relations). The $build entry point is used
  to create and initialize the file, the $reference, $dereference and $delete
  are used to modify it, and the $find is used to query it.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

mu_db_xref:
     proc;

	return;

/************************* EP build *************************/

/*DESCRIPTION
  This procedure creates a keyed_sequential vfile_ and goes through
  each relation in the db_model adding the attribute and domain names to the
  vfile as keys and a crossreference as the record data.  No duplicate
  attributes or domains are stored so when complete it contains a list of all
  the unique objects in the database.
*/

mu_db_xref$xref_build:
     entry (Itemp_dir_path, Idb_path, Idbm_ptr, Ofile_name, Oiocb_ptr, Oerror_message, Ocode);

/* Initialization */

	temp_dir_path = Itemp_dir_path;
	db_path = Idb_path;
	dbm_ptr = Idbm_ptr;

/* Create the attach description, attach and open the file */

	temp_file_attach_name = unique_chars_ ("0"b) || ".rmdb.xref";
	temp_file_attach_desc = "vfile_  " || rtrim (temp_dir_path) || ">" || temp_file_attach_name || " -share";

	temp_file_iocb_ptr, temp_seg_ptr, fm_ptr = null;
	close_temp_file = TRUE;
	on cleanup
	     begin;
		if fm_ptr ^= null
		then call terminate_file_ (fm_ptr, (0), TERM_FILE_TERM, (0));
		call cleaner;
	     end;

	call iox_$attach_name (temp_file_attach_name, temp_file_iocb_ptr, temp_file_attach_desc, null, code);
	if code = 0
	then call iox_$open (temp_file_iocb_ptr, Keyed_sequential_update, "0"b, code);
	if code ^= 0
	then call error (code, temp_file_attach_desc);

	call mu_temp_segments$get_temp_segment_path (temp_dir_path, myname, temp_seg_ptr, code);
	if code ^= 0
	then call error (code, "Unable to get a temporary segment.");
	crossref_info_record_ptr = temp_seg_ptr;

	max_seg_size = sys_info$max_seg_size * 4;

/* Look at all the relations */

	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) 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);

/* Add this relation to the xref. */
	     call find_record (RELATION_KEY_HEAD, (file_info.file_name), crossref_info_record_ptr, max_seg_size);
	     if code = 0
	     then call error (code, (file_info.file_name));
	     else if code ^= error_table_$no_record
		then call error (code, error_message);

	     call add_name ("", rel (fi_ptr), "0"b);

/* Get a pointer to the relation_info structure in the file_model. */
	     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);	/* Relation info ptr */

/* Loop through all attributes */

	     do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread)
		while (rel (ai_ptr) ^= NULL_OFFSET);

		call find_record (ATTRIBUTE_KEY_HEAD, (attr_info.name), crossref_info_record_ptr, max_seg_size);
		if code = 0
		then do;				/* it is there, so update the reference count */
		     call add_name ((file_info.file_name), "0"b, "1"b);
		     if code ^= 0
		     then call error (code, "Rewriting list record: " || key);
		     end;
		else if code = error_table_$no_record
		     then do;			/*  attribute name is not in list so add it */
			call add_name ((file_info.file_name), attr_info.domain_ptr, "0"b);
			if code ^= 0
			then call error (code, "Storing list record: " || key);
			end;
		     else call error (code, "Seek key: " || key);

/* Now update the domain crossreference record for this attribute */

		di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
		call find_record (DOMAIN_KEY_HEAD, (domain_info.name), crossref_info_record_ptr, max_seg_size);
		if code = 0
		then do;				/* key is already there */
		     call add_name ((attr_info.name), "0"b, "1"b);
		     if code ^= 0
		     then call error (code, "Storing list record: " || key);
		     end;
		else if code = error_table_$no_record
		     then do;			/* key is not there, so add it */
			call add_name ((domain_info.name), attr_info.domain_ptr, "0"b); 
			                              /* entry for generated attr */
			if code ^= 0
			then call error (code, "Storing list record: " || key);
			call add_name ((attr_info.name), "0"b, "1"b);
			if code ^= 0
			then call error (code, "Storing list record: " || key);
			end;
		     else call error (code, "Seeking list record: " || key);

		end;				/* END of all attributes */

/* Done with this file_model segment */
	     call terminate_file_ (fm_ptr, (0), TERM_FILE_TERM, code);
	     if code ^= 0
	     then call error (code, "Terminating " || file_model_name);

	     end;					/* END of all files (relations) */

/* Now go thru the list of domains adding the domain name as an attribute name
   to take care of the case where a domain might not have an attribute defined
   for it */

	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
	     while (rel (di_ptr) ^= NULL_OFFSET);

	     call find_record (ATTRIBUTE_KEY_HEAD, (domain_info.name), crossref_info_record_ptr, max_seg_size);
	     if code = error_table_$no_record
	     then do;				/*  Attr name is not in list so add it */
		call add_name ("", rel (di_ptr), "0"b);
		if code ^= 0
		then call error (code, "Storing list record: " || key);
		end;
	     else if code ^= 0
		then call error (code, "Seeking list record: " || key);

/* Add in the unreferenced domains */
	     call find_record (DOMAIN_KEY_HEAD, (domain_info.name), crossref_info_record_ptr, max_seg_size);
	     if code = error_table_$no_record
	     then do;
		call add_name ((domain_info.name), rel (di_ptr), "0"b);
		if code ^= 0
		then call error (code, "Storing list record: " || key);
		end;
	     else if code ^= 0
		then call error (code, "Seeking list record: " || key);

	     end;					/* END loop thru all domains */

/* Finally, do all the unreferenced attributes. The unreferenced domains were
   caught in the previous loop, when all the defined domains were added. */

	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);

	     call find_record (ATTRIBUTE_KEY_HEAD, (unreferenced_attribute.name), crossref_info_record_ptr,
		max_seg_size);
	     if code = 0
	     then call error (mrds_error_$internal_error, "Encountered a seek key for unreferenced attribute: " || key);
	     else if code = error_table_$no_record
		then do;
		     call add_name ("", unreferenced_attribute.domain_ptr, "0"b);
		     if code ^= 0
		     then call error (code, "Storing list record: " || key);
		     end;
		else call error (code, "Seeking key: " || key);

/* Now update the domain crossreference record for this attribute */
	     di_ptr = ptr (dbm_ptr, unreferenced_attribute.domain_ptr);
	     call find_record (DOMAIN_KEY_HEAD, (domain_info.name), crossref_info_record_ptr, max_seg_size);
	     if code = 0
	     then do;				/* key is already there */
		call add_name ((unreferenced_attribute.name), "0"b, "1"b);
		if code ^= 0
		then call error (code, "Storing list record: " || key);
		end;
	     else if code = error_table_$no_record
		then call error (mrds_error_$internal_error,
			"Did not encounter a seek domain key for an unreferenced attribute: " || key);
		else call error (code, "Seeking list record: " || key);

	     end;					/* do ai_ptr */

/* vfile_ now contains all unique attribute names as keys with domain offset and reference count as data.  */

	Ofile_name = temp_file_attach_name;
	Oiocb_ptr = temp_file_iocb_ptr;
	close_temp_file = FALSE;

	call error (0, "");
%page;
/************************* EP destroy ***************************/

/*DESCRIPTION
  This entry point deletes the crossreference file.
*/

mu_db_xref$xref_destroy:
     entry (IOfile_iocb_ptr, Itemp_dir_path, IOfile_name, Oerror_message, Ocode);

	temp_file_iocb_ptr = IOfile_iocb_ptr;
	temp_dir_path = Itemp_dir_path;
	temp_file_attach_name = IOfile_name;

	temp_seg_ptr = null;
	if temp_file_iocb_ptr ^= null
	then close_temp_file = TRUE;			/* so cleaner proc will delete it */

	IOfile_iocb_ptr = null;
	IOfile_name = "";
	call error (0, "");
%page;
/************************* EP reference *************************/

/*DESCRIPTION
  This entry point adds a given attribute or domain to the specified type of
  record. An error is returned if the record doesn't already exist.
*/

mu_db_xref$xref_reference:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Iobject_name, Irecord_ptr, Irecord_length, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	temp_seg_ptr = null;
	close_temp_file = FALSE;
	call get_temp_dir_path;

	on cleanup call cleaner;
	call mu_temp_segments$get_temp_segment_path (temp_dir_path, myname, temp_seg_ptr, code);
	if code ^= 0
	then call error (code, "Cannot get temp segment.");

	crossref_info_record_ptr = temp_seg_ptr;
	max_seg_size = sys_info$max_seg_size * 4;
	call find_record (Ikey_head, Irecord_name, crossref_info_record_ptr, max_seg_size);
	if code ^= 0
	then call error (code, "Seeking list record: " || key);

	call add_name (Iobject_name, "0"b, "1"b);
	if code = 0
	then do;
	     if Irecord_ptr ^= null
	     then do;				/* give the caller something for his trouble */
		max_seg_size = min (currentsize (crossref_info_record) * 4, Irecord_length);
		call mlr_ (crossref_info_record_ptr, max_seg_size, Irecord_ptr, max_seg_size);
		end;
	     call error (0, "");
	     end;
	else call error (code, "Rewriting list record: " || key);
%page;
/************************* INTERNAL add_name *************************/

/* This internal subroutine adds a single name to a crossref record and writes
   it back out to the temp file. It maintains the list of unique names in
   sorted ascending order. */

add_name:
     proc (name, offset, record_exists);

dcl  idx fixed bin;
dcl  name char (*) parameter;
dcl  offset bit (18) unaligned parameter;
dcl  position fixed bin;
dcl  record_exists bit (1) aligned parameter;

	if record_exists
	then do;
	     if ^search (name, idx)
	     then do;
		position, crossref_info_record.count = crossref_info_record.count + 1;
		crossref_info_record.object_head (position) = OBJECT_HEAD;
		crossref_info_record.object (position) = name;
		end;				/* end insert somewhere */
	     call iox_$rewrite_record (temp_file_iocb_ptr, crossref_info_record_ptr,
		currentsize (crossref_info_record) * 4, code);
	     end;					/* end record exists */
	else do;					/* build a new record */
	     crossref_info_record.offset = offset;
	     if name ^= ""
	     then do;
		crossref_info_record.count = 1;
		crossref_info_record.object_head = OBJECT_HEAD;
		crossref_info_record.object (1) = name;
		end;
	     else crossref_info_record.count = 0;

	     call iox_$write_record (temp_file_iocb_ptr, crossref_info_record_ptr,
		currentsize (crossref_info_record) * 4, code);
	     end;					/* end build a new record */

	return;
     end add_name;
%page;
/************************* EP create *************************/

/*DESCRIPTION
  This entry point creates a new crossreference record of the type specified.
*/
mu_db_xref$xref_create_record:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Ioffset, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	crossref_info_record_ptr = addr (local_buffer);
	temp_seg_ptr = null;
	close_temp_file = FALSE;

/* Look for the record, it had better not be there or we can't create it */
	call find_record (Ikey_head, Irecord_name, null, 0);
	if code = 0
	then if Ikey_head = DOMAIN_KEY_HEAD		/* it was there */
	     then call error (mrds_error_$domain_already_defined, Irecord_name);
	     else call error (mrds_error_$attr_already_exists, Irecord_name);
	else if code ^= error_table_$no_record
	     then call error (code, error_message);

/* It wasn't there, go ahead, create it and write it out to the file */
	call add_name ("", Ioffset, "0"b);
	call error (code, error_message);
%page;
/************************* EP delete *************************/

/*DESCRIPTION
  This entry deletes a single record from the crossreference file. Note that
  if other records reference this one, they are not modified. The caller should
  call $dereference on all other referenced records before using $delete.
*/

mu_db_xref$xref_delete_record:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	temp_seg_ptr = null;
	close_temp_file = FALSE;

	call find_record (Ikey_head, Irecord_name, null, 0);
	if code ^= 0
	then if code = error_table_$no_record
	     then call error (0, "");
	     else call error (code, error_message);

	call iox_$delete_record (temp_file_iocb_ptr, code);
	call error (code, "Unable to delete record for key list: " || key);
%page;
/************************* EP dereference *************************/

/*DESCRIPTION
  This entry point deletes a specific name from a specified crossreference
  record.
*/

mu_db_xref$xref_dereference:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Iobject_name, Oreference_count, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	temp_seg_ptr = null;
	close_temp_file = FALSE;
	call get_temp_dir_path;

	on cleanup call cleaner;
	call mu_temp_segments$get_temp_segment_path (temp_dir_path, myname, temp_seg_ptr, code);
	if code ^= 0
	then call error (code, "Cannot get temp segment.");

	crossref_info_record_ptr = temp_seg_ptr;
	max_seg_size = sys_info$max_seg_size * 4;
	call find_record (Ikey_head, Irecord_name, crossref_info_record_ptr, max_seg_size);
	if code ^= 0
	then call error (code, "Seeking list record: " || key);

	if ^search (Iobject_name, place)
	then call error (mrds_error_$internal_error,
		"Unable to find name " || rtrim (Iobject_name) || " in list record: " || key);

	call delete (place);

	call iox_$rewrite_record (temp_file_iocb_ptr, crossref_info_record_ptr, currentsize (crossref_info_record) * 4,
	     code);
	if code ^= 0
	then call error (code, "Rewriting list record: " || key);

	Oreference_count = crossref_info_record.count;

	call error (0, "");
%page;
/************************* EP modify_record_name *************************/

/*DESCRIPTION
  This entry point changes the key for a specified crossreference record.
  This must be done be deleting the old record (with it's key), and re-entering
  it. The contents of the record may or may not be specified. If not, the record
  is read first. The current record is then deleted, and the same record is
  then stored.
*/

mu_db_xref$xref_modify_record_name:
     entry (Ifile_iocb_ptr, Ikey_head, Ifrom_name, Ito_name, Irecord_ptr, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	temp_seg_ptr = null;
	close_temp_file = FALSE;

	if Irecord_ptr = null
	then do;
	     call get_temp_dir_path;
	     on cleanup call cleaner;

	     call mu_temp_segments$get_temp_segment_path (temp_dir_path, myname, temp_seg_ptr, code);
	     if code ^= 0
	     then call error (code, "Cannot get a temp segment.");

	     max_seg_size = sys_info$max_seg_size * 4;
	     crossref_info_record_ptr = temp_seg_ptr;

	     call find_record (Ikey_head, Ifrom_name, crossref_info_record_ptr, max_seg_size);
	     if code ^= 0
	     then call error (code, error_message);
	     end;
	else do;
	     crossref_info_record_ptr = Irecord_ptr;
	     temp_seg_ptr = null;

	     call find_record (Ikey_head, Ifrom_name, null, (0));
	     if code ^= 0
	     then call error (code, error_message);
	     end;

	call iox_$delete_record (temp_file_iocb_ptr, code);
	if code ^= 0
	then call error (code, "Deleting list record: " || key);

	call find_record (Ikey_head, Ito_name, null, (0));
	if code ^= error_table_$no_record
	then call error (mrds_error_$internal_error, "Found list record but shouldn't have:" || key);

	call iox_$write_record (temp_file_iocb_ptr, crossref_info_record_ptr, currentsize (crossref_info_record) * 4,
	     code);
	if code ^= 0
	then call error (code, "Writing list record: " || key);

	call error (0, "");
%page;
/************************* EP modify_reference_name *************************/

/*DESCRIPTION
  This entry point reads the specified record from the crossreference file,
  searches for the specified name. It should be there. It then deletes the
  old name, and adds the new name. This effectively does a rename operation.
  Note that in the initial implementation it moves all the names twice in the
  worst case. It should be modified to check whether the insertion point is also
  the deletion point.
*/

mu_db_xref$xref_modify_reference_name:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Ifrom_name, Ito_name, Oerror_message, Ocode);

	temp_seg_ptr = null;
	close_temp_file = FALSE;
	temp_file_iocb_ptr = Ifile_iocb_ptr;
	call get_temp_dir_path;

	on cleanup call cleaner;

	call mu_temp_segments$get_temp_segment_path (temp_dir_path, myname, temp_seg_ptr, code);
	if code ^= 0
	then call error (code, "Unable to get a temp segment.");

	crossref_info_record_ptr = temp_seg_ptr;
	max_seg_size = sys_info$max_seg_size * 4;

/* Retrieve the specified record */
	call find_record (Ikey_head, Irecord_name, crossref_info_record_ptr, max_seg_size);
	if code ^= 0
	then call error (code, error_message);

/* Find the specified from name */
	if ^search (Ifrom_name, place)
	then call error (mrds_error_$internal_error,
		"Unable to find name " || rtrim (Ifrom_name) || " in list record: " || key);

	call delete (place);
	call add_name (Ito_name, "0"b, "1"b);

	call error (0, "");
%page;
/************************* INTERNAL delete *************************/

/*DESCRIPTION
  This internal subroutine deletes a single name from the current
  crossref_info_record. */

delete:
     proc (idx);

dcl  from_ptr ptr;
dcl  idx fixed bin parameter;
dcl  move_length fixed bin (21);
dcl  to_ptr ptr;

	if idx ^= crossref_info_record.count
	then do;					/* if not last entry, must move data */
	     from_ptr = addr (crossref_info_record.entry (idx + 1));
	     to_ptr = addr (crossref_info_record.entry (idx));
	     move_length = (crossref_info_record.count - idx) * 33;

	     call mlr_ (from_ptr, move_length, to_ptr, move_length);
	     end;

	crossref_info_record.count = crossref_info_record.count - 1;
	return;
     end delete;
%page;
/************************* INTERNAL search *************************/

/*DESCRIPTION
  This internal subroutine looks for the specified name inthe current
  crossreference_info_record. If found, it returns the position. If not found,
  0 is returned; as the point for new entries is always at the end of the
  list. */

search:
     proc (name, idx) returns (bit (1) aligned);

dcl  idx fixed bin parameter;
dcl  name char (*) parameter;
dcl  position fixed bin (21);
dcl  search_name char (33);

	search_name = OBJECT_HEAD || name;
	position = index (crossref_info_record_objects, search_name);
	if position = 0
	then idx = 0;
	else idx = divide (position, 33, 17, 0) + 1;
	return (idx > 0);

     end search;
%page;
/************************* EP find *************************/

/*DESCRIPTION
  This routine searches the temp file for the specified record, returning as
  much of the record as was requested.
*/

mu_db_xref$xref_find_record:
     entry (Ifile_iocb_ptr, Ikey_head, Irecord_name, Irecord_ptr, Irecord_length, Oerror_message, Ocode);

	temp_file_iocb_ptr = Ifile_iocb_ptr;
	temp_seg_ptr = null;
	close_temp_file = FALSE;

	call find_record (Ikey_head, Irecord_name, Irecord_ptr, Irecord_length);
	call error (code, error_message);

/************************* INTERNAL find_record *************************/

find_record:
     proc (key_head, record_name, record_ptr, record_length);

dcl  chars_read fixed bin (21);
dcl  key_head char (*) parameter;
dcl  record_length fixed bin (21) parameter;
dcl  record_name char (*) parameter;
dcl  record_ptr ptr parameter;

	key = key_head || rtrim (record_name);
	call iox_$seek_key (temp_file_iocb_ptr, key, (0), code);
	if code ^= 0
	then do;
	     error_message = "Seeking record key: " || key;
	     return;
	     end;

	if record_ptr ^= null
	then do;
	     call iox_$read_record (temp_file_iocb_ptr, record_ptr, record_length, chars_read, code);
	     if code ^= error_table_$long_record
	     then error_message = "Reading list record: " || key;
	     else do;
		code = 0;
		error_message = "";
		end;
	     end;
	return;
     end find_record;
%page;
/************************* EP statistics *************************/

/*DESCRIPTION
  This entry point returns the number of records of each type that exist in
  the database crossreference file.
*/

mu_db_xref$xref_statistics:
     entry (Ifile_iocb_ptr, Odomain_count, Oattribute_count, Orelation_count, Oerror_message, Ocode);

/* Initialize */
	temp_file_iocb_ptr = Ifile_iocb_ptr;
	Odomain_count, Oattribute_count, Orelation_count = 0;
	close_temp_file = FALSE;
	
/* Position to beginning of file */
	call iox_$position (temp_file_iocb_ptr, -1, 0, code);
	if code ^= 0
	then call error (code, "Positioning to beginning of crossreference file.");

/* Loop through all the records in the file */
	call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
	do while (code = 0);
	     if /* case */ substr (key, 1, min (length (key), length (ATTRIBUTE_KEY_HEAD))) = ATTRIBUTE_KEY_HEAD
	     then Oattribute_count = Oattribute_count + 1;
	     else if substr (key, 1, length (DOMAIN_KEY_HEAD)) = DOMAIN_KEY_HEAD
	     then Odomain_count = Odomain_count + 1;
	     else Orelation_count = Orelation_count + 1;
	     call iox_$position (temp_file_iocb_ptr, 0, 1, code);
						/* goto next record */
	     if code = 0
	     then call iox_$read_key (temp_file_iocb_ptr, key, (0), code);
	     end;					/* do while */

	if code = error_table_$end_of_info
	then call error (0, "");
	else call error (code, "Reading crossreference file.");
%page;
RETURN_TO_CALLER:
	return;

/************************* INTERNAL error *************************/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	if code = 0
	then Oerror_message = "";
	else Oerror_message = msg;
	call cleaner;

	goto RETURN_TO_CALLER;
     end error;

/************************* INTERNAL cleaner *************************/

cleaner:
     proc;

	if temp_seg_ptr ^= null
	then call mu_temp_segments$free_temp_segment (myname, temp_seg_ptr, (0));
	if (temp_file_iocb_ptr ^= null & close_temp_file)
	then call close_and_delete_temp_file;

	return;
     end cleaner;

/************** INTERNAL close_and_delete_file ***********************/

close_and_delete_temp_file:
     proc;

	call iox_$close (temp_file_iocb_ptr, (0));
	call iox_$detach_iocb (temp_file_iocb_ptr, (0));
	call iox_$destroy_iocb (temp_file_iocb_ptr, (0));
	temp_file_iocb_ptr = null;

	call delete_$path (temp_dir_path, temp_file_attach_name, "101111"b, myname, (0));

	return;
     end close_and_delete_temp_file;
%page;
/************************* INTERNAL get_temp_dir_path *************************/

/*DESCRIPTION
  Find the directory the crossreference file is created in. This is the temp
  directory specified for this rmdb invocation. */

get_temp_dir_path:
     proc;

	attach_block_ptr = temp_file_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	temp_dir_path = substr (attach_block.attach_descrip_string, 8, attach_block.dname_len);

	return;
     end get_temp_dir_path;
%include access_mode_values;
%include iocb;
%include iox_modes;
%include mdbm_db_model;
%include mdbm_file_model;
%include rmdb_crossref_info;
%include terminate_file;
%include vfile_attach_block;
%page;
dcl  addr builtin;
dcl  cleanup condition;
dcl  close_temp_file bit (1) aligned;
dcl  code fixed bin (35);
dcl  currentsize builtin;
dcl  db_path char (168);
dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  divide builtin;
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  FALSE bit (1) aligned int static options (constant) init ("0"b);
dcl  file_model_name char (32);
dcl  fixed builtin;
dcl  Idb_path char (*) parameter;
dcl  Idbm_ptr ptr parameter;
dcl  Ifile_iocb_ptr ptr parameter;
dcl  Ifrom_name char (*) parameter;
dcl  Ikey_head char (*) parameter;
dcl  index builtin;
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  Iobject_name char (*) parameter;
dcl  Ioffset bit (18) unaligned parameter;
dcl  IOfile_iocb_ptr ptr parameter;
dcl  IOfile_name char (*) parameter;
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$delete_record 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  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  iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  Irecord_length fixed bin (21) parameter;
dcl  Irecord_name char (*) parameter;
dcl  Irecord_ptr ptr parameter;
dcl  Itemp_dir_path char (*) parameter;
dcl  Ito_name char (*) parameter;
dcl  key char (256) varying;
dcl  length builtin;
dcl  local_buffer (10) fixed bin (35);
dcl  max_seg_size fixed bin (21);
dcl  mu_temp_segments$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mu_temp_segments$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  min builtin;
dcl  mlr_ entry (ptr, fixed bin (21), ptr, fixed bin (21));
dcl  mrds_error_$attr_already_exists fixed bin (35) ext static;
dcl  mrds_error_$domain_already_defined fixed bin (35) ext static;
dcl  mrds_error_$internal_error fixed bin (35) ext static;
dcl  myname char (32) int static options (constant) init ("mu_db_xref");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unal int static options (constant) init ((18)"1"b);
dcl  Oattribute_count fixed bin parameter;
dcl  Ocode fixed bin (35) parameter;
dcl  Odomain_count fixed bin parameter;
dcl  Oerror_message char (*) parameter;
dcl  Ofile_name char (*) parameter;
dcl  Oiocb_ptr ptr parameter;
dcl  Oreference_count fixed bin (21) parameter;
dcl  Orelation_count fixed bin parameter;
dcl  place fixed bin;
dcl  ptr builtin;
dcl  rel builtin;
dcl  rtrim builtin;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  temp_dir_path char (168);
dcl  temp_file_attach_desc char (256);
dcl  temp_file_attach_name char (32);
dcl  temp_file_iocb_ptr ptr;
dcl  temp_seg_ptr ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  TRUE bit (1) aligned int static options (constant) init ("1"b);
dcl  unique_chars_ entry (bit (*)) returns (char (15));

     end mu_db_xref;




		    mu_de_queue_user.pl1            10/23/86  1024.8r w 10/23/86  1009.4       46728



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

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

mu_de_queue_user: de_queue_user: proc (open_sw, scope_sw, a_dbc_ptr, this_ul_ptr, code);


/*
   HISTORY:
   Written by Oris Friesen July 1977
   Modifidied by M. Pierret 13 April 1980 to remove priority queue.
*/

/* remove all traces of this user.
   Remove from
   -list of open users
   -list of active or waiting users

*/

	dcl     ophset		 bit (18) unal based; /* offset format */
	dcl     (ouo_ptr,				/* ptr to open_users_offset */
	        this_ul_ptr,			/* ptr to the user_list entry which is to be dequeued */
	        this_fl_ptr,			/* ptr to file_list entry to be de-queued */

	        auo_ptr,				/* ptr to active_users offset */
	        wuo_ptr,				/* ptr to waiting_users offset */
	        a_dbc_ptr)		 ptr;		/* ptr to data base control segment */
	dcl     code		 fixed bin (35);
	dcl     scope_sw		 bit (1) unal;	/* ON => free the file list for a user */
	dcl     open_sw		 bit (1) unal;	/* ON => de_queue from open list; OFF => de_queue only from active and waiting  and
						   priority lists */

	dcl     null		 builtin;
	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     rel		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin ext;

	dcl     mdbm_error_$unknown_proc_id fixed bin (35) ext;

%include mdbm_dbc;

%include mdbm_users;

	dcl     hold_open_mode	 fixed bin;	/* open mode of user being de-queued */

/* look at list of open users */
	dbc_ptr = a_dbc_ptr;
	ouo_ptr = addr (dbc.open_users_ofs);
	auo_ptr = addr (dbc.active_users_ofs);
	wuo_ptr = addr (dbc.waiting_users_ofs);

	if this_ul_ptr = null
	then call error (mdbm_error_$unknown_proc_id);
	else ul_ptr = this_ul_ptr;
	num_filns = 0;

	if user_list.active_sw
	then do;

		ul_ptr = convert (dbc_ptr, auo_ptr -> ophset);
		do while (ul_ptr ^= this_ul_ptr & ul_ptr ^= null);

		     auo_ptr = addr (user_list.next_active_ofs);
		     ul_ptr = convert (dbc_ptr, user_list.next_active_ofs);
		end;

		if ul_ptr = null then call error (mdbm_error_$unknown_proc_id);

		auo_ptr -> ophset = user_list.next_active_ofs;
		dbc.active_users = dbc.active_users - 1;
		user_list.next_active_ofs = NULL_OFS;
		user_list.active_sw = "0"b;
		user_list.passive_sw = "1"b;
	     end;

	else if user_list.waiting_sw
	then do;
		ul_ptr = convert (dbc_ptr, wuo_ptr -> ophset);
		do while (ul_ptr ^= this_ul_ptr & ul_ptr ^= null);
		     wuo_ptr = addr (user_list.next_waiting_ofs);
		     ul_ptr = convert (dbc_ptr, user_list.next_waiting_ofs);
		end;

		if ul_ptr = null then call error (mdbm_error_$unknown_proc_id);

		wuo_ptr -> ophset = user_list.next_waiting_ofs;
		dbc.waiting_users = dbc.waiting_users - 1;
		user_list.next_waiting_ofs = NULL_OFS;
		user_list.waiting_sw = "0"b;

	     end;

/* free all files referenced by this user only if the scope_sw is ON */

	if scope_sw then do;
		fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);
		do while (fl_ptr ^= null);
		     this_fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
		     free fil_list in (dbc.static_area);
		     fl_ptr = this_fl_ptr;
		end;
		user_list.fil_list_ofs = NULL_OFS;
	     end;

	if open_sw then do;
		hold_open_mode = user_list.open_mode;

		ul_ptr = convert (dbc_ptr, ouo_ptr -> ophset);
		do while (ul_ptr ^= this_ul_ptr & ul_ptr ^= null);
		     ouo_ptr = addr (user_list.next_open_ofs);
		     ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		end;
		if ul_ptr = null then call error (mdbm_error_$unknown_proc_id);

		ouo_ptr -> ophset = user_list.next_open_ofs;
		dbc.open_users = dbc.open_users - 1;


		free user_list in (dbc.static_area);
						/* finished */
		this_ul_ptr = null;			/* return a null pointer to caller */

	     end;
exit:
	return;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

error: proc (cd);

	dcl     cd		 fixed bin (35);

	code = cd;
	goto exit;

     end error;

     end mu_de_queue_user;





		    mu_define_area.pl1              04/18/85  1437.3rew 04/18/85  0908.1       73143



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

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

mu_define_area:
define_area:
     procedure (defined_area_ptr, area_size, area_name, extensible, no_freeing,
	zero_on_alloc, zero_on_free, error_code);

/* DESCRIPTION:

   This  is  a general routine to encapsulate the call to define_area_ and the
   initializing  of  the  area_info structure needed for that call.  Note that
   the area defined by this call must be deleted by a call to release_area_ to
   properly clean up any temp segments created.
   
   Notice:  If the caller's temp segment should be placed in the MRDS temp
   directory, the caller MUST call the define_temp_dir_area entry point which
   uses mu_temp_segs to get the temp segment. The segment may then be released
   by an appropriate call to mu_temp_segments.

   PARAMETERS:

   defined_area_ptr  -  -  (input/output)  pointer, points to the start of the
   area   to   be   defined  by  this  call.   also  the  address  pointed  by
   defined_area_ptr  must  be  even(0  mod  2).   if  null, then it's value is
   assigned, and a temp segment for the area is created.

   dbi - - (input) fixed bin (35), the database index which is associated with
   the area being defined. It is used for the call to mu_temp_segments.

   area_size - - (input) fixed bin(18), the size that the area will be defined
   to have, the initial size for extensible areas

   area_name  -  - (input) char(11), a name for the area, it will be used with
   extensible  areas  to name added segments following the {unique_name}.area.
   they should be of the form MRDS.store or LINUS.modify for identification.

   extensible  -  - (input) bit(1) aligned, ON => define this as an extensible
   area.  This will also cause the 'system' bit to come on in order to get the
   extension to be placed in the same directory.

   no_freeing  -  -  (input) bit(1) aligned, ON => define this as an area that
   will never have any freeing done, in order to make use of a faster allocate
   method.

   zero_on_alloc - - (input) bit(1) aligned, ON => zero out storage of a block
   to be allocated before returning from the allocation.

   zero_on_free - - (input) bit(1) aligned, ON => zero out storage of block at
   the time it is being freed.

   error_code  -  -  (output)  fixed bin(35), 0 unless an error occured in the
   call to define_area_ or while getting a temp segment.
   
   
   
   HISTORY:

   80-02-01 Jim Gray : Originally written.
   
   81-07-07  Rickie  E.   Brinegar:  Modified  to  always  pass define_area_ a
   non-null  pointer.   MRDS  now  handles getting and releasing temp segments
   only using define_area_ to reset the header of the area.

   82-07-08 R. Harvey: Modified to set system bit on extensible areas and to
   copy a static structure for speed.

   83-01-27 R. Harvey: Added define_temp_dir_area entry point.

   85-01-15 Thanh Nguyen: Added define_spec_temp_dir_area entry point to create
   our own space manager in the economic way of allocate without freeing.
*/

/* initialize the area_info, based on input parameters */

	error_code = 0;
	if defined_area_ptr = null then
	     call get_temp_segment_ (area_name, defined_area_ptr, error_code);
	goto COMMON;



define_temp_dir_area:
     entry (defined_area_ptr, dbi, area_size, area_name, extensible,
	no_freeing, zero_on_alloc, zero_on_free, error_code);

	error_code = 0;
	if defined_area_ptr = null () then
	     call mu_temp_segments$get_temp_segment (dbi, area_name, defined_area_ptr, error_code);



COMMON:
	if error_code = 0 then do;
		static_area_info.control.extend = extensible;
		static_area_info.control.zero_on_alloc = zero_on_alloc;
		static_area_info.control.zero_on_free = zero_on_free;
		static_area_info.control.no_freeing = no_freeing;
		if extensible then static_area_info.control.system = "1"b;
		static_area_info.owner = area_name;
		static_area_info.size = area_size;
		static_area_info.areap = defined_area_ptr;

/* now make the call to define the area according to the parameters */

		call define_area_ (addr (static_area_info), error_code);
	     end;					/* error_code = 0 */


	return;
%page;
define_spec_temp_dir_area: entry (defined_area_ptr, dbi, area_name, error_code);

/* This entry defines a special area which is the temporary segment is created
   as any other temporary segment in MRDS, but it only be initialized by
   subroutine mrds_area_initialize (mrds_area_initialize.incl.pl1) and 
   allocated by function allocate (mdbm_allocate.incl.pl1).

   For now, this entry is only called by mrds_dsl_retrieve, mrds_dsl_modify,
   mrds_dsl_store, mrds_dsl_compile and mrds_dsl_define_temp_rel to create the
   "mrds area" for the allocation of value_for_user in module mu_retrieve.
 */

	error_code = 0;
	if defined_area_ptr = null then
	     call mu_temp_segments$get_temp_segment (dbi, area_name, defined_area_ptr, error_code);
	if error_code = 0 then
	     call mrds_area_initialize (defined_area_ptr);

	return;
%page;
%include mrds_area_initialize;
%page;
	declare defined_area_ptr	 ptr;		/* points to area to be defined */
	declare dbi		 fixed bin (35);	/* data base index */
	declare area_size		 fixed bin (18);	/* size of area to be defined */
	declare area_name		 char (11);	/* name to be given to area and extended segs */
	declare (extensible, zero_on_alloc, zero_on_free, no_freeing) bit (1) aligned;
						/* parameters area is to have */

	dcl     1 static_area_info	 aligned internal static,
		2 version		 fixed bin init (1),/* version number for this structure is 1 */
		2 control		 aligned,		/* control bits for the area */
		  3 extend	 bit (1) unal init ("0"b), /* says area is extensible */
		  3 zero_on_alloc	 bit (1) unal init ("0"b), /* says block gets zerod at allocation time */
		  3 zero_on_free	 bit (1) unal init ("0"b), /* says block gets zerod at free time */
		  3 dont_free	 bit (1) unal init ("0"b), /* debugging aid, turns off free requests */
		  3 no_freeing	 bit (1) unal init ("0"b), /* for allocation method without freeing */
		  3 system	 bit (1) unal init ("0"b), /* says area is managed by system */
		  3 pad		 bit (30) unal init ((30)"0"b),
		2 owner		 char (32) unal init (""), /* creator of the area */
		2 n_components	 fixed bin init (0),/* number of components in the area (returned only) */
		2 size		 fixed bin (18) init (0), /* size of the area in words */
		2 version_of_area	 fixed bin init (1),/* version of area (returned only) */
		2 areap		 ptr init (null ()),/* pointer to the area (first component on multisegment area) */
		2 allocated_blocks	 fixed bin init (0),/* number of blocks allocated */
		2 free_blocks	 fixed bin init (0),/* number of free blocks not in virgin */
		2 allocated_words	 fixed bin (30) init (0), /* number of words allocated in the area */
		2 free_words	 fixed bin (30) init (0); /* number of words free in area not in virgin */

	declare define_area_	 entry (ptr, fixed bin (35)); /* routine that defines an area */
	declare error_code		 fixed bin (35);	/* error status encoding */
	dcl     mu_temp_segments$get_temp_segment entry (fixed bin (35), char (*), ptr, fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* get a seg to define the area on */
	dcl     (addr, null)	 builtin;



     end;





		    mu_display_descriptor.pl1       04/18/85  1437.3re  04/18/85  0908.2       90819



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

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

/* HISTORY:

   Written by Jim Gray - - Dec. 1979, to include new data  types  in
   MR7  release of PL1 and replace the old mrds_cmdb_alpha_desc with
   a more general routine.

   Modified  March  25,  1980  by  R.  Lackey  to  remove  calls  to
   mdbm_util_

   81-09-23 Davids: changed an if statement with a substr  reference
   to  an  if  statement  with  an  index  reference  to  prevent  a
   stringrange condition from occuring if the  requested  string  is
   larger than the original string.
*/


mu_display_descriptor: display_descriptor: procedure (desc_ptr) returns (char (120) varying);

/* DESCRIPTION:

   given a pointer to a multics  pl1  standard  argument  descriptor
   (see  subsystem  writers  guide  for  format and data types) this
   routine returns a character string that includes the pl1 keywords
   attributes  that  would  have  appeared  in  a  declaration  that
   produced the given descriptor,  plus  some  clarifying  comments,
   when  no  keywords  are  available to describe the data type. for
   example: if the input pointer pointed to the descriptor
   "100000110000000000000000000000010001"b  then  the  output  would
   look like "real fixed binary (17,0) unaligned" for an input of
   "100100110000000000000000000000010001"b the output would be
   "real fixed decimal (17,0) unaligned /* leading sign 4-bit byte-aligned * /"
   structures are only displayed as "structure /* 4 elements * /"
   an array example would be "character (96) varying aligned dimension(1:20,3:-3)"

   NOTE: the descriptor/array bounds informations is assumed  to  be
   in correct format with legal values, no error checking is done in
   this  routine,  since  this  is  to  be  an  efficient   run-time
   routine(cmdb should guarantee correctness).

*/

/* PARAMETERS:

   desc_ptr - - (input) pointer, points to a standard multics pl1 argument
   descriptor(bit(36) aligned), as described in the subsystem writers guide(under argument list format)
   if not scalar, the array bounds/multiplier follow the descriptor in consecutive fixed bin(35) words.

   declaration - - (output) char(120) varying, the declaration of the data type varying,
   as it would appear after a declare statement that would produce
   the given descriptor, plus clarifying comments.

*/

/* break down the descriptor into its individual parts */

	call decode_descriptor_ (desc_ptr, 0, type, unaligned, ndims, size, scale);

/* set up the return declaration according to the descriptor fields */

	if type < 1 | type > 63 then
	     declaration = "Unrecognized data type";
	else do;

/* get the basic data type declaration based on the type */

		declaration = data_type (type);

		if index (declaration, "Unused") = 1 then ; /* CHANGE 81-09-23 ********** */
		else do;

/* go add data type specific information */

			call add_specifics ();

/* now add common attribute information, first alignment */

			if ^new_format_descriptor then ; /* packing info not available in old descriptor */
			else do;

				if unaligned then
				     declaration = declaration || " unaligned";
				else declaration = declaration || " aligned";

			     end;

/* now add dimension info, if any */

			if ndims = 0 then ;
			else do;

				if ^new_format_descriptor then /* number of dimension unknown in old format */
				     declaration = declaration || " /* array, old format descriptor */";
				else call add_dimension ();

			     end;

/* add on clarifying comments */

			declaration = declaration || comment (type);

		     end;

	     end;

/* report final declaration attributes to caller */

	return (declaration);

add_specifics: procedure ();

/* add precision/scale for numbers, string size for bit/char, or
   number of elements for a structure */

/* numeric types need a precision, scale field attribute */

	if mu_data_class$number (desc_ptr) then do;	/* arithmetic data types */

		declaration = declaration || " (";
		declaration = declaration || ltrim (char (size));

		if ^mu_data_class$fixed (desc_ptr) then ; /* float types don't have scale */
		else do;
			declaration = declaration || ",";
			declaration = declaration || ltrim (char (scale));
		     end;

		declaration = declaration || ")";

	     end;

/* areas, bit, and character types need a size field */

	else if type >= 18 & type <= 22 then do;	/* area or bit or character */

		declaration = declaration || " (";
		declaration = declaration || ltrim (char (size));
		declaration = declaration || ")";

/* add the varying/nonvarying attribute for bit or character strings */

		if type = 20 | type = 22 then
		     declaration = declaration || " varying";
		else if type = 19 | type = 21 then
		     declaration = declaration || " nonvarying";

	     end;
						/* report via a comment, the number of structure elements */

	else if type = 17 then do;			/* structure */

		if ^new_format_descriptor then ;	/* no info on elements in old descriptor */
		else do;

			declaration = declaration || " /* ";
			declaration = declaration || ltrim (char (size));
			declaration = declaration || " element";
			if size = 1 then
			     declaration = declaration || " */";
			else declaration = declaration || "s */";

		     end;

	     end;

     end;

add_dimension: procedure ();

/* add the dimension attribute, with array bounds */

	declaration = declaration || " dimension (";

/* add a bound_pair "upper:lower" for each dimension */

	do dimension_number = 1 to ndims;

	     offset = (3 * dimension_number) - 2;	/* number of words from descriptor to bound */

/* pick up bounds words following descriptor */

	     declaration = declaration || ltrim (char (addrel (desc_ptr, offset) -> lower_bound));
	     declaration = declaration || ":";
	     declaration = declaration || ltrim (char (addrel (desc_ptr, offset + 1) -> upper_bound));

/* add separator or terminator */

	     if dimension_number < ndims then
		declaration = declaration || ",";
	     else declaration = declaration || ")";

	end;

     end;

	dcl     desc_ptr		 ptr;		/* pointer to Multics descriptor (input) */

	declare declaration		 char (120) varying;/* This variable used to build return declaration */
	declare type		 fixed bin;	/* descriptor type */
	declare unaligned		 bit (1) aligned;	/* indicates unaligned ("1"b) or aligned ("0"b) */
	declare ndims		 fixed bin;	/* number dimensions ; must be zero for dbm version 1 */
	declare size		 fixed bin;	/* char string size or arithmetic precision */
	declare scale		 fixed bin;	/* arithmetic scale factor */

	declare data_type		 (1:63) char (28) varying internal static options (constant) initial (
				 "real fixed binary", "real fixed binary", "real float binary", "real float binary", /* 1 - 4 */
				 "complex fixed binary", "complex fixed binary", "complex float binary", "complex float binary", /* 5 - 8 */
				 "real fixed decimal", "real float decimal", "complex fixed decimal", "complex float decimal", /* 9 - 12 */
				 "pointer", "offset", "label", "entry", /* 13 - 16 */
				 "structure", "area", "bit", "bit", /* 17 - 20 */
				 "character", "character", "file", /* 21 - 23 */
				 (5) ("Unused data type"), /* 24 - 28 */
				 (2) ("real fixed decimal"), /* 29 - 30 */
				 (2) ("Unused data type"), /* 31 - 32 */
				 (2) ("real unsigned fixed binary"), /* 33 - 34 */
				 "real unsigned fixed decimal", /* 35 */
				 "real fixed decimal", /* 36 */
				 "Unused data type",/* 37 */
				 "real unsigned fixed decimal", /* 38 */
				 "real fixed decimal", /* 39 */
				 "Unused data type",/* 40 */
				 (2) ("real fixed decimal", "real float decimal"), /* 41 - 44 */
				 "complex fixed decimal", "complex float decimal", /* 45 - 46 */
				 (17) ("Unused data type")); /* 47 - 63 */

	declare comment		 (1:63) char (40) varying internal static options (constant) initial (
				 (8) (""),	/* 1 - 8 */
				 (2) (" /* leading sign 9-bit */", " /* 9-bit */"), /* 9 - 12 */
				 (16) (""),	/* 13 - 28 */
				 " /* leading overpunched sign 9-bit */", /* 29 */
				 " /* trailing overpunched sign 9-bit */", /* 30 */
				 (4) (""),	/* 31 - 34 */
				 " /* 9-bit */",	/* 35 */
				 " /* trailing sign 9-bit */", /* 36 */
				 "", " /* 4-bit */",/* 37 - 38 */
				 " /* trailing sign 4-bit */", /* 39 */
				 "", " /* leading sign 4-bit */", " /* 4-bit */", /* 40 - 42 */
				 " /* leading sign 4-bit byte-aligned */", /* 43 */
				 " /* 4-bit byte-aligned */", /* 44 */
				 " /* leading sign 4-bit byte-aligned */", /* 45 */
				 " /* 4-bit byte-aligned */", /* 46 */
				 (17) (""));	/* 47 - 63 */

	declare (ltrim, index, addrel, char) builtin;
	declare decode_descriptor_	 entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
	declare new_format_descriptor	 bit (1) unal based (desc_ptr); /* version bit of descriptor is first */
	declare dimension_number	 fixed bin;	/* number of current dimension */
	declare offset		 fixed bin;	/* number of words past desc_ptr, to get array bound */
	declare (lower_bound, upper_bound) fixed bin (35) based; /* overlays for array bound info */
	declare (mu_data_class$number,
	        mu_data_class$fixed)	 entry (ptr) returns (bit (1) aligned); /* decides if data in entries class */

     end;




		    mu_empty_scope.pl1              10/23/86  1024.8r w 10/23/86  1008.9       34407



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

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

mu_empty_scope:
empty_scope:
     procedure (dbc_p, scope_p, rdbi_p, delink);

/*
   DESCRIPTION:
   This procedure empties the scope definition of a user for the data base specified.
   ---------------------------------------------------------------------------
   HISTORY:
   Written in 1975
   Modified by O D Friesen in July 1977 to handle queued scope requests
   Changed from mrds_dsl_empty_scope to mu_empty_scope by O Friesen - Sept. 1978 -
   to handle file scopes
   Modified by M. Pierret 13 December 1979 to fix bug.  If database was opened twice
   by the same process, it was not gauranteed to empty the scope associated
   with the correct opening.  (Test for rdbi_ptr was incorrect)
   Modified by M. Pierret 14 January 1980 to force conflict check even if process id and db are same
   Modified by M. Pierret 22 July 1980 to make scope_info...flags = "0"b one assignment instead of four.
   --------------------------------------------------------------------------- */

	dcl     dbc_p		 ptr parm;
	dcl     scope_p		 ptr parm;
	dcl     rdbi_p		 ptr parm;
	dcl     rdbi_ptr		 ptr;
	dcl     i			 fixed bin;
	dcl     delink		 bit (1) unal;
	dcl     icode		 fixed bin (35);	/* return code */

	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     mu_de_queue_user	 entry (bit (1), bit (1), ptr, ptr, fixed bin (35));
	dcl     get_process_id_	 entry returns (bit (36));

	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     null		 builtin;
	dcl     rel		 builtin;
	dcl     unspec		 builtin;


	dbc_ptr = dbc_p;				/* use local variable */
	scope_ptr = scope_p;
	rdbi_ptr = rdbi_p;
	num_filns = 0;

	do i = 1 to scope_info.nfiles;		/* iterate once for each file in data base */
	     scope_info.scope.flags (i) = "0"b;
	end;

	scope_info.active_scopes = 0;

/* Get rid of all traces of this user on any scope list */

	if delink
	then do;
		ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);
		do while (ul_ptr ^= null);

		     if user_list.process_id = get_process_id_ ()
			& unspec (user_list.rdbi_bits) = unspec (rdbi_ptr)
		     then do;
			     call mu_de_queue_user (NO_DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr,
				icode);
			     ul_ptr = null;
			end;
		     else ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		end;

	     end;
	return;

convert:
     proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

%include mdbm_dbc;

%include mdbm_users;

%include mdbm_scope_info;

     end mu_empty_scope;





		    mu_get_data.pl1                 04/18/85  1437.3rew 04/18/85  0908.2      111339



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

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

mu_get_data: get_data: proc (a_rmri_ptr, a_area_ptr, a_simple_typed_vector_ptr, a_ml_ptr, code);

/* NOTES:

   This procedure moves  attribute  values  from  a  tuple  to  user
   arguments.  Any  required conversions are performed, and decoding
   takes place if specified.  The  $item  entry  performs  the  same
   function for a single (possibly mis-aligned) attribute value.


   HISTORY:

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

   79-07-11 Al Kepner: Modified to change  the  length  field  of  a
   varying char attribute from a bit length to a char length.

   80-02-01 Jim Gray  :  Modified  to  make  use  of  an  extensible
   non-freeing area.


   80-05-08  Davids:  modified  assignments  of  tuple_num_atts  and
   tuple_nvar_atts  to  take  values from rm_rel_info.model_num_attr
   and  model_nvar_atts   rather   than   rm_rel_info.num_attr   and
   nvar_atts.  This  was  to  fix  a problem with submodels were the
   submodel view did not contain a varying string attribute and  the
   model did.

   80-08-12 Davids: length of attributes  for  moves  not  requiring
   conversion          are         now         calculated         by
   mu_data_length$get_data_bit_length. this fixes a bug caused  when
   decoded declaration and data mode declaration are not the same.

   81-05-06 Rickie E. Brinegar: Modified  to  use  cu_$generate_call
   and the changed resultant model.

   81-06-01 Jim Gray : changed to use new resultant structure.

   81-10-17 Davids: added calls to add_bit_offset_ to calculate  the
   value   of  item_ptr  in  mu_get_data  because  the  old  way  of
   overlaying a bit array and taking the addr  of  some  element  in
   that  array  ran into a pl1 bug when the offset was large and the
   compiler had all the prefixes set.

   82-08-20 D. Woodka : removed references to rm_attr_info.bit_offset
   and rm_rel_info.max_data_len for DMS conversion

   82-09-03 Mike Kubicar : Converted to use simple_typed_vectors.

   83-04-07 Davids: Deleted declaration to unused variable fb35u.

   84-07-19 Hergert: Initialized icode to 0 in get_item just in case
   users decode proc doesnt handle code properly.

   84-09-05 Thanh Nguyen: Added code to check for needing of data type
   conversion, in case of the user descriptor (if the decode_declare present)
   is different with the actual target user data type. (TR # 16198)

   85-01-15 Thanh Nguyen: Modified code to call mrds_space_allocate function
   to allocate value_for_db or value_for_user instead of using the standard
   PL/I allocate, so we would not have the overflow of area (in case of the
   caller is mu_retrieve).  Added mrds_space_allocate.incl.pl1.
*/


	area_ptr = a_area_ptr;
	rmri_ptr = a_rmri_ptr;			/* move into local storage */
	simple_typed_vector_ptr = a_simple_typed_vector_ptr;
	ml_ptr = a_ml_ptr;

	do i = 1 to move_list.nitems;			/* loop for each value to be moved */

	     raip = rm_rel_info.attr_ptrs (move_list.item.attr_index (i));

	     item_ptr = simple_typed_vector.dimension (raip ->
		rm_attr_info.defn_order).value_ptr;

	     call get_item (raip, item_ptr,		/* call proc. to do the work */
		move_list.item.user_ptr (i), move_list.item.user_desc_ptr (i));

	end;					/* attr. value loop */

	code = 0;

exit:
	return;

item: get_data_item: entry
	(a_raip, b_area_ptr, a_item_ptr, a_targ_ptr, a_desc_ptr, code);

/* Entry to pass only one item back to the user.  THis item may be mis-aligned. */

	dcl     (a_raip,
	        b_area_ptr,
	        a_item_ptr,
	        a_desc_ptr,
	        a_targ_ptr)		 ptr;


	area_ptr = b_area_ptr;
	call get_item (a_raip, a_item_ptr, a_targ_ptr, a_desc_ptr);

	code = 0;

	return;

get_item: proc (aip, ip, target_data_ptr, target_desc_ptr);

/* Procedure to process a single value */

	dcl     (aip,
	        ip,
	        target_data_ptr,
	        target_desc_ptr)	 ptr;
						/* just make sure code = 0 in case user's decode proc doesn't handle code properly. */
	icode = 0;
	rai_ptr = aip;				/* attribute info */
	rdi_ptr = rm_attr_info.domain_ptr;		/* domain info */

	if ^rm_domain_info.decd_proc then do;		/* if no decoding */

		if target_desc_ptr -> bit36 = rm_domain_info.db_desc &
		     target_desc_ptr -> bit36 = rm_domain_info.user_desc
						/* if no conversion */
		then do;
			len = mu_data_length$get_data_bit_length ((rm_domain_info.user_desc));
			target_data_ptr -> target_str = ip -> src_str;
		     end;

		else do;				/* if must convert */
			call align_item;		/* move into temp & set db_val_ptr */

			call mu_convert (db_val_ptr,	/* convert from db data type */
			     addr (rm_domain_info.db_desc),
			     target_data_ptr,	/* to data type that user wants */
			     target_desc_ptr,
			     icode);
			if icode ^= 0 then call error (icode);
		     end;				/* if must convert */

	     end;					/* if no decoding */

	else do;					/* if must decode */

		call align_item;			/* move into temp & set db_val_ptr */

		if rm_domain_info.user_bit_len > 2376 then do; /* if wont fit into work space */
			user_val_ptr = mrds_space_allocate (area_ptr, (rm_domain_info.user_bit_len + 35) / 36);
			if user_val_ptr = null then
			     call error (error_table_$noalloc);
			ub_alloc = "1"b;
		     end;
		else user_val_ptr = addr (wksp2);	/* if will fit */

		value_for_user = "0"b;		/* clear out space */

		decode_list.uv_ptr = user_val_ptr;	/* user val is output from decode */
		user_descriptor = rm_domain_info.user_desc; /* move descriptor into local storage */
		decode_list.ud_ptr = addr (user_descriptor);

		if decode_list.ud_ptr -> descriptor.type = VAR_CHAR /* varying strings are strange */
		     | decode_list.ud_ptr -> descriptor.type = VAR_BIT then
		     decode_list.uv_ptr = addr (decode_list.uv_ptr -> varying.string); /* point to string, not length */

		decode_list.dbv_ptr = db_val_ptr;	/* db value is input to decode */
		db_descriptor = rm_domain_info.db_desc; /* move into local storage */
		decode_list.dbd_ptr = addr (db_descriptor); /* and get into arg list */

		if decode_list.dbd_ptr -> descriptor.type = VAR_CHAR /* more strange strings */
		     | decode_list.dbd_ptr -> descriptor.type = VAR_BIT then
		     decode_list.dbv_ptr = addr (decode_list.dbv_ptr -> varying.string);

		decode_list.code_ptr = addr (icode);	/* return code */
		decode_list.coded_ptr = addr (FB35_DESC);

/* 81-05-06 Rickie E. Brinegar: Start changed code ************************* */

		call cu_$generate_call /* call decode_proc(value_for_user, value_for_db, icode) */
		     (rm_domain_info.decd_proc_entry, addr (decode_list));

/* 81-05-06 Rickie E. Brinegar: End changed code *************************** */

		if icode ^= 0 then call error (icode);

		if target_desc_ptr -> bit36 = rm_domain_info.user_desc /* if no conversion required */
		then do;
			len = mu_data_length$get_data_bit_length ((rm_domain_info.user_desc));
			target_data_ptr -> target_str = user_val_ptr -> src_str;
		     end;

		else do;
			call mu_convert (user_val_ptr,/* convert decoded output as appropriate */
			     addr (rm_domain_info.user_desc),
			     target_data_ptr,
			     target_desc_ptr,
			     icode);
			if icode ^= 0 then call error (icode);
		     end;				/* convertion required */

	     end;					/* if needed to decode */

align_item: proc;

/* Procedure to move source item to a properly aligned position */

	dcl     src_str		 bit (len) based (ip);

	if rm_attr_info.bit_length > 2376 then do;	/* if wont fit in work space */
		db_val_ptr = mrds_space_allocate (area_ptr, (rm_attr_info.bit_length + 35) / 36);
		if db_val_ptr = null then call error (error_table_$noalloc);
		db_alloc = "1"b;
	     end;
	else db_val_ptr = addr (wksp1);		/* if will fit */
	value_for_db = "0"b;			/* clear out space */

	len = rm_attr_info.bit_length;

	value_for_db = src_str;

     end align_item;

     end get_item;
%page;
%include mrds_space_allocate;
%page;
error: proc (cd);

/* Error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;

%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_move_list;
%page;
%include vu_typed_vector;
%page;
	dcl /* input parameters */
	        a_rmri_ptr		 ptr,
	        a_area_ptr		 ptr,
	        a_simple_typed_vector_ptr ptr,		/* points to tuple structure */
	        a_ml_ptr		 ptr;		/* points to move_list structure for user's output */

	dcl     (raip,				/* temp attr info pointer */
	        item_ptr,				/* pointer to value */
	        db_val_ptr,				/* pointer to converted value, ready for tuple */
	        user_val_ptr)	 ptr;		/* pointer to converted value, prior to encoding */

	dcl     (wksp1,				/* work spaces to minimize allocations */
	        wksp2)		 (33) fixed bin (71);

	dcl     (db_alloc,				/* to remember allocations */
	        ub_alloc)		 bit (1) aligned;

	dcl     target_str		 bit (len) based;
	dcl     src_str		 bit (len) based;
	dcl     len		 fixed bin;	/* length of value */
	dcl     i			 fixed bin;	/* internal indexes */

	dcl     (code,				/* Output: status code */
	        icode)		 fixed bin (35);	/* internal status code */
	dcl     db_descriptor	 bit (36) aligned;	/* describes the way db wants data */
	dcl     user_descriptor	 bit (36) aligned;	/* describes the way user proc wants data */

	dcl     work_area		 area (sys_info$max_seg_size) based (area_ptr); /* working area */
	dcl     value_for_db	 bit (rm_attr_info.bit_length) based (db_val_ptr); /* converted value, ready for tuple */
	dcl     value_for_user	 bit (rm_domain_info.user_bit_len) based (user_val_ptr); /* converted val., ready for encoding */
	dcl     bit36		 bit (36) based;	/* templates */

	dcl     1 varying		 based unaligned,	/* description of varying string */
		2 length		 fixed bin (35),	/* length word */
		2 string		 char (0);	/* string starts here */

	dcl     1 descriptor	 aligned based,
	        ( 2 flag		 bit (1),
		2 type		 fixed bin (6) unsigned, /* data type */
		2 packed		 bit (1),		/* ON = unaligned */
		2 number_dims	 fixed bin (4) unsigned, /* non-zero for arrays */
		2 size		 fixed bin (24) unsigned) unaligned, /* size of data */
		2 array_info	 (0 refer (descriptor.number_dims)),
		  3 lower_bound	 fixed bin (35),
		  3 upper_bound	 fixed bin (35),
		  3 multiplier	 fixed bin (35);

	dcl     1 decode_list	 aligned,		/* arg list for decode proc. */
		2 nargs		 fixed bin (17) unal init (6),
		2 code		 fixed bin (17) unal init (4),
		2 ndescs		 fixed bin (17) unal init (6),
		2 pad		 fixed bin (17) unal init (0),
		2 dbv_ptr		 ptr,
		2 uv_ptr		 ptr,
		2 code_ptr	 ptr,
		2 dbd_ptr		 ptr,
		2 ud_ptr		 ptr,
		2 coded_ptr	 ptr;

	dcl     FB35_DESC		 bit (36) aligned int static options (constant)
				 init ("100000100000000000000000000000100011"b);
	dcl     VAR_BIT		 fixed bin (5) int static options (constant) init (20);
	dcl     VAR_CHAR		 fixed bin (5) int static options (constant) init (22);

	dcl     sys_info$max_seg_size	 ext fixed bin (35);
	dcl     error_table_$noalloc	 fixed bin (35) ext static;
	dcl     (addr,
	        null)		 builtin;


	dcl     mu_convert		 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_data_length$get_data_bit_length entry (bit (36)) returns (fixed bin (35));

/* 81-05-06 Rickie E. Brinegar: Start changed code ************************* */

	dcl     cu_$generate_call	 entry (entry, ptr);

/* 81-05-06 Rickie E. Brinegar: End changed code *************************** */

	declare area_ptr		 ptr;
     end mu_get_data;




		    mu_get_relation_acl.pl1         04/18/85  1437.3rew 04/18/85  0908.3       41922



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

mu_get_relation_acl: get_relation_acl: procedure (database_path, model_relation_name,
	DBA, read_acl, write_acl, error_code);

/* DESCRIPTION:

   given an absoulte database path, and the model name of a relation,
   plus whether the user is a database administrator,
   this routine will return the Multics acl's the user
   has to the relation data multi-segment file (vfile_).

*/

/* PARAMERERS:

   database_path - - (input) char(*), the absolute pathname of the database
   with suffix (as can be obtained from rm_db_info.db_path)

   model_relation_name - - (input) char(*), the name of the relation as it
   appears in the model, not a submodel name

   DBA - - (input) bit(1), if this bit is on, it indicates the user
   is a database administrator, and that if he does not
   have "rw" acl to the relation, he should get it.

   read_acl - - (output) bit(1), this bit is on if the user
   had read ("r") acl on the given relation data

   write_acl - - (output) bit(1), this bit is on if the user
   has write ("w") acl on the given relation data

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

*/

/* HISTORY:

   Originally written by Jim Gray - - March 1981

   83-05-31 Davids: Modified to use object_type_$get_user_access_modes so that
   ring 2 dms files can be handled ok.

   83-07-05 Mike Kubicar : Still problems with object_type.  I had to make
   a distinction between vfile msfs and dmfile msfs.

   83-09-30 Mike Kubicar : Upgraded to use the again new versions of
   fs_util_ (object_type_).  Hopefully the distinction between vfile msfs
   and dmfiles has gone away.

*/
%page;
/* initialize */

	error_code = 0;
	need_to_set_acls = "0"b;
	mode = "0"b;

	call fs_util_$get_user_access_modes (database_path,
	     model_relation_name, (""), (-1), mode, unused, error_code);
	if error_code = 0 then do;
		if DBA & /* check for a DBA without rw acl */
		     addr (mode) -> access_string ^= "101"b
		then need_to_set_acls = "1"b;
		else need_to_set_acls = "0"b;
	     end;
	else if error_code = error_table_$incorrect_access | /* null on msf, "s" or greator on db dir */
		error_code = error_table_$no_info then do; /* null on both db dir and msf */
		if DBA then
		     need_to_set_acls = "1"b;
		else do;				/* user not a DBA, and not sufficient access */

/* assume that we failed because there was not access of "s"
   on the msf "dir", and no access on component 0,
   thus the user has "n" access to the msf */

			mode = "0"b;		/* set null access */
			error_code = 0;
			need_to_set_acls = "0"b;

		     end;

	     end;

	if need_to_set_acls then do;

		call mrds_dm_authorization$set_needed_access
		     (database_path, error_code);	/* fails if user not dba */
		if error_code = 0 then
		     mode = "101"b;			/* set rw access */
	     end;

/* set the users acl bits for returning */

	read_acl = addr (mode) -> access.read;
	write_acl = addr (mode) -> access.write;

	return;
%page;
	dcl     addr		 builtin;
	dcl     mode		 bit (36) aligned;
	dcl     unused		 bit (36) aligned;
	dcl     access_string	 based bit (3) unal;
	dcl     1 access		 based unal,	/* overlay for getting access bits */
		2 read		 bit (1) unal,
		2 exec		 bit (1) unal,
		2 write		 bit (1) unal;
	dcl     DBA		 bit (1);		/* on =. user is a database administorator */
	dcl     database_path	 char (*);	/* absolute pathname of the database dir */
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     error_table_$incorrect_access fixed bin (35) ext; /* null on msf, "s" or more on db dir */
	dcl     error_table_$no_info	 fixed bin (35) ext;/* null on both msf and db dir */
	dcl     fs_util_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				 bit (36) aligned, fixed bin (35));
	dcl     model_relation_name	 char (*);	/* name of the relation data msf in the model */
	dcl     mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* gives DBA all acls he needs */
	dcl     need_to_set_acls	 bit (1);		/* on => set rw acls for a DBA */
	dcl     read_acl		 bit (1);		/* on => user has "r" acl to relation data */
	dcl     write_acl		 bit (1);		/* on => user has "w" acl to relation data */

     end;




		    mu_get_tuple.pl1                08/01/88  1347.6rew 08/01/88  1300.0       44523



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




/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, changed referneces of sel_ptr to select_list_ptr.
                                                   END HISTORY COMMENTS */



mu_get_tuple: proc (I_dbcb_ptr, I_area_ptr, I_rmri_ptr, X_t_ptr, O_code);

/* .                        BEGIN_DESCRIPTION

   This procedure was removed from mrds_dsl_define_temp_rel  by R. Lackey
   so it could be used by rmdb_create_and_pop_rel.

   The purpose is to get the next tuple of a translated selection expression

   .                         END_DESCRIPTION
*/

/* HISTORY
   82-04-26 R. Lackey : Moved from mrds_dsl_temp_rel and made an expternal proc
   for use by other routines.

   82-09-09 Mike Kubicar : converted from using the tuple structure to using
   the simple typed vector structure.

   83-06-08 Davids: Modified so that mrds_dsl_retrieve$set_tuple is called
   with the input simple_typed_vector_ptr (X_t_ptr) instead of a temp_ptr
   and then doing a copy of the vector.
*/

%page;


/*      PARAMETERS    */

	dcl     I_dbcb_ptr		 ptr parameter;	/* Pointer to dbcb */
	dcl     I_area_ptr		 ptr parameter;	/* Pointer to work area */
	dcl     I_rmri_ptr		 ptr parameter;	/* Pointer to rm_rel_info structure */
	dcl     X_t_ptr		 ptr parameter;	/*  Pointer to tuple structure */
	dcl     O_code		 fixed bin (35) parameter; /* Error code */

	dbcb_ptr = I_dbcb_ptr;
	area_ptr = I_area_ptr;
	rmri_ptr = I_rmri_ptr;
	simple_typed_vector_ptr = X_t_ptr;
	O_code = 0;

	if dbcb.ss_ptr ^= null then do;		/* set ptrs needed later */
		ss_ptr = dbcb.ss_ptr;
		select_list_ptr = select_sets.items.select_ptr (1);
		range_ptr = select_sets.items.range_ptr (1);
		ti_ptr = select_sets.items.ti_ptr (1);
	     end;
	else do;
		range_ptr = dbcb.range_ptr;		/* initialize */
		select_list_ptr = dbcb.select_ptr;
		ti_ptr = dbcb.ti_ptr;
	     end;
%page;
	if dbcb.ss_ptr ^= null then do;		/* if a "set" selection expr. */

		call mrds_dsl_retrieve$set_tuple (dbcb_ptr, area_ptr, simple_typed_vector_ptr, icode);
	     end;
	else do;					/* Not a "set" selection expr */

		call mrds_dsl_search (dbcb_ptr, area_ptr, icode);
		if icode = 0 then do;		/* if got hit, build temp rel tuple */
			old_vi = 0;
			simple_typed_vector_ptr -> simple_typed_vector.number_of_dimensions
			     = select_list.num_items;
			do i = 1 to select_list.num_items; /* put each attr value into tuple */
			     if old_vi ^= select_list.item.var_index (i) then do;
						/* do tuple init only if necessary */
				     old_vi = select_list.item.var_index (i);
				     rip = range.tup_var.ri_ptr (old_vi);
				     do j = 1 to tuple_info.num_tuples
					while (old_vi ^= tuple_info.tuple.var_index (j));
				     end;
				     st_ptr = tuple_info.tuple.tuple_ptr (j);
				end;		/* tuple init. */
			     traip = rm_rel_info.attr_ptrs (i);
			     sraip, rai_ptr = select_list.item.ai_ptr (i); /* target and source attr info ptrs */

			     simple_typed_vector_ptr ->
				simple_typed_vector.dimension (
				traip -> rm_attr_info.defn_order)
				.value_ptr = st_ptr ->
				simple_typed_vector.dimension (
				sraip -> rm_attr_info.defn_order)
				.value_ptr;
			end;			/* attr loop */
		     end;

	     end;					/* if not set */

	O_code = icode;
	X_t_ptr = simple_typed_vector_ptr;

exit:	return;
%page;
	dcl     addr		 builtin;
	dcl     area_ptr		 ptr;
	dcl     fixed		 builtin;
	dcl     i			 fixed bin;
	dcl     icode		 fixed bin (35);
	dcl     j			 fixed bin;
	dcl     mrds_data_$max_attributes fixed bin (35) ext static;
	dcl     mrds_data_$max_id_len	 fixed bin (35) ext;
	dcl     mrds_data_$max_select_items ext fixed bin (35);
	dcl     mrds_dsl_retrieve$set_tuple entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsl_search	 entry (ptr, ptr, fixed bin (35));
	dcl     null		 builtin;
	dcl     old_vi		 fixed bin;
	dcl     rel		 builtin;
	dcl     rip		 ptr;
	dcl     sraip		 ptr;
	dcl     st_ptr		 ptr;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     traip		 ptr;
%page;
%include mrds_tuple_info;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_range;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mrds_select_list;
%page;
%include mrds_select_sets;
%page;
%include mdbm_descriptor;
%page;
%include vu_typed_vector;


     end mu_get_tuple;




		    mu_open_name_manager.pl1        04/18/85  1437.3re  04/18/85  0908.4      291051



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

*/

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

/* DESCRIPTION:

   This routine provides the ability to refer the an opening
   of a database (via dsl_), a model (via mmi_), or a submodel (via msmi_),
   with a user defined name of arbitrary length, and to have
   an arbitrary number of openings of any kind at the same time.
   The result of a "name to opening correspondence" is a pointer
   to the particular structure involved
   (i.e. a pointer to either the resultant, db, or sub - model)
   The current search method used is a binary threaded tree of names.
   The internal procedures for it were copied from the
   mrds_rst_tree_... routines.

   There are  6 entries:
   define_open_name, get_model_pointer, display_open_names,
   delete_open_name, delete_all_open_names, list_all_open_names

   The last returns a structure, rather than calling ioa_, like the display entry.

   The delete_all_open_names entry should be used with caution,
   since, not only the callers (say a model manager),
   but all opening names will be deleted as well.
*/

/* PARAMETERS:

   ===== define_open_name entry

   user_name - - (input) char(*), the name the user desires to give this opening,
   it will be accepted as a valid name if not already in the list of open names

   open_model_type - - (input) char(1), "r" => resultant model, "m" => db model,
   "s" => submodel, is the type of opening being defined

   model_pointer - - (input) pointer, a pointer to the resultant/db/sub model,
   depending on the open_model_type, that is to be associated with this name.

   ===== get_model_pointer entry

   user_name - - (input) char(*), the name for which the opened model
   pointer is to be retrieved.

   open_model_type - - (output), char(1), same as for define_open_name entry

   model_pointer - - (output), pointer, same as for define_open_name entry

   ===== display_open_names entry

   no inputs - - displays the (ordered by name) current set of open names,
   the open type, and in debug mode, the model pointer.

   ===== delete_open_name entry

   user_name - - (input) char(*), removes all information associated with this
   name from the list of open names

   ===== delete_all_open_names entry

   only error code parameter(see below), deletes all currently defined names,
   the error code will be 0 if no names are defined.

   ===== list_all_open_names entry

   user_area_ptr - - (input) a pointer to an area in which to allocate a list
   of pointers to the names in the list

   open_name_list_ptr - - (output) a pointer to a singly linked list of open
   names, where each element may be overlayed with the mrds_open_name_element.incl.pl1
   This pointer will be null of there are no open names defined.

   open_name_list_size - - (output) fixed bin (24), the number of elements
   in the open name list.


   *******************************************************
   ***** common to all entries, but display_open_names

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

*/

/* entry to allow defing of a new opening name */

define_open_name: entry (user_name, open_model_type, model_pointer, error_code);

	on area begin;				/* capture name space overflow */
		error_code = mdbm_error_$too_many_open_names;
		goto skip_allocate;
	     end;

	error_code = 0;

	call tree_insert (user_name, root_of_tree_ptr, node_ptr, success);

	if success then
	     current_number_of_names = current_number_of_names + 1;
	else error_code = mdbm_error_$open_name_already_known;

skip_allocate:

	return;

/* entry to remove an opening name from further use */

delete_open_name: entry (user_name, error_code);

	error_code = 0;


	call tree_delete (user_name, root_of_tree_ptr, success);

	if success then do;
		current_number_of_names = current_number_of_names - 1;
		if current_number_of_names = 0 then
		     call clean_up ();
	     end;

	else error_code = mdbm_error_$open_name_not_known;

	return;

/* entry to get a pointer to the model (resultant, db or sub model)
   given an opening name, also returned is the type of model */

get_model_pointer: entry (user_name, open_model_type, model_pointer, error_code);

	error_code = 0;
	model_pointer = null ();
	open_model_type = "";

	call tree_search (user_name, root_of_tree_ptr, node_ptr, parent_ptr, success);

	if success then do;
		mrds_open_name_ptr = node_ptr;
		model_pointer = mrds_open_name.mrds_info.model_pointer;
		open_model_type = mrds_open_name.mrds_info.opening_type;
	     end;

	else error_code = mdbm_error_$open_name_not_known;

	return;

/* entry to display all currently known opening names */

display_open_names: entry ();

	node_ptr = root_of_tree_ptr;			/* convention to get first on list */

	success = "1"b;

	if current_number_of_names > 0 then
	     call ioa_ ("^/Number of opening names:  ^d^/", current_number_of_names);

	number_of_open_names = 0;

/* go through the tree in order, till all names displayed */

	do while (success);

	     call tree_successor (root_of_tree_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);

	     if success then do;
		     number_of_open_names = number_of_open_names + 1;
		     mrds_open_name_ptr, node_ptr = successor_ptr; /* to get next in list */

		     call ioa_ ("^/Opening name:  ^a", mrds_open_name.user_info.name);
		     call ioa_ ("Opening type:  ^a", mrds_open_name.mrds_info.opening_type);

		     if substr (db_mu_open_name_manager, 1, 1) then do; /* display debug output if switch on */

			     put skip data (mrds_open_name_ptr);

			     put skip data (mrds_open_name);

			     put skip;

			end;
		end;

	end;

	if number_of_open_names = 0 then
	     call ioa_ ("^/No opening names defined.^/");
	else call ioa_ ("^/");

	return;

/* entry to delete all names from the lsit of open names */

delete_all_open_names: entry (error_code);

	error_code = 0;

	success = "1"b;

	do while (success);

	     node_ptr = root_of_tree_ptr;		/* get first one on list each time */

	     call tree_successor (root_of_tree_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);

	     if success then do;
		     node_ptr = successor_ptr;

		     call tree_delete ((node_ptr -> mrds_open_name.user_info.name), root_of_tree_ptr, success);

		     if ^success then
			error_code = mdbm_error_$open_name_not_known;

		end;

	end;

	current_number_of_names = 0;

	call clean_up ();

	return;

/* entry to return a linked list of currently defined open names */

list_all_open_names: entry (user_area_ptr, structure_version, open_name_list_ptr, open_name_list_size, error_code);

/* initizlize */

	error_code = 0;
	node_ptr = root_of_tree_ptr;
	success = "1"b;
	open_name_list_ptr = null ();
	open_name_list_size = 0;
	number_of_open_names = 0;

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

	if user_area_ptr = null () then
	     error_code = error_table_$badcall;
	else if structure_version ^= mrds_open_name_element_structure_version then
	     error_code = error_table_$unimplemented_version;

	if error_code ^= 0 then ;
	else do;

/* go through the tree in reverse order, so that the list is in order */

		do while (success);

		     call tree_predecessor (root_of_tree_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success);

		     if success then do;

			     number_of_open_names = number_of_open_names + 1;

			     mrds_open_name_ptr, node_ptr = predecessor_ptr;
			     mrds_open_name_element_length_init = mrds_open_name.user_info.name_length;

			     allocate mrds_open_name_element set (mrds_open_name_element_ptr) in (user_area_ptr -> work_area);

			     unspec (mrds_open_name_element) = "0"b;

/* fill in the details for this element in the list */

			     mrds_open_name_element.version = mrds_open_name_element_structure_version;
			     mrds_open_name_element.name_length = mrds_open_name_element_length_init;
			     mrds_open_name_element.name = mrds_open_name.user_info.name;
			     mrds_open_name_element.open_type = mrds_open_name.mrds_info.opening_type;
			     mrds_open_name_element.model_pointer = mrds_open_name.mrds_info.model_pointer;

/* insert the element into the linked list, at the head */

			     mrds_open_name_element.next = open_name_list_ptr;
			     open_name_list_ptr = mrds_open_name_element_ptr;

			end;

		end;

	     end;

	if error_code = 0 then
	     open_name_list_size = number_of_open_names;

exit:

	return;

tree_search: procedure (key, root_ptr, node_ptr, parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   Threaded binary tree search
   Given a pointer to the desired list, do a binary search for the key.
   Return either a not found indication,
   or a found indication with a pointer to the key node,
   and a pointer to it's parent */

/* PARAMETERS:

   key - - (input) word to be searched for as key to tree node

   root_ptr - - (input) pointer to root node of desired tree

   node_ptr - - (output) pointer to node containing key when found,
   else root pointer pointer

   parent_ptr - - (output) pointer to direct tree parent when key node found,
   else pointer to prospective parent for insertion of key

   success - - (output) bit value indicating key was found in tree(on),
   or that place for it's  insertion was found(off)

*/


/* Initialize search loop
   note: parent_ptr is root_ptr when no dummy head exists,
   or when the dummy head node left link is a thread
   thus indicating a empty tree */

	parent_ptr = root_ptr;
	success = "0"b;

/* if dummy node at head of tree missing,
   we fail since tree was never built */

	if root_ptr = null () then ;
	else do;
		node_ptr = root_ptr -> mrds_open_name.left.link;
		thread = root_ptr -> mrds_open_name.left.thread;


/* Search the tree while the data key is not found,
   and branches remain to be searched .
   failure to make even one loop pass means the tree is empty,
   because the dummy head node left link is a thread to itself */

		do while (^thread & ^success);

/* Branch left for smaller or right for larger keys.
   If key matches, note success and remember pointers. */

		     if key > node_ptr -> mrds_open_name.user_info.name then do;
			     thread = node_ptr -> mrds_open_name.right.thread;
			     parent_ptr = node_ptr;
			     node_ptr = node_ptr -> mrds_open_name.right.link;
			end;

		     else if key < node_ptr -> mrds_open_name.user_info.name then do;
			     thread = node_ptr -> mrds_open_name.left.thread;
			     parent_ptr = node_ptr;
			     node_ptr = node_ptr -> mrds_open_name.left.link;
			end;

		     else success = "1"b;

		end;

	     end;

	declare key		 char (*);	/* key to be searched for */
	declare root_ptr		 ptr;		/* pointer to root of tree */
	declare node_ptr		 ptr;		/* output ptr to found node */
	declare parent_ptr		 ptr;		/* prospective parent node for insertion */
	declare success		 bit (1);		/* on => key found, else place for insertion found */
	declare thread		 bit (1);		/* on => link is a thread not pointer */



     end;

tree_successor: procedure (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree inorder successor retrieval routine
   given a pointer to the current node in the tree
   ( set node_ptr = root_ptr to get first tree element )
   and a pointer to the root of the tree
   a pointer to it's inorder successor and that nodes parent
   are returned with a success indication, or
   when end of tree(no more successors) or empty tree is detected,
   a failure indication is returned */

/* PARAMETERS:

   root_ptr - - (input) pointer to root of desired tree

   node_ptr - - (input) pointer to current for which the successor is desired

   successor_ptr - - (output) pointer to resulting inorder successor of current node

   successor_parent_ptr - - (output) pointer to successor node direct tree parent

   success - - (output) bit value that is on when successor found,
   and off when end of tree or empty tree is detected

*/



/* no current node means no successor */

	if node_ptr = null () then
	     success = "0"b;

	else do;

/* current node exists, if it's right link is a thread
   it is either a pointer to the root meaning no more successors
   or it points to the current node's inorder successor */

		successor_parent_ptr = node_ptr;
		successor_ptr = node_ptr -> mrds_open_name.right.link;

		if node_ptr -> mrds_open_name.right.thread then

		     if successor_ptr = root_ptr then
			success = "0"b;
		     else success = "1"b;

		else do;

/* current node's right link is not a thread,
   go left from current node's right descendent until
   a left thread is found and return it's owner
   as the inorder successor */

			do while (^successor_ptr -> mrds_open_name.left.thread);

			     successor_parent_ptr = successor_ptr;
			     successor_ptr = successor_ptr -> mrds_open_name.left.link;

			end;

/* if pointer is still to root, the dummy head node
   left link was a thread indicating an empty tree */

			if successor_ptr = root_ptr then
			     success = "0"b;
			else success = "1"b;

		     end;


	     end;


	declare root_ptr		 ptr;		/* points to root of tree */
	declare node_ptr		 ptr;		/* points to node for which successor desired */
	declare successor_ptr	 ptr;		/* pointer to resulting inoder successor */
	declare successor_parent_ptr	 ptr;		/* successor node direct parent ptr */
	declare success		 bit (1);		/* on => successor found */




     end;

tree_delete: procedure (key, root_ptr, success);

/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree deletion routine
   A search is made for the key in the tree
   specified by the root pointer.
   If the key is not found,
   the deletion fails.
   Otherwise the tree node area is unlinked
   from the tree, and the space freed */

/* PARAMETERS:

   key - - (input) word in tree indicating node to be deleted

   root_ptr - - (input/output) pointer to root node of desired tree,
   may be changed if key is at root node

   success - - (output) bit value indicating deletion done(on),
   or attempt to delete node not in tree(off)     */

/* basic algorithm

   simple case - delete node has no right subtree
   make delete node's left subtree the new descendent of delete node's parent

   complex case - delete node has a right subtree
   subcase 1 - delete node's successor is direct descendent
   replace delete node with successor, giving it the
   delete node's left subtree
   subcase 2 - delete node's successor is not a direct descendent
   same as subcase 1 but additionally
   successor's parent get's successors right subtree as it's left subtree
   and successor's right subtree becomes that of the delete node's */


/* get pointer to node to be deleted and to it's parent */

	call tree_search (key, root_ptr, node_ptr, parent_ptr, success);

/* if node to be deleted is not found, deletion fails */

	if ^success then ;

	else do;

/* node found, save data pointer, and rearrange tree links to eliminate the node */

		thread = "0"b;

/* fix predecessor thread

   since we are replacing the delete node with it's successor(if it has one),
   the delete node's predecessor must have its's right thread
   point to this new node(the delete node's successor) */

		if node_ptr -> mrds_open_name.right.thread then ;
		else call tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);
		if node_ptr -> mrds_open_name.left.thread then ;
		else do;
			call tree_predecessor (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success);
			if node_ptr -> mrds_open_name.right.thread then
			     predecessor_ptr -> mrds_open_name.right.link = node_ptr -> mrds_open_name.right.link;
			else do;
				predecessor_ptr -> mrds_open_name.right.link = successor_ptr;
			     end;
		     end;

/* if simple case of no inorder successor(right link a thread)
   then use the left subtree of delete node as his parent's new descendent,
   when the left link of the delete node is not a thread,
   else a left thread means that the parent link will become a thread.
   the left thread of the delete node may be used as this thread unless it points
   to the parent, in which case the right thread must be used. */

		if node_ptr -> mrds_open_name.right.thread then
		     if ^node_ptr -> mrds_open_name.left.thread then
			successor_ptr = node_ptr -> mrds_open_name.left.link;
		     else do;
			     thread = "1"b;
			     if parent_ptr ^= node_ptr -> mrds_open_name.left.link then
				successor_ptr = node_ptr -> mrds_open_name.left.link;
			     else successor_ptr = node_ptr -> mrds_open_name.right.link;
			end;

		else do;

/* complex case - delete node has a successor
   give the successor node a new left subtree(previously a thread)
   that is the current delete node's left subtree
   this is the first step in moving the successor node
   into the delete node's place in the tree */

			successor_ptr -> mrds_open_name.left.link = node_ptr -> mrds_open_name.left.link;
			successor_ptr -> mrds_open_name.left.thread = node_ptr -> mrds_open_name.left.thread;

/* for direct descendent successor, ignore right subtrees */

			if node_ptr = successor_parent_ptr then ;
			else do;

/* for successor not a direct descendent, the successor's new right subtree
   will be that of the delete node's.   The successor's old right subtree becomes
   the left subtree of the successor's old parent */

/* fix successor's parent's threads for case of delete node's right link not a thread,
   and successor is not direct descendent of delete node,

   successor node's right link a thread means that the successor node's
   parent's left link must become a thread to the successor node since the successor node
   is being made the predecessor of the successor node's parent.
   also the successor's right thread must be changed to pointer
   since it will link to delete node's right subtree(known to be nonempty).

   successor node's right link not a thread means that the successor's
   parent node's left link will be a pointer set equal to the successor
   node's right link. (the successor parent gets as his left, the successor's rught subtree) */

				if successor_ptr -> mrds_open_name.right.thread then do;
					successor_parent_ptr -> mrds_open_name.left.thread = "1"b;
					successor_ptr -> mrds_open_name.right.thread = "0"b;
				     end;
				else successor_parent_ptr -> mrds_open_name.left.link =
					successor_ptr -> mrds_open_name.right.link;
				successor_ptr -> mrds_open_name.right.link = node_ptr -> mrds_open_name.right.link;

			     end;

		     end;

/* for all cases, change parent of delete node to point to it's new successor.
   determine which branch of delete node parent to change.
   the link from the parent will be a thread only if
   the delete node's links were both threads */

		if node_ptr = parent_ptr -> mrds_open_name.left.link then do;
			parent_ptr -> mrds_open_name.left.link = successor_ptr;
			parent_ptr -> mrds_open_name.left.thread = thread;
		     end;

		else do;
			parent_ptr -> mrds_open_name.right.link = successor_ptr;
			parent_ptr -> mrds_open_name.right.thread = thread;
		     end;


/* release deleted nodes space */

		call node_free (length (key), node_ptr);
		success = "1"b;

	     end;

	declare key		 char (*);	/* name to be searched for, and deleted */
	declare root_ptr		 ptr;		/* pointer to root of tree */
	declare success		 bit (1);		/* on => deletion accomplished */
	declare successor_ptr	 ptr;		/* points to successor node */
	declare successor_parent_ptr	 ptr;		/* points to successor parent */
	declare thread		 bit (1);		/* on => link is a thread not pointer */
	declare predecessor_ptr	 ptr;		/* pointer to previous in order */
	declare predecessor_parent_ptr ptr;		/* points to aprent of predecessor */
	declare parent_ptr		 ptr;		/* points to node parent */
	declare node_ptr		 ptr;		/* pointer to current element in tree */





     end;

tree_insert: procedure (key, root_ptr, node_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   Threaded binary tree insertion routine
   Given a pointer to the root of the desired list, a search is made
   for the key.
   If the key is found, the insertion fails to
   avoid duplicating keys.
   A successful insertion returns a pointer to
   the new tree node */

/* PARAMETERS:

   key - - (input) word to be inserted as key in new node

   root_ptr - - (input/output) pointer to root node of tree,
   will be modified on empty tree insert

   node_ptr - - (output) pointer to the node just inserted

   success - - (output) bit value indicating good insertion(on)
   or failure due to key duplication attempt(off)

*/


/* get pointer to inorder parent in tree */

	call tree_search (key, root_ptr, node_ptr, parent_ptr, success);

/*  A search success(key was found) means a duplication
   of keys is being attempted, return failure */

	if success then success = "0"b;

/* Normal insertion, get a new list element, and fill in the blanks */

	else do;
		success = "1"b;

		call node_allocate (length (key), node_ptr);
		node_ptr -> mrds_open_name.user_info.name = key;
		node_ptr -> mrds_open_name.right.thread = "1"b;
		node_ptr -> mrds_open_name.left.thread = "1"b;

/* Add the new element to the tree.
   Change the head pointer if empty tree */

		if root_ptr ^= null () then ;
		else do;

/* no dummy node for tree head, get new node for it,
   then make its right link a pointer to itself, and
   make it's left link a thread to itself thus indicating
   that the tree is empty */

			call node_allocate (length (key), root_ptr);

			root_ptr -> mrds_open_name.right.link = root_ptr;
			root_ptr -> mrds_open_name.right.thread = "0"b;

			root_ptr -> mrds_open_name.left.link = root_ptr;
			root_ptr -> mrds_open_name.left.thread = "1"b;

		     end;

/* dummy head node for tree exists for all cases now, but tree may still
   be empty(dummy node left link = thread), if so then force the
   dummy node to be a right parent of the new data node
   this is done by making the dummy node pointer serve as the
   new node parent and setting the dummy node key equal to
   the new node key so the test for descendent direction
   will cause a left insert to take place */

		if ^root_ptr -> mrds_open_name.left.thread then ;
		else do;
			parent_ptr = root_ptr;
			root_ptr -> mrds_open_name.user_info.name = key;
		     end;

/* good parent within tree, determine if node is right
   or left descendent.   right descendents have a left thread
   to their direct parent, and a right thread
   to their inorder successor. left descendents have a right
   thread to their direct parent, and a left thread
   to their inorder predecessor */

		if key > parent_ptr -> mrds_open_name.user_info.name then do;

			node_ptr -> mrds_open_name.right.link = parent_ptr -> mrds_open_name.right.link;
			node_ptr -> mrds_open_name.left.link = parent_ptr;

			parent_ptr -> mrds_open_name.right.link = node_ptr;
			parent_ptr -> mrds_open_name.right.thread = "0"b;

		     end;

		else do;

			node_ptr -> mrds_open_name.left.link = parent_ptr -> mrds_open_name.left.link;
			node_ptr -> mrds_open_name.right.link = parent_ptr;

			parent_ptr -> mrds_open_name.left.link = node_ptr;
			parent_ptr -> mrds_open_name.left.thread = "0"b;

		     end;


	     end;

	declare key		 char (*);	/* name to be inserted */
	declare root_ptr		 ptr;		/* points to root of tree */
	declare node_ptr		 ptr;		/* pointer to node created */
	declare success		 bit (1);		/* on => good insertion operation */
	declare parent_ptr		 ptr;		/* pointer to parent of new node */


     end;

tree_predecessor: procedure (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree inorder predecessor retrieval routine
   given a pointer to the current node in the tree
   ( set node_ptr = root_ptr to get last tree element )
   and a pointer to the root of the tree
   a pointer to it's inorder predecessor and that nodes parent
   are returned with a success indication, or
   when end of tree(no more predecessors) or empty tree is detected,
   a failure indication is returned */

/* PARAMETERS:

   root_ptr - - (input) pointer to root of desired tree

   node_ptr - - (input) pointer to current for which the predecessor is desired

   predecessor_ptr - - (output) pointer to resulting inorder predecessor of current node

   predecessor_parent_ptr - - (output) pointer to predecessor node direct tree parent

   success - - (output) bit value that is on when predecessor found,
   and off when end of tree or empty tree is detected

*/



/* no current node means no predecessor */

	if node_ptr = null () then
	     success = "0"b;

	else do;

/* current node exists, if it's left link is a thread
   it is either a pointer to the root meaning no more predecessors
   (or empty tree when node_ptr was root_ptr)
   or it points to the current node's inorder predecessor */

		predecessor_parent_ptr = node_ptr;
		predecessor_ptr = node_ptr -> mrds_open_name.left.link;

		if node_ptr -> mrds_open_name.left.thread then

		     if predecessor_ptr = root_ptr then
			success = "0"b;
		     else success = "1"b;

		else do;

/* current node's left link is not a thread,
   go left from current node's left descendent until
   a right thread is found and return it's owner
   as the inorder predecessor */

			success = "1"b;

			do while (^predecessor_ptr -> mrds_open_name.right.thread);

			     predecessor_parent_ptr = predecessor_ptr;
			     predecessor_ptr = predecessor_ptr -> mrds_open_name.right.link;

			end;

		     end;


	     end;


	declare root_ptr		 ptr;		/* points to root of tree */
	declare node_ptr		 ptr;		/* points to node predecessor desired for */
	declare predecessor_ptr	 ptr;		/* pointer to preious node */
	declare predecessor_parent_ptr ptr;		/* parent of previous node ptr */
	declare success		 bit (1);		/* on => predecessor found */




     end;

node_allocate: procedure (key_length, node_ptr);

/* DESCRIPTION:

   routine to allocate the space needed for the opening name structure.
   The space where the allocations occur is a temp segment
   whose location is determined by set_mrd_temp_dir
   (the value before the first allocation in this routine)

*/

/* PARAMETERS:

   key_length - - (input) fixed bin(24), the length of the varying length
   name in the open name structure.

   open_model_type - - (input) char(1), the type of opening
   "r" => resultant model, "m" => db_model, "s" => submodel

   model_pointer - - (input) pointer, a pointer to the model for this opening type

   node_ptr - - (output) pointer, points to the newly allocated node

*/

/* initialize */

	if area_ptr = null () then
	     call init_work_area ();

	mrds_open_name_length_init = key_length;

	allocate mrds_open_name set (mrds_open_name_ptr) in (work_area);

	unspec (mrds_open_name) = "0"b;

	mrds_open_name.version = mrds_open_name_structure_version;
	mrds_open_name.user_info.name_length = key_length;
	mrds_open_name.mrds_info.opening_type = open_model_type;
	mrds_open_name.mrds_info.model_pointer = model_pointer;

	node_ptr = mrds_open_name_ptr;



	declare key_length		 fixed bin (24);	/* length of name */
	declare node_ptr		 ptr;		/* points to allocated tree element */

     end;

node_free: procedure (key_length, node_ptr);

/* routine to free a tree node allocated in the work area */


	mrds_open_name_length_init = key_length;

	free node_ptr -> mrds_open_name in (work_area);


	declare node_ptr		 ptr;		/* points to an allocated tree element */
	declare key_length		 fixed bin (24);	/* length of users name */

     end;

init_work_area: procedure ();

/* routine to make a temp seg in the user process dir */

	call get_temp_segment_ (program_name, area_ptr, error_code);
	if error_code ^= 0 then
	     goto skip_allocate;

	area_ptr -> work_area = empty ();

     end;

clean_up: procedure ();

/* routine to get rid of temp segment, after last name deleted
   it also re-initializes all critical internal static storage */

	if area_ptr ^= null () then do;

		call release_temp_segment_ (program_name, area_ptr, discard);

		area_ptr = null ();

		root_of_tree_ptr = null ();

		current_number_of_names = 0;

	     end;



	declare discard		 fixed bin (35);	/* unused error code */

     end;

	declare program_name	 char (32) init ("mu_open_name_manager"); /* name of calling program */
	declare root_of_tree_ptr	 ptr int static init (null ()); /* points to root of name tree */
	declare user_name		 char (*);	/* users name for this opening */
	declare error_code		 fixed bin (35);	/* error status endoing */
	declare mdbm_error_$too_many_open_names fixed bin (35) ext; /* more than space allows */
	declare mdbm_error_$open_name_not_known fixed bin (35) ext; /* name given not in tree */
	declare mdbm_error_$open_name_already_known fixed bin (35) ext; /* name already in tree */
	declare success		 bit (1);		/* on => operation succeded */
	declare parent_ptr		 ptr;		/* pointer to parent of node */
	declare model_pointer	 ptr;		/* pointer to resultant/model/submodel */
	declare open_model_type	 char (1);	/* r => resultant, m => model, s => submodel */
	declare ioa_		 entry options (variable); /* reports open name list */
	declare area_ptr		 ptr int static init (null ()); /* points to space for open names */
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr); /* space for open names */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare number_of_open_names	 fixed bin (24);	/* number of names displayed */
	declare current_number_of_names fixed bin (24) int static init (0); /* current count of names known */
	declare successor_ptr	 ptr;		/* points to next in tree "inorder" */
	declare area		 condition;	/* signaled when no space for names */
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets work space */
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets rid of temp pace */
	declare successor_parent_ptr	 ptr;		/* pointer to parent of next node */
	declare node_ptr		 ptr;		/* points to current node */
	declare sysprint		 file;		/* for debug output */
	declare (null, substr, length, empty, unspec) builtin;
	declare open_name_list_ptr	 ptr;		/* points to head of linked list of open names */
	declare open_name_list_size	 fixed bin (24);	/* number of elements in list */
	declare error_table_$area_too_small fixed bin (35) ext; /* not enough space in suers area */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area pointer */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* bad structure version */
	declare structure_version	 fixed bin;	/* desired version of structure */
	declare user_area_ptr	 ptr;		/* pointer to place to put list of names */
	declare predecessor_ptr	 ptr;		/* points to previous in list */
	declare predecessor_parent_ptr ptr;		/* points to parent of previous node */

%include mrds_open_name;

%include mrds_open_name_element;

%include mrds_debug_names;

     end;




		    mu_print_error.pl1              08/01/88  1421.8rew 08/01/88  1300.0       76653



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-08,Dupuis), install(88-08-01,MR12.2-1073):
     Written.
                                                   END HISTORY COMMENTS */


mu_print_error:
    proc (a_se_info_ptr);

/*   DESCRIPTION

   The purpose of this procedure is to try and print some form of intelligent
   error message from the parser when syntax errors are discovered in the
   parsing of a selection expression.

   HISTORY:

   84-11-05 Originally written by John Hergert (FMC).

   86-02-25 John Hergert: modified for new parser.

   INPUT CONDITIONS:

   se_info_ptr points to the se_info structure which has all the info to print


   OUTPUT DEFINITIONS:

   This routine calls ioa_ with a formatted selection expression and
   the error code generated in the parse after signalling mrds_se_error_.

*/

        se_info_ptr = a_se_info_ptr;

        if se_info.se_length = 0 then return;

        se_len = se_info.se_length;
        se_ptr = se_info.se_ptr;
        call init_sex;				/* make local copy of sex */

        on cleanup free sex in (work_area);

        if se_info.token_start > se_info.se_length
        then
	   raw_token_position, token_position = se_info.se_length;
        else raw_token_position, token_position = se_info.token_start;

        token_ptr = addcharno(se_info.se_ptr,se_info.token_start-1);

        call format_sex;

/* now put in the pointer to the offending token */

        current_NL = 1;
        done = "0"b;
        do while (^done);
	  next_NL = index (substr (sex || NL, current_NL), NL);
	  if token_position >= next_NL then do;
	      token_position = token_position - next_NL + 1;
	      current_NL = current_NL + next_NL;
	  end;
	  else do;
	      if current_NL + next_NL < length (sex)	/* we are not in the last line */
	      then sex =
		     substr (sex, 1, current_NL + next_NL - 1)
						/* first portion of se */
		     || copy (" ", token_position - 1) || "^"
		     || NL			/* the pointer */
		     || substr (sex, current_NL + next_NL);
						/* the second portion of the se */

	      else sex = sex || NL || copy (" ", token_position - 1) || "^";
	      done = "1"b;
	  end;
        end;

        call convert_status_code_ (se_info.error_code, short_message,
	  long_message);
						/* get english error message */

        msei.header.version = error_info_version;
        msei.header.action_flags.cant_restart = "0"b;
        msei.header.action_flags.default_restart = "1"b;
        msei.header.action_flags.quiet_restart = "0"b;
        msei.header.action_flags.support_signal = "1"b;
        msei.header.action_flags.pad = "0"b;
        msei.header.info_string = "";			/* used by default_error_handler_ */
        msei.header.status_code = se_info.error_code;
        msei.error_type = se_info.error_type;
        msei.error_msg = se_info.error_msg;
        msei.token = token;
        msei.raw_select_expr.se_ptr = se_info.se_ptr;
        msei.raw_select_expr.se_len = se_info.se_length;
        msei.raw_select_expr.token_position = raw_token_position;
        msei.formatted_select_expr.se_ptr = addr (sex);
        msei.formatted_select_expr.se_len = length (sex);
        msei.formatted_select_expr.token_position = token_position;
        msei.header.length = size (msei);

        call signal_ ("mrds_se_error_", null, addr (msei), null);
						/* see if anyone wants to handle it. */

/* if no one handles the signal the default_error_handler_ will just
   put the string "default_error_handler_" into info_string. */

        if msei.header.info_string = "default_error_handler_"
						/* user didnt handle it */
        then
	   call ioa_$ioa_switch (iox_$error_output,
	       "^2/Error: MRDS ^a error.^/^a^/^[^s^;^a^/^]^a^/",
	       rtrim (se_info.error_type), rtrim (long_message),
	       se_info.error_msg = " ", rtrim (se_info.error_msg),
	       rtrim (sex));

        free sex in (work_area);

        return;

print_se:
    entry (a_se_ptr, a_se_len);

/* entry to just print out formatted selection expression */

        if se_len ^= 0 then do;
	  se_ptr = a_se_ptr;
	  se_len = a_se_len;
	  call init_sex;				/* make a local copy of sex */
	  on cleanup free sex in (work_area);

	  call format_sex;
	  call ioa_ ("^/^a^/", rtrim (sex));
	  free sex in (work_area);
        end;

        return;

format_sex:
    proc;
						/*
						   procedure to format the selection expression by putting newlines in before
						   keywords
						*/
						/* put NL's in to sex before each keyword */

        do j = 1 to hbound (keyword.name, 1);		/* for each keyword */
	  if keyword.major_keyword (j) then do;
	      i = verify (sex, WHITE_SPACE) + 1;	/* start after the first keyword */
	      done = "0"b;
	      do while (^done);			/* until end of sex is reached */
		if i < length (sex) then do;
		    x = index (substr (sex, i), rtrim (keyword.name (j)));
		    if x ^= 0 then do;
		        sex = substr (sex, 1, x + i - 2) || NL
			  || substr (sex, x + i - 1);
		        i = x + i + 4;		/* skip past the NL and the token */
		    end;
		    else done = "1"b;
		end;
		else done = "1"b;
	      end;
	  end;
        end;



/* break each line into no more than 79 chars */

        current_NL = 1;
        done = "0"b;

        do while (^done);
	  if current_NL < length (sex) then do;
	      next_NL = index (substr (sex || NL, current_NL), NL);
	      if next_NL > 79 then do;
		i = index (reverse (substr (sex, 1, current_NL + 79)), SP);
		if i < 80 then do;
		    sex = substr (sex, 1, current_NL + 80 - i) || NL
		        || substr (sex, current_NL + 81 - i);
		    current_NL = current_NL + 82 - i;
		end;
		else done = "1"b;
	      end;
	      else if next_NL = 0
		 then done = "1"b;
		 else current_NL = current_NL + next_NL + 1;
	  end;
	  else done = "1"b;
        end;

    end format_sex;

init_sex:
    proc;

/* Since we are going to be manipulating the selection expression we need
   to make a local copy. Since we have no idea how big it is going to get
   we need to put it somewhere out of the way
*/

        work_area_ptr = get_system_free_area_ ();
        allocate sex in (work_area) set (sex_ptr);

        sex = arg_sex;

    end;

%include mrds_se_info;
%page;
%include mrds_dsl_keywords;
%page;
%include mrds_se_error_info;
%page;
%include condition_info_header;

/* ARGS */
dcl     a_se_info_ptr	 ptr parameter;
dcl     a_se_ptr		 ptr parameter;
dcl     a_se_len		 fixed bin (17) parameter;


/* LOCALS */

dcl     se_info_ptr		 ptr;
dcl     work_area_ptr	 ptr;
dcl     sex_ptr		 ptr;

dcl     1 msei		 aligned like mrds_se_error_info;
						/* the working copy */

dcl     short_message	 char (8) aligned;
dcl     long_message	 char (100) aligned;
dcl     token		 char (se_info.token_length) based (token_ptr);
dcl     token_ptr              ptr;

dcl     (raw_token_position, token_position, current_NL, next_NL, i, j, x)
			 fixed bin;
dcl     done		 bit;
dcl     WHITE_SPACE		 char (6) based (addr (WHITE_SPACE_data));
dcl     WHITE_SPACE_data	 (6) bit (9) unaligned internal static
			 options (constant)
			 init ("011"b3, "012"b3, "013"b3, "014"b3,
			 "015"b3, "040"b3);		/* HT LF VT FF CR SP */
dcl     NL		 char (1) based (addr(NL_data));
dcl NL_data bit(9) internal static options (constant) init("012"b3);
dcl     SP		 char (1) internal static options (constant)
			 init (" ");

dcl     se_ptr		 ptr;
dcl     se_len		 fixed bin;
dcl     arg_sex		 char (se_len) based (se_ptr);
dcl     sex		 char (se_len + 256) var based (sex_ptr);

dcl     mrds_data_$max_td_len	 fixed bin (35) ext;
dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
dcl     iox_$error_output	 ptr ext static;

dcl     cleanup		 condition;

dcl     (addcharno, addr, char, copy, fixed, hbound, index, length, ltrim, null, rel, reverse, rtrim,
        size, substr, verify)		 builtin;

dcl     work_area		 area based (work_area_ptr);

dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned,
			 char (100) aligned);
dcl     get_system_free_area_	 entry () returns (ptr);
dcl     ioa_		 entry () options (variable);
dcl     ioa_$ioa_switch	 entry () options (variable);
dcl     signal_		 entry (char (*), ptr, ptr, ptr);

    end mu_print_error;





		    mu_quiesce.pl1                  10/23/86  1024.8r w 10/23/86  1008.9      136314



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

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

mu_quiesce: proc;

/* HISTORY:

   Originally written by Al Kepner, March 1979.

   80-12-09 Jim Gray : changed method of getting dbc_ptr, so that a common
   routine could determine if AMDB -rs needed to be run to update the
   dbc structure versions.

   82-05-19 Mike Kubicar : modified to allow multiple database quiesces
   per process.  Also removed code that started to implement multiple
   quiesces per call.

   84-10-23 Paul Benjamin : changed to use a smaller lock wait time when 
   calling set_lock_$lock from the cleanup handler.
*/

/* DESCRIPTION:


   BEGIN_DESCRIPTION
   " N__a_m_e:  mu_quiesce
   "
   "      This  routine allows  the caller to  quiesce an  entire data
   " base   or  selected   files   for  such   purposes   as  dumping,
   " restructuring, or file ring changes. Files which are quiesced are
   " reserved  for the  exclusive use  of the  process which  does the
   " quiescing.
   "
   "
   " E__n_t_r_y:  mu_quiesce$quiesce_quiet
   "
   "
   "      This  entry is  called  to quiesce  an entire  data  base or
   " selected files.
   "
   "
   " U__s_a_g_e
   "
   "      dcl  mu_quiesce$quiesce_quiet entry (char (168), fixed bin (17),
   "	     fix bin (35));
   "
   "      call mu_quiesce$quiesce_quiet (database_pathname, wait_time, code);
   "
   " where:
   "
   " 1.   database_pathname    (Input)
   "             the pathname of the database to be quiesced.
   "
   " 2.   wait_time            (Input)
   "             the length of time (in seconds) to wait on locks.
   "
   " 3.   code                 (Output)
   "             is a standard system error code.  If the wait time is
   "             exceeded   the   error    code   returned   will   be
   "             mdbm_error_$db_busy.  The data base has been quiesced
   "             only  if a  0 error  code  is returned.   Other error
   "             codes     which    may     be     returned    include
   "             mdbm_error_$quiesced_dead_db (The data  base has been
   "             quiesced  by  a  process  which  no  longer  exists,)
   "             mdbm_error_$my_quiesced_db (Attempt to quiesce a data
   "             base  which   has  already  been   quiesced  by  this
   "             process,)  mdbm_error_$hold_quiesced_db  (Attempt  to
   "             quiesce a  data base before  previously quiesced data
   "             bases  have  been  freed,)
   "             mdbm_error_$trouble_lock (The data base is locked and
   "             may          be          inconsistent.)           and
   "             mdbm_error_$quiesce_too_few (The number of data bases
   "             to quiesce is negative or zero.)
   "
   "
   " N__o_t_e_s
   "
   "      Only one user  at a time may quiesce a given
   " data base.  The  data base is locked against  further attempts to
   " quiesce  until  mu_quiesce$quiesce_free  is  called by  the  same
   " process which first called mu_quiesce$quiesce_quiet.
   "
   "
   " E__n_t_r_y:  mu_quiesce$quiesce_free
   "
   "
   "      This entry  is called to  free the files or  data base which
   " have been quiesced.
   "
   "
   " U__s_a_g_e
   "
   "      dcl  mu_quiesce$quiesce_free entry (char (168), fixed bin(35));
   "
   "      call mu_quiesce$quiesce_free (database_pathname, code);
   "
   " where:
   "
   " 1.   database_pathname    (Input)
   "             the pathname of the database to be freed.
   "
   " 2.   code                 (Output)
   "             is a  standard system error code.   Error codes which
   "             may be returned  include mdbm_error_$quiesced_db (The
   "             data  base  has been  quiesced  by another  process,)
   "             mdbm_error_$quiesced_dead_db (The data  base has been
   "             quiesced  by  a  process  which  no  longer  exists,)
   "             mdbm_error_$trouble_lock (The data base is locked and
   "             may          be           inconsistent,)          and
   "             mdbm_error_$free_not_quiesced (Attempt to free a data
   "             base which was not quiesced.)
   "
   "
   END_DESCRIPTION

*/

quiesce_quiet: quiet: entry (db_path, quiesce_wait_time, code);
	dcl     db_path		 char (168);
	dcl     quiesce_wait_time	 fixed bin (17);
	dcl     code		 fixed bin (35) parm;

/* Initialization: */
	hold_ul_ptr, dbc_ptr = null ();
	handling_a_cleanup = "0"b;
	on cleanup begin;
	     handling_a_cleanup = "1"b;
	     call tidy_up;
	end;
	code = 0;

/* Obtain a pointer to the dbc (dbc_ptr). */
	call get_dbc_ptr (bc, dbc_ptr);

/* Lock the db against other attempts to quiesce. */
	call set_lock_$lock (dbc.quiesce_lock,
	     quiesce_wait_time,
	     icode);
	if icode ^= 0 then do;
		if icode = error_table_$lock_wait_time_exceeded
		then call error (mdbm_error_$db_busy);
		if icode = error_table_$invalid_lock_reset
		then do;
			dbc.trouble_switch = "1"b;
			call error (mdbm_error_$quiesced_dead_db);
		     end;
		if icode = error_table_$locked_by_this_process
		then call error (mdbm_error_$my_quiesced_db);
		call error (icode);
	     end;

	time_remaining = quiesce_wait_time;
	go to check_opens;

	do while (time_remaining > 0);

/* Sleep for 30 seconds. */
	     time_remaining = time_remaining - 30;
	     call timer_manager_$sleep (30, "11"b);

check_opens:   ;

/* Lock open_lock using the wait time suppied. */
	     call set_lock_$lock (dbc.open_lock,
		quiesce_wait_time,
		icode);
	     if icode ^= 0 then do;
		     if icode = error_table_$lock_wait_time_exceeded
		     then call error (mdbm_error_$db_busy);
		     if icode = error_table_$invalid_lock_reset
		     then do;
			     dbc.trouble_switch = "1"b;
			     call error (mdbm_error_$trouble_lock);
			end;
		     else call error (icode);
		end;

/* Check for potentially inconsistent data base. */
	     if dbc.trouble_switch then do;
		     call set_lock_$unlock (dbc.open_lock, icode);
		     call error (mdbm_error_$trouble_lock);
		end;

/* Determine if any users have the db open. */
	     if dbc.open_users = 0 then go to quiesce_db_ok;

/* Unlock open_lock. */
	     call set_lock_$unlock (dbc.open_lock, icode);
	     if icode ^= 0 then call error (icode);
	end;

/* The wait time has been exceeded. */
	call error (mdbm_error_$db_busy);

quiesce_db_ok: ;
	quiesce_sw = "1"b;
	quiesce_db = "1"b;

/* Add information about the quiescing process to the users list. */
	num_filns = 0;
	allocate user_list in (dbc.static_area) set (hold_ul_ptr);
	ul_ptr = hold_ul_ptr;
	call get_lock_id_ (user_list.db_lock_id);
	if icode ^= 0 then call error (icode);
	user_list.rdbi_bits = "0"b;
	user_list.num_filns = 0;
	user_list.fil_list_ofs = NULL_OFS;
	user_list.next_active_ofs = NULL_OFS;
	user_list.next_waiting_ofs = NULL_OFS;
	user_list.next_open_ofs = dbc.open_users_ofs;	/* Add user to list of data base
						   open users. */
	dbc.open_users_ofs = rel (ul_ptr);
	user_list.group_id = get_group_id_ ();
	user_list.open_mode = mdbm_data_$quiesce_mode;
	user_list.bypass_count = 0;
	user_list.allowance_count = 0;
	user_list.process_id = get_process_id_ ();
	user_list.ev_chn_id = 0;
	user_list.dead_proc = "0"b;
	user_list.dead_proc_conflict = "0"b;
	user_list.priority_high = "0"b;
	user_list.waiting_sw = "0"b;
	user_list.active_sw = "0"b;
	user_list.event_signal_sw = "0"b;
	user_list.passive_sw = "1"b;			/* assume passivity */
	call set_lock_$unlock (dbc.open_lock, icode);
	if icode ^= 0 then call error (icode);
	go to common_exit;

quiesce_free: free: entry (db_path, code);

/* Initialization: */
	hold_ul_ptr, dbc_ptr = null ();
	handling_a_cleanup = "0"b;
	on cleanup begin;
	     handling_a_cleanup = "1"b;
	     call tidy_up;
	end;
	code = 0;

/* Obtain a pointer to the dbc (dbc_ptr). */
	call get_dbc_ptr (bc, dbc_ptr);

/* Make sure quiesce_lock was locked by this process.
   If not give an appropriate error code and return. */

	call get_lock_id_ (lock_id);
	if dbc.quiesce_lock ^= lock_id
	then do;
		call set_lock_$lock (dbc.quiesce_lock,
		     0, icode);
		if icode = 0
		then do;
			call free_db;
			call error (mdbm_error_$free_not_quiesced);
		     end;
		else if icode = error_table_$invalid_lock_reset
		then do;
			dbc.trouble_switch = "1"b;
			call error (mdbm_error_$quiesced_dead_db);
		     end;
		else if icode = error_table_$lock_wait_time_exceeded
		then call error (mdbm_error_$quiesced_db);
		else call error (icode);
	     end;
	else do;
		call free_db;
	     end;
common_exit: ;
	return;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from NULL_OFS to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the resultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

delete_quiesce_user_from_list: proc;

/* This routine deletes the quiesce user entry out of the list of open
   users.  It is called in response to (1) most errors, (2) the cleanup condition,
   and (3) the mu_quiesce$free entry point. */

	previous_ul_ptr = null ();
	proc_id = get_process_id_ ();
	do ul_ptr = convert (dbc_ptr, dbc.open_users_ofs)
	     repeat convert (dbc_ptr, user_list.next_open_ofs)
	     while (ul_ptr ^= null ());
	     if user_list.process_id = proc_id
		& user_list.open_mode = mdbm_data_$quiesce_mode
	     then do;
		     hold_ul_ptr = ul_ptr;
		     if previous_ul_ptr = null ()
		     then dbc.open_users_ofs = user_list.next_open_ofs;
		     else previous_ul_ptr -> user_list.next_open_ofs = user_list.next_open_ofs;
		     go to free_user_storage;
		     dcl	   proc_id	      bit (36); /* process_id of this process. */
		     dcl	   previous_ul_ptr	      ptr;/* ptr to the user_list entry which precedes the current one */
		end;
	     previous_ul_ptr = ul_ptr;
	end;
free_user_storage: ;
	if hold_ul_ptr ^= null ()
	then free hold_ul_ptr -> user_list in (dbc.static_area);
	return;
     end delete_quiesce_user_from_list;

error: proc (cd);
	dcl     cd		 fixed bin (35) parm;
	code = cd;
	call tidy_up;
	go to common_exit;
     end error;

free_db: proc;
	call set_lock_$lock (dbc.open_lock,
	     mdbm_data_$lock_wait, icode);
	if icode ^= 0 then do;
		if icode = error_table_$lock_wait_time_exceeded
		then call error (mdbm_error_$db_busy);
		if icode = error_table_$invalid_lock_reset
		then do;
			dbc.trouble_switch = "1"b;
			call error (mdbm_error_$trouble_lock);
		     end;
		else call error (icode);
	     end;

/* Check for potentially inconsistent data base. */
	if dbc.trouble_switch then do;
		call set_lock_$unlock (dbc.open_lock, icode);
		call error (mdbm_error_$trouble_lock);
	     end;
	quiesce_sw = "0"b;
	quiesce_db = "0"b;
	call delete_quiesce_user_from_list;
	call set_lock_$unlock (dbc.open_lock, icode);
	if icode ^= 0 then call error (icode);
	call set_lock_$unlock (dbc.quiesce_lock, icode);
	if icode ^= 0 then call error (icode);
	return;
     end free_db;

get_dbc_ptr: proc (bc, dbc_ptr);
	dcl     bc		 fixed bin (24) parm;
	dcl     dbc_ptr		 ptr parm;

/* Use the data base pathname supplied in the quiesce data structure to
   obtain a pointer to the dbc. */

	call mu_concurrency_control$open_control_segment (db_path,
	     dbc_ptr, bc, icode);
	if icode ^= 0 then
	     call error (icode);

	return;
     end get_dbc_ptr;

tidy_up: proc;

/* This routine is called when any error occurs and for the
   cleanup condition. It attempts to leave the dbc in a non quiesced state. */
	if code = mdbm_error_$my_quiesced_db then return;
	if code = mdbm_error_$hold_quiesced_db then return;
	if code = mdbm_error_$quiesce_too_few then return;
	if dbc_ptr = null () then return;
	call get_lock_id_ (lock_id);
	if dbc.quiesce_lock ^= lock_id
	then return;
	if handling_a_cleanup
	     then call set_lock_$lock (dbc.open_lock,	/* mdbm_data_$lock_wait is too */
	     mdbm_data_$cleanup_lock_wait, icode);	/* long for a cleanup handler */
	else call set_lock_$lock (dbc.open_lock,
	     mdbm_data_$lock_wait, icode);
	if icode = 0 | icode = error_table_$locked_by_this_process
	then do;
		quiesce_sw = "0"b;
		quiesce_db = "0"b;
		call delete_quiesce_user_from_list;
		call set_lock_$unlock (dbc.open_lock, icode);
		call set_lock_$unlock (dbc.quiesce_lock, icode);
	     end;
     end tidy_up;

/* VARIABLES FOR MU_QUIESCE */
	dcl     bc		 fixed bin (24);
	dcl     cleanup		 condition;
	dcl     error_table_$invalid_lock_reset ext fixed bin (35);
	dcl     error_table_$lock_wait_time_exceeded ext fixed bin (35);
	dcl     error_table_$locked_by_this_process ext fixed bin (35);
	dcl     get_group_id_	 entry returns (char (32));
	dcl     get_lock_id_	 entry (bit (36) aligned);
	dcl     get_process_id_	 entry returns (bit (36));
	dcl     handling_a_cleanup     bit (1) aligned;
	dcl     hold_ul_ptr		 ptr;		/* ptr to user_list entry when newly allocated
						   or about to be freed. */
	dcl     icode		 fixed bin (35);
	dcl     lock_id		 bit (36) aligned;
	dcl     mdbm_data_$cleanup_lock_wait ext fixed bin (17);
	dcl     mdbm_data_$lock_wait	 ext fixed bin (17);
	dcl     mdbm_data_$quiesce_mode ext fixed bin (17);
	dcl     mdbm_error_$db_busy	 ext fixed bin (35);
	dcl     mdbm_error_$free_not_quiesced ext fixed bin (35);
	dcl     mdbm_error_$hold_quiesced_db ext fixed bin (35);
	dcl     mdbm_error_$my_quiesced_db ext fixed bin (35);
	dcl     mdbm_error_$quiesce_too_few ext fixed bin (35);
	dcl     mdbm_error_$quiesced_db ext fixed bin (35);
	dcl     mdbm_error_$quiesced_dead_db ext fixed bin (35);
	dcl     mdbm_error_$trouble_lock ext fixed bin (35);
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));
	dcl     sys_info$max_seg_size	 ext fixed bin (35);
	dcl     time_remaining	 fixed bin (71);
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     mu_concurrency_control$open_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35)); /* opens dbc_ptr */
	dcl     (fixed, null, rel) builtin;

%include mdbm_dbc;

%include mdbm_users;
     end mu_quiesce;




		    mu_rel_statistics.pl1           04/18/85  1437.3re  04/18/85  0908.6       60039



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
mu_rel_statistics: proc;

/*
                   BEGIN_DESCRIPTION
  This module calls the various relation manager routines to  get  a
  relations's  statistics.  There  are  two types of routines, those
  that return statistics and the one that records the statistics  in
  the        resultant.       The       main       entry       point
  mu_rel_statistics$mu_rel_statistics should never be called.


  The entry return_tuple_count returns an exact count of the  number
  of  tuples  in  the  relation.


  The  entry  record_statistics records the number of duplicates for
  each  indexed  attribute  in  the  number_of_dups  element  in the
  attribute's  rm_attr_info  structure.  It also records an estimate
  of the total  number of  tuples    in    the   relation   in   the
  current_tuple_population  element  of  the  relation's rm_rel_info
  structure.   The statistics on when the statistics  were collected
  (also  in  rm_rel_info) are also upgraded.  Since things are being
  recorded  in  the  resultant structures the database must be open.
  Cursors  are  obtained  via mu_cursor_manager_ so that they may be
  saved  and  used  later  (or  reused  if  they  have  already been
  created).

  Known Bugs:

  Other Problems:

  History:
      82-09-24 Davids: written

      82-10-18 Davids: corrected the parameter list of the record_statistics
      entry to include the parameter relmgr_get_count - it had been left out

      83-05-23 Mike Kubicar : new relation manager calling sequences and
      relation cursor changes.

      83-09-20 Ron Harvey: changed record_statistics entry so that it uses its
      new relmgr_get_population parameter in preference to relmgr_get_count.

                   END_DESCRIPTION
*/
%page;
/* PARAMETERS */

	dcl     cursor_ptrs_storage_ptr ptr;		/* (input) pointer to storage where cursor_ptrs to */
						/*         <rel_opening_id-collection_index-tuple_variable> */
						/*        mappings are kept */
	dcl     cursor_storage_area_ptr ptr;		/* (input) pointer to where the cursors will be allocated */
	dcl     dbi		 fixed bin (35);	/* (input) index of an open database */
	dcl     last_s_e_id_num	 fixed bin (35);	/* (input) identifer for last selection expression seen */
	dcl     Prmri_ptr		 ptr;		/* (input) pointer to the relation's rm_rel_info structure */
						/*         needed because rmri_ptr is "P" */
						/*         dcl'ed in the incl file */
	dcl     relmgr_create_cursor	 entry (bit (36) aligned, ptr, ptr, fixed bin (35));
						/* (input) entry used to create a cursor */
	dcl     relmgr_get_count	 entry (ptr, ptr, fixed bin (35), fixed bin (35));
						/* (input) entry used to count tuples in a relation */
	dcl     relmgr_get_duplicate_key_count entry (ptr, bit (36) aligned, fixed bin (17), fixed bin (35), fixed bin (35));
						/* (input) entry used to count duplicates within a key */
	dcl     relmgr_get_population	 entry (ptr, fixed bin (35), fixed bin (35));
						/* (input) entry used to get estimeated 'population' of a relation */
	dcl     relmgr_open		 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
						/* (input)entry used to open a relation */

	dcl     code		 fixed bin (35);	/* (output) standard error code */
	dcl     tuple_count		 fixed bin (35);	/* (output) number of tuples in the relation */

/* AUTOMATIC */

	dcl     i			 fixed bin;	/*loop index */
	dcl     cursor_ptr		 ptr;		/* pointer to a cursor */


/* CONSTANTS */

	dcl     ALL_THE_ATTRIBUTES	 fixed bin init (1) internal static options (constant);
						/* all one fields in an index will be considered */
						/* when looking for duplicates */
	dcl     DEFAULT_TUPLE_VARIABLE fixed bin (35) init (0) internal static options (constant);

/* BUILTINS */

	dcl     clock		 builtin;
	dcl     null		 builtin;

/* ENTRIES */

	dcl     mu_cursor_manager_$get entry (fixed bin (35), ptr, fixed bin (35), bit (36) aligned, entry, entry, ptr, ptr,
				 ptr, fixed bin (35));

/* INCLUDES */
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
return_tuple_count: entry (dbi, relmgr_create_cursor, relmgr_open, relmgr_get_count,
	cursor_ptrs_storage_ptr, cursor_storage_area_ptr, Prmri_ptr, tuple_count, code);

	rmri_ptr = Prmri_ptr;
	call mu_cursor_manager_$get (dbi, rmri_ptr, DEFAULT_TUPLE_VARIABLE,
	     rmri_ptr -> rm_rel_info.rel_id,
	     relmgr_create_cursor, relmgr_open, cursor_ptrs_storage_ptr,
	     cursor_storage_area_ptr, cursor_ptr, code);

	if code = 0
	then call relmgr_get_count (cursor_ptr, null (), tuple_count, code);

	if code ^= 0
	then tuple_count = 0;

	goto exit;
%page;
record_statistics: entry (dbi, relmgr_create_cursor, relmgr_open, relmgr_get_duplicate_key_count, relmgr_get_population, relmgr_get_count,
	cursor_ptrs_storage_ptr, cursor_storage_area_ptr, Prmri_ptr, last_s_e_id_num, code);

/* This entry will use the relmgr_get_population procedure for an 'estimated' count
   of the number of tuples in the relation. If the 'estimated' count is ZERO,
   then the relmgr_get_count procedure will be used for the actual count. */

	rmri_ptr = Prmri_ptr;
	call mu_cursor_manager_$get (dbi, rmri_ptr, DEFAULT_TUPLE_VARIABLE,
	     rmri_ptr -> rm_rel_info.rel_id,
	     relmgr_create_cursor, relmgr_open, cursor_ptrs_storage_ptr,
	     cursor_storage_area_ptr, cursor_ptr, code);
	if code ^= 0
	then goto exit;

	do i = 1 to rmri_ptr -> rm_rel_info.num_attr;
	     rai_ptr = rmri_ptr -> rm_rel_info.attr_ptrs (i);
	     if rai_ptr -> rm_attr_info.index_attr
	     then do;
		     call relmgr_get_duplicate_key_count (cursor_ptr,
			rai_ptr -> rm_attr_info.index_id,
			ALL_THE_ATTRIBUTES,
			rai_ptr -> rm_attr_info.number_of_dups, code);
		     if code ^= 0
		     then goto exit;
		end;
	end;

	call relmgr_get_population (cursor_ptr, rmri_ptr -> rm_rel_info.current_tuple_population, code);
	if code ^= 0 then goto exit;

	if rmri_ptr -> rm_rel_info.current_tuple_population = 0
	then do;					/* make certain */
		call relmgr_get_count (cursor_ptr, null (), rmri_ptr -> rm_rel_info.current_tuple_population, code);
		if code ^= 0
		then goto exit;
	     end;

	rmri_ptr -> rm_rel_info.last_statistics_update_count = 1;
	rmri_ptr -> rm_rel_info.last_statistics_update_time = clock ();
	rmri_ptr -> rm_rel_info.last_statistics_update_s_e_ref_num = last_s_e_id_num;

exit:
	return;
%page;
     end mu_rel_statistics;




		    mu_release_area.pl1             04/18/85  1437.3re  04/18/85  0908.6       20862



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - March 1980
   Made to do something by R. Harvey - 27 January 1982
   Made not to do anything by R. Harvey - 7 February 1982

*/

mu_release_area:
release_area:
     procedure (area_ptr);

/* DESCRIPTION:

   This is a strategy module for the handling of the temporary storage
   areas used by the five access entries dsl_$store, modify, delete,
   retrieve, and define_temp_rel. it is called at the end of each call
   to the particular module, with a pointer to that modules temporary
   area, and then this module may do a release_area_, truncate_seg_,
   or whatever seems more appropiate, and efficient.
   Currently nothing is done in this routine, and the individual
   dsl_ entries mentioned do a define_area_ over the existing area,
   and only at close time is release_area_ called, in order to promote
   best efficiency.

*/

/* PARAMETERS:

   area_ptr - - (input/output) pointer, one of the five pointers in the
   mrds_dbcb.incl.pl1, store_area_ptr, modify_area_ptr, delete_area_ptr,
   retrieve_area_ptr, def_temp_rel_area_ptr. it should not be null.
   NOTE: this procedure should only by called if the area is the whole
   segment.
   if release_area_ is called with this pointer, the pointer should be
   set to null before returning.

*/

	declare area_ptr		 ptr parameter;	/* input parameter to area to be "released" */



     end;




		    mu_retrieve.pl1                 08/01/88  1347.6r w 08/01/88  1315.0      212652



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

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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-06-14 by Thanh
     Nguyen. (see mrds #137)
  2) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-10-13 by John
     Hergert. (see mrds #138, phx19901)
                                                   END HISTORY COMMENTS */


mu_retrieve: proc (dbcb_ptr, area_ptr, rti_ptr, search_spec_ptr_parm,
	cvla_ptr_parm, tid_ptr, tuple_var_name, whole_stv_ptr,
	simple_typed_vector_ptr_parm, id_list_ptr_parm, code);

/* NOTES:

   This  procedure  retrieves  the  next  tuple  within the current range which
   satisfies the specified constraints.

*/
%page;
/* HISTORY:

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

   79-03-28 Al Kepner: Modified to return the located  tuple_id  for
   the restricted range case.

   79-05-17 Al Kepner: Modified to add entries db_on & db_off.

   79-06-21 Al Kepner: Partially rewritten to provide for comparison
   between two values from the same tuple.

   79-08-21 NSDavids: Comparison of  the  operands  (which  was  not
   always  done  correctly  if  they were of different scales and/or
   precisions) was replaced by a call to mu_compare_values.

   79-12-01 Rickie E.  Brinegar:  Modified  to  use  mrds_debug_tool
   switches instead of the entry points db_on & db_off.

   80-02-01 Jim Gray: Modified to add area_ptr parameter.

   80-02-15 Davids: Modified added data_ptr to the parameter list as
   output.  this  is  a  pointer  to  tuple.data  which is needed by
   mrds_dsl_search for determining the value of varying attributes.

   80-03-25 R. Lackey: Modified to remove calls to mdbm_util_

   80-05-08  Davids:  modified  assignments  of  tuple_num_atts  and
   tuple_nvar_atts  to  take  values from rm_rel_info.model_num_attr
   and  model_nvar_atts   rather   than   rm_rel_info.num_attr   and
   nvar_atts.  This  was  to  fix  a problem with submodels were the
   submodel view did not contain a varying string attribute and  the
   model did.

   80-10-30 M. Pierret: Modified to align 'match' for efficiency  of
   call to mu_compare_values.

   81-02-20 Rickie E. Brinegar: Changed calls to  mdb_display_value_
   to be calls to mdb_display_data_value$ptr. The latter allows more
   that 256 characters to be displayed.

   81-03-27 Jim Gray : changed dbi parameter to  dbcb_ptr,  and  for
   the  mu_sec_get_tuple  routines called, changed the dbi parameter
   to both dbcb_ptr and rmri_ptr. This is part of getting rid of the
   mus_ptr_man module.

   81-05-21   Jim   Gray   :   changed   placement   of   call    to
   mu_comapre_values,  so that if an error occured, the debug output
   about what the values were, gets  displayed.  This  was  done  to
   improve  the  information  in  the error message about conversion
   problems from mu_compare_values. Also added display of data  type
   for the value displayed, for the non-zero error code case.

   81-05-28 Jim Gray : commented out code dealing wiith foreign  key
   thread chasing.

   81-06-01 Jim Gray : changed to use new resultant structure.


   81-06-17 Jim Gray : added iocb index param to mu_sec_get_tuple$id
   so that key retrieves do not need to use dedicated update iocb.

   81-10-19 Davids: deleted many declared but unreferenced variables
   and also a couple of include files that were never used. modified
   the internal routine get_comparison_value to call add_bit_offset_
   rather  than  overlaying  a  bit  array  and  taking  the addr of
   bit_array (offset), this because there is a pl1 bug which  causes
   an  incorrect  addr to be returned when the code is compiled with
   the prefix subscriptrange (see tr11784)

   82-09-03 Mike Kubicar : Converted the module to use the simple vector
   structure instead of the tuple structure.

   82-10-26 Davids: changed the call to mu_sec_get_tuple$id to pass the
   rtrv_info.record_collection_cursor_ptr instead of the cursor_ptr.

   82-10-28 Davids: Modified the calls to mu_sec_get_tuple$next and $id
   to use the dbcb.select_area_ptr instead of the area_ptr which is an
   input parameter. The select_area does not get reinitialized until the
   selection expression changes, the area pointed to be the input param
   gets reinitialized at every call of retrieve (or delete or modify)

   83-04-25 Mike Kubicar : There is no longer any distinction between
   getting tuple sequentially and getting them via a key list.  Removed
   mu_sec_get_tuple$* calls and replaced it with a single internal
   procedure to get the next tuple via a search specification.

   83-04-28 Davids: Removed dcls for mu_sec_get_tuple$next and id.
   added a dcl for the builtin empty.

   83-05-24 R. Harvey: Changed to use the appropriate simple_typed_vector_ptr
   and id_list_ptr that are now passed in as arguments.

   83-05-31 Mike Kubicar : Updated to use new relation manager calling
   sequence and search specification.

   83-08-03 Mike Kubicar : This program will no longer free the element
   id list after returning from relation manager.  It uses the static
   list set up by search program generation.

   84-08-07 Thanh Nguyen : Added code to check and call the user's decoded 
   procedure of an attribute (if it is required), in case of the exp_ptr 
   is null.

   85-01-15 Thanh Nguyen : Added code to check error code after calling 
   get_comparison_value and handle the case of uncessful allocation by reset
   the work area.  Modified get_comparison_value procedure to call
   mrds_space_allocate function instead of the standard PL/I allocate.  Added
   two include files (mrds_space_allocate and mrds_area_initialize).

   85-01-25 Thanh Nguyen & John Hergert : Added code to check and continue
   to get the next tuple when the get_next_tuple subroutine received the
   mrds_error_$inconsistent_data_length.  This error is caused by the deleted
   tuple in the share mode while getting the tuple by its tuple-id.

   85-04-14 Thanh Nguyen: Added code to detect the case of the scope that is 
   changed  from non-shared to shared mode.

   85-06-14 Thanh Nguyen: Added code to check for the scope that is changed
   from non-shared to shared mode only if the dbcb.scopes_changed is on (This
   flag is set by mrds_dsl_set_scope and reset by mrds_dsl_gen_srch_prog and
   mrds_dsl_optimize

   85-10-13 John Hergert: Backed out some changes made in fix of
   84-08-02. This was done to fix TR's phx11536 and phx19901
*/

/* PARAMETERS:
   dbi -- (INPUT) data base index

   rti_ptr -- (INPUT) pointer to rtrv_info

   search_spec_ptr_parm -- (INPUT) pointer to the search spec to use for
   the retrieval.  Note that the search spec may be changed from an
   absolute to relative spec during this call.

   cvla_ptr_parm -- (INPUT) pointer to list of comparison values

   tid_ptr -- (INPUT) pointer to place that tuple_id of retrieved tuple
   will be stored.

   tuple_var_name -- (INPUT) name of the tuple variable for which retrieval
   is done (used for debugging only)

   whole_stv_ptr -- (INPUT) pointer to simple_typed_vector of whole view of
   relation.

   simple_typed_vector_ptr -- (INPUT) pointer to newly retrieved tuple

   id_list_ptr_parm -- (INPUT) pointer to id_list structure which corresponds to
   simple_typed_vector_ptr -> simple_typed_vector.

   code -- (OUTPUT) error code */

/* MRDS_DEBUG_TOOL SWITCHES:

   bit 1 = display values compared.
   bit 2 = display tuple data.
   bits 3 through 9 = not used.
*/
%page;
	display_values_compared = substr (db_mu_retrieve, 1, 1);
	display_tuple_data = substr (db_mu_retrieve, 2, 1);
	cvla_ptr = cvla_ptr_parm;
	id_list_ptr = id_list_ptr_parm;
	simple_typed_vector_ptr = simple_typed_vector_ptr_parm;

	rmri_ptr = rtrv_info.ri_ptr;
	k = 0;
	ta_ptr = rtrv_info.ta_ptr;
	ta_nids = rtrv_info.ntids;

	found = "0"b;
	do while (^found);				/* loop until find approp. tuple */

	     call get_next_tuple (dbcb_ptr, rti_ptr,
		search_spec_ptr_parm, simple_typed_vector_ptr, tuple_id);
	     found = "1"b;


/* Now that we've got one, see if it matches the rest of the constraints */

	     i, j = 0;
	     if cvla_ptr ^= null then do;		/* if comparisons to be made */

		     work_area_ptr = dbcb.work_area_ptr;
		     match = "0"b;
		     do i = 1 to cvl_array.nlists while (^match); /* loop through and groups */
			cvl_ptr = cvl_array.list_ptr (i);
			match = "1"b;
			do j = 1 to comp_val_list.nvals while (match); /* loop through and group items */

			     desc_ptr1 = addr (comp_val_list.val.desc1 (j));
			     desc_ptr2 = addr (comp_val_list.val.desc2 (j));
			     need_to_free_user_value = "0"b;
GET_COMPARISON_VALUE:
			     call get_comparison_value (
				comp_val_list.val.exp_ptr (j),
				null(),
				comp_val_list.val.erslt_ptr (j),
				comp_val_list.val.attr_ind (j),
				desc_ptr1,
				di_ptr,
				icode);
			     if icode = error_table_$noalloc
			     then do;
				     call mrds_area_initialize (work_area_ptr);
				     go to GET_COMPARISON_VALUE;
				end;
			     if comp_val_list.val.match_ptr (j) = null () /* compare to value from current tuple. */
			     then do;
				     call get_comparison_value (
					comp_val_list.val.exp_ptr2 (j),
					comp_val_list.val.c_ai_ptr2 (j),
					comp_val_list.val.erslt_ptr2 (j),
					comp_val_list.val.attr_ind2 (j),
					desc_ptr2,
					di_ptr2,
					icode);
				     if icode = error_table_$noalloc then do;
					     call mrds_area_initialize (work_area_ptr);
					     go to GET_COMPARISON_VALUE;
					end;
				end;
			     else do;		/* compare to value not from current tuple */
				     di_ptr2 = comp_val_list.val.match_ptr (j);
				end;		/* compare to value not from current tuple */

			     call mu_compare_values (di_ptr, desc_ptr1, di_ptr2, desc_ptr2,
				comp_val_list.val.op (j), match, code);

			     if display_values_compared | code ^= 0 then do;
				     if display_values_compared then
					call ioa_ ("di_ptr = ^p; di_ptr2 = ^p", di_ptr, di_ptr2);
				     if display_values_compared then
					call ioa_ ("Compared: ");
				     else call ioa_ ("Compared the data type:  ^a", mu_display_descriptor (desc_ptr1));
				     call mdb_display_data_value$ptr (di_ptr, desc_ptr1);
				     call ioa_ ("Using the comparison operator ""^a"" to:", rtrim (CVL_ops (comp_val_list.val.op (j))));
				     if ^display_values_compared then
					call ioa_ ("The data type:  ^a", mu_display_descriptor (desc_ptr2));
				     call mdb_display_data_value$ptr (di_ptr2, desc_ptr2);
				end;		/* if debug_switch */

			     if code ^= 0
			     then call error (code);
			     if need_to_free_user_value then
				free value_for_user;
			end;			/* comparing attr. in and group */
		     end;				/* comparing and group with or group */
		     found = match;
		end;				/* if had comparisons */
	     if display_tuple_data then do;
		     call mdb_display_tuple_$data (simple_typed_vector_ptr, rmri_ptr, iox_$user_output, icode);
		     if icode ^= 0 then call error (icode);
		     if found
		     then call ioa_ ("Tuple Accepted for ""^a""", tuple_var_name);
		     else call ioa_ ("Tuple Rejected for ""^a""", tuple_var_name);
		end;				/* if debug switch */
	end;					/* search for tuple */

	code = 0;

exit:
	return;
%page;
get_next_tuple:
     proc (dbcbptr, retrieve_info_ptr, search_spec_ptr,
	simple_typed_vector_ptr, tuple_id);

/**********
*
*   This routine will get the next tuple from a relation.  It needs to call
*   get_tuple_id followed by get_tuple_by_id since mrds needs both the
*   tuple id and the tuple in many cases.  It tries to use relation manager
*   as efficiently as is reasonable.  To do so, it gets as many tuple ids as
*   it can by one call to relation manager get_tuple_id.  It will then return
*   the first tuple in the list of ids by getting the tuple by id.  On
*   successive calls, it will use the other tuple ids in the list.  When
*   it has run out of tuple ids, it will get more by calling $get_tuple_id
*   again.  The routine effectively buffers tuple ids.  The routine uses
*   the following parameters:
*
*   dbcbptr  (input)  - Pointer to the dbcb
*   retrieve_info_ptr (input) - Pointer to the retrieve info to be used
*       on this retrieval.  Note that the rtrv_info structure may be
*       modified by this procedure.
*   search_spec_ptr (input) - The relation_search_specification to be used
*       in the search.  Note that the search spec pointed at may be modified by
*       this procedure.
*   simple_typed_vector_ptr (output) - The tuple which was retrieved.  Note
*       that locations pointed at by the simple typed vector structure will
*       be filled in with data from the database.  The simple typed vector
*       structure itself is not changed.  If no data is to be returned
*       by the procedure (i.e. only the tuple id is desired) as indicated
*       by a zero array extent on the id list, the contents of the structure
*       pointed to by this pointer is undefined.  Indeed, the pointer is not
*       used.
*   tuple (output) - The tuple id of the tuple returned.
*
*
*   If relation manager returns an error code, the error routine is called.
*   Also, if a call is to be made to $get_tuple_id and less tuple ids than
*   expected were returned in a prior call, then mrds_error_$no_tuple_found
*   is passed to the error routine.
*
**********/


/*  Parameters */

	dcl     dbcbptr		 ptr;
	dcl     retrieve_info_ptr	 ptr;
	dcl     search_spec_ptr	 ptr;
	dcl     simple_typed_vector_ptr ptr;
	dcl     tuple_id		 bit (36) aligned;
	dcl     continue_for_next_tuple bit (1) aligned;

/*  Local data */

	dcl     icode		 fixed bin (35);	/* Returned error code */


/* Procedure */

	continue_for_next_tuple = "1"b;
	do while (continue_for_next_tuple);
	     continue_for_next_tuple = "0"b;
	     if dbcb.scopes_changed then do; 
	        if retrieve_info_ptr -> rtrv_info.ri_ptr -> rm_rel_info.file_type ^= 3 then 
		 /* this relation is not a temporary relation */
		 if dbcb.non_shared_to_shared = "0"b then do;
		     current_scope_ptr = retrieve_info_ptr -> rtrv_info.ri_ptr -> rm_rel_info.scope_flags_ptr;
		     if (current_scope_flags.permits.read_attr |
		         current_scope_flags.permits.delete_tuple |
		         current_scope_flags.permits.modify_attr) then
		        if ^current_scope_flags.prevents.modify_attr |
			(^current_scope_flags.prevents.append_tuple &
			 ^current_scope_flags.prevents.delete_tuple) then
			if retrieve_info_ptr -> rtrv_info.maxtids ^=
			  mrds_data_$max_safe_tids_returned_per_call then
			/* Somebody just changes the scope to shared mode within the
			same select expression (should be -another) */
			  dbcb.non_shared_to_shared = "1"b;
		end;
	     end;

	     if retrieve_info_ptr -> rtrv_info.ctid >=
		retrieve_info_ptr -> rtrv_info.ntids then do; /* None left from prior call or first time in routine */
		     if retrieve_info_ptr -> rtrv_info.first_seq_io then do; /* Furst get from this tuple variable */
			     retrieve_info_ptr -> rtrv_info.first_seq_io = "0"b;
			     search_spec_ptr -> relation_search_specification.head.type =
				ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE;
			end;
		     else do;			/* Get another set of tids */
			     if retrieve_info_ptr -> rtrv_info.ntids <
				retrieve_info_ptr -> rtrv_info.maxtids /* Got less than we expected last time */
			     then call error (mrds_error_$tuple_not_found);
			     search_spec_ptr -> relation_search_specification.head.type =
				RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE;
			     retrieve_info_ptr -> rtrv_info.ta_ptr -> element_id_list.number_of_elements = 0;
			end;
		     call dbcbptr -> dbcb.relmgr_entries.get_tuple_id (
			retrieve_info_ptr -> rtrv_info.relation_cursor_ptr,
			search_spec_ptr, dbcbptr -> dbcb.select_area_ptr,
			retrieve_info_ptr -> rtrv_info.ta_ptr,
			icode);
		     if icode ^= 0
		     then call error (icode);
		     retrieve_info_ptr -> rtrv_info.ctid = 0;
		     retrieve_info_ptr -> rtrv_info.ntids =
			retrieve_info_ptr -> rtrv_info.ta_ptr -> element_id_list.number_of_elements;
		end;


/* Now get the next tuple in the element id list */

	     retrieve_info_ptr -> rtrv_info.ctid =
		retrieve_info_ptr -> rtrv_info.ctid + 1;
	     tuple_id = retrieve_info_ptr -> rtrv_info.ta_ptr ->
		element_id_list.id (retrieve_info_ptr -> rtrv_info.ctid);
	     if id_list_ptr -> id_list.number_of_ids > 0	/* Retrieving one or more attributes of the tuple */
	     then do;
		     call dbcbptr -> dbcb.relmgr_entries.get_tuple_by_id (
			retrieve_info_ptr -> rtrv_info.relation_cursor_ptr,
			tuple_id, id_list_ptr, dbcbptr -> dbcb.select_area_ptr,
			simple_typed_vector_ptr, icode);
		     if icode = mrds_error_$inconsistent_data_length then do;
			     icode = 0;
			     continue_for_next_tuple = "1"b;
			end;
		     else if icode ^= 0
		     then call error (icode);
		end;
	end;					/* end while */

     end get_next_tuple;
%page;
get_comparison_value: proc (exp_ptr, ai_ptr, erslt_ptr, attr_index, desc_ptr, di_ptr, icode);

/* This routine produces a pointer to one of the values to be used in the
   comparison.  An attribute will be check and call the decoded procedure
   if there is a decode proc for that attribute.  An expression may be
   evaluated if necessary. */

	dcl     exp_ptr		 ptr;		/* INPUT : ptr to expression to be evaluated or null */
	dcl     ai_ptr		 ptr;		/* INPUT : ptr to rm_attr_info, it may be null. */
	dcl     erslt_ptr		 ptr;		/* INPUT : ptr to result of expression. */
	dcl     attr_index		 fixed bin (17);	/* INPUT : attribute of interest */
	dcl     desc_ptr		 ptr;		/* INPUT : ptr to descriptor */
	dcl     di_ptr		 ptr;		/* IN/OUT: ptr to comparison value. */
	dcl     icode		 fixed bin (35);	/* IN/OUT: standard error code. */

	icode = 0;
	if exp_ptr = null ()			/* Just an attribute, no expression */
	then do;
		di_ptr = whole_stv_ptr -> simple_typed_vector.dimension (attr_index).value_ptr;
		if ai_ptr ^= null then /* need to decode attribute */
		     if ai_ptr -> rm_attr_info.domain_ptr -> rm_domain_info.decd_proc
		     then do;
			     t_domain_ptr = ai_ptr -> rm_attr_info.domain_ptr;
			     user_bit_length = t_domain_ptr -> rm_domain_info.user_bit_len;
			     user_val_ptr = mrds_space_allocate (work_area_ptr, (user_bit_length + 35) / 36);
			     if user_val_ptr = null () then do;
				     icode = error_table_$noalloc;
				     return;
				end;
			     k = k + 1;
			     value_for_user = "0"b;	/* clear out space */
						/* evaluate and call decoded procedure */
			     call mu_get_data$get_data_item (ai_ptr, work_area_ptr, di_ptr,
				user_val_ptr, desc_ptr, icode);
			     if icode = error_table_$noalloc then
				return;
			     di_ptr = user_val_ptr;	/* set output ptr */
			end;
	     end;
	else do;					/* if expression */
		di_ptr = erslt_ptr;
		call mrds_dsl_eval_expr (area_ptr, exp_ptr, rmri_ptr, whole_stv_ptr, icode);
	     end;					/* if expression */
	if icode ^= 0 then call error (icode);
     end get_comparison_value;
%page;
%include mrds_space_allocate;
%page;
%include mrds_area_initialize;
%page;
error: proc (cd);

/* Error procedure */

	dcl     cd		 fixed bin (35);

	if (cd = dm_error_$no_tuple) | (cd = dm_error_$no_tuple_id)
	then code = mrds_error_$no_tuple;
	else code = cd;
	go to exit;

     end error;
%page;
	dcl     cvla_ptr_parm	 ptr;
	dcl     id_list_ptr_parm	 ptr parameter;
	dcl     simple_typed_vector_ptr_parm ptr parameter;
	dcl     search_spec_ptr_parm	 ptr;
	dcl     tuple_var_name	 char (*);	/* tuple variable name for debugging */
	dcl     user_bit_length	 fixed bin;
	dcl     value_for_user	 bit (user_bit_length) based (user_val_ptr);
	dcl     work_area_ptr	 ptr;

	dcl     (i, k,				/* internal indexes */
	        j)		 fixed bin;

	dcl     (code,				/* Output:  status code */
	        icode)		 fixed bin (35);	/* offset of item in tuple.data */

	dcl     (area_ptr,
	        desc_ptr1,				/* ptr to desc for first value to be compared. */
	        desc_ptr2,				/* ptr to desc for second value to be compared. */
	        di_ptr,				/* to data item */
	        di_ptr2,				/* ptr to second comparison value */
	        t_domain_ptr,			/* temp ptr use to point to rm_domain_info. */
	        tid_ptr,
	        user_val_ptr,			/* ptr to converted value for decoding */
	        whole_stv_ptr)	 ptr;		/* Input:  to place to store tuple id */


	dcl     (display_tuple_data,			/* flags */
	        display_values_compared,
	        found)		 bit (1) unaligned;

	dcl     match		 bit (1) aligned;	/* aligned for efficiency in call to mu_compare_values */
	dcl     need_to_free_user_value bit (1) aligned;

	dcl     (addr,
	        fixed,
	        null,
	        rel,
	        rtrim,
	        substr,
	        unspec)		 builtin;

	dcl     tuple_id		 bit (36) aligned based (tid_ptr);

	dcl     CVL_ops		 (1:6) char (2) int static options (constant) init (
				 "=",
				 "^=",
				 "<",
				 "<=",
				 ">",
				 ">=");
	dcl     1 current_scope_flags	aligned based (current_scope_ptr) like scope_flags;
          dcl     current_scope_ptr      ptr;
	dcl     dm_error_$no_tuple	 fixed bin (35) ext static;
	dcl     dm_error_$no_tuple_id	 fixed bin (35) ext static;
	dcl     mrds_data_$max_safe_tids_returned_per_call fixed bin (35) ext static;
	dcl     mrds_error_$no_tuple	 ext fixed bin (35);
	dcl     mrds_error_$tuple_not_found fixed bin (35) ext static;
	dcl     mrds_error_$inconsistent_data_length fixed bin (35) ext static;
	dcl     mrds_dsl_eval_expr	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);

	dcl     iox_$user_output	 ext ptr;

	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

	dcl     error_table_$noalloc	 fixed bin (35) ext static;

	dcl     mdb_display_data_value$ptr entry (ptr, ptr);

	dcl     mdb_display_tuple_$data entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mu_compare_values	 entry (ptr, ptr, ptr, ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     mu_display_descriptor	 entry (ptr) returns (char (120) varying); /* gets char form of descriptor */
	dcl     mu_get_data$get_data_item entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
%page;
%include dm_element_id_list;
%page;
%include dm_id_list;
%page;
%include dm_relation_spec;
%page;
%include dm_specification_head;
%page;
%include mdbm_scope_info;
%page;
%include mdbm_comp_val_list;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rtrv_info;
%page;
%include mrds_debug_names;
%page;
%include mrds_dbcb;
%page;
%include vu_typed_vector;

     end mu_retrieve;




		    mu_sec_init_res.pl1             08/01/88  1347.6rew 08/01/88  1300.0      149535



/****^  ***********************************************************
        *                                                         *
        * 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-08-13,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
     Removed change of 84-11-05. i.e. reinstalled initialization of
     even_word_pad.
                                                   END HISTORY COMMENTS */



mu_sec_init_res:
init_res:
     proc (dsm_path, submodel_version, db_path, insecure_db_ptr,
	insecure_dbcb_ptr, insecure_rdbi_ptr, error_code);

/* BEGIN DESCRIPTION 

   This  routine  gets  a  segment  to  be  used  as the secure portion of the
   resultant  model  in  the  process  directory,  and  initializes  its base
   structure rm_db_info, as well as the rm_rel_array and rm_rel_array for both
   temporary  relations and  the  files/relations known to the user from the
   submodel or model he opened with.

   END DESCRIPTION


   PARAMETERS:

   dsm_path  - - (input) char(168), the pathname of the submodel if a submodel
   opening was used

   submodel_version  -  - (input) fixed bin, the version of the submodel used,
   if this was an opening via a submodel, else 0.

   db_path - - (input) char(168), the pathname of the database model

   insecure_db_ptr - - (input) the insecure pointer to the db_model segment in
   the database model

   insecure_dbcb_ptr  -  -  (input)  pointer  to the non-secure portion of the
   resultant  model,  which  contains the database index for this opening, and
   the submodel switch

   insecure_rdbi_ptr  -  -  (input)  pointer  to  the rm_db_info segment, the
   secure portion of the resultant

   error_code  -  -  (output)  fixed bin (35) error type encoding, 0 unless an
   error occurred

   sub_error_  -  - (output) condition, signaled upon occurence of an error to
   provide more info


   HISTORY:

   78-08-01 Oris D. Friesen: Originally written.

   79-05-01 Jim Gray : Rewritten to
   1) reflect resultant model changes of the active bit in the file array
   2) the mdbm_secured bit in the file array, no longer in rm_file_info
   3) add TP ctl_file iocb_ptr and sw_name to rm_db_info
   4) add freeing of submodel parameter structures after their use
   5) add use of sub_err_ and structured error handling
   6) change interface to allow more general information as input

   80-02-01  Jim  Gray : Modified to make rm_db_info.static_area extensible to
   handle large database resultant model building during opening.

   80-03-25 R. Lackey: Modified to remove calls to mdbm_util_

   80-10-01  Lindsey  Spratt:  changed  to  work  with the new secure submodel
   system;  the  mdbm_secured  switches, rm_rel_array.file_data.mdbm_secured,
   rm_db_info.mdbm_secured,  are  set  to the value of dsm_sw; dsmd_ calls are
   now   directly   to  the  relevant  mrds_dsm  module;  an  external  static
   submodel_iocb_ptr,  set  by  mrds_dsl_init_res,  is used when accessing the
   submodel.

   80-11-03  Jim  Gray  :  Modified to change delete_$ptr to hcs_$delentry_seg
   calls for performance.

   80-11-05  Jim  Gray  :  Modified  to set the mdbm_secured switches from the
   secured bit the the database model, as set by secure_mrds_db.

   80-11-06  Jim  Gray : Modified to only set rm_db_info.mdbm_secured from the
   model   secured   bit,   and   elsewhere   set   mdbm_secured   bits   from
   rm_db_info.mdbm_secured,  so that the model is only touched once in getting
   this info.

   81-1-12  Jim  Gray  :  added  submodel_version  parameter, so this could be
   initialized in the resultant when opening was via a submodel.

   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-27 Jim Gray : removed call to obsolete module mus_ptr_man.

   81-05-21    Rickie   E.    Brinegar:   Modified   to   use   the   modified
   mrds_dsm_get_relation_names.incl.pl1  which  changed  dsm_relation_names to
   mrds_dsm_relation_name.

   81-05-28 Jim Gray : modified for new structure of resultant.  This included
   combining  the  rm_rel/file_arrays,  and  adding  info  to  the  rm_db_info
   structure for a domain list.

   81-09-16  Rickie  E.  Brinegar: Modified model_name to be char (32) and the
   assignment  of name_in_model to be done via an rtrim to eliminate substring
   condtion from occurring on a compile.

   81-12-07  Roger D. Lackey: Modified to cause get_temp_segment_ to be called
   only when submodel is used.   And to change the initization of the variable
   caller_name from mrds_dsl_open to mu_sec_init_res. For TR12046.

   81-12-17 Davids: modified so that the rm_rel_array used for temp_rels has a
   dimension 1 greater than mrds_data_$max_temp_rels. this extra slot is  used
   when a temp rel is being self-defined. TR11630.

   82-07-21 Woodka: modified to initialize rdbi_ptr to null to prevent clean_up
   from trying to delete whatever rdbi_ptr happened to be pointing at if the 
   user hit break before the pointer was assigned. TR phx13152.

   83-05-04 Davids: Modified so that the segment the rdbi is in is a temp
   segment obtained from mu_temp_segment. Cleanup of the segment in case of an
   error will be done by the mrds_dsl_init_res module which will clean up all
   temp segments. The variable resultant_dir and the entry
   mrds_dsl_resultant_storage$get_temp_dir were deleted since mu_temp_segments
   knows where to put the temp segment. The entries hcs_$make_seg,
   unique_chars_ and hcs_$delentry_seg were also deleted since no segments
   need to be explicitly created, unique character strings are not needed for
   names for those segments which are no longer created. Cleanup is no done 
   by mrds_dsl_init_res which will cleanup all temp segments.

   83-05-16 Davids: Deleted the internal procedure get_rdbi_ptr which got a
   temp segment to put the rdbi into. Also converted the insecure_rdbi_ptr
   from an output parameter to an input parameter. The temp segment is now
   obtained in mrds_dsl_init_res in the same call that gets the other
   temp segments. Deleted the declaration for mu_temp_segments$get_temp_segment

   83-05-20 Davids: Added code to set the new rm_db_info.saved_res_version from
   mrds_data_$saved_res_version.

   84-11-05 Thanh Nguyen:  Changed  the  initialization  of  even_word_pad  to
   ref_name_proc_ptr in the structure rm_db_info. 
*/
%page;
/* initialize */

	dbm_ptr = insecure_db_ptr;			/* get local version of pointers */
	dbcb_ptr = insecure_dbcb_ptr;
	rdbi_ptr = insecure_rdbi_ptr;
	db_index = dbcb_ptr -> dbcb.dbi;
	dsm_sw = dbcb_ptr -> dbcb.dsm_sw;
	error_code = 0;
	area_ptr = null ();
	clean_up_condition = OFF;

/* establish handler to tie up loose ends if user does a quit/release */

	on cleanup
	     begin;
		clean_up_condition = ON;
		if substr (db_mu_sec_init_res, 1, 1) then
		     on sub_error_ ;		/* ignore sub_err_ calls during cleanup */
		call clean_up ();
	     end;

/* get space for submodel parameter structures */


	if dsm_sw then do;
		call get_temp_segment_ (caller_name, area_ptr, error_code);

		if error_code ^= 0 then
		     call
			sub_err_ (error_code, caller_name, continue, info_ptr,
			return_value, "^/^a",
			"Unable to get a temporary segment for submodel parameter structure area"
			);

		area_ptr -> parameter_area = empty ();
	     end;


/* get the number of relations and files in the model or submodel */

	call get_number_of_relations ();

/* initialize the rm_db_info based on this segment */

	call init_rm_db_info ();

/* initialize the temporary relation file and rel arrays */

	call init_temp_rel_array ();

/* initialize the normal model or submodel file and rel arrays */

	call init_rel_array ();

/* get rid of any temporary storage, and cleanup after errors */

	call clean_up ();

	return;
%page;
get_number_of_relations:
     procedure ();

/* set the number of relations known to the user,
   based upon the opening mode from model or submodel */

	if ^dsm_sw then /* not submodel, get from model */
	     number_of_relations = dbm_ptr -> db_model.num_rels;


	else do;					/* get from submodel */

		call mrds_dsm_get_relation_names (area_ptr,
		     mrds_dsm_relation_names_ptr,	/* points to relation name list returned */
		     submodel_iocb_ptr,
		     error_code);

		if error_code = 0 then
		     number_of_relations =
			mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names.nrels;
		else do;
			call
			     sub_err_ (error_code, caller_name, continue, info_ptr,
			     return_value, "^/^a ^a",
			     "Unable to get the relation names for the submodel", dsm_path);
			number_of_relations = 0;
		     end;

	     end;

     end;
%page;
init_rm_db_info:
     procedure ();

/* fill in the rm_db_info initial values */

	if error_code = 0 then do;

		rm_db_info.db_version = dbm_ptr -> db_model.version;
		rm_db_info.db_path = db_path;
		rm_db_info.sm_path = dsm_path;
		if dsm_sw then
		     rm_db_info.sm_version = submodel_version;
		else rm_db_info.sm_version = 0;
		rm_db_info.val_level = 4;		/* default validation level */
		rm_db_info.mdbm_secured = db_model.mdbm_secured; /* depends on secure_mrds_db command */
		rm_db_info.administrator = OFF;	/* set in mrds_dsl_init_res */
		rm_db_info.pad = OFF;
		rm_db_info.domain_list_ptr = null ();
		rm_db_info.ra_ptr = null ();
		rm_db_info.tra_ptr = null ();
		rm_db_info.saved_res_version = mrds_data_$saved_res_version;
		rm_db_info.even_word_pad = 0;

/* define the secure resultant model area as extensible */

		rdbi_area_ptr = addr (rm_db_info.static_area);
		area_size = sys_info$max_seg_size - fixed (rel (rdbi_area_ptr));

		call
		     mu_define_area (rdbi_area_ptr, area_size, "MRDS.rdbi",
		     "1"b /* extensible */, "0"b /* freeing */, "0"b,
		     "0"b /* no zeroing */, error_code);

	     end;



	declare area_size		 fixed bin (18);	/* size of area to be defined, initially */
	declare rdbi_area_ptr	 ptr;		/* points to area to be defined */


     end;
%page;
init_temp_rel_array:
     procedure ();

/*
   get space for the temp rel rel_array in the
   rm_db_info area, and fill in the initial values.
   There is one more slot than max so that a temp rel can be self-defined.
   This slot is not usable by the user.
*/

	rm_num_rels_init = mrds_data_$max_temp_rels + 1;

	allocate rm_rel_array set (rmra_ptr) in (rm_db_info.static_area);

	rm_db_info.tra_ptr = rmra_ptr;


	do i = 1 by 1 to rm_num_rels_init;
	     call fill_rel_array_entry ((BLANK), (BLANK));
	end;




     end;
%page;
init_rel_array:
     procedure ();

/* get space for the normal rel array over the submodel or model,
   in the rm_db_info area, and fill in the initial values */

	rm_num_rels_init = number_of_relations;

	allocate rm_rel_array set (rmra_ptr) in (rm_db_info.static_area);

	rm_db_info.ra_ptr = rmra_ptr;

	rm_rel_array.num_rels = rm_num_rels_init;

	do i = 1 by 1 to rm_num_rels_init while (error_code = 0);

	     if ^dsm_sw then do;			/* from model */

		     if i = 1 then
			fi_ptr = pointer (dbm_ptr, dbm_ptr -> db_model.file_ptr);
		     else fi_ptr = pointer (dbm_ptr, fi_ptr -> file_info.fwd_ptr);

		     model_name, submodel_name = fi_ptr -> file_info.file_name;
		end;

	     else do;				/* from submodel */
		     call
			mrds_dsm_read_relation ((mrds_dsm_relation_names.relation (i)),
			area_ptr, relation_block_ptr, submodel_iocb_ptr, error_code);
		     if error_code ^= 0 then do;
			     call
				sub_err_ (error_code, caller_name, continue, info_ptr,
				return_value, "^/^a^a^a",
				"Unable to get the model name of submodel file """,
				mrds_dsm_relation_names.relation (i), """.");
			     model_name, submodel_name = BLANK;
			end;
		     else do;
			     model_name = relation_block.dm_rel_name;
			     submodel_name = relation_block.dsm_rel_name;
			end;
		end;

	     call fill_rel_array_entry (model_name, submodel_name);
	end;


     end;
%page;
fill_rel_array_entry:
     procedure (name_in_model, name_in_submodel);

/* initialize a relation array element */

	rm_rel_array.name (i).submodel = name_in_submodel;
	rm_rel_array.name (i).mark = "!";		/* name separator for searching */
	rm_rel_array.rel_data (i).model_name = rtrim (name_in_model);
	rm_rel_array.rel_data (i).ri_ptr = null ();

	declare name_in_model	 char (32);	/* name stored in db */
	declare name_in_submodel	 char (32);	/* alias given in submodel */

     end;
%page;
clean_up:
     procedure ();

/* get rid of temp parameter area used for submodels */


	if area_ptr ^= null () then do;

		call release_temp_segment_ (caller_name, area_ptr, code);
		if code ^= 0 then
		     call sub_err_ (code, caller_name, continue, info_ptr, return_value,
			"^/^a",
			"Unable to release the temp segment used for submodel parameter area."
			);
		area_ptr = null ();
	     end;

	if error_code ^= 0 | clean_up_condition
	then rdbi_ptr = null ();			/* the temp seg will be deleted by the mrds_dsl_init_res cleanup handler */

     end;
%page;
	dcl     db_index		 fixed bin (35);	/* output parameter -- data base index */
	dcl     insecure_db_ptr	 ptr;		/* parameter -- points to db model or submodel */
	declare insecure_dbcb_ptr	 ptr;		/* pointer to non-secure segment in resultant model */
	dcl     dsm_sw		 bit (1) unal;	/* parameter -- ON => submodel */
	dcl     submodel_iocb_ptr	 ext ptr init (null); /* Also used by mrds_dsl_init_res,
						   mus_get_relation_names, and
						   mus_get_attribute_names. */
	declare cleanup		 condition;	/* signaled during release */
	declare clean_up_condition	 bit (1);		/* on => cleanup signaled */
	dcl     insecure_rdbi_ptr	 ptr;		/* parameter -- points to res. model db info */
	dcl     error_code		 fixed bin (35);
	dcl     db_path		 char (168);	/* abs. path of data base */
	dcl     dsm_path		 char (168);	/* path name of submodel */
	dcl     i			 fixed bin;	/* index value */


	dcl     (addr, fixed, empty, null, pointer, rel, rtrim, substr) builtin;

	declare code		 fixed bin (35);	/* unused */
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* gets parameter space */
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* cleans up area */
	declare parameter_area
				 area (sys_info$max_seg_size - 24 /* for area header */) based;
						/* space for parameters */
	declare OFF		 bit (1) internal static options (constant) init ("0"b);
						/* false value */
	declare ON		 bit (1) internal static options (constant) init ("1"b);
						/* true value */
	declare BLANK		 char (1) internal static options (constant) init (" ");
						/* empty space */
	declare caller_name		 char (20) init ("mu_sec_init_res"); /* routine reporting error */
	declare continue		 char (1) init ("c"); /* no halt after printing error message */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare area_ptr		 ptr;		/* space for working structures */
	declare sub_err_		 entry options (variable); /* error reporter */
	declare number_of_relations	 fixed bin;	/* submodel, or model count */
	declare model_name		 char (32);	/* name of rel in db */
	declare submodel_name	 char (32);	/* name of rel in submodel */
	declare sub_error_		 condition;	/* signaled when sub_err_ called */
	declare mu_define_area
				 entry (ptr, fixed bin (18), char (11), bit (1) aligned,
				 bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
						/* sets up call to define_area_ */
	declare submodel_version	 fixed bin;	/* version of submodel used */

	dcl     (
	        mrds_data_$max_temp_rels,
	        sys_info$max_seg_size
	        )			 ext fixed bin (35);
	dcl     mrds_data_$saved_res_version ext char (8);
%page;
%include mrds_dbcb;
%page;
%include mdbm_db_model;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mrds_dsm_entry_dcls;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_debug_names;
%page;
%include mrds_authorization;
     end mu_sec_init_res;




		    mu_sec_make_res.pl1             08/01/88  1347.6r w 08/01/88  1314.3      270828



/****^  ***********************************************************
        *                                                         *
        * 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-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Added code to keep track of the rm_attr_info structures that have been
     allocated (phx20301, mrds #154). Previously this code allocated one
     rm_attr_info structure for each attribute in each relation. In the test
     case for this TR this resulted in 7926 rm_attr_info's being allocated,
     which took up 206076 words. This new code results in about 435
     rm_attr_info's being allocated, for the test case.
                                                   END HISTORY COMMENTS */


mu_sec_make_res:
make_res:
     proc (insecure_dbrdy_ptr, insecure_frdy_ptr, temp_area_ptr, 
	arg_submodel_iocb_ptr, resultant_attributes_info_ptr_parm, error_code);
	goto common;

/*

		      BEGIN_DESCRIPTION

   This routine builds the part of the resultant model needed to ready a file.
   this  includes  rm_rel_info, the rm_rel_infos for the files relations, the
   rm_attr_infos,  and  rm_domain_infos  for  the  relations  attributes,  and
   rm_plink_infos  and rm_clink_infos for the files links.  the rm_rel_array,
   and  rm_rel_array are updated to reflect the readied file.  the file itself
   is  attached  and  opened  for  the  given  ready  mode.   note that if the
   resultant for the file is already built from a previous readying, that only
   the attach and open process take place.

		       END_DESCRIPTION

   PARAMETERS:

   insecure_dbrdy_ptr  -  - (input) pointer to the db_rdy structure containing
   the db_index, db_model pointer, and dbcb pointer

   insecure_frdy_ptr  - - (input) pointer to the file_rdy structure containing
   the file name, file ready mode, and it's index in the file array

   temp_area_ptr - - (input) pointer to a scratch area for use in calling
   mus_get_rel_names and mus_get_att_names

   arg_submodel_iocb_ptr - - (input) submodel iocb pointer, if a submodel
   opening

   resultant_attributes_info_ptr_parm - - (input) pointer to resultant_attributes_info structure.

   error_code - - (output) fixed bin (35), type of error encoding, 0 unless an
   error occured

   sub_error_  -  -  (output)  condition,  signaled upon detection of error to
   provide more info


   HISTORY:

   78-08-01 Oris D. Friesen: Originally written.

   79-05-01 Jim Gray : Rewritten to
   1) add sub_err_ and structured reporting of errors
   2) insure cleanup of parameter structures
   3) add logic to only attach & open if resultant already built for file
   4) correct and complete initialization of resultant structures
   5)  add  logic  formerly  in mu_sec_complete_res(deleted) to update readied
   .   links
   6) add array of varying attribute pointers to rm_rel_info

   79-12-01 Jim Gray : Modified to make the  build_ptr  routine  use
   cv_ptr_  on a path$entry, instead of an hcs_$initiate, which does
   not work.

   79-12-02 Jim Gray : Modified to change get_assign_length, so that
   packed decimal types would work properly

   80-04-01 Jim Gray : Modified to fix  attr  definition  order  for
   submodels.

   80-04-02 Jim Gray : Modified to set rm_rel_info.delete/store bits
   off it submodel view does not contain all attributes.

   80-04-03 Jim Gray  :  Modified  to  make  db  path  available  to
   mus_attach_open_vile  so that the change to relative paths in the
   model could be expanded for the attach description.

   80-05-01 Jim Gray : Modified to include the models num_attrs, and
   nvar_atts  in the rm_rel_info, so that partial view submodels can
   properly access the tuple structure.

   80-05-01 Jim Gray  :  Modified  to  make  partial  view  submodel
   modify, a debug switch for this release.

   80-05-02  Jim  Gray  :  Modified  to   add   model_nkey_attr   to
   rm_rel_info for key head submodel access info.

   80-06-18  M.  Pierret:  Modified  to   accept   submodel   access
   information.

   80-06-24 Lindsey Spratt: Modified to set the mdbm_secured  switch
   equal to dsm_sw.

   80-08-01 Lindsey Spratt: Modified to add access  permission  bits
   to mus_get_ interface.

   80-11-05 Jim Gray : Modified to set the mdbm_secured bit from the
   secured  bit  in the model (as set by secure_mrds_db), instead of
   from the submodel switch.

   80-11-05  Jim  Gray  :  Modified  to  add  mdbm_secured  bit   to
   rm_attr_info  so  that rm_rel_info does not have to be checked in
   routines that do not have that info (e.g. select/where clause and
   expr/func routines)

   80-11-06 Jim  Gray  :  Modified  to  set  mdbm_secured  bit  from
   rm_db_info.mdbm_secured,  so  that model is only touched once for
   the setting of the secure bit in the resultant.

   80-11-04 Jim Gray : Modified to take the call to attach and  open
   the  data  vfile out of this routine, now that the file is opened
   at set_scope time in mrds_dsl_set_fscope instead, so that  access
   checks  and access/scope conflict checks can be made indenpendent
   of opening the file.

   80-12-10 Jim Gray : to properly initialize  the  new  version  of
   scope_info.   This   only   happenns   for   files   readied   in
   scope_update/retrieve modes, for other modes open  still  happens
   here.

   80-12-11 Jim Gray : added  initialization  of  submodel  name  in
   scope info

   80-12-24 Jim Gray : improved error message  for  case  when  null
   access doesn't allow getting pointer to model segment.

   81-01-22     Davids:      changed      mrds_dsm_open_read      to
   mrds_dsm_open$read.    also    removed    the    use    of    the
   mrds_dsm_entry_dcls include file

   81-01-23    Jim    Gray     :     added     initialization     of
   last_model_attr_char_var   bit   in  rm_rel_info,  now  added  to
   mus_get_att_names interface, so that partial view  submodels  can
   determine  where  the end of a tuple with varying attributes, not
   in  it's  view,  has  it's  last  bit.  Also  removed  all  logic
   preventing   partial   view   modifies   that   turned   off  the
   rm_rel_info.modify bit.

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

   81-01-30 Jim Gray : added  init  of  current_tuple_population  in
   rm_rel_info.

   81-02-20 Jim Gray  :  changed  init  of  rm_rel_info.key_attr_ptr
   array,  so  that the key attr pointers always appear in model key
   order. Previously a submodel that re-order  the  key  attributes,
   and  stored  data, would have a tuple not retrievable by that key
   in the model, and vice versa. This is a fix for TR 9038. Now  the
   key  is  always  maintained  in the model's key order, for entire
   view relations, whether the opening is through  the  model  or  a
   submodel.  Note  that  the method used for the fix only works for
   full view submodels doing a store, if we ever allow  null  values
   in  key  attrs,  and  partial  view  stores, this will have to be
   changed.

   81-05-06 Rickie E. Brinegar : Added build_entry and  changed  the
   encode,  decode and check proc pointers in the resultant model to
   entry variables. This was done to allow these  procedures  to  be
   written  in  other  than  pl1  and  to  accommodate  the  use  of
   cu_$generate_call instead of cu_$gen_call.

   81-05-28 Jim Gray :  changed  code  to  handle  to  structure  of
   resultant  model.  This involved combining the rm_rel/file_array,
   and combining the rm_rel/file_info. All blocked file and  foreign
   key  references  were  eliminated.  The  -check  option stuff was
   removed.  Now  only  one  rm_domain_info  per  domain  is   used.
   Descriptors are now used, instead of pointers to descriptors.

   81-06-16 Jim Gray : changed initization of number of iocb's possible
   per relation, to allow up to 20 tuple variables on the same relation.

   81-07-02 Jim Gray : added initialization of the relation vfile statistics
   in rm_rel_info, and the statistics update count and time.

   81-09-16 Davids: added  the  rtrim  builtin.  rel_info.name  will
   never be more than 30 characters but since it is declared as char
   (32) a stringsize is signaled when the code is  compiled  with  a
   prefix of stringsize. adding the rtrim  allows  the  code  to  be
   compiled.

   82-04-21  R. Lackey : Add rm_rel_info.number_selected = 0;
   To help keep track of how much space is used and delete old subsets.
   TR12205 (Suggestion).

   82-05-12 Roger Lackey  : added min to
   rm_rel_info.file_id_len = min (7, db_model.unblk_file_id_len);
   because file_id_len is used as a length for substr in several modules
   where the target variable is only 7 bits long.

   82-08-12  Mike  Kubicar  : Added a fix as part of TR phx 13118.  In
   case    of   problems   accessing   an   encode/decode   procedure,
   mu_sec_make_res  will return mrds_error_$bad_domain_proc.  This
   is    because    an    upper    level   routine   is   interpreting
   error_table_$moderr  as  incorrect  access to model/submodel.  This
   also applies to error_table_$no_info.

   82-08-20 D. Woodka : deleted references to  rm_attr_info.bit_offset
   and rm_rel_info.max_data_len for DMS conversion.     

   82-09-23 Davids: added the setting of rm_rel_info.primary_key_index_id

   82-09-24 Woodka : modified for DMS conversion. Deleted references to iocb
   pointers, and  references to deleted fields, and added  initialization of
   several new fields.

   82-11-05 Davids: added assignment to the new field model_defn_order in
   rm_attr_info.

   83-02-26 Moberg: added parameters so that the temp_segment is not gotten
   for each relation and if a submodel_opening, the submodel is not opened
   for each relation

   83-04-06 Davids: Added code to set the new rm_rel_info.scope_flags_ptr.
   Also deleted references to discard_code, mrds_data_$max_tuple_var, length
   min, substr.

   83-06-06 Davids: Added code in the build_entry procedure so that the error
   code returned is set before the call to sub_err_ and so that the info_ptr
   argument in the call to sub_err_ is the addr of the error_code. This is
   so that the sub_error handler in mrds_dsl_create_res_copy can reset the
   error code to allow the resultant to be created even if the entry does
   not exist. It was decided to do this so that the resultant creation code
   will not need to be duplicated for saving the resultant in the db dir
   during the database creation.
*/
%page;
common:						/* initialize */
	submodel_iocb_ptr = arg_submodel_iocb_ptr;
	num_dims = 0;
	resultant_attributes_info_ptr = resultant_attributes_info_ptr_parm;
	error_code = 0;

/* copy the pointer parameters for security purposes */

	frdy_ptr = insecure_frdy_ptr;
	dbrdy_ptr = insecure_dbrdy_ptr;

	dbcb_ptr = db_rdy.dbcb_ptr;
	rdbi_ptr = dbcb.rdbi_ptr;
	dbm_ptr = db_rdy.db_model_ptr;
	fa_index = file_rdy.file_array_index;
	rmra_ptr = rm_db_info.ra_ptr;

/* get the pointer to the file model for this file */

	call
	     hcs_$initiate ((rm_db_info.db_path),
	     rtrim (rm_rel_array.rel_data.model_name (fa_index)) || ".m", "", 0, 0,
	     fm_ptr, error_code);

	if error_code = error_table_$moderr then do;
		call
		     mrds_dm_authorization$set_needed_access (rtrim (rm_db_info.db_path),
		     error_code);
		if error_code ^= 0 then
		     error_code = error_table_$moderr;
		else call
			hcs_$initiate ((rm_db_info.db_path),
			rtrim (rm_rel_array.rel_data.model_name (fa_index)) || ".m",
			"", 0, 0, fm_ptr, error_code);
	     end;

	if fm_ptr = null then
	     call
		sub_err_ (error_code, caller_name, continue, info_ptr,
		return_value, "^/^a^a^a",
		"Unable to get a pointer to the model segment """,
		rtrim (rm_db_info.db_path) || ">"
		|| rtrim (rm_rel_array.rel_data (fa_index).model_name) || ".m",
		""".");
	else do;

		error_code = 0;
		fi_ptr = pointer (dbm_ptr, file_model.fi_ptr);

/* set up for processing the relation */

		call get_area_and_rel_init ();


		if error_code = 0 then do;

/* now process each relation within this file */

			rel_index = 1;
			call process_relation ();

/* scope ready modes need the mdbm to manage concurrency, initialize if neccessary */

			if (file_rdy.mode >= SCOPE_MODES) & (error_code = 0)
			then call set_up_scope ();	/* scope retrieve or scope update */

		     end;

	     end;

	return;
%page;
get_area_and_rel_init:
     procedure ();

/* routine to get the initial values needed to allocate the rm_rel_info
   if it hasn't been previously built, else just get the rmfi_ptr */


/* get space for a parameter area */

	temp_area_ptr -> parameter_area = empty ();

/* get the number of relations in the submodel or model for this file */

	call mus_get_rel_names (dbcb.dsm_sw, rmra_ptr, fa_index, temp_area_ptr,
	     fm_ptr, rns_ptr, error_code);

     end;
%page;
set_up_scope:
     proc;

/* get the scope_info pointer, or initialize it if this is its first reference */

	if dbcb.scope_ptr ^= null () then
	     scope_ptr = dbcb.scope_ptr;
	else do;					/* first time, init structure */

		max_file_init = rm_rel_array.num_rels;
		allocate scope_info set (scope_ptr) in (dbcb.static_area);

		dbcb.scope_ptr = scope_ptr;

		scope_info.mbz1 = OFF;
		scope_info.nfiles = max_file_init;
		scope_info.active_scopes = 0;

		do i = 1 to scope_info.nfiles;
		     scope_info.scope.name (i) = BLANK;
		     scope_info.scope.sm_name (i) = BLANK;
		     scope_info.scope.flags (i) = OFF;
		end;
	     end;

/* enter this files name in an empty slot in the scope array */

	do i = 1 to scope_info.nfiles while (scope_info.scope.name (i) ^= BLANK);
	end;

	scope_info.scope.name (i) = rm_rel_info.model_name;
	scope_info.scope.sm_name (i) = rm_rel_info.name;
	rm_rel_info.scope_flags_ptr = addr (scope_info.scope (i).flags);

     end set_up_scope;
%page;
process_relation:
     procedure ();

/* build the attr/domain/relation/plink/clink resultant infos for this relation */

	ri_ptr = rel_names.item (rel_index).ri_ptr;

	call
	     mus_get_att_names (dbm_ptr, dbcb.dsm_sw, rns_ptr, rel_index,
	     temp_area_ptr, ans_ptr, error_code);
	if error_code = 0 then do;

/* go through each attribute in the users view of this relation */

		do att_index = 1 to att_names.num while (error_code = 0);

		     call init_rm_domain_info ();

		     call init_rm_attr_info ();

		     att_names.item.rai_ptr (att_index) = rai_ptr;

		end;


/* find an empty slot in the relation array,
   then fill in the resultant relation info */

		if error_code = 0 then do;

			rm_rel_index = fa_index;

			call init_rm_rel_info ();

			rm_rel_array.rel_data.ri_ptr (rm_rel_index) = rmri_ptr;

		     end;

	     end;

     end;
%page;
init_rm_domain_info:
     proc ();

/* fill in the resultant domain info */

	di_ptr = att_names.item.di_ptr (att_index);

	declare found		 bit (1);		/* on => leave loop */

	found = OFF;
	rdi_ptr = rm_db_info.domain_list_ptr;
	do while (^found);

	     if rdi_ptr = null () then
		found = ON;
	     else if rm_domain_info.name = domain_info.name then
		found = ON;
	     else rdi_ptr = rm_domain_info.next_domain_ptr;

	end;

	if rdi_ptr = null () then do;			/* domain name not init yet */
		allocate rm_domain_info set (rdi_ptr) in (rm_db_info.static_area);
		rm_domain_info.next_domain_ptr = rm_db_info.domain_list_ptr;
		rm_db_info.domain_list_ptr = rdi_ptr;


		rm_domain_info.db_desc = domain_info.db_desc;
		rm_domain_info.user_desc = domain_info.user_desc;
		rm_domain_info.user_bit_len =
		     mu_data_length ((rm_domain_info.user_desc));
		rm_domain_info.name = domain_info.name;


		error_source = "domain " || rm_domain_info.name;


		rm_domain_info.ck_proc, rm_domain_info.encd_proc,
		     rm_domain_info.decd_proc = "0"b;
		if domain_info.check_path_ptr ^= NULL_OFFSET then do;
			rm_domain_info.ck_proc_entry =
			     build_entry (domain_info.check_path_ptr, di_ptr, "check");
			rm_domain_info.ck_proc = "1"b;
		     end;
		if domain_info.encd_path_ptr ^= NULL_OFFSET then do;
			rm_domain_info.encd_proc_entry =
			     build_entry (domain_info.encd_path_ptr, di_ptr, "encode");
			rm_domain_info.encd_proc = "1"b;
		     end;
		if domain_info.decd_path_ptr ^= NULL_OFFSET then do;
			rm_domain_info.decd_proc_entry =
			     build_entry (domain_info.decd_path_ptr, di_ptr, "decode");
			rm_domain_info.decd_proc = "1"b;
		     end;



		rm_domain_info.pad = OFF;

	     end;

     end init_rm_domain_info;
%page;
init_rm_attr_info:
     proc ();

dcl 1 irai_based_rm_attr_info like rm_attr_info based (irai_based_rm_attr_info_ptr);
dcl irai_based_rm_attr_info_ptr ptr;
dcl irai_havent_found_one_yet bit (1) aligned;
dcl irai_loop fixed bin;
dcl 1 irai_rm_attr_info like rm_attr_info;
/* fill in the resultant attribute info */

	ai_ptr = att_names.item.ai_ptr (att_index);
	rai_ptr = addr (irai_rm_attr_info);

	rm_attr_info.name = att_names.item.sm (att_index);
	rm_attr_info.model_name = attr_info.name;
	rm_attr_info.key_attr = attr_info.key_attr;
	rm_attr_info.index_attr = attr_info.index_attr;
	type = addr (rm_domain_info.db_desc) -> descriptor.type;
	rm_attr_info.read_perm = att_names.item.r_perm (att_index);
	rm_attr_info.modify_perm = att_names.item.u_perm (att_index);
	rm_attr_info.mdbm_secured = rm_db_info.mdbm_secured;
	rm_attr_info.reserved = OFF;
	rm_attr_info.index_id = attr_info.index_id;
	rm_attr_info.defn_order = att_index;		/* will be defn order for view */
	rm_attr_info.model_defn_order = attr_info.defn_order; /* will be defn order for actual model */
	rm_attr_info.key_order = attr_info.key_order;
	rm_attr_info.bit_length = attr_info.bit_length;
	rm_attr_info.domain_ptr = rdi_ptr;
	rm_attr_info.number_of_dups = 0;


	if rm_attr_info.index_attr	/* Don't update resultant_attributes_info if it's an indexed attribute */
	then call allocate_an_rm_attr_info_structure;
	else if resultant_attributes_info.current_number_of_attributes = 0
	     then do;		/* Update it for the first rm_attr_info */
		call allocate_an_rm_attr_info_structure;
		call update_resultant_attributes_info;
	     end;
	     else do;
		irai_havent_found_one_yet = ON;
		do irai_loop = 1 to resultant_attributes_info.current_number_of_attributes
		     while (irai_havent_found_one_yet);
		     if resultant_attributes_info.attributes.name (irai_loop) = rm_attr_info.name
		     then do;
			irai_based_rm_attr_info_ptr = resultant_attributes_info.attributes.value_ptr (irai_loop);
			if unspec (irai_based_rm_attr_info) = unspec (rm_attr_info)
			then irai_havent_found_one_yet = OFF;
		     end;
		end;
		if irai_havent_found_one_yet
		then do;
		     call allocate_an_rm_attr_info_structure;
		     call update_resultant_attributes_info;
		end;
		else rai_ptr = irai_based_rm_attr_info_ptr;
	     end;
%skip(1);
	return;
%page;
allocate_an_rm_attr_info_structure: proc;
%skip(1);
	allocate rm_attr_info in (rm_db_info.static_area) set (rai_ptr);
	unspec (rm_attr_info) = unspec (irai_rm_attr_info);
%skip(1);
	return;
%skip(1);
     end allocate_an_rm_attr_info_structure;
%page;
update_resultant_attributes_info: proc;
%skip(1);
dcl 1 urai_rai_info like resultant_attributes_info based (urai_rai_info_ptr);
dcl urai_rai_info_ptr ptr;
dcl urai_save_number_of_attributes fixed bin;
%skip(1);
	if resultant_attributes_info.current_number_of_attributes + 1
	> resultant_attributes_info.number_of_attributes
	then do;
	     urai_rai_info_ptr = resultant_attributes_info_ptr;
	     urai_save_number_of_attributes = resultant_attributes_info.number_of_attributes;
	     rai_init_number_of_attributes = urai_save_number_of_attributes + mrds_data_$number_of_resultant_attributes;
	     allocate resultant_attributes_info in (dbcb.static_area)
		set (resultant_attributes_info_ptr);
	     resultant_attributes_info.number_of_attributes = urai_save_number_of_attributes;
	     unspec (resultant_attributes_info) = unspec (urai_rai_info);
	     resultant_attributes_info_ptr_parm = resultant_attributes_info_ptr;
	     free urai_rai_info in (dbcb.static_area);
	     resultant_attributes_info.number_of_attributes = urai_save_number_of_attributes + mrds_data_$number_of_resultant_attributes;
	     resultant_attributes_info.current_number_of_attributes = urai_save_number_of_attributes;
	end;
%skip(1);
	resultant_attributes_info.current_number_of_attributes
	     = resultant_attributes_info.current_number_of_attributes + 1;
	resultant_attributes_info.value_ptr (resultant_attributes_info.current_number_of_attributes) = rai_ptr;
	resultant_attributes_info.name (resultant_attributes_info.current_number_of_attributes) = rm_attr_info.name;
%skip(1);
	return;
%skip(1);
     end update_resultant_attributes_info;
%skip(1);
     end init_rm_attr_info;
%page;
init_rm_rel_info:
     proc ();

/* fill in the resultant relation info */

	nvar_atts_init = att_names.num_varying_attrs;
	nkey_attr_init = att_names.num_key_attrs;
	natts_init = att_names.num;

	allocate rm_rel_info set (rmri_ptr) in (rm_db_info.static_area);

	entire_view = rel_names.item.total_view (rel_index);
	rm_rel_info.name = rel_names.item.sm (rel_index);
	rm_rel_info.model_name = rtrim (rel_info.name);	/* CHANGE 81-09-16 */
	rm_rel_info.retrieve = (file_rdy.mode ^= LOAD);
	rm_rel_info.modify =
	     ((file_rdy.mode = UPDATE) | (file_rdy.mode = SCOPE_UPDATE));
	rm_rel_info.store =
	     (((file_rdy.mode = LOAD) | rm_rel_info.modify) & entire_view);
	rm_rel_info.delete = ((rm_rel_info.modify) & entire_view);
						/* verify str/del/mod flags valid before set */
	if rm_rel_info.nkey_attr = rel_info.num_key_attrs then
	     rm_rel_info.total_key = ON;
	else rm_rel_info.total_key = OFF;
	rm_rel_info.indexed = rel_info.indexed;
	rm_rel_info.mdbm_secured = rm_db_info.mdbm_secured; /* check whether secure_mrds_db has set this */
	rm_rel_info.status_perm = rel_names.item.status_perm (rel_index);
	rm_rel_info.append_tuple_perm =
	     rel_names.item.append_tuple_perm (rel_index);
	rm_rel_info.delete_tuple_perm =
	     rel_names.item.delete_tuple_perm (rel_index);
	rm_rel_info.unused_perm = rel_names.item.unused_perm (rel_index);
	rm_rel_info.last_model_attr_char_var = att_names.last_model_attr_char_var;
	rm_rel_info.reserved = OFF;
	rm_rel_info.num_attr = natts_init;
	rm_rel_info.model_num_attr = rel_info.num_attr;
	rm_rel_info.nkey_attr = nkey_attr_init;
	rm_rel_info.model_nkey_attr = rel_info.num_key_attrs;
	rm_rel_info.nsec_inds = 0;			/* not counted yet */
	rm_rel_info.max_key_len = ceil (rel_info.max_key_len / 9);
	rm_rel_info.current_tuple_population = 0;	/* set later at file attach time */

	rm_rel_info.last_statistics_update_count = 0;
	rm_rel_info.last_statistics_update_time = 0;
	rm_rel_info.last_statistics_update_s_e_ref_num = 0;
	if rel_info.primary_key_index_id = "111111111111111111111111111111111111"b then do;
		rm_rel_info.primary_key_index_id = "0"b;
		rm_rel_info.rel_id = (36)"1"b;
	     end;
	else do;
		rm_rel_info.primary_key_index_id = rel_info.primary_key_index_id;
		rm_rel_info.rel_id = rel_info.id;
	     end;
	rm_rel_info.reserved = OFF;
	rm_rel_info.ready_mode = file_rdy.mode;
	rm_rel_info.file_type = file_model.file_type;
	rm_rel_info.tuple_id_len = file_model.tuple_id_len;
	rm_rel_info.scope_flags_ptr = null ();



/* fill in the pointer arrays */

	call fill_rel_ptr_arrays ();			/* get good pointers for this process */

/* Set up an id_list structure for gets */

	il_number_of_ids = rm_rel_info.num_attr;
	allocate id_list in (rm_db_info.static_area) set (id_list_ptr);
	id_list.version = ID_LIST_VERSION_1;
	id_list.number_of_ids = il_number_of_ids;
	do i = 1 to rm_rel_info.num_attr;
	     id_list.id (i) = rm_rel_info.attr_ptrs (i)
		-> rm_attr_info.model_defn_order;
	end;
	rm_rel_info.id_list_ptr = id_list_ptr;

     end init_rm_rel_info;
%page;
fill_rel_ptr_arrays:
     proc ();

/* fill in all the pointer arrays in the rel info */


/* fill in the attribute pointer, key attribute pointer
   and varying data type attribute pointer arrays,
   and count up the number of secondary index attributes */

	j = 0;
	k = 1;
	do i = 1 to rm_rel_info.num_attr;

	     rai_ptr = att_names.item.rai_ptr (i);
	     rm_rel_info.attr_ptrs (i) = rai_ptr;

	     if ^rm_attr_info.key_attr then
		;
	     else do;

		     if entire_view then
			j = rm_attr_info.key_order;
		     else j = j + 1;
		     rm_rel_info.key_attr_ptrs (j) = rai_ptr;


		end;


	     if rm_attr_info.index_attr then
		rm_rel_info.nsec_inds = rm_rel_info.nsec_inds + 1;

	end;

     end fill_rel_ptr_arrays;
%page;



build_entry:
     proc (path_entry_offset, base_pointer, proc_type) returns (entry);

/* DESCRIPTION:

   This  procedure  initiates the segment referenced by the pathname structure
   at the given offset The pointer to the initiated segment is returned in the
   output_ptr  parameter.   If  the  segment  could not be initiated the error
   procedure is called.

*/

	dcl     output_entry	 entry variable;	/* output -- entry of initiated segment */
	declare proc_type		 char (*);	/* type of procedure being set up */
	declare path_entry_offset	 bit (18);	/* offset in the given area to the path_entry struct */
	declare base_pointer	 ptr;		/* base of segment for given path_entry */
	declare reported_error	 fixed bin (35);	/* error reported via sub_error */

	if error_code = 0 then do;
		path_entry_ptr = pointer (base_pointer, path_entry_offset);
		output_entry =
		     cv_entry_ (path_entry.path || "$" || path_entry.entry, null,
		     error_code);

		if error_code ^= 0 then do;
			reported_error = error_code;
			error_code = mrds_error_$bad_domain_proc;
			call sub_err_ (reported_error, caller_name, "c", addr (error_code),
			     return_value, "^/^a^a^a ^a^a^a ^a^a^a^/",
			     "Unable to build an entry variable for the """, proc_type,
			     """ procedure using the path$entry =", path_entry.path, "$",
			     path_entry.entry, "for """, error_source, """.");
		     end;
	     end;

	return (output_entry);

     end build_entry;
%page;
	dcl     (
	        insecure_frdy_ptr,			/* nonsecure pointer to file ready info */
	        insecure_dbrdy_ptr
	        )			 ptr;		/* points to db ready info */

	dcl     resultant_attributes_info_ptr_parm ptr parm;
	dcl     error_code		 fixed bin (35);	/* status codes */

	dcl     (
	        fa_index,				/* index to file array */
	        i,				/* index variable */
	        j,
	        k,
	        rel_index,				/* index to relation */
	        att_index,				/* index to attribute */
	        rm_rel_index			/* index into resultant relation array */
	        )			 fixed bin;

	dcl     (null, addr, ceil, fixed) builtin;
	dcl     (empty, pointer, rel, rtrim, unspec) builtin;

	dcl     sys_info$max_seg_size	 fixed bin ext;

	dcl     arg_submodel_iocb_ptr	 ptr;
	dcl     submodel_iocb_ptr	 ptr ext;

	declare NULL_OFFSET		 bit (18) init ((18)"1"b); /* mrds version of null offset */

	dcl     hcs_$initiate
				 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));

	dcl     mus_get_rel_names
				 entry (bit (1) unal, ptr, fixed bin, ptr, ptr, ptr, fixed bin (35));
	dcl     mus_get_att_names
				 entry (ptr, bit (1) unal, ptr, fixed bin, ptr, ptr, fixed bin (35));
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare sub_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (19) init ("mu_sec_make_res") /* calling program name */
				 int static options (constant);
	declare continue		 char (1) init ("c"); /* don't stop after printing message */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare temp_area_ptr	 ptr;		/* points to temporary segment for parameter area */
	declare parameter_area	 area (sys_info$max_seg_size) based; /* space for parameters */
	declare UNBLOCKED		 fixed bin init (1);/* type code for unblocked file */
	declare LOAD_MODE		 fixed bin init (4);/* load ready mode type */
	declare SCOPE_MODES		 fixed bin init (5);/* >= 5 => scope modes */
	declare NEVER_READIED	 bit (36) init ((36)"0"b); /* => file never been readied */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare LOAD		 fixed bin init (4);/* load mode type */
	declare UPDATE		 fixed bin init (3);/* update mode type */
	declare SCOPE_UPDATE	 fixed bin init (6);/* scope update mode type */
	declare type		 fixed bin;	/* temporary for descriptor type */
	declare BLANK		 char (1) init (" "); /* space character */
	declare mu_data_length	 entry (bit (36)) returns (fixed bin (35));
						/* bit length from descriptor */
	declare error_source	 char (48) varying; /* logical structure where setting up proc ptrs */
	dcl     cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry);
						/* get an entry from path$entry */
	declare entire_view		 bit (1);		/* on => all attributes present in view of relation */
	declare error_table_$moderr	 fixed bin (35) ext static; /* no access to entry */
	declare mrds_data_$number_of_resultant_attributes fixed bin (35) external;
	declare mrds_error_$bad_domain_proc fixed bin (35) ext; /* No acces to encode/decode procedure */
	declare mrds_dm_authorization$set_needed_access
				 entry (char (*), fixed bin (35)); /* sets access for DBA types */
%page;
%include dm_id_list;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_dbcb;
%page;
%include mdbm_db_file_list;
%page;
%include mdbm_rel_att_array;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_scope_info;
%page;
%include mrds_res_attr_info;
     end mu_sec_make_res;





		    mu_sec_reg_user.pl1             08/01/88  1347.6r w 08/01/88  1315.0       99270



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

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

mu_sec_reg_user: reg_user: procedure (ins_dbc_ptr, ins_rdbi_ptr, code);

/*
   This procedure checks for dead processes and registers users
   and their associated relations, if applicable, at open time
*/

/* HISTORY:

   Written by O D Friesen for queued scope requests -- July 1977
   Modified by A. N. Kepner, Feb 27, 1979 to correct reference to
   error_table_$lock_wait_time_exceeded (was misspelled.)
   Modified by A. N. Kepner, March 14, 1979 to remove the quiesce_sw
   parameter and to add new users to the beginning (as opposed to the end)
   of the list of open users.
   Modified by M. Pierret 5 Feb 1980 to correct the use of set_lock_
   and to de-queue dead procs.
   Modified by M. Pierret 29 Feb 1980 to fix >one dead processes case.

   80-12-12 Jim Gray : added initialization of pad areas in the user_list structure.

   80-12-23 Jim Gray : added capture of error for no write permission
   on the database control segment, rather than attempting a write
   and winding up with an un-handled condition.

   81-05-29 Jim Gray : modified to use new resultant model structures.

   81-09-15 Davids: added the rtrim operator.  this  was  needed  so
   that the module would compile when -prefix stringsize was used in
   the call to pl1. The length of rm_rel_array.name.submodel was not
   changed  to char (30) even though 30 characters is the max length
   because the current length of 32 is hard-wired in to the code  in
   several places.

   83-05-20 Davids: explicitly declared builtins that were left implicitly
   declared and deleted declarations to things that were no longer used.
*/

	hold_ul_ptr = null;
	dbc_ptr = ins_dbc_ptr;
	rdbi_ptr = ins_rdbi_ptr;
	code, icode, kode, num_filns = 0;
	if dbc.trouble_switch
	then do;
		code = mdbm_error_$trouble_lock;
		go to exit;
	     end;

	call set_lock_$lock (dbc.open_lock, mdbm_data_$lock_wait, code); /* lock the open table */
	if code = error_table_$invalid_lock_reset |
	     code = error_table_$locked_by_this_process
	then code = 0;
						/* ignore these error codes */
	if code = error_table_$no_w_permission then do;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a^a^a",
		     "No permission to set scope lock on """, rtrim (rm_db_info.db_path),
		     ">", rtrim (mrds_data_$control_segment_name), """.");
		goto exit;
	     end;
	else if code ^= 0 then do;
		dbc.trouble_switch = "1"b;		/* prevent further openings while inconsistent */
		goto exit;
	     end;

	on cleanup call clean_up;

	call morgue (icode);			/* warning_flag will be examined later */
	if icode ^= 0 then call error (icode);
	call register_user (icode);

	if warning_flag then dbc.dead_proc_flag = "1"b;
	call set_lock_$unlock (dbc.open_lock, kode);
	if icode ^= 0 then call error (icode);
	else if kode ^= 0 then call error (kode);

exit:	return;

register_user: proc (icode);

	dcl     i			 fixed bin;
	dcl     icode		 fixed bin (35);
	dcl     ptr_bit_string	 bit (72) based;	/* bit string format of pointer variable */

	dbc.open_users = dbc.open_users + 1;
	rmra_ptr = rm_db_info.ra_ptr;
	num_filns = rm_rel_array.num_rels;
	allocate user_list in (dbc.static_area) set (hold_ul_ptr);
	unspec (hold_ul_ptr -> user_list) = "0"b;	/* zero pad areas */

	ul_ptr = hold_ul_ptr;
	call get_lock_id_ (user_list.db_lock_id);
	if icode ^= 0 then call error (icode);
						/* we must
						   differentiate between
						   different openings of the same data base
						   by one process ... the pointer to the resultant
						   data base info will serve as the tiebreaker in such cases */
	user_list.rdbi_bits = addr (rdbi_ptr) -> ptr_bit_string;
	user_list.num_filns = num_filns;
	user_list.fil_list_ofs = NULL_OFS;
	user_list.next_active_ofs = NULL_OFS;
	user_list.next_waiting_ofs = NULL_OFS;
	user_list.next_open_ofs = dbc.open_users_ofs;	/* Add user to list of data base
						   open users. */
	dbc.open_users_ofs = rel (ul_ptr);
	user_list.group_id = get_group_id_ ();
	user_list.open_mode = mdbm_data_$normal_mode;
	user_list.bypass_count = 0;
	user_list.allowance_count = 0;
	user_list.process_id = get_process_id_ ();
	user_list.ev_chn_id = 0;
	user_list.dead_proc = "0"b;
	user_list.dead_proc_conflict = "0"b;
	user_list.priority_high = "0"b;
	user_list.waiting_sw = "0"b;
	user_list.active_sw = "0"b;
	user_list.event_signal_sw = "0"b;
	user_list.passive_sw = "1"b;			/* assume passivity */
	do i = 1 to user_list.num_filns;
	     user_list.file (i) = rtrim (rm_rel_array.name.submodel (i));
						/* CHANGE 81-09-15 */
	end;

     end register_user;

morgue: proc (icode);

/*
   we are looking for dead processes which still have this data base open.
   If a dead process is found then see if it has  a -permit stor, modify or delete
   (denoted by dbc.passive_sw being turned OFF) on any relation.
   In this case set a warning flag
   to indicate that the data base is potentially infirm -- then go on and complete the opening process.

   It is the user's choice whether to proceed or give up and call
   the DBA.

   If the dead process is passive, then de-queue it and continue
*/

	dcl     icode		 fixed bin (35);


	warning_flag = "0"b;
	if dbc.open_users > 0 then do;
		icode = 0;
		ul_ptr = convert (dbc_ptr, dbc.open_users_ofs); /* look at all users who have the data base open */
		do while (ul_ptr ^= null & icode = 0);

/* determine whether the process represented by this user is dead or alive.
   If it is dead then set_lock should return a status of invalid_lock_id.
   If it is alive then set_lock should return a status of locked_by_this_process.
   Any other status is an error .
*/

		     de_queue_flag = "0"b;

		     call dead_or_alive (icode);

		     if de_queue_flag		/* If dead proc was de-queued... */
		     then ul_ptr = next_ul_ptr;	/* ..then next ul ptr was saved */
		     else if ul_ptr ^= null
		     then ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);

		end;

	     end;

     end morgue;


dead_or_alive: proc (icode);

	dcl     icode		 fixed bin (35);


	icode = 0;
	if user_list.dead_proc then status = DEAD;
	else do;
		status = ALIVE;
		call set_lock_$lock ((user_list.db_lock_id), 0, state);
		if state ^= 0 then do;
			if state = error_table_$invalid_lock_reset /* locked by dead  process */
			then status = DEAD;
			else if state = error_table_$locked_by_this_process |
				state = error_table_$lock_wait_time_exceeded
			then status = ALIVE;
			else icode = state;
		     end;
	     end;

	if icode = 0
	then if status = DEAD
	     then if ^user_list.passive_sw
		then do;
			warning_flag = "1"b;
			user_list.dead_proc = "1"b;
		     end;

		else do;
			de_queue_flag = "1"b;
			next_ul_ptr = convert (dbc_ptr, user_list.next_open_ofs); /* After user is dequeued */
						/* we won't be able to get the next user */
			call mu_de_queue_user (DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr, icode);
			icode = 0;
		     end;


     end dead_or_alive;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

clean_up: proc;
	if hold_ul_ptr ^= null
	then free hold_ul_ptr -> user_list in (dbc.static_area);
     end clean_up;

error: proc (cd);
	dcl     cd		 fixed bin (35);

	code = cd;
	if warning_flag then dbc.dead_proc_flag = "1"b;
	call clean_up;
	call set_lock_$unlock (dbc.open_lock, kode);
	goto exit;
     end error;

	dcl     code		 fixed bin (35);	/* standard status return code */
	dcl     kode		 fixed bin (35);
	dcl     state		 fixed bin (35);

	dcl     status		 bit (1) unal;	/*  ON => process is alive; OFF => process is dead */

	dcl     ins_dbc_ptr		 ptr;		/* points to data base control seg. */
	dcl     ins_rdbi_ptr	 ptr;		/* points to resultant db info */

	dcl     warning_flag	 bit (1) unal;	/* indicates a relation is in the scope of a dead process */
	dcl     de_queue_flag	 bit (1) unal;	/* ON => dead proc was de-queued */
	dcl     icode		 fixed bin (35);

	dcl     hold_ul_ptr		 ptr;		/* holder for ptr to newly allocated user_list entry */
	dcl     next_ul_ptr		 ptr;		/* holds next ul ptr if user de-queued */

	dcl     (addr, fixed, null, rel, rtrim, unspec) builtin;
	dcl     cleanup		 condition;

/*	Multics subroutines		*/

	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35)),
	        get_group_id_	 entry returns (char (32)),
	        get_process_id_	 entry returns (bit (36)),
	        get_lock_id_	 entry (bit (36) aligned),
	        set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));

/*	Other subroutines		*/

	dcl     mu_de_queue_user	 entry (bit (1), bit (1), ptr, ptr, fixed bin (35));
	declare sub_err_		 entry options (variable); /* reports error details */
	declare continue		 char (1) init ("c") int static options (constant); /* dont stop after printing mesg */
	declare info_ptr		 ptr init (null ());/* dummy argumnt */
	declare return_value	 fixed bin (35) init (0); /* dummy argument */
	declare caller_name		 char (32) init ("mu_sec_reg_user") int static options (constant); /* name of calling routine */
	declare mrds_data_$control_segment_name char (32) ext; /* name of concurrenty control segment */


/*		External data		*/

	dcl     mdbm_data_$normal_mode fixed bin ext,
	        mdbm_data_$lock_wait	 fixed bin ext,
	        mdbm_error_$trouble_lock fixed bin (35) ext,
	        error_table_$no_w_permission fixed bin (35) ext,
	        error_table_$locked_by_this_process fixed bin (35) ext,
	        error_table_$invalid_lock_reset fixed bin (35) ext,
	        error_table_$lock_wait_time_exceeded fixed bin (35) ext,
	        sys_info$max_seg_size	 fixed bin (35) ext;

%include mdbm_rm_db_info;

%include mdbm_rm_rel_array;

%include mdbm_dbc;

%include mdbm_users;

     end mu_sec_reg_user;





		    mu_store.pl1                    08/01/88  1347.6r w 08/01/88  1315.0       65736



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

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

mu_store: store: proc;				/* This entry point is not used */
	return;

/*
		      BEGIN_DESCRIPTION

   This is the MDBM utility routine which will store a tuple into the database,
   given information on the relation into which the tuple is to be stored and
   a list of user-supplied values.

		       END_DESCRIPTION



*/
%page;
/* HISTORY:

   Initially written by JA Weeldreyer -- June, 1978.
   6-sep-79 Davids: Modified to accommodate a change to the calling sequence of mu_encd_key
   16-oct-79 Davids: Modified to correctly calculate the lengths of varying strings
   28-nov-79 Davids: Removed calculation of length (in bits) of varying strings
   so that length word will consistantly contain the number of bits or characters
   (depending on data type) throught out MRDS (i hope)
   Modified by Jim Gray - - Feb. 1980, to make use of extensible non-freeing area.
   8-may-80  Davids:  modified  assignments  of  tuple_num_atts  and
   tuple_nvar_atts  to  take  values from rm_rel_info.model_num_attr
   and  model_nvar_atts   rather   than   rm_rel_info.num_attr   and
   nvar_atts.  This  was  to  fix  a problem with submodels were the
   submodel view did not contain a varying string attribute and  the
   model did.
   Modified by Jim Gray - - June 1980, to add first_time_flag to direct entry,
   so that definition of large temp rels could reuse space already allocated.

   80-11-04 Davids: removed the code checking for update  access  on
   each  attribute  in  the relation since the current definition of
   store  requires  only  append  (s_perm  =  "1"b)  access  on  the
   relation.   also   removed   the   include   file   reference  to
   mdbm_rm_db_info.incl.pl1 and declared  rdbi_ptr  (which  was  the
   only thing used from that include file) as an automatic pointer.

   80-11-07  Davids:  Changed  reference  to  rm_rel_info.s_perm  to
   rm_rel_info.append_tuple_perm   to  correspond  to  include  file
   changes.

   80-11-21 Davids: For the secured database case, added a check  to
   be sure that r_perm is set for all attributes of the primary key.
   This was needed to prevent a situation where  tuples  are  stored
   until  the  dup_key  error  is  returned - at which time database
   security has been broken.

   81-03-27 Jim Gray : added dbcb_ptr parameter in place of dbi parameter
   for each entry, as part of getting rid of mus_ptr_man module.
   Combined mu_sec_store into this module.

   81-04-30 Jim Gray : commented out calls to mus_add_btup
   and mus_add_lks

   81-05-01 Jim Gray : removed calls to mu_hash_key and mu_build_parl
   by commenting them out, since they are only used by blocked files
   and foreign keys, which are not implemented.


   81-05-29 Jim Gray : changed to use new form of resultant structure.
   Also deleted unused code.

   82-09-07 Mike Kubicar : converted to use the tuple structure.  Note that
   this routine should not have to access the internal structure of a tuple
   since it merely passes tuples between routines via pointer.  In this phase
   of the conversion (of tuples) some code which references the tuple
   structure has been left in.  This is because the code will be deleted soon
   as it manipulates key lists.  Key list code will be deleted when the
   module is entirely converted.

   82-09-24 D. Woodka : Modified for DMS conversion to call mu_cursor_manager
   and relation_manager put_tuple. 

   83-03-30 Davids: Eliminated variables that were not used (in some cases they
   were set but had no impact on the rest of the execution): direct,
   allocation_flag, temp_flag, TEMP, ncbs, change_bits, cbp, saved_cbp, and i.
   Removed the references to the mdbm_change_bits mdbm_rm_domain_info
   mdbm_descriptor mdbm_index and mdbm_rm_db_info include files.
   Moved the call to build_tuple to before the direct entry so the direct flag
   indicating the type of entry was not needed (build_tuple is not called if
   the module is called via the direct entry). Note that the first_time_flag
   and area_ptr in the calling sequence of the direct entry are no longer
   needed. Explicitly declared the builtins addr, fixed, and rel which were
   declared by implication.

   83-04-04 Davids: Eliminated the ready_mode, view and security level
   checking (moved them into mrds_dsl_store). Also eliminated the variables
   i, mdbm_error_$inc_rel_acc, mdbm_error_$inc_attr_acc, UPDATE, LOAD,
   SCOPE_UPDATE, mdbm_error_$inc_ready_mode, mdbm_error_$view_prevent, null
   and the mdbm_rm_attr_info include file which are no longer needed.

   83-04-08 Mike Kubicar : Removed unused code (mu_store main entry point).
   Also unused parameters from mu_store_$direct.  Added check of error
   code after call to mu_cursor_manager_$get and made sure the tuple
   variable index used in the call is zero.

   83-05-23 Mike Kubicar : Changed relation manager calling sequences.

*/
%page;
direct: store_direct: entry (dbcb_ptr, rmri_ptr, simple_typed_vector_ptr, code);

/* get cursor for call to relation_manager put_tuple */

	tuple_variable_index = 0;			/* tvi is always zero for any store */
	call mu_cursor_manager_$get (dbcb.dbi, rmri_ptr, tuple_variable_index,
	     rm_rel_info.rel_id, dbcb.relmgr_entries.create_cursor,
	     dbcb.relmgr_entries.open, dbcb.cursor_ptrs_storage_ptr,
	     dbcb.cursor_storage_area_ptr, cursor_ptr, code);
	if code ^= 0
	then call error (code);
	call dbcb.relmgr_entries.put_tuple (cursor_ptr,
	     simple_typed_vector_ptr, tuple_id, code);
	if code ^= 0 then call error (code);


	code = 0;
exit:
	return;
%page;
error: proc (cd);

/* Error procedure, sets code, cleans up, and exits */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;
%page;

	dcl     cursor_ptr		 ptr;		/* ptr for cursor to use for put_tuple */
	dcl     code		 fixed bin (35);	/* Output: status code */
	dcl     tuple_id		 bit (36) aligned;	/* tuple id for stored tuple */
	dcl     tuple_variable_index	 fixed bin (35);	/* for call to cursor_manager */
	dcl     simple_typed_vector_ptr ptr;		/* vector to be stored */
	dcl     (addr, fixed, rel)	 builtin;
	dcl     mu_cursor_manager_$get entry (fixed bin (35), ptr, fixed bin (35), bit (36) aligned, entry, entry, ptr, ptr,
				 ptr, fixed bin (35));
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
%page;
%include mdbm_rm_rel_info;
%page;
%include mrds_dbcb;
%page;
     end mu_store;




		    mu_temp_segments.pl1            10/16/86  1551.4rew 10/16/86  1144.3      205299



/****^  ***********************************************************
        *                                                         *
        * 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-02-14,Spitzer), approve(86-02-14,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     add free_temp_segments, get_temp_segment_path, cleanup_temp_dir
     and get_temp_segments_path entry points.
                                                   END HISTORY COMMENTS */


/* HISTORY:

   11/21/75	by S. Webber (Initial coding)
   11/15/76	by Larry Johnson to add arguments to list_temp_segments
   08/29/77	by Melanie Weaver to add entry list_segnos
   11/2/77	by Richard A. Barnes to add get_temp_segment_ & release_temp_segment_
   08/25/80         by E Brunelle, renamed mu* to be used by the MRDS system
   .                to allow 'temp' segments to be put into the mrds temp dir
   .		and to add entry  free_temp_segment_, which does not truncate
   .		temp seg, to improve performance
   10/20/80		by Jim Gray, to use mrds_dsl_resultant_storage$get_opening_temp_dir, so that
   .		proper temp dir for a databse opening is used,
   .		this required adding the database index parameter to
   .		"get" entries.
   10/20/80		by Jim Gray, to change naming conventions for entries
   .		to those used by mdbm_util_, this meant removing
   .		trailing "_", having an unused main procedure, and entry
   .		names as would be seen in calls to mdbm_util_$get_temp_segment, etc.
   10/20/80		by Jim Gray, to add delete_all_temp_segments
   .		entry, so that dsl_$close can remove temp segs from the temp dir.
   10/20/80		by Jim Gray, to remove code that wiped out the caller when releasing,
   .		so that the delete entry could work properly, since the logic
   .		for the "used" bit always masks anyone from seeing it anyway.
   10/21/80		by Jim Gray, to change ".temp." suffix of temp seg names
   .		to ".MRDS.", in order to identify mrds temp segs.
   10/21/80		by Jim Gray, to insure that only temp segs belonging
   .		to the current caller, of those that are free, are actually used by the caller.
   .		this avoids one database opening using temp segs in another
   .		opeings temp dir, which can be removed by that opening being closed.
   10/21/80		by Jim Gray, to add free_all_temp_segments entry,
   .		that will be used by mrds_dsl_delete_se instead of
   .		the entry release_all_temp_segments.
   .		this is a tradeoff of capacity against performance.

   81-09-16 Davids: changed the declarations of ename to  char  (32)
   from char (20) and block.name to char (32) from char (25) so that
   stringsize errors would not result when compiling with  a  prefix
   of stringsize.

   83-03-10 Davids: added the delete_temp_segment entry point.

   83-05-03 Davids: Modified so that the uid of the directory the temp seg is
   in is recorded in the block structure (dir_uid element). When a call to
   get a temp segment is made the uid of the opening_temp_dir is obtained and
   a free temp segment in the same temp dir is looked for. The old check that
   assigned a temp segment only if the caller names were equal was removed - 
   as long as the temp seg is currently free who cares who originally created
   it. For segments that are freed or released the caller name is changed to
   FREE so that a call to (free release delete)_all which acts only on the
   caller name will work correctly, i.e. not delete anything its not supposed
   to. Adding the dbi onto the caller name does not help since the database
   index is reused.

   83-05-04 Davids: Modified to set the a_code parameter to 0 in the
   delete_temp_segment entry so that if the segment is deleted it will return
   0 and not what ever happened to be input.
*/

mu_temp_segments:
     proc ();
	return;					/* not valid entry */

/* description and parameters on next page */
%page;
/* DESCRIPTION:

   this program was originally the system get_temp_segment_ manager routines.
   It was adopted for the MRDS subsystem utility interface.
   This allowed the storage for the temp segments to be other than the process dir.
   It added the entries free_temp_segment, and delete_all_temp_segments
   to the existing entries of get_temp_segments(s), release_temp_segment(s),
   list_temp_segments, list_segnos, release_all_temp_segments.
   The free_temp_segment(s) does not do truncation on the temp segment,
   in order to improve performance (the existing space is just reused)
   The delete_all_temp_segments is used by dsl_$close to actually remove
   all temp segments associated with a particular database opening.
   The segments are named {unique_name}.MRDS.[seg_no]
   The storage of the temp segments can be changed via the set_mrds_temp_dir command.
   Each database opening will have it's own independent set of temp segs,
   that are managed in a pool, unaffected by other db openings.
   Currently mrds_dsl_search uses the temp segments for tid_array storage
   in processing internal mrds intersection/union/difference of tuple id sets.

*/

/* Parameters */

	dcl     a_caller		 char (*);	/* INPUT: calling program identifier */
	dcl     a_path		 char (*);	/* INPUT: directory to create temp segs in */
	dcl     a_ptrs		 (*) ptr;		/* pointers to temp segments INPUT/OUTPUT */
	dcl     a_code		 fixed bin (35);	/* OUTPUT: error status encoding */
	declare a_db_index		 fixed bin (35);	/* INPUT: database opening index */
%page;
/* Automatic */

	dcl     new_block_ptr	 ptr;
	dcl     array_ptr		 ptr;
	declare temp_dir		 char (168);	/* path of mrds temp dir for this opening */
	dcl     j			 fixed bin;
	dcl     n_segs		 fixed bin;
	dcl     new_blocks		 fixed bin;
	dcl     i			 fixed bin;
	dcl     n_found		 fixed bin;
	declare n_deleted		 fixed bin;
	dcl     old_blocks		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     ename		 char (32);	/* CHANGE 81-09-16 */
	dcl     ename2		 char (32);
	dcl     segno		 (4) char (1) defined (ename2) pos (22);
	dcl     segment_number	 fixed bin;
	dcl     found_it		 bit (1);
	dcl     arg_count		 fixed bin;
	dcl     arg_list_ptr	 ptr;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin;
	dcl     release_called	 bit (1);
	dcl     containing_temp_dir	 char (168);
	dcl     entry_temp_dir	 char (32);
	dcl     temp_dir_uid	 bit (36);
	dcl     01 local_status	 like status_branch;

/* Based */

	dcl     ptrs		 (n_segs) ptr based (array_ptr);
	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     1 octal_digits	 aligned based (addr (segment_number)),
		2 filler		 bit (24) unal,
		2 digit		 (4) bit (3) unal;
	dcl     1 new_block		 (new_blocks) aligned based (new_block_ptr) like block;
	dcl     1 block		 (n_blocks) aligned based (block_ptr),
		2 dir_uid		 bit (36),
		2 caller		 char (32),
		2 segptr		 ptr,
		2 name		 char (32),	/* CHANGE 81-09-16 */
		2 used		 bit (1);
	dcl     area		 area based (areap);

/* Static */

	dcl     block_ptr		 ptr static init (null);
	dcl     areap		 ptr static init (null);
	dcl     n_blocks		 fixed bin static init (0);

/* Builtin */

	dcl     (addr, baseno, bin, dim, max, null, substr) builtin;

/* Entries */

	dcl     hcs_$chname_seg	 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     get_system_free_area_	 entry returns (ptr);
	dcl     hcs_$delentry_seg	 entry (ptr, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unique_bits_	 entry returns (bit (70));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$make_seg
				 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35))
				 ;
	dcl     ioa_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
	dcl     mrds_dsl_resultant_storage$get_opening_temp_dir
				 entry (fixed bin (35), fixed bin (35)) returns (char (168));

/* External */

	dcl     error_table_$argerr	 fixed bin (35) ext;
	dcl     error_table_$no_s_permission fixed bin (35) ext;


/* Includes */
%page;
%include status_structures;
%page;
/* Execution of mu_get_temp_segments_ begins here */

get_temp_segments:
     entry (a_db_index, a_caller, a_ptrs, a_code);

	n_segs = dim (a_ptrs, 1);			/* get number of segments wanted */
	array_ptr = addr (a_ptrs);			/* get ptr to the array of ptrs */
	goto gts_join;

get_temp_segments_path:
     entry (a_path, a_caller, a_ptrs, a_code);

	temp_dir = a_path;
	n_segs = dim (a_ptrs, 1);
	array_ptr = addr (a_ptrs);
	goto gts_join_have_path;

gts_join:
	temp_dir =
	     mrds_dsl_resultant_storage$get_opening_temp_dir (a_db_index, code);
	if code ^= 0 then do;
		a_code = code;
		return;
	     end;

gts_join_have_path:
	a_code = 0;
	n_found = 0;				/* initialize indicating we've found no free entries */
	call expand_pathname_ (temp_dir, containing_temp_dir, entry_temp_dir, code);
	if code ^= 0 then do;
		a_code = code;
		return;
	     end;
	status_ptr = addr (local_status);
	call hcs_$status_long (containing_temp_dir, entry_temp_dir, 0, status_ptr, null (), code);
	if code ^= 0 & code ^= error_table_$no_s_permission then do;
		a_code = code;
		return;
	     end;
	temp_dir_uid = status_ptr -> status_branch.long.uid;

	if block_ptr = null then do;			/* we haven't yet gotten any segments */
		n_blocks = n_segs;			/* so get the exact amount requested */
		areap = get_system_free_area_ ();	/* get pointer to standard area to use */
		allocate block in (area) set (block_ptr); /* get the needed storage */
		old_blocks = 0;			/* needed by get_new_segments routine */
		call get_new_segments;		/* do the work in this subr */
		return;
	     end;

	do i = 1 to n_blocks while (n_found < n_segs);	/* search for the necessary free segments */
	     if ^block (i).used & (block (i).dir_uid = temp_dir_uid) then do;
						/* we found another free one */

/* we have found an unused temp seg in the appropriate temp dir */

		     block (i).used = "1"b;		/* mark entry as being used */
		     block (i).caller = a_caller;	/* update the caller name */
		     n_found = n_found + 1;
		     ptrs (n_found) = block (i).segptr;
		end;
	end;
	if n_found < n_segs then do;			/* there weren't enough free ones */
		new_blocks = n_blocks + n_segs - n_found; /* get more storage, just large enough */
		old_blocks = n_blocks;
		if areap = null then
		     areap = get_system_free_area_ ();	/* get pointer to area */
		allocate new_block in (area) set (new_block_ptr); /* get the needed storage */
		new_block_ptr -> block = block;	/* copy the current structure */
		free block in (area);
		n_blocks = new_blocks;
		block_ptr = new_block_ptr;
		call get_new_segments;		/* get the needed segments */
	     end;

	return;
%page;
get_new_segments:
     proc;

	dcl     (i, j)		 fixed bin;

	do i = old_blocks + 1 to n_blocks;		/* initialize the new entries */
	     block (i).used = "1"b;			/* the caller will use these blocks */
	     block (i).caller = a_caller;		/* ditto */
	     block (i).dir_uid = temp_dir_uid;
	     ename2 = unique_chars_ (unique_bits_ ()) || ".MRDS.";
	     ename = ename2;
	     call
		hcs_$make_seg (temp_dir, ename, "", 01110b, block (i).segptr, code);
	     if code ^= 0 then do;
		     call undo;
		     return;
		end;
	     segment_number = bin (baseno (block (i).segptr), 18);
	     do j = 1 to 4;
		segno (j) = substr ("01234567", bin (digit (j), 3) + 1, 1);
	     end;
	     call hcs_$chname_seg (block (i).segptr, ename, ename2, code);
	     if code ^= 0 then do;
		     call undo;
		     return;
		end;
	     block (i).name = ename2;
	     n_found = n_found + 1;
	     ptrs (n_found) = block (i).segptr;
	end;

undo:
     proc;

	a_code = code;
	n_blocks = old_blocks;			/* reset to the way things were */
	do j = old_blocks + 1 to i - 1;		/* clean up the segments we already got */
	     call hcs_$delentry_seg (block (j).segptr, code);
	end;

     end;
     end;
%page;
get_temp_segment:
     entry (a_db_index, a_caller, a_ptr, a_code);

	dcl     a_ptr		 ptr parameter;

	n_segs = 1;				/* only 1 segment is being processed */
	array_ptr = addr (a_ptr);
	go to gts_join;

get_temp_segment_path:
     entry (a_path, a_caller, a_ptr, a_code);

	temp_dir = a_path;
	n_segs = 1;
	array_ptr = addr (a_ptr);
	goto gts_join_have_path;
%page;
release_temp_segments:
     entry (a_caller, a_ptrs, a_code);

	n_segs = dim (a_ptrs, 1);			/* get number of segments wanted */
	array_ptr = addr (a_ptrs);			/* get ptr to the array of ptrs */
	release_called = "1"b;			/* need to truncate also */
rts_join:
	a_code = 0;
	do i = 1 to n_segs;				/* release each segment passed in */
	     if ptrs (i) ^= null then do;
		     found_it = "0"b;		/* flag says we've not yet found this segment */
		     do j = 1 to n_blocks while (^found_it); /* search for segment in array */
			if block (j).used then do;	/* candidate, see if right one */
				if ptrs (i) = block (j).segptr then do; /* we found the given segment */
					if block (j).caller ^= a_caller then
					     a_code = error_table_$argerr;
					else do;	/* the right guy (as far as we care) */
						if release_called then do; /* wants to truncate it also */
							call hcs_$truncate_seg (block (j).segptr, 0, code);
						/* truncate now */
							if code ^= 0 then
							     a_code = code; /* accumulate error */
						     end;
						block (j).used = "0"b; /* ditto */
						block (j).caller = "FREE";
						ptrs (i) = null;
						found_it = "1"b;
					     end;
				     end;
			     end;
		     end;
		     if ^found_it then
			a_code = error_table_$argerr;
		end;
	end;
	return;
%page;
release_temp_segment:
     entry (a_caller, a_ptr, a_code);

	n_segs = 1;				/* only 1 segment is being processed */
	array_ptr = addr (a_ptr);
	release_called = "1"b;			/* truncate the seg also */
	goto rts_join;

free_temp_segments:
     entry (a_caller, a_ptrs, a_code);

	n_segs = dim (a_ptrs, 1);
	array_ptr = addr (a_ptrs);
	release_called = "0"b;
	goto rts_join;



free_temp_segment:
     entry (a_caller, a_ptr, a_code);

/* this entry will just free the segment and not truncate it */
/* this is a performance hack */

	n_segs = 1;				/* only 1 segment is being processed */
	array_ptr = addr (a_ptr);
	release_called = "0"b;			/* just free the seg */
	goto rts_join;
%page;
release_all_temp_segments:
     entry (a_caller, a_code);

/* entry to release all temp segments for a_caller */

	release_called = "1"b;

rats_join:
	a_code = 0;
	found_it = "0"b;				/* flag says we've not yet found this segment */
	do j = 1 to n_blocks;			/* search for segment in array */
	     if block (j).used then /* candidate, see if right one */
		if block (j).caller = a_caller then do; /* the right guy (as far as we care) */
			if release_called then do;
				call hcs_$truncate_seg (block (j).segptr, 0, code);
						/* truncate now */
				if code ^= 0 then
				     a_code = code; /* accumulate error */
			     end;
			block (j).used = "0"b;	/* ditto */
			block (j).caller = "FREE";
			found_it = "1"b;
		     end;
	end;
	if ^found_it then
	     a_code = error_table_$argerr;
	return;










free_all_temp_segments:
     entry (a_caller, a_code);

/* entry to set temp segs for caller to un-unused,
   without doing a truncation of the segments.
   this saves time, but allows the temp segs to grow to that
   size which the largest selection expression would use */

	release_called = "0"b;
	goto rats_join;
%page;
delete_all_temp_segments:
     entry (a_caller, a_code);

/* entry to delete all temp segments for a_caller */

	a_code = 0;
	found_it = "0"b;				/* flag says we've not yet found this segment */
	n_deleted = 0;
	do j = 1 to n_blocks;			/* search for segment in array */
	     if block (j).caller = a_caller then do;	/* the right guy (as far as we care) */
		     call hcs_$delentry_seg (block (j).segptr, code);
		     if code ^= 0 then
			a_code = code;		/* accumulate error */
		     n_deleted = n_deleted + 1;
		     found_it = "1"b;
		end;
	end;

/* shrink list of temp segments, removing current callers
   temp segments from the list of all temp segs */


	if ^found_it then
	     a_code = error_table_$argerr;		/* no segs for caller */
	else do;
		new_blocks = n_blocks - n_deleted;
		old_blocks = n_blocks;
		if areap = null then
		     areap = get_system_free_area_ ();
		allocate new_block in (area) set (new_block_ptr);

		i = 1;
		do j = 1 to old_blocks;
		     if block (j).caller = a_caller then
			;
		     else do;			/* save everyone elses temp segs */
			     new_block (i) = block (j);
			     i = i + 1;
			end;

		end;

		free block in (area);
		n_blocks = new_blocks;
		block_ptr = new_block_ptr;

	     end;

	return;
%page;
/* this entry is mainly called by restructure_mrds_db to delete all the temp
   segments in some directory. this is because rmdb creates a temp dir in the
   temp dir specified, then deletes the created dir to get rid of all segments
   at once. the saved static pointers in this program are invalid and may point
   to other initiated segments. */

cleanup_temp_dir:
     entry (a_path, a_code);

	a_code = 0;
	found_it = "0"b;
	n_deleted = 0;
	call expand_pathname_ (a_path, containing_temp_dir, entry_temp_dir, code);
	if code ^= 0 then do;
	     a_code = code;
	     goto end_cleanup_temp_dir;
	     end;

	status_ptr = addr (local_status);
	call hcs_$status_long (containing_temp_dir, entry_temp_dir, 0, status_ptr, null (), code);
	if code ^= 0 & code ^= error_table_$no_s_permission then do;
	     a_code = code;
	     goto end_cleanup_temp_dir;
	     end;
	temp_dir_uid = status_ptr -> status_branch.long.uid;

/* delete all segments with the same containing directory uid */
	do j = 1 to n_blocks;
	     if block (j).dir_uid = temp_dir_uid then do;
		call hcs_$delentry_seg (block (j).segptr, code);
		if code ^= 0 then a_code = code;

		n_deleted = n_deleted + 1;
		found_it = "1"b;
		end;
	     end;					/* do j */

/* shrink the list of temp segments. */
	if ^found_it then
	     a_code = error_table_$argerr;
	else do;
	     new_blocks = n_blocks - n_deleted;
	     old_blocks = n_blocks;
	     if areap = null then
		areap = get_system_free_area_ ();
	     allocate new_block in (area) set (new_block_ptr);

	     i = 1;
	     do j = 1 to old_blocks;
		if block (j).dir_uid = temp_dir_uid then
		     ;				/* ignore this directories entries */
		else do;
		     new_block (i) = block (j);
		     i = i + 1;
		     end;
		end;				/* do j */

	     free block in (area);
	     n_blocks = new_blocks;
	     block_ptr = new_block_ptr;

	     end;

end_cleanup_temp_dir:
	     return;
%page;
delete_temp_segment: entry (a_caller, a_ptr, a_code);

/* this entry will delete the segment with the given name and pointer */

	n_segs = 1;
	array_ptr = addr (a_ptr);
	a_code = 0;

	found_it = "0"b;
	do i = 1 to n_blocks while (^found_it);
	     if block (i).segptr = ptrs (1) & block (i).caller = a_caller
	     then found_it = "1"b;
	end;

	if ^found_it
	then do;
		a_code = error_table_$argerr;
		goto exit_delete_temp_segment;
	     end;

	i = i - 1;				/* search loop increments i before checking found_it */
	call hcs_$delentry_seg (block (i).segptr, code);
	if code ^= 0
	then do;
		a_code = code;
		goto exit_delete_temp_segment;
	     end;

	new_blocks = n_blocks - 1;
	old_blocks = n_blocks;
	if areap = null
	then areap = get_system_free_area_ ();
	allocate new_block in (area) set (new_block_ptr);
	do j = 1 to i - 1;
	     new_block (j) = block (j);
	end;
	do j = i + 1 to old_blocks;
	     new_block (j - 1) = block (j);
	end;
	free block in (area);
	n_blocks = new_blocks;
	block_ptr = new_block_ptr;

exit_delete_temp_segment:
	return;
%page;
list_temp_segments:
     entry;

	if n_blocks = 0 then do;			/* nothing ever allocated */
		call ioa_ ("No temporary segments.");
		return;
	     end;
	call cu_$arg_count (arg_count);
	call cu_$arg_list_ptr (arg_list_ptr);

	begin;					/* to allocate storage */

	     dcl	   treq		      char (32);
	     dcl	   req		      (max (1, arg_count)) char (32);
	     dcl	   nreq		      fixed bin;	/* number of names requested */
	     dcl	   all_sw		      bit (1);	/* set if -all given */
	     dcl	   (i, j, cnt)	      fixed bin;
	     dcl	   dup_sw		      bit (1);

	     nreq = 0;
	     all_sw = "0"b;
	     do i = 1 to arg_count;			/* get table of requests */
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr);
		if arg = "-all" | arg = "-a" then
		     all_sw = "1"b;
		else do;
			dup_sw = "0"b;		/* be sure not given dup args */
			treq = arg;
			do j = 1 to nreq;
			     if req (j) = treq then
				dup_sw = "1"b;
			end;
			if ^dup_sw then do;		/* new one */
				nreq = nreq + 1;
				req (nreq) = treq;
			     end;
		     end;
	     end;
	     if all_sw then
		nreq = 0;

	     if nreq = 0 then do;			/* if no special requests */
		     cnt = 0;
		     do i = 1 to n_blocks;		/* count free segs */
			if ^block.used (i) then
			     cnt = cnt + 1;
		     end;
		     call
			ioa_ ("^/^-^d Segment^[s^],  ^d Free^/", n_blocks,
			(n_blocks ^= 1), cnt);
		end;
	     else do;				/* count segments that match requests */
		     cnt = 0;
		     do i = 1 to n_blocks;
			if block.used (i) then
			     do j = 1 to nreq;
				if block.caller (i) = req (j) then
				     cnt = cnt + 1;
			     end;
		     end;
		     call ioa_ ("^/^-^d Segment^[s^] used.^/", cnt, (cnt ^= 1));
		end;

	     do i = 1 to n_blocks;			/* now print them */
		if all_sw then
		     go to print_it;
		else if block.used (i) then do;
			if nreq = 0 then
			     go to print_it;
			else
			     do j = 1 to nreq;
				if block.caller (i) = req (j) then
				     go to print_it;
			     end;
		     end;
		go to next_block;
print_it:
		call
		     ioa_ ("^a  ^[^a^;(free)^]", block.name (i), block.used (i),
		     block.caller (i));
next_block:
	     end;
	     call ioa_ ("");
	end;
	return;
%page;
list_segnos:
     entry (struc_ptr);

	dcl     struc_ptr		 ptr;
	dcl     1 segno_struc	 aligned based (struc_ptr),
		2 num_segs	 fixed bin,
		2 segno		 (n_blocks) fixed bin;


	if (block_ptr = null) | (areap = null) then do;
		struc_ptr = null;
		return;
	     end;

	allocate segno_struc in (area) set (struc_ptr);
	segno_struc.num_segs = n_blocks;
	do i = 1 to n_blocks;
	     segno_struc.segno (i) = bin (baseno (block (i).segptr), 15);
	end;

	return;


     end;




		    mu_trim_descriptor.pl1          04/18/85  1437.3re  04/18/85  0908.9       48528



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - January 1980

*/

mu_trim_descriptor: trim_descriptor: procedure (character_descriptor) returns (char (*));

/* DESCRIPTION:

   this routine takes the character form of the descriptor as returned
   from mu_display_descriptor, and puts it in it's shortest possible form,
   by trimming comments, using short forms of keywords, and omitting
   keywords when defaults apply.
   NOTE: without array dimensions, the maximum input length from mu_display_descriptor
   is about 77 characters, the maximum output from this routine is about 29 characters

*/

/* PARAMETERS:

   character_descriptor - - (input) char(120) varying, the output from mu_display_descriptor,
   the character form of the descriptor declaration attributes

   trimmed_descriptor - - (output) char(*), the reduced, shorted form of the character form of the
   descriptor in terms of declaration attributes.

*/

/* get local version of declaration attributes */

	desc = character_descriptor;

/* determine data catagory */

	i = index (desc, "char");
	j = index (desc, "bit");
	h = index (desc, "/*");			/* start of comment, possibly containing "bit" */

/* do strings if char or bit keyword found */

	if i ^= 0 | (j ^= 0 & h = 0) then do;		/* string data types */

/* check for long character keyword */

		g = index (desc, "character");
		if g = 0 then ;
		else substr (desc, g + 4) = substr (desc, g + 9); /* replace character with char */

/* check for varying attributes */
		k = index (desc, "var");
		l = index (desc, "nonvar");
		m = index (desc, "ying");

		if k = 0 then ;			/* no varying attribute present */
		else if l ^= 0 then do;		/* nonvarying attribute present, remove it since default */
			if m = 0 then /* short form nonvar removed */
			     substr (desc, l) = substr (desc, l + 6);
			else substr (desc, l) = substr (desc, l + 10); /* long form nonvarying removed */
		     end;
		else do;				/* varying attribute present, shorten it */
			if m = 0 then ;		/* already short */
			else substr (desc, k + 3) = substr (desc, k + 7); /* shorten varying to var */
		     end;

/* check for alignment attribute */

		n = index (desc, "aligned");
		o = index (desc, "unal");

		if n = 0 then ;			/* no alignment attribute */
		else if o = 0 then do;		/* aligned, leave alone, unless varying */
			if k = 0 | l ^= 0 then ;	/* varying not present */
			else substr (desc, n) = substr (desc, n + 7); /* remove varying default of aligned */
		     end;
		else substr (desc, o) = substr (desc, o + 9); /* unaligned, remove since default */

	     end;
	else do;

/* do numbers if real or complex keyword found */

		p = index (desc, "real");
		q = index (desc, "complex");

		if p + q = 0 then ;			/* already shortened, or not a number */
		else do;				/* number types */

/* get rid of default real attribute */

			if p = 0 then ;
			else substr (desc, p) = substr (desc, p + 4);

/* shorten complex keyword */

			if q = 0 then ;
			else substr (desc, q) = "cplx" || substr (desc, q + 7);

/* use short forms of decimal/binary keywords */

			r = index (desc, "binary");
			s = index (desc, "decimal");

			if r = 0 then ;
			else substr (desc, r + 3) = substr (desc, r + 6); /* use bin for binary */

			if s = 0 then ;
			else substr (desc, s + 3) = substr (desc, s + 7); /* use dec for decimal */

/* get rid of default 0 scale */

			t = index (desc, ",0)");
			if t = 0 then ;
			else substr (desc, t) = substr (desc, t + 2);

/* check for alignment attribute */

			v = index (desc, "aligned");
			w = index (desc, "unal");

			if v = 0 then ;		/* nothing to be done */
			else if w ^= 0 then
			     substr (desc, w + 4) = substr (desc, w + 9); /* shorten unaligned to unal */
			else substr (desc, v) = substr (desc, v + 7); /* remove default aligned */

/* strip off any comments */

			h = index (desc, "/*");
			u = index (desc, "*/");
			if h = 0 | u = 0 then ;
			else substr (desc, h - 1) = substr (desc, u + 2);

		     end;

	     end;

/* return the modified descriptor string */

	desc = rtrim (ltrim (desc));

	return (desc);

	declare (g, h, i, j, k, l, m, n, o,
	        p, q, r, s, t, u, v, w) fixed bin (24);	/* indexes into descriptor string */
	declare desc		 char (120) varying;/* local version of descriptor string */
	declare character_descriptor	 char (120) varying;/* input descriptor string */
	declare index		 builtin;
	declare ltrim		 builtin;
	declare substr		 builtin;
	declare rtrim		 builtin;

     end;




		    mu_valid_data_type.pl1          04/18/85  1437.3re  04/18/85  0908.8       46692



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - December 1979
   Modified by Jim Gray - - Dec. 1979, to add entry to allow structures/arrays to be legal

*/

mu_valid_data_type: valid_scalar_data_type: procedure (input_descriptor) returns (bit (1) aligned);

/* DESCRIPTION:

   given a 36-bit multics argument descriptor,
   this routine determines whether it describes a data type
   that is currently supported by the current version MRDS databases.
   a true value is returned if the data type is supported/valid, else false is returned.
   the descriptor is assumed to be valid, with correct values for
   scale, precision, size, etc. for that data type, since this is to
   be an efficient run-time routine having error checks made elsewhere.
   the current supported data types are 1-12, 19-22, 43-46, scalar
   values(no arrays). see the subsystem writers guide for
   details of descriptors and their type information.
   note: the data types that MRDS can handle can be expanded to those
   that assign_ can handle, but no further. currently the other types that
   assign_ can handle, that mrds doesn't are 33-34, and 41-42.
   types 41-42 could never be supported due to the need for mrds to be able
   to calculate bit storage length of any data type, and the types
   require knowledge of the storage location, in order to do that.

*/

/* PARAMETERS:

   input_descriptor - - (input) bit(36), multics pl1 argument descriptor
   to be checked as to whether it is a supported MRDS data type,
   see subsystem writers guide for format.

   valid_flag - - (output) bit(1) aligned, true/false indicator,
   true if descriptor given is a supported MRDS data type, else false.

   sub_error_ - - (output) condition, signaled upon occurence of an error
   to provide more information

*/

/* normal entry */

	arrays_ok, structures_ok = OFF;

	call check_descriptor ();

/* reports results to caller */

	return (valid_flag);





/* entry to allow arrays and structures to be legal */

structures_arrays_ok: valid_structure_data_type: entry (input_descriptor) returns (bit (1) aligned);

	arrays_ok, structures_ok = ON;

	call check_descriptor ();

/* report results to users */

	return (valid_flag);

check_descriptor: procedure ();

/* get local version of descriptor */

	descriptor = input_descriptor;

/* invalidate array variables */

	if dimension > 0 & ^arrays_ok then
	     valid_flag = OFF;
	else do;

/* check for supported data types */

/*  if (data_type >= 1 & data_type <= 12) | /* binary or decimal */
/*  (data_type >= 19 & data_type <= 22) | /* character and bit */
/*      /* (data_type >= 33 & data_type <= 34) | /* binary unsigned */
/*      /* (data_type >= 41 & data_type <= 42) | /* decimal 4-bit */
/*  (data_type >= 43 & data_type <= 46) | /* decimal 4-bit byte-aligned, "packed decimal" */
/*   (data_type = 17 & structures_ok) then ; */

		if legal (data_type) then
		     valid_flag = ON;
		else if data_type = 17 & structures_ok then
		     valid_flag = ON;
		else valid_flag = OFF;


	     end;

     end;

	declare legal		 (0:63) bit (1) /* array of flags for legal data types */
				 init ((1) ("0"b), (12) ("1"b), (6) ("0"b), (4) ("1"b), (20) ("0"b), (4) ("1"b), (17) ("0"b))
				 int static options (constant);
	declare valid_flag		 bit (1) aligned;	/* on => valid, else invalid data type */
	declare input_descriptor	 bit (36);	/* users data descriptor */
	declare descriptor		 bit (36);	/* local version of descriptor */
	declare 1 descriptor_dimension unal based (addr (descriptor)), /* overlay for dimension field of descriptor */
		2 unused_1	 bit (8) unal,
		2 dimension	 unsigned fixed bin (4) unal, /* dimension field */
		2 unused_2	 bit (24) unal;
	declare 1 descriptor_type	 unal based (addr (descriptor)), /* overlay for data type field */
		2 unused_1	 bit (1) unal,
		2 data_type	 unsigned fixed bin (6) unal, /* descriptor type code */
		2 unused_2	 bit (29) unal;
	declare ON		 bit (1) init ("1"b) int static options (constant); /* true value */
	declare OFF		 bit (1) init ("0"b) int static options (constant); /* false value */
	declare structures_ok	 bit (1);		/* on => allow structures to be legal */
	declare arrays_ok		 bit (1);		/* on => allow arrays to be legal */
	declare addr		 builtin;

     end;




		    mus_get_att_names.pl1           10/16/86  1551.4rew 10/16/86  1142.6      100314



/****^  ***********************************************************
        *                                                         *
        * 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-08-12,Blair), approve(86-08-12,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Check for when the submodel name doesn't match any name in the model so
     that we can tell the user to correct and recreate his submodel.  This
     situation can arise as the result of restructuring.
                                                   END HISTORY COMMENTS */


mus_get_att_names:
     proc (dbm_ptr, dsm_sw, rns_ptr, rel_index, wa_ptr, ans_ptr, error_code);

/* DESCRIPTION:

   BEGIN_DESCRIPTION
   For  a given relation in a submodel or model, return an array of attributes
   defined  for  that relation, giving the number of attributes, number of key
   attributes,  attribute  model  name,  it's  submodel  name,  attribute info
   pointer, and domain info pointer.



   PARAMETERS:

   dbm_ptr - - (input) pointer to the db_model segment in the database model

   dsm_sw  -  -  (input)  bit  (1), ON => this is a submodel relation, else =>
   model relation

   rns_ptr - - (input) pointer to the rel_names array structure containing the
   relation model and submodel name, and it's rel info pointer

   rel_index  - - (input) fixed bin, index into the rel_names array giving the
   desired relation for which to return attribute information

   wa_ptr  -  -  (input) pointer to an area in which to allocate the attribute
   information array to be returned

   ans_ptr  -  -  (output) pointer to the att_name array allocated in the area
   pointed  to by wa_ptr, containing the desired attribute information for the
   relation specified by the rel_name array and index

   error_code  -  -  (output) fixed bin (35), error type encoding, 0 unless an
   error occured

   sub_error_  -  - (output) condition, signaled upon occurence of an error to
   provide more info
   END_DESCRIPTION


   HISTORY:

   78-08-01 Oris D. Friesen: Originally written.

   79-06-01 Jim Gray : Modified to
   1) add number of key and varying attributes to info returned
   2) add sub_err_ reporting of errors
   3) change from freeing to area deleting in higher routine for cleanup
   4) document the program interface and logic

   80-08-01  Spratt:  Changed  to  understand new submodel system; an external
   submodel  iocb ptr was added for reference through mrds_dsm modules, set by
   higher  program;  dsmd_$foo  calls  changed  to  mrds_dsm_foo  calls;  uses
   relation_block structure instead of dsm_relation_str; the r_perm and u_perm
   switches    are   now   set   in   the   attr_names.item   structure;   the
   mrds_dsm_rel_block and mrds_dsm_entry_dcls include files were added.

   80-09-23  Davids: modified so that att_names.item.r_perm and u_perm are set
   to "1"b when opening is done via the model.

   81-01-14  Davids:  modified  to  use the new relation_block structure which
   individually names the attribute access bits.

   81-01-23  Jim  Gray  :  added  last_model_attr_char_var  bit  to  att_names
   interface  structure,  so that partial view submodels can properly find the
   end of tuple.

   81-05-29   Jim   Gray   :   modified   to  use  resultant  structures,  and
   mdbm_rel_att_array include file without foreign key info.

   81-07-01  Rickie  E.  Brinegar: modified to set last_model_attr_char_var to
   "1"b if the current attribute is character varying and to set it to "0"b if
   the  current  attribute  is  bit varying.  This guarantees that if the last
   varying attribute in the definition order character type (implying the last
   attribute    in    the    tuple    will    be   character   varying)   then
   att_names.last_model_attr_char_var  is  set.  This is a part of the fix for
   TR 9755.

   82-06-03 Mike Kubicar : added fix for TR phx12282.  The problem was that
   last_mode_attr_char_var could be set incorrectly if a submodel instead of
   a model were opened.

*/

/* initialize */

	error_code = 0;
	ans_ptr = null;

/* get the rel_info pointer, and number of attributes from the rel_name array */

	ri_ptr = rel_names.item.ri_ptr (rel_index);
	num_atts_init = rel_names.item.natts (rel_index);

/* initialize the attribute array to be returned */

	allocate att_names in (work_area);
	unspec (att_names) = "0"b;
	att_names.num = num_atts_init;

/* fill in the attribute array information */

	if dsm_sw then
	     call submodel_relation ();
	else call model_relation ();

	return;

submodel_relation:
     procedure ();

/* call the submodel(opened in a higher routine) to get the
   attributes involved with this submodel definition of this relation */

	num_dims = 0;
	call mrds_dsm_read_relation (rel_names.item.sm (rel_index), wa_ptr, relation_block_ptr, submodel_iocb_ptr, error_code);
	if error_code ^= 0 then
	     call
		sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		"Unable to get the attribute information for submodel relation ""^a"".", rel_names.item (rel_index).sm);
	else if relation_block.version ^= RELATION_BLOCK_VERSION_1 then do;
		error_code = error_table_$unimplemented_version;
		call
		     sub_err_ (error_table_$unimplemented_version, caller_name, continue, info_ptr, return_value,
		     "Expecting version ^d of the relation_block structure, got version ^d.", RELATION_BLOCK_VERSION_1,
		     relation_block.version);
	     end;
	else do;

/* go through all attributes defined for this submodel relation */

		j = 0;				/* no key attrs yet */
		k = 0;
		do i = 1 to relation_block_ptr -> relation_block.no_rb_attributes;

/* search the model attribute list for this relation,
   to find the current submodel attribute, in order to get
   the correct attr_info for this attribute */

		     do ai_ptr = ptr (ri_ptr, rel_info.attr_ptr) repeat ptr (ri_ptr, attr_info.fwd_thread)
			while (attr_info.name ^= relation_block.attribute_info.dm_attr_name (i) &  attr_info.fwd_thread ^= NULL_OFFSET);
		     end;

/* fill in the att_name array slot for this submodel attribute */

		     if (attr_info.fwd_thread = NULL_OFFSET & attr_info.name ^= relation_block.attribute_info.dm_attr_name (i))
		     then do;
			error_code = mrds_error_$inconsistent_submodel;
			call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, 
			"Attribute ""^a"" in the submodel does not correspond to an attribute in the model. Please correct and recreate the submodel.", rtrim (relation_block.attribute_info.dm_attr_name (i)));
			end;
		     att_names.item.sm (i) = relation_block.attribute_info.dsm_attr_name (i);
		     att_names.item.dm (i) = attr_info.name;
		     att_names.item.ai_ptr (i) = ai_ptr;
		     att_names.item.di_ptr (i), di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
		     att_names.item.rai_ptr (i) = null;
		     att_names.item.r_perm (i) = relation_block.attribute_info.attr_access.read (i);
		     att_names.item.u_perm (i) = relation_block.attribute_info.attr_access.modify (i);

/* count up key and varying attributes */

		     if attr_info.key_attr
		     then j = j + 1;

		     if domain_info.db_desc_is_ptr then
			desc_ptr = addr (domain_info.db_desc) -> pointer_format;
		     else desc_ptr = addr (domain_info.db_desc);

		     if descriptor.type = 20 | descriptor.type = 22
		     then k = k + 1;		/* this is a varying bit or char string data type */
		end;

		att_names.num_key_attrs = j;
		att_names.num_varying_attrs = k;
	     end;

/* find out if the last attr in the model is character or not */

	i = 1;
	do ai_ptr = ptr (ri_ptr, rel_info.attr_ptr) repeat ptr (ri_ptr, attr_info.fwd_thread) while (i <= rel_info.num_attr);
	     i = i + 1;
	end;

	     di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);

	     if domain_info.db_desc_is_ptr then
		desc_ptr = addr (domain_info.db_desc) -> pointer_format;
	     else desc_ptr = addr (domain_info.db_desc);

	     if descriptor.type = 22 then
		att_names.last_model_attr_char_var = "1"b;
	     else if descriptor.type = 20 then
		att_names.last_model_attr_char_var = "0"b;

     end;

model_relation:
     procedure ();

/* go through the model's list of attributes for this relation,
   and fill in the attribute array to be returned */

	i = 1;
	do ai_ptr = ptr (ri_ptr, rel_info.attr_ptr) repeat ptr (ri_ptr, attr_info.fwd_thread) while (i <= att_names.num);

	     att_names.item.sm (i) = attr_info.name;
	     att_names.item.dm (i) = attr_info.name;
	     att_names.item.ai_ptr (i) = ai_ptr;
	     att_names.item.di_ptr (i), di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
	     att_names.item.rai_ptr (i) = null;
	     att_names.item.r_perm = "1"b;		/* opening via the model gives complete access */
	     att_names.item.u_perm = "1"b;


	     if domain_info.db_desc_is_ptr then
		desc_ptr = addr (domain_info.db_desc) -> pointer_format;
	     else desc_ptr = addr (domain_info.db_desc);

	     if descriptor.type = 22 then
		att_names.last_model_attr_char_var = "1"b;
	     else if descriptor.type = 20 then
		att_names.last_model_attr_char_var = "0"b;

	     i = i + 1;

	end;

/* set the number of key and varying attributes */

	att_names.num_key_attrs = rel_info.num_key_attrs;
	att_names.num_varying_attrs = rel_info.nvar_atts;

     end;

	dcl     wa_ptr		 ptr;		/* points to working area */
	dcl     (i, j, k)		 fixed bin;	/* index variable */
	dcl     rel_index		 fixed bin;	/* index into rel_names structure */
	dcl     error_code		 fixed bin (35);

	dcl     dsm_sw		 bit (1) unal;	/* ON => data submodel was used to open the data base */

	dcl     work_area		 area based (wa_ptr);

	dcl     (ptr, addr, null, unspec) builtin;

	dcl     error_table_$unimplemented_version fixed bin (35) ext;
          dcl     mrds_error_$inconsistent_submodel fixed bin(35) ext static;

	declare caller_name		 char (20) init ("mrds_dsl_ready_file") int static options (constant);
						/* name of calling routine */
	declare continue		 char (1) init ("c") int static options (constant);
						/* no stop after printing */
          declare NULL_OFFSET            bit (18) unaligned int static options (constant) init ((18)"1"b);
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35);	/* unused */
	declare sub_err_		 entry options (variable); /* error reporting routine */
	declare submodel_iocb_ptr	 ext ptr init (null); /* Set in mrds_dsl_init_res, used by
						   mu_sec_init_res and
						   mus_get_rel_names. */
	declare pointer_format	 ptr based;	/* overlay to pick up a pointer */

%include mdbm_descriptor;

%include mdbm_db_model;

%include mdbm_file_model;

%include mdbm_rel_att_array;

%include mrds_dsm_rel_block;
%include mrds_dsm_entry_dcls;
     end mus_get_att_names;




		    mus_get_rel_names.pl1           10/16/86  1551.4r w 10/16/86  1145.0       91134



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

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

mus_get_rel_names: proc (dsm_sw, rmra_ptr, fa_index, wa_ptr, fm_ptr, rns_ptr, error_code);

/* DESCRIPTION:

   For  a  given  file  in  a  submodel or model, return an array of relations
   defined  for  that  file,  giving  the  number  of  relations, and for each
   relation  giving  the  number  of  attributes,  the model name and rel_info
   pointer, and the number of links it is involved in as parent and/or child.



   PARAMETERS:

   dsm_sw  -  -  (input) bit (1), ON => this is a submodel file, else => model
   file

   rmra_ptr  -  -  (input)  pointer to the resultant model file array for this
   opening  of  the  database,  which  contains file names and pointers to the
   resultant file_info structures

   fa_index  -  -  (input)  fixed  bin,  index  into the file array giving the
   desired file for which to return relation information

   wa_ptr  -  -  (input)  pointer to an area in which to allocate the relation
   information array to be returned

   fm_ptr - - (input) pointer to the database file model for this file

   rns_ptr  -  -  (output) pointer to the rel_names array structure containing
   relation  model and submodel name, and it's rel_info pointer as well as the
   attribute, parent link, and child link count

   error_code  -  -  (output) fixed bin (35), error type encoding, 0 unless an
   error occurred

   sub_error_  -  -  (output)  condition, signaled upon occurrence of error to
   provide more info



   HISTORY:

   78-08-01 Oris D. Friesen: Originally written.

   79-06-01 Jim Gray : Modified as follows:
   1) add sub_err_ reporting of errors
   2) change from freeing to area deleting in higher routine for cleanup
   3) document the program interface and logic

   80-04-01 Jim Gray : Modified to add total_view bit to relation info so that
   submodel permissions can be determined.

   80-08-01  Lindsey Spratt: Modified to use the new submodel security system.
   This  involved changing all calls to dsmd_$foo to be calls to mrds_dsm_foo,
   adding  an  external  static  submodel_iocb_ptr, setting the rel_names.item
   access  permission  bits, and using the relation_block structure instead of
   the  mrds_dsm_relation_str  structure.  Also, added the mrds_dsm_entry_dcls
   and the mrds_dsm_rel_block include files.

   80-09-23 Davids: modified so that rel_names.item.r_per (i), m_perm, s_perm,
   and d_perm are set to "1"b when opening is done via the model.

   80-11-07  Jim Gray : Modified to set the status_perm bit from dsm_rel_flags
   bit  1,  status_perm  (perviously  r_perm) had never been set from submodel
   processed access permission, and was just always set to true.

   80-12-30  Davids:  modified  internal  procedure  submodel_relation so that
   rel_names.item.status_perm  is  always  "0"b  since  it  no  longer has any
   meaning  and  append_tuple  and  delete_tuple  come  from  bits  1 and 2 of
   relation_block.dsm_rel_flags.access  rather than bits 2 and 3.  when status
   went away the bit positions where shifted and because of the implementation
   of  compute_access  it  is  easier to change the bit position meanings than
   shift them back.

   81-01-12   Davids:  took  the  call  to  mrds_dsm_read_relation  which  was
   incorrectly  used  to  set  up  a  mrds_dsm_relation_names  str  out of the
   submodel_relation     procedure    and    instead    just    allocated    a
   mrds_dsm_relation_names  str.   the  relation name is currently correct but
   may  not  be  forever.   as  soon as an interface for files in submodels is
   built this code should change

   81-01-14 Davids: modified to use the new relation_block structure which has
   individual variables for all the relation access rather than doing substr's
   from a bit string.

   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_dsm_relation_names include file.

   81-05-21    Rickie    E.    Brinegar:   changed   to   use   the   modified
   mrds_dsm_relation_names  include file.  The structure name was changed from
   dsm_relation_names to mrds_dsm_relation_names.

   81-05-29 Jim Gray : modified to use new mdbm_rel_att_array structures,
   modified to remove foreign key information.


*/

/* initialize */

	error_code = 0;
	rns_ptr = null;
	rmri_ptr = rm_rel_array.rel_data.ri_ptr (fa_index);

/* fill in the relation array information */

	if dsm_sw then
	     call submodel_relation ();
	else call model_relation ();

	return;

submodel_relation: procedure ();
	mrds_dsm_relation_names_nrels_alloc = 1;
	allocate mrds_dsm_relation_names set (mrds_dsm_relation_names_ptr) in (work_area);
	mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names.relation (1) = rm_rel_array.name.submodel (fa_index);

/* get space for the return structure array */

	num_rels_init = mrds_dsm_relation_names.nrels;
	allocate rel_names set (rns_ptr) in (work_area);
	rel_names.num = num_rels_init;

/* then get the dsm relation definition record for each rel. in above list --
   this gives us the corresponding data model name */

	do i = 1 to mrds_dsm_relation_names.nrels while (error_code = 0);

	     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (i),
		wa_ptr, relation_block_ptr, submodel_iocb_ptr, error_code);
	     if error_code ^= 0 then
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
		     "Unable to get the submodel information for relation """,
		     mrds_dsm_relation_names (i).relation, """.");
	     else if relation_block.version ^= RELATION_BLOCK_VERSION_1
	     then do;
		     error_code = error_table_$unimplemented_version;
		     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
			"Expecting version ^d, actually got version ^d.",
			RELATION_BLOCK_VERSION_1, relation_block.version);
		end;
	     else do;

/* now find the corresponding rel_info structure in the file_model */

		     do ri_ptr = ptr (fm_ptr, file_model.rel_ptr)
			repeat ptr (fm_ptr, rel_info.fwd_thread)
			while (relation_block.dm_rel_name ^=
			rel_info.name);
		     end;

/* fill in the rel_names array information for this relation */

		     rel_names.item.natts (i) = relation_block.no_rb_attributes;
		     rel_names.item.sm (i) = mrds_dsm_relation_names.relation (i);
		     rel_names.item.dm (i) = rel_info.name;
		     rel_names.item.ri_ptr (i) = ri_ptr;
		     rel_names.item.total_view (i) = (rel_info.num_attr =
			relation_block.no_rb_attributes);
		     rel_names.item.status_perm (i) = "0"b;
		     rel_names.item.unused_perm (i) = "0"b;
		     rel_names.item.append_tuple_perm (i) = relation_block.rel_access.append;
		     rel_names.item.delete_tuple_perm (i) = relation_block.rel_access.delete;
		     rel_names.item.pad (i) = "0"b;

		end;

	end;

     end;

model_relation: procedure ();

/* get the number of model relations for this file,
   and then get space for the return structure array */

	num_rels_init = file_model.num_rels;
	allocate rel_names set (rns_ptr) in (work_area);
	rel_names.num = num_rels_init;

/* fill in the rel_names array for each relation in this file */

	i = 1;
	do ri_ptr = ptr (fm_ptr, file_model.rel_ptr)
	     repeat ptr (fm_ptr, rel_info.fwd_thread)
	     while (i <= rel_names.num);

	     rel_names.item.natts (i) = rel_info.num_attr;
	     rel_names.item.sm (i) = rel_info.name;
	     rel_names.item.dm (i) = rel_info.name;
	     rel_names.item.ri_ptr (i) = ri_ptr;
	     rel_names.item.total_view (i) = "1"b;	/* model always complete view */
	     rel_names.item.pad (i) = "0"b;
	     rel_names.item.status_perm (i) = "1"b;	/* for opening via the model there */
	     rel_names.item.unused_perm (i) = "0"b;	/* is complete access */
	     rel_names.item.append_tuple_perm (i) = "1"b;
	     rel_names.item.delete_tuple_perm (i) = "1"b;
	     i = i + 1;
	end;

     end;

	declare sub_err_		 entry options (variable); /* error reporting routine */
	declare caller_name		 char (20) init ("mrds_dsl_ready_file") internal static options (constant); /* name of calling routine */
	declare continue		 char (1) init ("c") int static options (constant); /* don't stop after printing message */
	declare info_ptr		 ptr init (null ()) int static options (constant); /* unused */
	declare submodel_iocb_ptr	 ptr ext init (null);
	declare return_value	 fixed bin (35) init (0) int static options (constant); /* unused */
	dcl     wa_ptr		 ptr;		/* points to working area */
	dcl     i			 fixed bin;	/* index variable */
	dcl     dsm_sw		 bit (1) unal;	/* ON => we come from a data submodel */
	dcl     fa_index		 fixed bin;	/* index into rm_file_array structure */
	dcl     error_code		 fixed bin (35);

	dcl     work_area		 area based (wa_ptr);

	dcl     (null, ptr, addr, rel, fixed) builtin;

	dcl     error_table_$unimplemented_version fixed bin (35) ext;
	dcl     sys_info$max_seg_size	 ext fixed bin;

%include mdbm_rm_rel_array;
%page;
%include mdbm_file_model;
%page;
%include mdbm_rel_att_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_entry_dcls;
     end mus_get_rel_names;

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