



		    mdb_display_data_value.pl1      04/18/85  1433.7re  04/18/85  0907.1       69804



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

mdb_display_data_value: mddv: procedure ();

/* DESCRIPTION :

   The  purpose  of  the command is to display on the terminal, the value of a
   data  item,  when only a pointer to it's storage location, and a pointer to
   it's  descriptor  are known.  the input pointers can be any form of virtual
   pointer  that  is  accepted  by the cv_ptr_ subroutine.  assign_ is used to
   convert  the  data  to  character  format.   the  descriptor  is the system
   standard  pl1  data  descriptor for arguments.  see the reference manual or
   subsystem writers guide for storage formats of data, and their descriptors.

   NOTE:  the  converted  character  form  of  the data value must be <= 50000
   characters,  due  the  internal  buffer  size  used  in  the  call to iox_.

   ADDITION:  the  entry  mdb_display_data_value$ptr is a subroutine interface
   that will accept pointers directly, rather than virtual pointers.


   PARAMETERS :

   vir_data_ptr  -  -  (input)  virtual pointer (char (*)), that points to the
   data value in storage

   vir_desc_ptr  -  -  (input)  virtual  pointer (char(*)), that points to the
   multics pl1 data descriptor(bit(36)) for the data value

   data  value  -  -  (output)  displayed  on  the  terminal  when  conversion
   successful

   command_error_  -  - (output) condition, signaled by com_err_, that is used
   to reports errors in virtual pointer or data conversion.

   input_data_ptr,   input_desc_ptr   -   -  (input)  pointers,  same  as  the
   virtual_...._ptr    parameters,    except    for   the   subroutine   entry
   mdb_display_data_value$ptr


   HISTORY:

   79-11-01 Jim Gray : Originally written.

   79-11-02 Jim Gray : Modified to add subroutine interface

*/

/* check for correct argument count */

	call cu_$arg_count (nargs);
	if nargs ^= 2 then
	     call com_err_ (error_table_$wrong_no_of_args, caller_name, "^/^a^/",
		"Usage: mdb_display_data_value virtual_data_pointer virtual_descriptor_pointer");
	else do;

/* get the two char(*) arguments */

		call cu_$arg_ptr (1, vir_data_ptr_ptr, vir_data_ptr_len, error_code);
		call cu_$arg_ptr (2, vir_desc_ptr_ptr, vir_desc_ptr_len, error_code);


/* get a real pointer to the data value */

		data_ptr = cv_ptr_ (vir_data_ptr, error_code);
		if error_code ^= 0 then
		     call com_err_ (error_code, caller_name, "^/^a^a^a^/",
			"Unable to convert the virtual data pointer """,
			vir_data_ptr, """ to a real pointer.");
		else do;

/* get a real pointer to the multics pli descriptor for the given data value */

			desc_ptr = cv_ptr_ (vir_desc_ptr, error_code);
			if error_code ^= 0 then
			     call com_err_ (error_code, caller_name, "^/^a^a^a^/",
				"Unable to convert the virtual descriptor pointer """,
				vir_desc_ptr, """ to a real pointer.");
			else do;

/* convert and output the data value */

				call convert_value ();
			     end;
		     end;

		return;




/* subroutine interface, that accepts pointer input values directly */

ptr: entry (input_data_ptr, input_desc_ptr);

		data_ptr = input_data_ptr;
		desc_ptr = input_desc_ptr;

		call convert_value ();

		return;

convert_value: procedure ();

/* this routine makes the call to convert the data from the input
   type into character format for output to the terminal. */

/* set up pointers to the char(50000) output variable, and it's descriptor */

	char_data_ptr = addr (char_data);
	char_desc_ptr = addr (char_desc);

/* now use the encapsuled assign_ to do the conversion */

	call mu_convert (data_ptr, desc_ptr, char_data_ptr, char_desc_ptr, error_code);
	if error_code ^= 0 then
	     call com_err_ (error_code, caller_name, "^/^a ^a^p^a^p^a^/",
		"Unable to convert the data to character form,",
		"using the data pointer """, data_ptr,
		""" and the descriptor pointer """, desc_ptr, """.");
	else do;

/* output the converted data value */

		call output_value ();

	     end;
     end;

	     end;

output_value: procedure ();

/* this routine does the i/o to the user's terminal of the converted
   data value in it's character format, a header is output first */

	header = NL || "The data value is:" || NL;
	header_ptr = addr (header);

	call iox_$put_chars (iox_$user_output, header_ptr, length (rtrim (header)), error_code);
	if error_code ^= 0 then
	     call com_err_ (error_code, caller_name, "^/^a^/",
		"Unable to output the header to user_output.");
	else do;

/* output the actual data vaule in character form, surrounded by quotes, with trailing new lines */

		char_data = char_data || """";
		char_data = """" || char_data;
		char_data = char_data || NL;
		char_data = char_data || NL;

		call iox_$put_chars (iox_$user_output, addrel (char_data_ptr, 1), length (char_data), error_code);
		if error_code = 0 then ;
		else call com_err_ (error_code, caller_name, "^/^a^/",
			"Unable to output data value to user_output.");

	     end;

     end;

	declare header		 char (24);	/* header information */
	declare NL		 char (1) init ("
");						/* new line character */
	declare header_ptr		 ptr;		/* points to  header character buffer */
	declare com_err_		 entry options (variable); /* reports command errors */
	declare char_data		 char (50004) varying; /* general output variable + 4 chars for NL'S/quotes */
	declare (data_ptr,				/* points to input data value */
	        desc_ptr,				/* points to input value's descriptor */
	        char_data_ptr,			/* points to output variable */
	        char_desc_ptr)	 ptr;		/* points to descriptor for char output variable */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare vir_data_ptr	 char (vir_data_ptr_len) based (vir_data_ptr_ptr); /* virutal pointer to input data value */
	declare vir_desc_ptr	 char (vir_desc_ptr_len) based (vir_desc_ptr_ptr); /* virutal pointer to input value descriptor */
	declare cv_ptr_		 entry (char (*), fixed bin (35)) returns (ptr); /* converts virtual pointers to real pointers */
	declare char_desc		 bit (36) init ("101011000000000000001100001101010000"b); /* char (50000) varying descriptor */
	declare mu_convert		 entry (ptr, ptr, ptr, ptr, fixed bin (35)); /* encapsulates assign_ conversion routine */
	declare caller_name		 char (22) init ("mdb_display_data_value"); /* name of calling routine */
	declare iox_$user_output	 external pointer;	/* user_i/o iocb pointer */
	declare iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* outputs characters */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets char(*) arguments */
	declare cu_$arg_count	 entry (fixed bin); /* gets argument count */
	declare nargs		 fixed bin;	/* number of arguments */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* wrong arg count, s/b 2 */
	declare vir_data_ptr_ptr	 ptr;		/* points to virtual_data_ptr char(*) arg */
	declare vir_desc_ptr_ptr	 ptr;		/* pointer to virutal_desc_ptr char (*) arg */
	declare vir_data_ptr_len	 fixed bin (21);	/* length of virtual_data_ptr char(*) arg */
	declare vir_desc_ptr_len	 fixed bin (21);	/* length of virtual_desc_ptr char(*) arg */
	declare input_data_ptr	 ptr;		/* subr input data pointer */
	declare input_desc_ptr	 ptr;		/* subr input descriptor pointer */
	declare (
	        addr,
	        addrel,
	        length,
	        rtrim
	        )			 builtin;

     end;




		    mrds_dsl_close.pl1              08/01/88  1347.3rew 08/01/88  1300.0      326880



/****^  ***********************************************************
        *                                                         *
        * 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-04-19 by Thanh
     Nguyen. (see mrds #136)
  2) change(86-08-13,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-06,Dupuis), install(88-08-01,MR12.2-1073):
     Removed changes installed on 84-11-02 to terminate domain procs. This
     slows things down and really doesnt need to be done.
                                                   END HISTORY COMMENTS */



mrds_dsl_close:
close:
     procedure ();

/* 
                   BEGIN_DESCRIPTION
   This  routine  is  to  be  called  with  "entry options (variable)", with a
   minimum  of  2 arguments, 1) a database index specifying the database to be
   closed,  and 2) an error code to be returned.  More than one database index
   may  be given.  the function performed is to "close" the database specified
   by   the  database  index  that  was  returned  from  a  previous  call  to
   mrds_dsl_open,  making  the  database  unusable  for  an  data manipulation
   operations  such  as  retrieve  or  modify.  if an error occurs, either all
   databases  in  the  list  of indexes, or none will be closed, the list will
   never be partially done.  Note that once the process of actually closing  a
   starts, any errors encountered are reported, but the database is not opened
   again.
                   END_DESCRIPTION
      
   PARAMETERS:

   database_index  - - (input) fixed bin(35), the integer returned from a call
   to  mrds_dsl_open,  specifying the database which is to be closed.  several
   database indexes may be given.

   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:

   76-02-01 R. G. Luebke: Initially written.

   77-07-01 O. Friesen: Modified to accomodate queued scope requests.

   77-11-01  R.   D.   Lackey:  Modified  to  add temporary fixed for handling
   dbcb.ret_fd_ptrs

   77-11-02 R. D. Lackey: Modified to make perm fixed to dbcb ret_fd_ptr

   79-05-31  Al  Kepner:  Modified to delete the segment for current selection
   expression allocations.

   79-07-01 Jim Gray : Rewritten to
   1) correct argument processing to leave user in known state upon error
   2) add sub_err_ reporting of errors, and structured error handling
   3) add control file closing logic for transaction mode created databases
   4) avoid calls to finish_file for non-ready files
   5) document the modules logic
   6) allow  handling  of  recursive  invocations,  so can use close as finish
   handler

   80-02-01   R.   Lackey:  Modified  to  change  call  to  mus_valid_iocb  to
   mcbm_util_$valid_iocb_detach

   80-03-01  Jim  Gray  :  Modified  to  clear  db indexes used by old version
   close/open.

   80-09-24 Jim Gray : Modified to correct control string for sub err mesg.

   80-09-30  Jim  Gray  :  Modified  to correctly get resultant model temp dir
   based on the opening index.

   80-10-20  Jim Gray : Modified to clean up temp segs now generated by search
   for tid arrays.

   80-11-03  Jim  Gray  :  Modified to change delete_$ptr to hcs_$delentry_seg
   calls for performance.

   80-11-10  Jim  Gray  : Modified to change delete_$path to hcs_$del_dir_tree
   and hcs_$delentry_file calls for performance.

   81-01-29 Jim Gray : removed references to mdbm_data_$current_version, using
   constants instead, to allow for future upgrades to db version.

   81-04-25  Jim  Gray  :  changed  declaration of mrds_data_$temp_seg_name to
   agree  with  change in mrds_data_, and increased the dbi_pic declaration to
   three digits, as part of increasing the opening capability from 64 to 128.

   81-05-29  Jim  Gray : modified to use the new resultant structure, also did
   away  with  call  to  mus_valid_iocb,  as  control  file  never used.  Also
   combined   mu_sec_close  into  this  module.   Also  changed  interface  to
   mrds_dsl_finish_file for efficiency.

   81-07-07  Rickie  E.  Brinegar : Changed calls to release_area_ to calls to
   release_temp_segments  so  that  the temporary segments are returned to the
   temporary segement free pool, and marked as free.

   82-10-06 Mike Kubicar : converted to use relation manager.  Specifically,
   the call to mrds_dsl_finish_file has been removed as this module has been
   deleted.  All scope deletion, cursor deletion, and relation closing is now
   done by this module.

   82-10-14 Davids: changed to call mu_cursor_manager_$destroy_all_no_free
   with the dbcb.cursor_ptrs_storage_ptr instead of the cursor_storage_area_ptr.
   Also to not call mu_cursor_manager_ at all if the cursor_ptrs_storage_ptr
   is null.

   82-10-15 Davids: changed so that the call to mu_cursor_manager_$destroy_all_no_free
   includes as a paramter dbcb.cursor_storage_area_ptr to conform to the new
   calling sequence of the entry.

   83-01-03 Roger Lackey : Changed in the close_database procedure ,
   call to mu_cursor_manager_$destroy_storage to 
   mu_cursor_manager_$cleanup_storage  the closing of the relation will
   be done in another place in this program.

   83-01-10  Roger Lackey : Changed to not call dbcb.relmgr_entries.close
   if oid was zero

   83-01-31  R. Harvey : Removed code to call release_temp_segment_ for the
   dbcb.*_area_ptr used by the 5 main dsl_ entries.

   83-02-01  Mike Kubicar : Added code to handle transaction processing.
   This is needed only in the delete_temp_rels procedure.  One transaction
   is started for each dm file database to be closed.

   83-02-02 Davids: Added a call to hcs_$get_uid_seg to compare the uid of the
   segment the dbc_ptr currently points to with what it was originally pointing to.
   If the uids don't match or the uid cannot be obtained it is assumed that the
   original segment has been deleted. Since the segment has been deleted there
   is no need to set the scope_lock or remove the open user so the code is skiped.
   The call to remove_resultant was taken out of the critical region protected
   by the scope lock since there was no need to have it protected. 

   83-03-11 Davids: Added calls to mu_temp_segments$delete_temp_segment to delete
   the MRDS.store, modify, delete, def_tr, and retrv temp segments.

   83-05-02 Davids: Modified to call mu_temp_segments$free_all_temp_segments or
   delete_all_temp_segments for the curdat, stadat, and selete_area segments
   (created in mrds_dsl_init_res). free is called if the segments were created
   in the pdir (determined by checking dbcb.resultant_in_pdir). delete is
   called for any other dir.

   83-05-04 Davids: Modified to remove the calls to delete the 5 dsl temp
   segments, the modules that get those temp segments now use the name
   MRDS || dbi so that they be deleted in 1 fell swoop. Same for deleting
   the rdbi segment, it was made a temp segmenbt with the same name as the
   others. Entries mu_temp_segment$delete_temp_segment and com_err_ were
   deleted.
 
   83-05-05 Davids: Changed calls to free_all_temp_segments to calls to
   release_all_temp_segments. The difference is that a release does a
   truncate to 0 length so that when a temp segment is reused it does
   not see stuff left over from a previous use which becuase mrds expects
   that a temp segment just obtained will be nothing but 0's caused a
   problem.

   83-05-24 Davids: Renamed the variable info_ptr to unused_ptr because
   the name info_ptr now has a ambiguous reference with a structure
   in the mrds_start_transaction include file and a name change is needed
   in order to compile and second the pointer is never used for anything.

   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). Also removed overhead of checking to be sure that old version
   db indicies and new version db indices were not given in the same call -
   minor performance improvement.

   84-11-02 Thanh Nguyen: Added code to check and terminate all of the
   reference names of the check, encode, or decode procedure.

*/
%page;
/* check for valid argument list */

	num_ptrs = 0;
	call cu_$arg_list_ptr (al_ptr);		/* get number of arguments */
	nargs = arg_list.desc_count / 2;		/* = arg_count, if called with entry options(variable) */

	if nargs < 2 then do;
		call
		     sub_err_ (error_table_$wrong_no_of_args, caller_name, continue, unused_ptr, return_value, "^/^a ^d ^a ^a",
		     "The number of arguments =", arg_list.arg_count / 2, "was less than the minimum of 2,",
		     "or the entry was not declared ""options (variable)"".");
	     end;
	else do;

/* initialize the error code argument */

		if arg_list.code = SPECIAL then
		     desc_index = nargs + 1;
		else desc_index = nargs;
		num_ptrs = desc_index + nargs;	/* arg_list ptr array size */
		desc_ptr = arg_list.arg_des_ptr (desc_index + nargs);
						/* last arg descriptor */

		if desc_ptr -> descriptor_ovrly ^= fixed_bin_35_descr then
		     call
			sub_err_ (error_table_$bad_arg, caller_name, continue, unused_ptr, return_value, "^/^a",
			"The error code(last) argument is not declared ""fixed binary (35) aligned"".");
		else do;

			error_code_ptr = arg_list.arg_des_ptr (nargs);
			error_code, code = 0;	/* initialize */

/* initialize the "databases to be closed" list */

			work_area_ptr, db_close_list_ptr = null ();
			call get_temp_segment_ (caller_name, work_area_ptr, error_code);
			if error_code ^= 0 then
			     call
				sub_err_ (error_code, caller_name, continue, unused_ptr, return_value, "^/^a",
				"Unable to obtain a temporary segment for work space.");
			else do;

				work_area_ptr -> work_area = empty ();
				clean_up_condition = OFF;

				on cleanup
				     begin;	/* in case user does quit/release */
					clean_up_condition = ON;
					if ^substr (db_mrds_dsl_close, 1, 1) then
					     ;
					else on sub_error_ ; /* ignore sub_err_ calls during cleanup */
					call clean_up ();
				     end;

				on seg_fault_error goto exit; /* in case segment deleted via previous invocation */

/* process the list of database indexes for databases to be closed,
   making a list to be closed, if the database indexes are valid,
   and are not duplicated, by saving the resultant model pointers */

				arg_count = 1;
				do while (arg_count < nargs & error_code = 0);

				     call
					mu_convert_parameter$convert_input_parameter (arg_list.arg_des_ptr (arg_count),
					arg_list.arg_des_ptr (desc_index + arg_count), dbi_ptr, addr (fixed_bin_35_descr), work_area_ptr, error_code);
				     if error_code ^= 0 then do;
					     call
						sub_err_ (error_code, caller_name, continue, unused_ptr, return_value, "^/^a ^d ^a",
						"Database index argument in position", arg_count,
						"could not be converted to ""fixed binary (35) aligned"".");
					end;

/* make sure that this database index refers to a currently open database */

				     else if ^valid_index () then
					;

/* check for list duplicates */

				     else if ^unique_index () then
					;

/* add the index, and it's resultant model pointer to the close list */

				     else call add_index ();

/* advance to the next database index argument */

				     arg_count = arg_count + 1;

				end;

				if error_code ^= 0 then
				     ;
				else do;

/* process the list of valid/unique databases to be closed */

					proc_id = get_process_id_ ();

					do db_close_ptr = db_close_list_ptr repeat db_close.next while (db_close_ptr ^= null ());

/* when this point is successfully reached, all databases in the "close list"
   will be forcefully closed, that is closing will go to completion, ignoring
   errors encountered, with only the first error encountered being returned
   in the error code(others reported via sub_err_), and an error upon closing
   the first database in the list will not affect later closings
   this allows close to be used as a finish/cleanup handler & leaves user in known state */

					     call close_database ();

					end;
				     end;

/* get rid of the "close list" now that processing is complete */

exit:
				call clean_up ();

			     end;
		     end;
	     end;
%page;
valid_index:
     procedure () returns (bit (1));

/* check that the current database index refers to a database open by this process
   and set a pointer to the resultant model if the index is good */

	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
						/* look up db in table */

	if dbcb_ptr ^= null () then
	     valid = ON;

	else do;
		valid = OFF;
		error_code = mrds_error_$invalid_db_index;
		call
		     sub_err_ (error_code, caller_name, continue, unused_ptr, return_value, "^/^a ^d ^a", "The database index =", db_index,
		     "does not refer to a database open by this process.");
	     end;


	return (valid);


	dcl     valid		 bit (1);		/* on => good index */

     end;
%page;
unique_index:
     procedure () returns (bit (1));

/* check that this index has not apeared before in the close list */

	unique = ON;

	do db_close_ptr = db_close_list_ptr repeat db_close.next while (db_close_ptr ^= null () & error_code = 0);

	     if db_close.index ^= db_index then
		;
	     else do;

		     unique = OFF;
		     error_code = mrds_error_$list_duplicate;
		     call
			sub_err_ (error_code, caller_name, continue, unused_ptr, return_value, "^/^a ^d ^a", "The database index =", db_index,
			"appears more than once in the argument list.");

		end;

	end;


	return (unique);


	dcl     unique		 bit (1);		/* on => good index */

     end;
%page;
add_index:
     procedure ();

/* add this index to the list of databases to be closed */

	allocate db_close set (db_close_ptr) in (work_area);

	db_close.index = db_index;
	db_close.dbcb_ptr = dbcb_ptr;
	db_close.next = null ();

/* link into the current list in user order */

	if db_close_list_ptr = null () then do;		/* first time */
		last_db_close_ptr = db_close_ptr;
		db_close_list_ptr = db_close_ptr;
	     end;
	else do;
		last_db_close_ptr -> db_close.next = db_close_ptr;
		last_db_close_ptr = db_close_ptr;
	     end;

     end;
%page;
close_database:
     procedure ();

/* This routine closes one database per call, using the database index,
   and resultant model pointer passed to it
*/

	dbcb_ptr = db_close.dbcb_ptr;
	close_index = db_close.index;
	rdbi_ptr = dbcb_ptr -> dbcb.rdbi_ptr;
	if rdbi_ptr = null () then
	     ;					/* no secure portion */
	else do;
		rmra_ptr = rm_db_info.ra_ptr;
		secured = "0"b;
		dbc_ptr = dbcb.dbc_ptr;

/* Files still in the ready state must be cleaned up.  That is, all scopes must
   be deleted in them. */

		call finish_files ();

/* temporary relations must be cleaned up */

		call delete_temp_rels ();

/* Close all non-temporary relations   */

		do x = 1 to rm_db_info.ra_ptr -> rm_rel_array.num_rels;

		     if rm_db_info.ra_ptr -> rm_rel_array.rel_data (x).ri_ptr ^= null then do;

			     oid = rm_db_info.ra_ptr -> rm_rel_array.rel_data (x).ri_ptr -> rm_rel_info.opening_id;
			     if oid ^= "0"b then do;
				     call dbcb.relmgr_entries.close (oid, code);
				     if code ^= 0 then call sub_err_ (code, caller_name,
					     continue, unused_ptr, return_value, "^/^a  ^a",
					     "Unable to close relation",
					     rm_db_info.ra_ptr -> rm_rel_array.rel_data (x).ri_ptr -> rm_rel_info.name);
				end;
			end;
		end;

/* Now delete all cursors and close the database */

		if dbcb.cursor_ptrs_storage_ptr ^= null ()
		then do;
			call mu_cursor_manager_$cleanup_storage (
			     dbcb.cursor_ptrs_storage_ptr, dbcb.cursor_storage_area_ptr, code);
			if code ^= 0
			then call sub_err_ (code, caller_name, continue,
				unused_ptr, return_value,
				"^/Cursor storage could not be deleted.");
		     end;

/* set scope lock around critical section of database closing */

		temp_uid = "0"b;
		call hcs_$get_uid_seg (dbc_ptr, temp_uid, code);
		if code = 0 & dbcb.dbc_uid = temp_uid
		then do;
			call set_lock_$lock (dbc.scope_lock, mrds_data_$lock_wait_time, code);
			if code ^= 0 & /* allow recursion into this critical region */
			     ^(code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process) then do;
				dbc.trouble_switch = "1"b;
				error_code = mrds_error_$inconsistent_close;
				call
				     sub_err_ (code, caller_name, continue, unused_ptr, continue, "^/^a ^d",
				     "Unable to set scope lock for this database index =", close_index);
			     end;
			else call remove_open_user ();
			call set_lock_$unlock (dbc.scope_lock, code);
			if code = 0 | code = error_table_$lock_not_locked then
			     ;			/* in case of recursion or locking error */
			else do;
				call
				     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^d",
				     "Unable to unlock scope for database index =", close_index);
				if error_code ^= 0 then
				     ;
				else error_code = code;
			     end;
		     end;
		call remove_resultant ();

	     end;
     end;
%page;
delete_file_scope: procedure ();

/* remove this files scope prevent and permit operations from the active scopes */

	scope_ptr = dbcb.scope_ptr;
	dbc_ptr = dbcb.dbc_ptr;

	if dbc_ptr = null () | scope_ptr = null () then ; /* never set */
	else do;

		if scope_info.active_scopes = 0 then ;	/* nothing to do */
		else do;

/* find the file name in the scope array */

			found = "0"b;
			do i = 1 to scope_info.active_scopes while (^found);

			     if rm_rel_info.model_name ^= scope_info.scope.name (i) then ;
			     else do;
				     found = "1"b;

/* set the prevent/permit op codes from the scope for this file */

				     perm = NO_OP;
				     prev = NO_OP;

				     if scope_info.scope (i).flags.permits.read_attr then
					perm = perm + READ_ATTR;
				     if scope_info.scope (i).flags.permits.append_tuple then
					perm = perm + APPEND_TUPLE;
				     if scope_info.scope (i).flags.permits.delete_tuple then
					perm = perm + DELETE_TUPLE;
				     if scope_info.scope (i).flags.permits.modify_attr then
					perm = perm + MODIFY_ATTR;

				     if scope_info.scope (i).flags.prevents.read_attr then
					prev = prev + READ_ATTR;
				     if scope_info.scope (i).flags.prevents.append_tuple then
					prev = prev + APPEND_TUPLE;
				     if scope_info.scope (i).flags.prevents.delete_tuple then
					prev = prev + DELETE_TUPLE;
				     if scope_info.scope (i).flags.prevents.modify_attr then
					prev = prev + MODIFY_ATTR;

/* go delete the scope for this file */

				     call mrds_dsl_dl_fscope (dbcb.dbi, scope_info.scope.sm_name (i), perm, prev, code);
				     if code = 0 then ;
				     else if code = mrds_error_$unknown_proc_id then code = 0; /* amdb done on dbc */
				     else do;
					     call sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a^a^a",
						"Unable to delete scope for file """, scope_info.scope.sm_name (i), """ during finish of file.");
					     if error_code ^= 0 then ;
					     else error_code = code;
					end;

				end;

			end;

		     end;

	     end;

	declare found		 bit (1);		/* on => file found in scope array, quit search */
	declare (perm, prev)	 fixed bin (35);	/* permit and prevent bits */
     end;
%page;
delete_temp_rels:
     procedure ();


/*  First of all, start a transaction if necessary */

	mstxn_transactions_needed = dbcb.transactions_needed;
	mstxn_txn_id = "0"b;
	on cleanup call mstxn_cleanup;
	on any_other call mstxn_any_other;
%include mrds_start_transaction;
	if mstxn_code ^= 0
	then call sub_err_ (mstxn_code, caller_name, continue, unused_ptr,
		return_value, "^/A transaction could not be started for database index ^d.  ^/Error occurred while releasing tempory relation storage.", close_index);

	dbcb.user_started_transaction = user_started_transaction;

/* delete any temporary relation definitions remaining */

	if rm_db_info.tra_ptr -> rm_rel_array.num_rels > 0 then do;

/* Close all the open temporary relations */

		call mrds_dsl_define_temp_rel$del_trels (dbcb_ptr); /* delete any temp rels */

/* now remove the storage areas for temporary relations, now that they are no longer needed */

		if dbcb.retr_info_ptr = null () & dbcb.trel_info_ptr = null () then
		     ;
		else do;

			resultant_dir = mrds_dsl_resultant_storage$get_opening_temp_dir (close_index, code);
			if code ^= 0 then do;
				if error_code ^= 0 then
				     ;
				else error_code = code;
				call
				     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^d",
				     "Unable to get the resultant model temporary directory for database index =",
				     close_index);
			     end;
			else do;

				do x = 1 by 1 to mrds_data_$max_sets;

				     if dbcb.retr_info_ptr = null () then
					;
				     else do;

					     fd_ptr = retrieve_info.ret_fd_ptr (x);
					     if fd_ptr = null () then
						;
					     else do;
						     vfile_type = "retrieve info";
						     call delete_vfile_seg ();
						     retrieve_info.ret_fd_ptr (x) = null ();
						end;

					end;

				     if dbcb.trel_info_ptr = null () then
					;
				     else do;

					     fd_ptr = trel_info.fd_ptr (x);
					     if fd_ptr = null () then
						;
					     else do;
						     vfile_type = "temp rel info";
						     call delete_vfile_seg ();
						     trel_info.fd_ptr (x) = null ();
						end;
					end;
				end;
			     end;
		     end;

	     end;

/* Finish the transaction.  If an error occurred, ignore it */

	mftxn_code = 0;
%include mrds_finish_transaction;
	if mftxn_code ^= 0
	then call sub_err_ (mftxn_code, caller_name, continue, unused_ptr,
		return_value, "^/A transaction could not be finished for database index ^d.  ^/Error occurred while releasing tempory relation storage.", close_index);


/***********
*
*   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;
     end restore_significant_data;



should_rollback:
     proc returns (bit (1));
	return ("0"b);
						/* There are no known cirumstances where a rollback is meaningful */
     end should_rollback;


     end delete_temp_rels;
%page;
finish_files:
     procedure ();

/* delete scopes on all files that the user has left still readied */

	do j = 1 to rm_rel_array.num_rels;

	     rmri_ptr = rm_rel_array.rel_data (j).ri_ptr;
	     call delete_file_scope ();

/* any errors were reported in the lower routine */

	     if code = 0 | error_code ^= 0 then
		;
	     else error_code = code;

	end;


     end;
%page;
remove_open_user:
     procedure ();

/* take this user out of the list of database openers */

	ul_ptr = pointer (dbc_ptr, dbc.open_users_ofs);

/* find the user in the list of database openers */

	do while (rel (ul_ptr) ^= NULL_OFFSET);

	     next_ul_ptr = pointer (dbc_ptr, user_list.next_open_ofs);

/* is this the right user in the list */

	     if user_list.process_id ^= proc_id then
		;
	     else do;

/* check that this is the right opening instance for this user in the user list */

		     if user_list.rdbi_bits ^= addr (rdbi_ptr) -> ptr_bit_string then
			;
		     else do;

/* correct opening instance, remove the user from the list of openers */

			     call mu_de_queue_user (DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr, code);
			     if code = 0 | code = error_table_$locked_by_this_process then
				;		/* allow recursion */
			     else do;
				     if error_code ^= 0 then
					;
				     else error_code = code;
				     call
					sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^d",
					"Unable to remove this user from the list of database openers for database index =", close_index);
				end;

			     next_ul_ptr = pointer (null, NULL_OFFSET); /* set to exit loop */

			end;

		end;

/* go to next user in open list */

	     ul_ptr = next_ul_ptr;
	end;


     end;
%page;
remove_resultant:
     procedure ();

/* the secure and non-secure portions of the resultant model
   must be removed, since they are no longer needed */


/* close the secure portion of the resultant */

	if rdbi_ptr ^= null ()			/* clean up the extensible area */
	then call release_area_ (addr (rdbi_ptr -> rm_db_info.static_area));

	dbi_pic = dbcb.dbi;				/* format db opening index */

/* cleanup most of the temp segements created */

	if dbcb.resultant_in_pdir			/* segments in pdir may be resused */
	then call mu_temp_segments$release_all_temp_segments ("MRDS" || dbi_pic, code);
	else call mu_temp_segments$delete_all_temp_segments ("MRDS" || dbi_pic, code);
	if code ^= 0 & code ^= error_table_$argerr
	then call sub_err_ (code, caller_name, continue, unused_ptr, return_value,
		"Could not clean up the temp segments created.");

/* cleanup the rest */

	temp_seg_name = mrds_data_$temp_seg_name || dbi_pic; /* name for temp segs */
	if dbcb.resultant_in_pdir
	then call mu_temp_segments$release_all_temp_segments (temp_seg_name, code);
	else call mu_temp_segments$delete_all_temp_segments (temp_seg_name, code);
	if code ^= 0 & code ^= error_table_$argerr
	then call sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^a",
		"Unable to release tid array search temp segs using the name:", temp_seg_name);


	call mu_database_index$reset_resultant_model_pointer (close_index, (dbcb_ptr));
						/* clear table entry */
	call hcs_$delentry_seg (dbcb_ptr, code);	/* delete dbcb */
	if code = 0 | code = error_table_$invalidsegno then
	     ;					/* previous invocation could have deleted */
	else do;
		if error_code ^= 0 then
		     ;
		else error_code = code;
		call
		     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^d ",
		     "Unable to delete the resultant model non-secure segment for database index =", close_index);
	     end;
	dbcb_ptr = null ();
     end;
%page;
delete_vfile_seg:
     procedure ();

/* routine to close, detach, and delete a vfile */

	if fd.iocb_ptr = null () then
	     ;
	else do;

		call iox_$close (fd.iocb_ptr, code);
		if code = 0 then
		     ;
		else do;
			if error_code ^= 0 then
			     ;
			else error_code = code;
			call
			     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^a ^a ^d", "Unable to close a", vfile_type,
			     "vfile for database index =", close_index);
		     end;

		call iox_$detach_iocb (fd.iocb_ptr, code);
		if code = 0 then
		     ;
		else do;
			if error_code ^= 0 then
			     ;
			else error_code = code;
			call
			     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^a ^a ^d", "Unable to detach a", vfile_type,
			     "vfile for database index =", close_index);
		     end;

		call iox_$destroy_iocb (fd.iocb_ptr, code);
		if code = 0 then
		     ;
		else do;
			if error_code ^= 0 then
			     ;
			else error_code = code;
			call
			     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a ^a ^a ^d", "Unable to destroy a", vfile_type,
			     "vfile iocb for database index =", close_index);
		     end;

		fd.iocb_ptr = null ();

		if fd.name = BLANK then
		     ;
		else do;

			begin;

			     call hcs_$del_dir_tree (resultant_dir, (fd.name), code);
			     if code = error_table_$notadir | code = 0 then
				call hcs_$delentry_file (resultant_dir, (fd.name), code);

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

			end;

			if code = 0 then
			     ;
			else do;
				if error_code ^= 0 then
				     ;
				else error_code = code;
				call
				     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a^a^a ^a ^a ^d",
				     "Unable to delete the segment """, fd.name, """ for a", vfile_type, "vfile for database index =", close_index);
			     end;

			fd.name = BLANK;

		     end;

	     end;


     end;
%page;
clean_up:
     procedure ();

/* remove the "close list" working area */

	if work_area_ptr = null () then
	     ;
	else do;

		call release_temp_segment_ (caller_name, work_area_ptr, code);
		if code = 0 then
		     ;
		else do;
			if error_code ^= 0 then
			     ;
			else error_code = code;
			call
			     sub_err_ (code, caller_name, continue, unused_ptr, return_value, "^/^a",
			     "Unable to release the working space temporary segment.");
		     end;

		work_area_ptr = null ();

	     end;




     end;
%page;
	dcl     db_index		 fixed bin (35) based (dbi_ptr), /* data base index of db to close (input) */
	        error_code		 fixed bin (35) based (error_code_ptr); /* status return error_code */

	dcl     (
	        nargs,				/* number of args */
	        i,
	        x,
	        j
	        )			 fixed bin;	/* length of argument */

	dcl     resultant_dir	 char (168);	/* resultant model directory pathname */
	dcl     secured		 bit (1) unal;	/* on if db is secured */

	dcl     proc_id		 bit (36) aligned;	/* process id for this user */

	dcl     (dbi_ptr, error_code_ptr) ptr;

	dcl     next_ul_ptr		 ptr;		/* ptr to next user_list entry */
	dcl     ptr_bit_string	 bit (72) unal based; /* bit string format of pointer */
	dcl     code		 fixed bin (35);	/* internal status code */

	dcl     never_readied	 bit (36) init ((36)"0"b); /* if file_array.id = this, then never readied */
	dcl     temp_uid		 bit (36) aligned;	/* uid of segment that dbc_ptr currently points to */

/*		Multics subroutines 		*/

	dcl     cu_$arg_list_ptr	 entry (ptr),
	        hcs_$delentry_seg	 entry (ptr, fixed bin (35)), /* deletes segs without ref names */
	        hcs_$get_uid_seg	 entry (ptr, bit (36) aligned, fixed bin (35)),
	        get_process_id_	 entry returns (bit (36)),
	        iox_$close		 entry (ptr, fixed bin (35)),
	        iox_$detach_iocb	 entry (ptr, fixed bin (35)),
	        iox_$destroy_iocb	 entry (ptr, 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));
	dcl     mu_temp_segments$delete_all_temp_segments entry (char (*), fixed bin (35));
						/* cleans up search temp segs */
	dcl     mu_temp_segments$release_all_temp_segments entry (char (*), fixed bin (35));
	dcl     dbi_pic		 pic "999";	/* format for database index in temp seg name */
	dcl     temp_seg_name	 char (26);	/* name used for search temp segs */

/*		other subroutines		*/

	dcl     mu_database_index$reset_resultant_model_pointer entry (fixed bin (35), ptr),
	        mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr),
	        mrds_dsl_define_temp_rel$del_trels entry (ptr),
	        mu_de_queue_user	 entry (bit (1), bit (1), ptr, ptr, fixed bin (35));

/*		external data		*/

	dcl     sub_err_		 entry options (variable); /* error reporting routine */
	dcl     caller_name		 char (15) init ("mrds_dsl_close"); /* name of calling routine */
	dcl     continue		 char (1) init ("c"); /* continue after printing err mesg */
	dcl     unused_ptr		 ptr init (null ());/* unused */
	dcl     return_value	 fixed bin (35) init (0); /* unused */
	dcl     OFF		 bit (1) init ("0"b); /* false */
	dcl     ON		 bit (1) init ("1"b); /* true */
	dcl     1 db_close		 aligned based (db_close_ptr), /* list element for database to close */
		2 next		 ptr,		/* to next database on list */
		2 index		 fixed bin (35),	/* database index */
		2 dbcb_ptr	 ptr;		/* pointer to resultant */
	dcl     db_close_ptr	 ptr;		/* points to close list element */
	dcl     db_close_list_ptr	 ptr;		/* points to head of list */
	dcl     last_db_close_ptr	 ptr;		/* points to last on list */
	dcl     arg_count		 fixed bin;	/* current argument number */
	dcl     mrds_error_$invalid_db_index fixed bin (35) ext,
	        error_table_$wrong_no_of_args fixed bin (35) ext, /* <2 arguments */
	        mrds_error_$list_duplicate fixed bin (35) ext, /* index >1 times in list */
	        mrds_data_$lock_wait_time fixed bin ext,
	        mrds_data_$max_sets	 fixed bin ext,
	        mrds_data_$max_data_length fixed bin ext,
	        mrds_error_$inconsistent_close fixed bin (35) ext,
	        error_table_$locked_by_this_process fixed bin (35) ext,
	        error_table_$invalid_lock_reset fixed bin (35) ext,
	        sys_info$max_seg_size	 fixed bin (35) ext;
	dcl     work_area		 area (1024) based (work_area_ptr); /* space for close list */
	dcl     work_area_ptr	 ptr;		/* points to close list area */
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* gets working space */
	dcl     NOT_READY		 bit (1) init ("0"b); /* file not currently readied */
	dcl     NULL_OFFSET		 bit (18) init ((18)"1"b); /* mrds version of null offset */
	dcl     vfile_type		 char (20) varying; /* retrieve info, or temp rel info */
	dcl     any_other		 condition;
	dcl     cleanup		 condition;	/* signaled during release */
	dcl     clean_up_condition	 bit (1);		/* on => cleanup signaled */
	dcl     BLANK		 char (1) init (" "); /* space character */
	dcl     close_index		 fixed bin (35);	/* local version of db_index */
	dcl     sub_error_		 condition;	/* signaled by sub_err_ call */
	dcl     mrds_error_$unknown_proc_id fixed bin (35) ext; /* Process not known to mrds database */
	dcl     mrds_data_$temp_seg_name char (23) ext;	/* common name for temp segments */
	dcl     error_table_$bad_arg	 fixed bin (35) ext;/* bad subroutine argument */
	dcl     error_table_$argerr	 fixed bin (35) ext;/* given if no temp segs of given name found */
	dcl     descriptor_ovrly	 bit (36) unal based; /* overlay for descriptor word */
	dcl     desc_index		 fixed bin;	/* offset to start of descriptor ptrs in arg list */
	dcl     SPECIAL		 fixed bin init (8);/* => extra ptr in arg_list */
	dcl     fixed_bin_35_descr	 bit (36) init ("100000100000000000000000000000100011"b);
						/* descriptor for fixed bin(35) */
	dcl     seg_fault_error	 condition;	/* signaled when invalid segment number used */
	dcl     error_table_$lock_not_locked fixed bin (35) ext; /* lock not set */
	dcl     error_table_$invalidsegno fixed bin (35) ext; /* bad segment number */
	dcl     mu_convert_parameter$convert_input_parameter entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
						/* gets db_index  */
	dcl     mrds_dsl_dl_fscope	 entry options (variable); /* Delete db scopes */
	dcl     mu_cursor_manager_$cleanup_storage entry (ptr, ptr, fixed bin (35));
	dcl     release_area_	 entry (ptr);	/* cleans up define_area_ areas */
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* removes temp work space */
	dcl     oid		 bit (36) aligned;
	dcl     mrds_dsl_resultant_storage$get_opening_temp_dir entry (fixed bin (35), fixed bin (35)) returns (char (168));
						/* gets temp dir for db_index */
	dcl     (addr, empty, fixed, null, pointer, rel, substr) builtin;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_scope_info;
%page;
%include mrds_dbcb;
%page;
%include mdbm_dbc;
%page;
%include mdbm_users;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_arg_list;
%page;
%include mrds_fd;
%page;
%include mrds_new_scope_modes;
%page;
%include mrds_retrieve_info;
%page;
%include mrds_trel_info;
%page;
%include mrds_debug_names;
     end;





		    mrds_dsl_close_all.pl1          04/18/85  1433.7re  04/18/85  0907.2       54000



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - July 1979

   81-01-30 Jim Gray : modified to call mrds_dsl_db_openings$list_dbs instead
   of mrds_dsl_list_dbs, after module renamed and modified for new interface $list_openings


   81-04-25 Jim Gray : changed size of work area to depend on mrds_data_$max_dbs

*/


mrds_dsl_close_all: close_all: procedure ();

/* DESCRIPTION:

   this routine will determine what databases the user currently has open,
   and proceed to close them all for him. an attempt will be made to close
   all open databases, regardless of any errors encountered during
   a close attempt on one particular database opening.

*/

/* PARAMETERS:

   (input) none

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

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

*/
%page;
/* check for the existance of a fixed bin (35) error code parameter */

	call cu_$arg_list_ptr (al_ptr);
	num_ptrs = arg_list.arg_count;
	nargs = arg_list.arg_count / 2;

	if nargs ^= 1 then do;
		code = error_table_$wrong_no_of_args;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a ^a",
		     "The number of arguments =", nargs, "was not 1 for the",
		     "error code argument, dcld ""fixed binary (35) aligned"".");
	     end;
	else do;

		error_code_ptr = arg_list.arg_des_ptr (1);
		error_code = 0;			/* initialize */

/* get a parameter area, and establish a clean up handler */

		area_ptr = null ();
		clean_up_condition = OFF;

		on cleanup begin;
			clean_up_condition = ON;
			call clean_up ();
		     end;

		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 obtain temporary segment for open database list.");
		else do;

			work_area = empty ();

/* get the open database list */

			call mrds_dsl_db_openings$list_dbs (area_ptr, database_list_ptr);
			if database_list_ptr = null () then ; /* no databases to close */
			else do;

				do loop_index = 1 by 1 to database_list.number_open;

				     call mrds_dsl_close (database_list.db (loop_index).index, code);
				     if code = 0 then ;
				     else if error_code ^= 0 then ; /* return first encountered error code */
				     else error_code = code;
				end;
			     end;
		     end;

/* get rid of temporary segment */

		call clean_up ();
	     end;
%page;
clean_up: procedure ();

/* remove temporary parameter space */

	if area_ptr = null () then ;
	else do;

		call release_temp_segment_ (caller_name, area_ptr, code);
		area_ptr = null ();
		if code = 0 | clean_up_condition then ;
		else do;
			call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
			     "Unable to release the temporary parameter space for the list of open databases.");
			if error_code ^= 0 then ;
			else error_code = code;

		     end;

	     end;

     end;
%page;
	dcl     cleanup		 condition;	/* signaled upon quit/release */
	dcl     clean_up_condition	 bit (1);		/* on => cleanup signaled */
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets work space */
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* deletes work space */
	dcl     ON		 bit (1) init ("1"b); /* true value */
	dcl     OFF		 bit (1) init ("0"b); /* false value */
	dcl     work_area		 area (60 * mrds_data_$max_dbs) based (area_ptr); /* parameter space */
	dcl     mrds_data_$max_dbs	 fixed bin (35) ext;/* max num open dbs */
	dcl     area_ptr		 ptr;		/* points to work space */
	dcl     empty		 builtin;		/* inits areas */
	dcl     caller_name		 char (18) init ("mrds_dsl_close_all"); /* name of calling routine */
	dcl     continue		 char (1) init ("c"); /* dont stop after printing mesg */
	dcl     info_ptr		 ptr init (null ());/* unused */
	dcl     return_value	 fixed bin (35) init (0); /* unused */
	dcl     error_code_ptr	 ptr;		/* pointer to error code argument */
	dcl     mrds_dsl_db_openings$list_dbs entry (ptr, ptr); /* getS list of open databases */
	dcl     mrds_dsl_close	 entry options (variable); /* closes open databases */
	dcl     sub_err_		 entry options (variable); /* reports errors */
	dcl     loop_index		 fixed bin (35);	/* opening index to be closed */
	dcl     error_code		 fixed bin (35) based (error_code_ptr); /* return status code */
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext; /* arg count ^= 1 */
	dcl     cu_$arg_list_ptr	 entry (ptr);	/* gets argument list */
	dcl     nargs		 fixed bin;	/* argument count */
	dcl     SPECIAL		 fixed bin init (8);/* special arg list type */
	dcl     fixed_bin_35_descriptor bit (36) init ("100000100000000000000000000000100011"b);
	dcl     packed_mask		 bit (36) init ("111111101111111111111111111111111111"b); /* ignore alignment */
	dcl     code		 fixed bin (35);	/* temp error code variable */
	dcl     null		 builtin;
%page;
%include mrds_database_list;
%include mdbm_descriptor;
%include mdbm_arg_list;

     end;




		    mrds_dsl_compile.pl1            08/01/88  1347.3r w 08/01/88  1314.7      130473



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

/****^  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-03-04 by
     John Hergert (mrds #144)
  2) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     Added the mrds_start_transaction and mrds_finish_transaction
     include files. (see mrds #142, phx19907)
  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)
                                                   END HISTORY COMMENTS */

mrds_dsl_compile:
compile:
     proc;

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

   DESCRIPTION

 The purpose of this procedure is to implement the dsl_$compile function. 
 This procedure creates an argument list for and calls translate, then 
 squirrels away the translated selection expression for future use by others.


   HISTORY:

 84-09-01 Originally written by John Hergert.

 85-03-04 John Hergert Fixed bug that failed to detect the condition when
 se_index was equal to 1 on the first call to dsl_$compile. It failed to
 return mrds_error_$no_sel_exp.

   INPUT CONDITIONS:

 database_index is the index of the database the caller wishes to compile
 a selection expression for.

 selection_expression is the expression supplied by the user to be compiled.

 se_index is the index of the selection expression.

 values are the indices (if any) of the temp rels used in the se 


   OUTPUT DEFINITIONS:

 If no errors are encountered the selection expression was sucessfully 
 compiled.

 se_index is the index of the selection expression just compiled.

 code = 0; if no errors were detected.

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

 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. 

*/

	area_ptr, dbcb_ptr = null;
	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 = arg_list.arg_count / 2;		/* 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			/* Get se descriptor */
	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;		/* if char var */
		se_len_ptr = addrel (se_ptr, -1);	/* get current length of varying string */
		se_len = se_len_ptr -> fb35u;
	     end;

	call cu_$arg_ptr (3, se_index_ptr, arg_len, icode); /* Get pointer to selection expression index */
	if icode ^= 0 then call error (icode);

	if nargs > 4 then do;			/* If we have any values get pointer to them */
		appl_ptr = addr (arg_list.arg_des_ptr (4));

		if arg_list.code = 4		/* and their descriptors */
		then adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 4));
		else adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 5));
	     end;
	else adpl_ptr, appl_ptr = null;

	num_args = nargs - 4;			/* 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 call error (mrds_error_$invalid_db_index);


	compiled_se_info_ptr = dbcb.compiled_se_info_ptr;
	if se_index >= 0 then do;			/* were compiling an se */

		dbi_pic = dbcb.dbi;
		if dbcb.compiled_se_info_ptr = null () then do; /* get a place to put compiled selection expressions */
						/* if we dont already have one */
			call mu_define_area$define_temp_dir_area (
			     dbcb.compiled_se_info_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);

			compiled_se_info_ptr = dbcb.compiled_se_info_ptr;
						/* initialize our new cse area */
			compiled_se_info.real_select_area_ptr = dbcb.select_area_ptr;
			compiled_se_info.number_of_compiled_se = 1;
			compiled_se_info.compile_area_ptr = null;
			compiled_se_info.se_info.seg_ptr (1) = null;
			compiled_se_info.se_info.saved_ptrs (1) = null;
			compiled_se_info.se_info.free (1) = "1"b;
			compiled_se_info.se_info.dup_retain (1) = "0"b;

			call get_cse_area (1);	/* get an area for the cse */
		     end;

/* get a work area */

		call mu_define_area$define_temp_dir_area (
		     compiled_se_info.compile_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 = compiled_se_info.compile_area_ptr;

		on cleanup call cleanup_handler;

		if se_index = 0 then do;		/* If new compiled se */
			sei = 0;
			do i = 1 to compiled_se_info.number_of_compiled_se;
			     if compiled_se_info.se_info.free (i) & sei = 0
			     then do;
				     sei = i;
				     compiled_se_info.se_info.free (sei) = "0"b;
				     dbcb.select_area_ptr, compiled_se_info.se_info.select_area_ptr (sei) =
					pointer (compiled_se_info.se_info.seg_ptr (sei), rel (compiled_se_info.real_select_area_ptr));
				     call mrds_dsl_delete_se (dbcb_ptr, (mrds_data_$caller_compile), icode);
				     if icode ^= 0 then call error (icode);
				end;
			end;
			if sei = 0 then do;		/* cant reuse a deleted one */
				compiled_se_info.number_of_compiled_se =
				     /* so make a new one */
				     compiled_se_info.number_of_compiled_se + 1;
				sei = compiled_se_info.number_of_compiled_se;

				compiled_se_info.se_info.free (sei) = "0"b;

				call get_cse_area (sei);
			     end;
		     end;
		else do;				/* redefining an old se */
			if (se_index <= compiled_se_info.number_of_compiled_se) &
			^(compiled_se_info.se_info.free(se_index))
			then do;
				sei = se_index;
				dbcb.select_area_ptr = compiled_se_info.se_info.select_area_ptr (sei);
				call mrds_dsl_delete_se (dbcb_ptr, (mrds_data_$caller_compile), icode);
				if icode ^= 0 then call error (icode);
			     end;
			else call error (mrds_error_$no_sel_exp);
		     end;

	     end;
	else do;					/* deleteing a compiled se */
		if dbcb.compiled_se_info_ptr = null then call error (mrds_error_$no_sel_exp);
		sei = -se_index;
		if sei <= compiled_se_info.number_of_compiled_se
		     & ^compiled_se_info.se_info.free (sei)
		then do;
			compiled_se_info.se_info.saved_ptrs (sei) = null;
						/* remove all references to the seg */
			compiled_se_info.se_info.free (sei) = "1"b;
			compiled_se_info.se_info.dup_retain (sei) = "0"b;
						/* indicate this seg is free now */
			code = 0;
		     end;
		else call error (mrds_error_$no_sel_exp);

		return;				/* nothing else to do here */
	     end;

	mstxn_transactions_needed = dbcb.transactions_needed;
	on cleanup begin;
	     call mstxn_cleanup;
	     call cleanup_handler;
	end;
	on any_other call mstxn_any_other;

%include mrds_start_transaction;
	if mstxn_code ^= 0
	then call error (mstxn_code);

	call mrds_dsl_translate (dbcb_ptr, area_ptr,
	     (mrds_data_$caller_compile), se_ptr, se_len, appl_ptr, adpl_ptr,
	     num_args, icode);
	mftxn_code = icode;
%include mrds_finish_transaction;
	if icode ^= 0 then call error (icode);

/* save the world for others */

	compiled_se_info.se_info.saved_ptrs.range_ptr (sei) = dbcb.range_ptr;
	compiled_se_info.se_info.saved_ptrs.select_ptr (sei) = dbcb.select_ptr;
	compiled_se_info.se_info.saved_ptrs.ti_ptr (sei) = dbcb.ti_ptr;
	compiled_se_info.se_info.saved_ptrs.ss_ptr (sei) = dbcb.ss_ptr;
	compiled_se_info.se_info.saved_ptrs.so_ptr (sei) = dbcb.so_ptr;
	compiled_se_info.se_info.saved_ptrs.lit_ptr (sei) = dbcb.lit_ptr;
	compiled_se_info.se_info.se_id_num (sei) = dbcb.last_s_e_id_num;
	compiled_se_info.se_info.dup_retain (sei) = dbcb.dup_retain;
	compiled_se_info.se_info.x_leaf_ptr (sei) = compiled_se_info.temp_x_leaf_ptr;
	compiled_se_info.se_info.temp_rel_list_ptr (sei) = compiled_se_info.temp_temp_rel_list_ptr;

	dbcb.select_area_ptr = compiled_se_info.real_select_area_ptr; /* cleanup after ourselves */
	compiled_se_info.temp_temp_rel_list_ptr,
	     compiled_se_info.temp_x_leaf_ptr = null;
	call mrds_dsl_delete_se (dbcb_ptr, mrds_data_$caller_compile, icode);
	if icode ^= 0 then call error (icode);

	if compiled_se_info.compile_area_ptr ^= null
	then call mu_release_area (compiled_se_info.compile_area_ptr);

	se_index = sei;
	code = 0;					/* evevrythings OK */
compile_exit:
	return;

get_cse_area:
     proc (index);

/* get an area for the new compiled selection expression
   (dbcb.select_area_ptr).  We cant use the one supplied to us by
   dsl_init_res because it is expecting to be reused and we want to save it.
*/

	dcl     index		 fixed bin (35);

	call mu_temp_segments$get_temp_segment (database_index, /* get a place to put thge compiled se */
	     "MRDS" || dbi_pic, compiled_se_info.se_info.seg_ptr (index), icode);
	if icode ^= 0 then call error (icode);

	compiled_se_info.se_info.saved_ptrs.select_area_ptr (index), dbcb.select_area_ptr = /* start the new area at the same offset the old starts in */
	     pointer (compiled_se_info.se_info.seg_ptr (index), rel (dbcb.select_area_ptr));

	dbcb.new_select_expr = "1"b;			/* tell search to start new tid_list management period */
	dbcb.last_s_e_id_num = mod (dbcb.last_s_e_id_num + 1, 999999); /* increment the select expr ID for current S.E. */

	call mrds_dsl_init_select_area (dbcb_ptr, icode); /* and initialize it */
	if icode ^= 0 then call error (icode);

     end get_cse_area;

error:
     proc (cd);

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

	code = cd;				/* Return the error code to caller */
	call cleanup_handler;			/* Tidy up before we leave */
	goto compile_exit;				/* Exit mrds_dsl_compile */

     end error;

cleanup_handler:
     proc;

	if dbcb_ptr ^= null then do;
		if dbcb.compiled_se_info_ptr ^= null
		then if compiled_se_info.compile_area_ptr ^= null
		     then call mu_release_area (compiled_se_info.compile_area_ptr);
		call mrds_dsl_delete_se (dbcb_ptr, mrds_data_$caller_compile, icode);
	     end;

	return;

     end cleanup_handler;
%page;
restore_significant_data: proc;

	return;

     end restore_significant_data;
%page;
should_rollback: proc () returns (bit (1));

	return ("0"b);

     end should_rollback;

%include mrds_dbcb;
%page;
%include mrds_compiled_se_info;
%page;
%include mdbm_arg_list;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_seg_area;

/* Multics Subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin,
				 fixed bin (35));

	dcl     sys_info$max_seg_size	 ext fixed bin (35);

/* DBM Routines */

	dcl     mrds_data_$caller_compile
				 fixed bin (35) ext;

	dcl     mrds_error_$invalid_db_index
				 ext fixed bin (35);
	dcl     mrds_error_$no_sel_exp
				 ext fixed bin (35);

	dcl     mrds_dsl_delete_se	 entry (ptr, fixed bin (35), fixed bin (35));
	dcl     mrds_dsl_init_select_area
				 entry (ptr, fixed bin (35));
	dcl     mu_temp_segments$get_temp_segment
				 entry (fixed bin (35), char (*), ptr,
				 fixed bin (35));
	dcl     mu_database_index$get_resultant_model_pointer
				 entry (fixed bin (35), ptr);
	dcl     mrds_dsl_translate	 entry (ptr, ptr, fixed bin, ptr, fixed bin, ptr,
				 ptr, fixed bin, fixed bin (35));

/* OTHERS */

	dcl     (
	        se_ptr,				/* pointer to selection expr. */
	        se_index_ptr,			/* pointer to selection expression index */
	        cd_ptr,				/* pointer to error 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     sei		 fixed bin (35);	/* selection expression indedx */
	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     se_index		 fixed bin (35) based (se_index_ptr);
						/* input: se index */

	dcl     (
	        nargs,				/* num args passed in */
	        i,				/* index variable */
	        se_len,				/* length of selection expr. */
	        arg_len,				/* length of an arg */
	        num_args
	        )			 fixed bin;	/* num args for translate */

	dcl     (null, addr, addrel, fixed, rel, mod, pointer)
				 builtin;

	dcl     (cleanup, arg_error, any_other)	 condition;

/* STATIC VARIABLES */

	declare clean_up_condition	 bit (1) init ("0"b); /* on => clean up proc called */
	declare mu_release_area	 entry (ptr);
	declare area_ptr		 ptr;

	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));
	declare se_len_ptr		 ptr;		/* temp for getting varying se length */
	dcl     dbi_pic		 picture "999";

     end mrds_dsl_compile;




		    mrds_dsl_create_res_copy.pl1    08/01/88  1347.3r w 08/01/88  1315.0      117405



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
mrds_dsl_create_res_copy: create_res_copy: proc (mdcrc_db_path, mdcrc_code);

/*
                   BEGIN_DESCRIPTION

   This  routine  will  create  a copy of the structures in the rdbi and dbcb
   segments  created during an opening via the model with a "r" ready mode in
   the  rdbi  and dbcb segments in the resultant_segs.dir directory under the
   db  directory.   It  will  create the resultant_segs.dir directory and the
   rdbi and dbcb segments if they do not already exist.
   
   If the main entry is used the database is opened and then this routine
   exits. The opening code will call the db_already_open entry which will
   complete the creation process.

                   END_DESCRIPTION

   Known Bugs:

   Notes:
      The main entry now just does a return - see the comment
      associated with the return for an explaination

      Naming convension: because 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.

   History:
     83-05-19 Davids: Written

     83-05-20 Davids: restructured so that the actual creation of the res.dir
     and rdbi and dbcb segments as well as the copying from the open db's
     resultant is done in the internal procedure create_and_copy. Added the
     entry that inputs both a path and a dbcb_ptr so that this module does
     not have to open the database if one is already open. Also added the
     entries report_res_created_(on off) for debugging purposes.

     83-05-24 Davids: added the check for error_table_$segknown to the 
     checks for non-error error codes returned by hcs_$make_seg

     83-05-24 Davids: Removed the call to mu_database_index and create_res_copy
     from the main entry. This is no longer needed since the opening process
     will call the db_already_open entry which calls the create_res_copy
     procedure.

     83-05-31 Davids: Added a return after mdcrc_code is set to 0 and before
     the call to mrds_dsl_open. This was needed so that a database could be
     created without having to have all its edit procs created before hand
     i.e. to remain compatable. The call to open requires that the edit procs
     already exist. [This was apparently reverted since there is nothing like
     it that I can find.  -PWB 10/03/83]

    83-06-02 Davids: replaced calls to hcs_$set_bc with calls to terminate_file_
    which will set the bit count and truncate the segment beyond the bit count.

    83-06-06 Davids: Added the sub_error_ handler. This will catch the error
    of opening a database without all the edit procs already created. It will
    reset the calls error code (pointed to by the info pointer) to allow the
    database to be created so the resesultant can be copied. Since the entry
    to the edit proc must be recreated at each opening it doesn't matter if the
    saved resultant has a bad entry pointer.

    83-06-07 Davids: Changed cac_number_of_chars from fixed bin to fixed bin (35)
    so that large rdbi segments do not cause a size condition when the number
    of characters is calculated.

    83-06-13 Davids: Modified sub_error_handler to test for a null info
    pointer before checking the value of what the info pointer points to.
    If the info pointer is null continue_to_signal_ is called. Also to reset
    the error code for the case of tring to open an inconsistent database.

    85-01-07 Davids & Thanh Nguyen:  Modified the create_and_copy procedure
    to declare the character overlay "cac_chars" as a based character string.
    By the typo error, it was declared as fixed bin (by default) causing
    the out of bound when we try to reference it as a large rdbi structure.
*/

/* PARAMETERS */

	dcl     mdcrc_db_path	 char (168);	/* (input) absolute path of the database dir */
	dcl     mdcrc_code		 fixed bin (35);	/* (output) error code */

/* AUTOMATIC */

	dcl     mdcrc_dbi		 fixed bin (35);	/* index of the open database */

/* INTERNAL STATIC */

	dcl     mdcrc_report_res_created bit (1) internal static init ("0"b);
						/* "1" => message will be sent when resultant is created */

/* INTERNAL CONSTANTS */

	dcl     mdcrc_READ		 fixed bin (35) internal static options (constant) init (1);
						/* datbase will be opened with a read ready mode */

/* CONDITIONS */

	dcl     cleanup		 condition;
	dcl     sub_error_		 condition;

/* EXTERNAL CONSTANTS */

	dcl     error_table_$namedup	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$segknown	 fixed bin (35) ext static;
	dcl     mrds_error_$bad_domain_proc fixed bin (35) ext static;
	dcl     mrds_error_$inconsistent_database fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

/* ENTRIES */

	dcl     adjust_bit_count_	 entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     get_group_id_$tag_star entry () returns (char (32));
	dcl     hcs_$append_branchx	 entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1),
				 fixed bin (1), fixed bin (24), fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, 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     mrds_dsl_close	 entry options (variable);
	dcl     mrds_dsl_open	 entry () options (variable);
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* BUILTINS */

	dcl     (addr, divide, fixed, null, rel, rtrim) builtin;

/* INCLUDES */

%include mrds_dbcb;
%page;
%include access_mode_values;
%page;
%include terminate_file;
%page;
%include sub_error_info;
%page;
%include condition_info_header;
%page;
%include condition_info;

	mdcrc_code = 0;
	mdcrc_dbi = 0;

	on sub_error_ call sub_error_handler;

	on cleanup call clean_up;

	call mrds_dsl_open (mdcrc_db_path, mdcrc_dbi, mdcrc_READ, mdcrc_code);
	if mdcrc_code ^= 0
	then goto exit_mrds_dsl_create_res_copy;

	if mdcrc_dbi ^= 0
	then call mrds_dsl_close (mdcrc_dbi, mdcrc_code);

exit_mrds_dsl_create_res_copy:
	return;

db_already_open: entry (dao_db_path, dao_dbcb_ptr, dao_code);


/* PARAMETERS */

	dcl     dao_db_path		 char (168);	/* (input) absolute path of the database dir */
	dcl     dao_dbcb_ptr	 ptr;		/* (input) pointer to an open db's dbcb structure */
	dcl     dao_code		 fixed bin (35);	/* (output) error code */





	dao_code = 0;

	call create_and_copy (dao_db_path, dao_dbcb_ptr, dao_code);

	return;

report_res_created_on: entry;

	mdcrc_report_res_created = "1"b;

	return;



report_res_created_off: entry;

	mdcrc_report_res_created = "0"b;

	return;

create_and_copy: proc (cac_db_path, cac_dbcb_ptr, cac_code);

/* PARAMETERS */

	dcl     cac_db_path		 char (168);	/* (input) absolute path of the database dir */
	dcl     cac_dbcb_ptr	 ptr;		/* (input) pointer to an open databases dbcb structure */
	dcl     cac_code		 fixed bin (35);	/* (output) error code);

/* AUTOMATIC */

	dcl     cac_bit_count	 fixed bin (35);	/* bit count of the open db's rdbi and dbcb segments */
	dcl     cac_dbcb_dir	 char (168);	/* path to directory containing the open db's dbcb segment */
	dcl     cac_dbcb_dir_len	 fixed bin;	/* number of non-blank characters in the dbcb_dir */
	dcl     cac_dbcb_entry	 char (32);	/* entry name of the segment containing the dbcb structures */
	dcl     cac_dbcb_copy_ptr	 ptr;		/* pointer to the segment containing
                                                               the copy of the dbcb structures */
	dcl     cac_number_of_chars	 fixed bin (35);	/* number of characters in the dbcb and rdbi segments */
	dcl     cac_resultant_segs_dir char (168);	/* absolute path of the resultant_segs.dir directory */
	dcl     cac_rdbi_dir	 char (168);	/* path to directory containing the open db's rdbi segment */
	dcl     cac_rdbi_dir_len	 fixed bin;	/* number of non-blank characters in the rdbi_dir */
	dcl     cac_rdbi_entry	 char (32);	/* entry name of the segment containing the rdbi structures */
	dcl     cac_rdbi_copy_ptr	 ptr;		/* pointer to the segment containing
                                                               the copy of the rdbi structures */
	dcl     cac_rdbi_ptr	 ptr;		/* pointer to the open database's rdbi segment */

/* BASED */

	dcl     cac_chars		 char (cac_number_of_chars) based;
						/* character overlay for copying the dbcb and rdbi segments */

/* INTERNAL CONSTANTS */

	dcl     cac_RINGS		 (3) fixed bin (3) internal static options (constant) init (7, 7, 7);
						/* ring brackets for created segments */

	call hcs_$append_branchx (cac_db_path, "resultant_segs.dir", SMA_ACCESS_BIN, cac_RINGS,
	     get_group_id_$tag_star (), 1, 0, 0, cac_code);
	if cac_code ^= 0 & cac_code ^= error_table_$namedup
	then goto exit_create_and_copy;

	cac_resultant_segs_dir = rtrim (cac_db_path) || ">resultant_segs.dir";

	call hcs_$make_seg (cac_resultant_segs_dir, "rdbi", "", RW_ACCESS_BIN, cac_rdbi_copy_ptr, cac_code);
	if cac_code ^= 0 & cac_code ^= error_table_$segknown & cac_code ^= error_table_$namedup
	then goto exit_create_and_copy;

	call hcs_$make_seg (cac_resultant_segs_dir, "dbcb", "", RW_ACCESS_BIN, cac_dbcb_copy_ptr, cac_code);
	if cac_code ^= 0 & cac_code ^= error_table_$segknown & cac_code ^= error_table_$namedup
	then goto exit_create_and_copy;

	call hcs_$fs_get_path_name (cac_dbcb_ptr, cac_dbcb_dir, cac_dbcb_dir_len, cac_dbcb_entry, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;

	call adjust_bit_count_ (cac_dbcb_dir, cac_dbcb_entry, "1"b, cac_bit_count, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;

	cac_number_of_chars = divide (cac_bit_count, 9, 17, 0) + 1; /* add 1 to be sure to get the last few */
	cac_dbcb_copy_ptr -> cac_chars = cac_dbcb_ptr -> cac_chars; /* bits even if they don't make a full character */

	call terminate_file_ (cac_dbcb_copy_ptr, (cac_bit_count), TERM_FILE_TRUNC_BC, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;


	cac_rdbi_ptr = cac_dbcb_ptr -> dbcb.rdbi_ptr;

	call hcs_$fs_get_path_name (cac_rdbi_ptr, cac_rdbi_dir, cac_rdbi_dir_len, cac_rdbi_entry, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;

	call adjust_bit_count_ (cac_rdbi_dir, cac_rdbi_entry, "1"b, cac_bit_count, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;

	cac_number_of_chars = divide (cac_bit_count, 9, 17, 0) + 1;
	cac_rdbi_copy_ptr -> cac_chars = cac_rdbi_ptr -> cac_chars;

	call terminate_file_ (cac_rdbi_copy_ptr, (cac_bit_count), TERM_FILE_TRUNC_BC, cac_code);
	if cac_code ^= 0
	then goto exit_create_and_copy;

	if mdcrc_report_res_created
	then call ioa_ ("Resultant copy created.");

exit_create_and_copy:
	return;

     end;

sub_error_handler: proc;

	dcl     seh_code		 fixed bin (35);
	dcl     01 seh_condition_info	 like condition_info;

	dcl     seh_fb35		 fixed bin (35) based;




	call find_condition_info_ (null (), addr (seh_condition_info), seh_code);
	if seh_code ^= 0
	then call continue_to_signal_ (seh_code);

	sub_error_info_ptr = seh_condition_info.info_ptr;

	if sub_error_info.info_ptr = null ()
	then call continue_to_signal_ (seh_code);
	else if sub_error_info.status_code = error_table_$noentry
	     & sub_error_info.info_ptr -> seh_fb35 = mrds_error_$bad_domain_proc
	then sub_error_info.info_ptr -> seh_fb35 = 0;	/* reset the error code in the */
						/* signaling procedure */
	else if sub_error_info.status_code = mrds_error_$inconsistent_database
	     & sub_error_info.info_ptr -> seh_fb35 = mrds_error_$inconsistent_database
	then sub_error_info.info_ptr -> seh_fb35 = 0;
	else call continue_to_signal_ (seh_code);

	return;

     end;

clean_up: proc;

/* AUTOMATIC */

	dcl     cu_discard_code	 fixed bin (35);	/* error code that will never be checked */





	if mdcrc_dbi ^= 0
	then call mrds_dsl_close (mdcrc_dbi, cu_discard_code);

	return;

     end clean_up;

     end mrds_dsl_create_res_copy;




		    mrds_dsl_db_openings.pl1        08/01/88  1347.3r w 08/01/88  1313.9       91746



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

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

mrds_dsl_db_openings: list_dbs: procedure (a_area_ptr, database_list_ptr);

/* DESCRIPTION:

   This routine has two entries, list_dbs  which  is  obsolete,  and
   list_openings  which extends the returned info to include opening
   mode and type of opening (model or submodel). this  routine  will
   return  an  array  of  database  indexes, and pathnames for those
   databases that are currently open by this process.  if  none  are
   open, a null pointer is returned. an area must be provided by the
   user that is a minimum 50 words for  each  open  database,  or  a
   maximum 4800 words, not counting the area header overhead of 24+2
   words for 1 database

*/

/* PARAMETERS:

   ===== list_dbs entry

   area_ptr - - (input) pointer to an area in which to allocate  the
   database_list  structure  of open database pathnames and indexes.
   it should be declared 4800 words long to handle the general case.

   database_list_ptr -  -  (output)  pointer  to  the  database_list
   structure  which  is an array of pathnames, database indexes, and
   opening modes for the databases open in this process. the pointer
   is    null   if   none   are   open.   use   the   include   file
   mrds_database_list.incl.pl1 for the returned structure.


   ===== get_openings entry

   area_ptr - - (input) pointer to a user supplied area large enough
   to hold the expected number of open database information details.

   structure_version - - (input) fixed bin, the desired  version  of
   the open information structure.

   mrds_database_openings_ptr - - (output) pointer,  points  to  the
   structure       defined       in       the      include      file
   mrds_database_openings.incl.pl1 which has been allocated  in  the
   users area.

   error_code - - (output) fixed bin(35), error status  encoding,  0
   unless an error occured. No error is returned if no databases are
   currently open, the structure is  still  allocated,  but  with  a
   number  open of 0. If the error code is not 0, then the structure
   is not allocated, and the pointer will be null.

*/

/* HISTORY:

   79-07-01 Jim Gray: Initially written.

   80-12-08 Rickie E. Brinegar: The opening mode was  added  to  the
   mrds_dbs_modes_list.incl.pl1 include file and the new entry point
   list_dbs_with_modes was added.

   80-12-12 Jim Gray : Added separate entry parameters for the  area
   pointer,  because occasionaly the wrong parameter list was looked
   at for getting this pointer, and the result was a bunch  of  null
   characters  for a database path. Also increased size of area from
   3200 to 4800 to handle additional mode info for the possible  max
   of  64 open dbs, each with 168 char paths. Also found that the do
   loop in the second entry was using number_of_openings, which  was
   never    initialized    in   that   entry,   instead   of   using
   number_of_db_open.

   81-01-30   Jim   Gray   :   changed   name   of   routine    from
   mrds_dsl_list_dbs  to  mrds_dsl_db_openings,  and  name  of entry
   list_dbs_with_modes to list_openings to be compatibile  with  new
   include file mrds_database_openings replacing mrds_dbs_modes_list
   as part of effort to  make  the  user  interface  extensible  and
   maintainable.  The  interface  was  also  changed  to  agree with
   project standards.

   81-04-24 Jim Gray : changed  area  size  to  be  proportional  to
   mrds_data_$max_dbs
*/

	number_of_openings = mu_database_index$get_number_open_dbs ();

	if number_of_openings = 0 then
	     database_list_ptr = null ();
	else do;

		area_ptr = a_area_ptr;		/* get local version for this entry */
		allocate database_list set (database_list_ptr) in (based_area);

		database_list.number_open = number_of_openings;

		number_found = 0;
		do db_index = 1 by 1 to mrds_data_$max_dbs while (number_found < number_of_openings);

		     call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);

		     if dbcb_ptr = null () then ;	/* not valid index */
		     else do;

			     rdbi_ptr = dbcb_ptr -> dbcb.rdbi_ptr;
			     if rdbi_ptr = null () then
				pathname = "PATH NOT AVAIABLE";
			     else pathname = rdbi_ptr -> rm_db_info.sm_path;

			     number_found = number_found + 1;

			     database_list (number_found).index = db_index;
			     database_list (number_found).path = pathname;
			end;

		end;

	     end;

	return;

list_openings: entry (b_area_ptr, structure_version, mrds_database_openings_ptr, error_code);

/* initialize */

	error_code = 0;
	mrds_database_openings_ptr = null ();

	mrds_database_openings_num_open_init = mu_database_index$get_number_open_dbs ();

/* check the users arguments */

	if structure_version ^= mrds_database_openings_structure_version then
	     error_code = error_table_$unimplemented_version;
	else if b_area_ptr = null () then
	     error_code = error_table_$badcall;
	else do;

		area_ptr = b_area_ptr;		/* get local version for this entry */
		unspec (my_area_info) = "0"b;
		my_area_info.version = 1;
		my_area_info.areap = area_ptr;

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

/* fill in the users structure */

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

			on cleanup begin;
				if mrds_database_openings_ptr ^= null () then do;
					free mrds_database_openings in (based_area);
					mrds_database_openings_ptr = null ();
				     end;
			     end;

			allocate mrds_database_openings set (mrds_database_openings_ptr) in (based_area);

			revert area;

			unspec (mrds_database_openings) = "0"b;
			mrds_database_openings.version = mrds_database_openings_structure_version;
			mrds_database_openings.number_open = mrds_database_openings_num_open_init;

			number_found = 0;
			do db_index = 1 by 1 to mrds_data_$max_dbs
			     while (number_found < mrds_database_openings_num_open_init);

			     call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);

			     if dbcb_ptr = null () then ; /* not valid index */
			     else do;

				     rdbi_ptr = dbcb_ptr -> dbcb.rdbi_ptr;
				     if rdbi_ptr = null () then
					pathname = "PATH NOT AVAIABLE";
				     else pathname = rdbi_ptr -> rm_db_info.sm_path;

				     number_found = number_found + 1;

				     mrds_database_openings (number_found).index = db_index;
				     mrds_database_openings (number_found).path = pathname;
				     if dbcb.dsm_sw then
					mrds_database_openings (number_found).submodel = "1"b;
				     else mrds_database_openings (number_found).model = "1"b;

/* set the mode argument */

				     mode_code = fixed (dbcb.open_mode);
				     if mode_code = 0 then
					mrds_database_openings (number_found).mode = "Mode not available";
				     else if mode_code = 1 then
					mrds_database_openings (number_found).mode = "retrieval";
				     else if mode_code = 2 then
					mrds_database_openings (number_found).mode = "update";
				     else if mode_code = 3 then
					mrds_database_openings (number_found).mode = "exclusive_retrieval";
				     else if mode_code = 4 then
					mrds_database_openings (number_found).mode = "exclusive_update";
				     else mrds_database_openings (number_found).mode = "Unknown opening mode";


				end;

			end;

		     end;

	     end;

skip_allocate:

	return;

	declare a_area_ptr		 ptr;		/* for main entry */
	declare area		 condition;	/* signaled if space too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets area details */
	declare area_ptr		 ptr;		/* pointer to users area */
	declare b_area_ptr		 ptr;		/* for get_path_info entry */
	declare based_area		 area (60 * mrds_data_$max_dbs) based (area_ptr); /* overlay for users area */
	declare cleanup		 condition;
	declare db_index		 fixed bin (35);	/* database index loop control */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$area_too_small fixed bin (35) ext; /* not enough space for structure */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* unknown structure version */
	declare mu_database_index$get_number_open_dbs entry returns (fixed bin); /* gets count of db's open by this process */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* get dbcb ptr from table */
	declare mode_code		 fixed bin;	/* code for the opening mode */
	declare mrds_data_$max_dbs	 fixed bin (35) ext;/* max number of allowed openings */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* area not freeable */
	declare number_found	 fixed bin;	/* current count of found database openings */
	declare pathname		 char (168);	/* pathname of database model/submodel opening */
	declare structure_version	 fixed bin;	/* desired structure version */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	declare (addr, fixed, null, rel, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local copy */

%include mrds_database_list;
%page;
%include mrds_database_openings;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include area_info;

     end;




		    mrds_dsl_declare.pl1            08/01/88  1347.3r w 08/01/88  1315.0       36936



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

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

mrds_dsl_declare: declare: proc (dbi, fn_name, code);

/* NOTES:

   BEGIN_DESCRIPTION
   This procedure makes the user-specified function known to the MRDS
   while processing the data base corresponding to the dbi.  The entry
   fn_name$fn_name is located using hcs_$make_ptr, and a scalfn_info
   block is created and put at the head of the known function list.
   Hence, all user_defined functions are searched prior to builtin
   functions.
   END_DESCRIPTION
*/

/* HISTORY:

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

   80-10-17 Rickie E. Brinegar: Use of hcs_$make_ptr was changed to expand_pathname_
   and cv_ptr_ to permit the use of absolute pathnames with declare for scalar
   functions.

   80-11-03 Rickie E. Brinegar: Use of cv_ptr_ changed to cv_entry_ so that
   the proper linkage information is set up.


   81-01-19 Jim Gray : added correct handling of old version database callers,
   so that dsl_v1_$declare gets called for them.

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

   81-06-23 Jim Gray : added call to mrds_dsl_get_builtins so that builtin
   functions are defined on an as needed basis.

   82-05-28 Mike Kubicar : removed incompatible change where dsl_$declare
   required the use of pathnames instead of refnames.  Now both are permitted.

   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)
*/

	dcl     (dbi,				/* Input: data base index */
	        code,				/* Output: status code */
	        icode)		 fixed bin (35);	/* internal status code */

	dcl     fn_name		 char (*);	/* Input: name of function */

	dcl     fn_entry		 entry variable;	/* entry of function */

	dcl     mrds_error_$invalid_db_index fixed bin (35) ext;

	dcl     null		 builtin;

	dcl     cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry);
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mrds_dsl_thread_fn_list entry (ptr, entry, fixed bin (35));

	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare (fixed, rel, addr)	 builtin;
	declare mrds_dsl_get_builtins	 entry (ptr, fixed bin (35)); /* defines builtin functions */

	call mu_database_index$get_resultant_model_pointer (dbi, dbcb_ptr);
	if dbcb_ptr = null then call error (mrds_error_$invalid_db_index);

	fn_entry = cv_entry_ (fn_name, null (), icode);
	if icode ^= 0 then
	     call error (icode);

/* BEGIN CHANGE 81-06-23 ******************************************** */

	if dbcb.sfi_ptr = null () then do;
		call mrds_dsl_get_builtins (dbcb_ptr, icode);
		if icode ^= 0 then call error (icode);
	     end;

/* END CHANGE 81-06-23 *********************************************** */

	call mrds_dsl_thread_fn_list (dbcb_ptr, fn_entry, icode); /* thread at head of list */
	if icode ^= 0 then
	     call error (icode);

	code = 0;
exit:	return;

error: proc (cd);

/* error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;

%include mrds_dbcb;

     end mrds_dsl_declare;




		    mrds_dsl_define_temp_rel.pl1    08/01/88  1347.3rew 08/01/88  1300.0      417366



/****^  ***********************************************************
        *                                                         *
        * 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-04-19,
     85-06-14, and 85-07-09 by Thanh Nguyen. (see mrds #136 and
     #139 (phx19906))
  2) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-11-26,Dupuis),
     install(86-12-09,MR12.0-1237):
     Change to use mrds_data_$relation_blocking_factor to create temp
     relations.
  3) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-05-19,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_define_temp_rel:
define_temp_rel:
     proc;

/* (database_index, selection_expression, sel_value, rel_index, code)

   DESCRIPTION:

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

   If  the rel_index is zero on input, a new temporary relation is defined and
   its index is returned in rel_index as an output parameter.  If rel_index is
   >zero  on  input,  and  a  temorary  relation possessing this index already
   exists, that temporary relation is redefined.  If rel index is <zero, and a
   temporary relation possessing that index already exists, it is deleted, and
   it's index made available for future use in another definition (rel_index =
   0).
		       END_DESCRIPTION






   INPUT CONDITIONS:

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

   selection_expression  is  the expression supplied by the user to select the
   tuplies to be include in the temp rel.  the selection_expression is ignored
   in the case of a negative rel_index.

   se_value selection expression values (optional);

   rel_index index designating the temp_rel being defined, It is zero on input
   if  a  new temp_rel is to be defined and the index is returned as an output
   paramater.  an input value for the rel_index of >0 means redefine that temp
   rel, and an input value of <0 means delete that temp rel definition.



   OUTPUT CONDITIONS:

   If no errors are encountered the temp_rel definition was performed.

   code = 0; If no errors are detected.

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

   code  =  mrds_error_$undefined_temp_rel_index; If the value of rel_index on
   input  is non-zero or does not refer to an existing temporary relation when
   non-zero.

   code  =  mrds_error_$max_temp_rels  If  the  number  of definitions exceeds
   mrds_data_$max_temp_rels

   code = something else; If some other error was detected;

   rel_index  = numeric value of the temporary relation created.  or it is set
   to 0, if an index was being deleted(i.e.  <0 on input)


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





   HISTORY:

   76-01-01 R. D. Lackey: Initially written.

   78-10-01 J. A. Weeldreyer: Modified for MR7.0.

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

   79-07-13  Al  Kepner:  Modified to handle char varying attributes stored in
   the data base by Pl/I standards.

   79-10-01 Jim Gray : Modified to correct key order counting.

   79-10-02  Jim  Gray  :  Modified  to  ignore duplicate key value tuples per
   documentation.

   79-10-03   Jim   Gray   :   Modified   to   change   iox_$attach_ioname  to
   iox_$attach_name, so that temp_rels can be properly deleted.

   79-10-04  Jim Gray : Modified to put temp rel info structures in rm_db_info
   area,  rather  than dbcb area, so that structures are handled consistantly,
   and so rdbi_ptr can be gotten simply after calls to mus_ptr_man$get_rip.

   79-12-01  Jim  Gray  :  Modified  to change the real_bit_length calculation
   routine,  to  use  whether  the  data  type  is varying character, not just
   varying,  to  determine  the bit length from the count field of the varying
   data item.

   80-01-01  Jim  Gray : Modified to handle undefined temp rel indexes, and to
   make negative temp rel indexes mean delete that temp rel definition, and to
   correct some undefined mrds_error_ table entries.

   80-01-02  Jim  Gray  : Modified to correct order of inititalization problem
   with  rm_rel_info/rm_rel_info in create_temp_rel_file that caused the value
   of the rmri_ptr to become unknown.

   80-01-03 Jim Gray : Modified to fix tidy_up problem on >max_temp_rel error,
   and to prevent recursive calls to tidy_up, when an error occurs.

   80-01-04  Jim Gray : Modified to fixed multiple redefinition problem (added
   destroy_iocb)

   80-02-01  Jim  Gray  : Modified to detect non-unique attr names in relation
   definition.

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

   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-05-12     Rickie     E.      Brinegar:     Modified     to    initialize
   rm_rel_info.model_nvar_atts      and      rm_rel_info.model_num_attr     in
   create_temp_rel_file  to  the  same initial values as rm_rel_info.nvar_atts
   and   rm_rel_info.num_attr   respectively.    This  was  necessary  because
   define_temp_rel builds its own tuple structure.

   80-06-01  Jim Gray : Modified to add first_time_flag to store direct entry,
   so that allocated space could be reused, especially for large temp rels.

   80-09-16  Jim  Gray  :  Modified to put the temp rel (vfile) storage in the
   same  place  as  the  resultant  model,  which  may  have  been  changed by
   set_mrds_temp_dir

   80-10-01  Jim  Gray  : Modified to make the $del_trels entry know about the
   proper  place  to get the resultant model temp dir, instead of always using
   the pdir.

   80-10-03  Jim Gray : Modified to make temp rel redefinition delete the temp
   rel, if the new temp rel definition did not find any tuples.  This makes it
   work  the  way  it used to before the recursive tidy up problem fix entered
   this rebug.

   80-10-17  Jim  Gray  :  Modified to allow empty temp rels to be created, or
   defined by redefinition, according to customer wishes.

   80-11-05  Jim  Gray : Modified to set mdbm_secured bit and ??_perm bits the
   same  way  as  a  normal  relation  would  be set, for proper handling when
   secure_mrds_db was invoked.

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

   81-1-13   Jim  Gray  :  added  routine  (from  mrds_rst_format_file  logic)
   force_msf_temp_rel,  to  always  start  temporary  relations  out  as  full
   multi-segment  files,  just  like  permanent  relations  are.   This avoids
   problems  with  vfile_ and msf_manager_ when the ssf grows to msf and there
   are  multiple  openings.   This  is  a  fix  for critical TR 8871.  It also
   results  in  a  permformance  improvement for cases where as msf would have
   been created on temp_rel creation (i.e.  most non-empty temp rels)

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

   81-01-29  Jim  Gray  :  added  proper  alignment of different data type and
   alignment   type   attributes   within   the  tuple,  as  already  done  in
   mrds_rst_file_handler  for  permanent  relations,  so that the logic in the
   rest  of  mrds  can  find the attributes in the tuple.  TR 9021 pointed out
   that  where  clause  comparisons  were failing due to improper alignment of
   temp  rel  tuple  attrs.   Also  found  that tuples were 9 times as long as
   necessary,  because  improper use of bit versus character lengths was being
   done, compare rel_info versus rm_rel_info as init in mu_sec_make_res.

   81-01-30  Jim  Gray  : added interface get_temp_rel_population according to
   suggestion  TR  8991,  this  required  a change to rm_rel_info that will be
   usefull in improving finding approx tuple count in perm relations.

   81-01-30  Jim Gray : added padding logic to align varying strings to a word
   boundary  in the get_tuple routine.  this was done because the previous fix
   only  set  the  max_data_len for the tuple, and var_offset (i.e.  the start
   and  end  of  the varying attr section of the tuple) but not the offsets of
   the  varying  attrs, because they are stored in current length fashion, and
   must be set at data definition time.

   81-02-03  Jim  Gray  : changed declaration of fb35 to unaligned and renamed
   fb35u,  in  answer  to  TR  9041.   Note this was done as a quick and dirty
   because  the  tuple  defined by a set operation is not properly aligned and
   padded.   Thus  it is different in structure from perm and temp rel tuples.
   However,  since  it can only be used in retrieves, and temp rel definition,
   this fix is adequate for now, until we build a common tuple manager.

   81-03-17  Davids:  added  code  to  set  the rm_rel_info.model_nkey_attr to
   nkey_attr_init  in  the internal procedure create_temp_rel_file, this fixed
   tr9211.   also removed some unused declarations and explicity declared some
   builtins.   added  the  page  macro  between  include file declarations and
   removed  the form feeds that were there, also removed extra form feeds that
   were  causing  blank pages.  reformated the header section so that the text
   is justified.

   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-03-27    Jim   Gray   :   changed   dbi   to   dbcb_ptr   parameter   to
   mu_store$store_direct as part of getting rid of the mus_ptr_man module.

   81-06-02 Jim Gray : changed to use new resultant structure.

   81-06-17 Jim Gray : changed iocb pointer init to call mu_open_iocb_manager.

   81-10-05  Rickie  E.   Brinegar: collapsed all of the processing to be done
   when  the  arg_list.code  =  4  and  when  it  is not into one if-then-else
   statement as opposed to the three that used to exist.

   81-10-14 Davids: corrected value of the adpl_ptr so it pointed to
   the descriptor of the argument following the selection expression
   instead of the selection expression  descriptor.  This  corrected
   .V. problems.

   81-10-23 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.

   81-12-04 Davids: changed the value of rm_rel_info.file_id_len  to
   be  equal to the constant 9 rather than computing it based on the
   max  number  of  temp  rels.  This  value  should   be   set   to
   db_model.unblk_file_id_len  but  it  was  easier  just to use the
   constant  value.  Also  set  rm_rel_info.file_id  to   "0"b   and
   rm_rel_info.file_type to UNBLK (= 1). All this is so that the tid
   created for a temp rel tuple will look the same (except  for  the
   component  and  offset)  as tids created for permanent relations.
   This is done so that the moving the data into the database dir to
   create a permanent relation will not cause any problems.

   81-12-16 Davids: modified to handle self-defined temp  rels,  i.e
   the  temp  rel refers to itself in the defining SE. This required
   changing the rm_rel_array refering to temp rels to have  1  extra
   slot, i.e. have a dimension of mrds_data_$max_temp_rels + 1, this
   was done in mu_sec_init_res. In this routine  all  references  to
   rm_rel_array.num_rels   have   been   changed  to  references  to
   mrds_data_$max_temp_rels becuase num_rels is now too big. The new
   relation  is  defined using the extra index and then the old temp
   rel is deleted and the rm_rel_array fields copied. for TR11630

   81-12-18         Davids:         modified         so         that
   rm_rel_array.last_statistics_update_s_e_ref_num   is  set  to  0,
   rm_rel_array.ready_mode is set to SCOPE_UPDATE instead  of  LOAD,
   the  view permissions modify and delete in rm_rel_info are set to
   "1"b (retrieve and store were already set), the scope permissions
   rm_attr_info.modify_perm  was  set  to  "1"b (others were already
   set) and reformated the assignments so they were easier to  read.
   All this so that temp rels can be updated.

   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-04-26 R. Lackey : removed get_tuple internal procedure and made it
   external with the name mu_get_tuple providing common code for
   rmdb_create_relation with a selection exp.

   82-05-24 R. Lackey : Modified the initialization of rm_rel_info.file_id_len
   from 9 to 7 cause the tuple_id_unbl.file_id length is only 7 bits.
   This corrected a stringsize condition.

   82-06-09 Mike Kubicar : added the fix for TR phx12347.  If a temp relation
   had varying strings in it but the last attribute in it is not a varying
   string, the temp relation would be missing data.

   82-08-20 D. Woodka : deleted references to rm_rel_info.max_data_len
   and to rm_attr_info.bit_offset for DMS conversion

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

   82-09-12 Mike Kubicar : Converted to use relation manager.

   82-12-10 Davids: Modified the call to dbcb.relmgr_entries.create_relation
   and destroy_relation_by_path by enclosing the relation 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 relation name
   is declared as character aligned in the include file while the entry expects
   character unaligned.

   83-01-31 Mike Kubicar : Added included files to call transaction manager
   when using a dm file database.

   83-02-17 Ron Harvey : Modified to call $create_relation with the attribute
   names.

   83-02-25 Davids: Modified to set the protected, no_concurrency and
   no_rollback elements of the file_create_info structure from the 
   transactions_needed, concurrency_on, rollback_on elements of the
   dbcb structure. This allows temp rels to be created with the same
   file attributes as the permanent relations.

   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-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-08-22 Pierret: Changed usage of file_create_info structure for version
   FILE_CREATE_INFO_VERSION_2.  This add the ring_brackets component, which
   is set to 0 to get the default action.

   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-06-14 Thanh Nguyen:  Initialized the rm_rel_info.scope_flags_ptr to null
   so later noone would have some gabages overwrite on their good areas when
   accidentally referencing scope_flags_ptr.

   85-07-09 Thanh Nguyen:  Modified the code to set rm_rel_info.file_type as
   TEMPORARY (3) from UNBLCK (1).
*/
%page;
	area_ptr, dbcb_ptr, simple_typed_vector_ptr = null;
	tri = 0;					/* initialize */
	no_recurse = "0"b;
	created_resultant = "0"b;
	mstxn_txn_id = "0"b;
	entry_point_name = "mrds_dsl_define_temp_rel";

	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 = arg_list.arg_count / 2;		/* Get the number of arguments to this proc */
	if nargs < 4 then
	     signal arg_error;			/* This returns to command level */

	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 do;
		num_ptrs = arg_list.arg_count;	/* Determine number of pointers in arg list */
		adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 3)); /* Get pointer to descriptor ptr list for
						   args after SE for translate */
		desc_ptr = arg_list.arg_des_ptr (nargs + 2); /* Get pointer to descriptor of the selection expression */
	     end;
	else do;
		num_ptrs = arg_list.arg_count + 1;
		adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 4));
		desc_ptr = arg_list.arg_des_ptr (nargs + 3);
	     end;

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

	call cu_$arg_ptr (nargs - 1, rel_index_ptr, arg_len, icode);
						/* Get the rel_index */
	if icode ^= 0 then
	     call error (icode);

	appl_ptr = addr (arg_list.arg_des_ptr (3));	/* Get ptr to the start  of the arg_ptr_list for translate */

	num_args = nargs - 4;			/* 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
	     call error (mrds_error_$invalid_db_index);

	rdbi_ptr = dbcb.rdbi_ptr;

	tr_dir = get_resultant_dir (database_index);	/* put temp rels in same dir as resultant model */

	dbi_pic = dbcb.dbi;
	call
	     mu_define_area$define_temp_dir_area (dbcb.def_temp_rel_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);
	area_ptr = dbcb.def_temp_rel_area_ptr;
	if icode ^= 0 then
	     call error (icode);
	rmra_ptr = rm_db_info.tra_ptr;		/* get rel and file aray ptrs */
						/* Create a work area for mu_retrieve to allocate the value_for_users. */
	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);
%page;

	if rel_index = 0 then do;			/* if new temp rel */
		tri = 0;
		do i = 1 to mrds_data_$max_temp_rels;
		     if rm_rel_array.rel_data.ri_ptr (i) = null () & tri = 0 then
			tri = i;
		end;
		if tri = 0 then
		     call error (mrds_error_$max_temp_rels);
	     end;					/* if new temp rel */
	else do;					/* if redefinition */
		if abs (rel_index) > mrds_data_$max_temp_rels then
		     call error (mrds_error_$undefined_temp_rel_index);
		tri = abs (rel_index);
		if rm_rel_array.rel_data.ri_ptr (tri) = null () then
		     call error (mrds_error_$undefined_temp_rel_index);
	     end;					/* if redefin. */
	mstxn_transactions_needed = dbcb.transactions_needed;
	save_appl_ptr = appl_ptr;
	save_adpl_ptr = adpl_ptr;
	save_num_args = num_args;
	on cleanup
	     begin;
		call mstxn_cleanup;
		call tidy_up;
	     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;
	if rel_index < 0 then
	     ;					/* ignore selection expr, when only deleting temp rel */
	else do;
		call
		     mrds_dsl_translate (dbcb_ptr, area_ptr,
		     mrds_data_$caller_define_temp_rel, se_ptr, se_len, appl_ptr,
		     adpl_ptr, num_args, icode);
		if icode ^= 0 then
		     call error (icode);
		if ^dbcb.val_dtr then
		     call error (mrds_error_$inval_dtr_expr);

		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);
			self_defined = "0"b;
			do i = 1 to select_sets.nitems while (^self_defined & rel_index > 0);
			     self_defined = check_self_definition (select_sets.items (i).range_ptr, rel_index);
			end;
		     end;
		else do;
			range_ptr = dbcb.range_ptr;	/* initialize */
			select_list_ptr = dbcb.select_ptr;
			ti_ptr = dbcb.ti_ptr;
			self_defined = "0"b;
			if rel_index > 0
			then self_defined = check_self_definition (range_ptr, rel_index);
		     end;
		stv_number_of_dimensions = mrds_data_$max_attributes;
		allocate simple_typed_vector set (simple_typed_vector_ptr)
		     in (work_area);
		simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
	     end;

	if self_defined				/* this saves the actual user requested temp */
	then do;					/* rel index and sets up to use a temporary */
		actual_rel_index = rel_index;		/* temp rel index */
		rel_index = mrds_data_$max_temp_rels + 1;
		tri = rel_index;
	     end;
	else actual_rel_index = tri;

	if rel_index ^= 0 then /* if redefining an old temp rel */
	     call delete_temp_rel_file;		/* Delete the existing file for this temp_rel */
	if rel_index < 0 then
	     rel_index = 0;				/* only deleting previously defined temp rel */
	else do;					/* redefine or initial define */
		call create_temp_rel_file;		/* Create a new temp_rel file for this temp_rel */
		ntuples_retrieved = 0;
		dbcb.last_store_rel_name = "!!!!!!!... ...!!!!!"; /*  Temparory store bad rel name incase this store fails */
		call mu_get_tuple (dbcb_ptr, area_ptr, rmri_ptr, simple_typed_vector_ptr, icode); /* get a tuple */
		do while (icode = 0);		/* so long as there are tuples to be retrieved */
		     call
			mu_store$store_direct (dbcb_ptr, rmri_ptr, simple_typed_vector_ptr,
			icode);			/* add tuple */
		     if icode = 0 | icode = dm_error_$key_duplication then do;
						/* ignore duplicates */
			     if icode = 0 then
				ntuples_retrieved = ntuples_retrieved + 1;
			     dbcb.another_flag = "1"b;
			     call mu_get_tuple (dbcb_ptr, area_ptr, rmri_ptr, simple_typed_vector_ptr, icode);
			end;
		end;
		if icode = mrds_error_$tuple_not_found then do; /* allow empty temp rels */
			rm_rel_info.current_tuple_population
			     = ntuples_retrieved;
			rm_rel_info.last_statistics_update_time,
			     rm_rel_info.last_statistics_update_s_e_ref_num = 0;
		     end;
		else call error (icode);
		if rel_index = 0 then /* A new temp_rel file was created */
		     rel_index = tri;		/* let caller know the index */

		if self_defined
		then call complete_definition;

	     end;
	code = 0;
exit:

	mftxn_code = code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0
	then code = mftxn_code;

	if dbcb_ptr = null () then
	     ;
	else if dbcb.def_temp_rel_area_ptr ^= null then
	     call mu_release_area (dbcb.def_temp_rel_area_ptr);
	return;					/* Return to the caller with a code */
%page;
get_temp_rel_population:
     entry (a_db_index, temporary_relation_index, tuple_count, a_error_code);

/* entry to get the number of tuples in a given temp
   rel definition, given it's temp rel index.  Note that no transactions
   need be started by this entry point.  It is used exclusively as an
   internal entry point by dsl_$get_population.  This module will have
   already started a transaction */

	a_error_code, tuple_count = 0;		/* init */
	no_recurse = "0"b;
	entry_point_name = "get_temp_rel_population";

	call mu_database_index$get_resultant_model_pointer (a_db_index, dbcb_ptr);
	if dbcb_ptr = null () then
	     a_error_code = mrds_error_$invalid_db_index;
	else do;
		rdbi_ptr = dbcb.rdbi_ptr;

		rmra_ptr = rm_db_info.tra_ptr;

		if temporary_relation_index <= 0
		     | temporary_relation_index > mrds_data_$max_temp_rels then
		     a_error_code = mrds_error_$undefined_temp_rel_index;
		else do;
			rmri_ptr =
			     rm_rel_array.rel_data.ri_ptr (temporary_relation_index);

			if rm_rel_array.rel_data.ri_ptr (temporary_relation_index)
			     = null () then
			     a_error_code = mrds_error_$undefined_temp_rel_index;
			else do;

				tuple_count = rm_rel_info.current_tuple_population;

			     end;
		     end;
	     end;

	return;
%page;
del_trels:
     entry (a_dbcb_ptr);

/* Entry to delete temp files.  This entry point is used only internally by
   mrds in dsl_$close.  Thus, it need not start its own transaction. */

	dcl     a_dbcb_ptr		 ptr;
	dcl     num_defined		 fixed bin;

	dbcb_ptr = a_dbcb_ptr;
	rdbi_ptr = dbcb.rdbi_ptr;
	rmra_ptr = rm_db_info.tra_ptr;
	area_ptr = null ();
	no_recurse = "0"b;
	entry_point_name = "del_trels";

	if rmra_ptr ^= null then do;
		tr_dir = get_resultant_dir (dbcb.dbi);
		num_defined = mrds_data_$max_temp_rels;
		do tri = 1 to mrds_data_$max_temp_rels; /* delete all temp files and rels */
		     call delete_temp_rel_file;
		end;
	     end;

	return;
%page;
get_resultant_dir:
     procedure (db_index) returns (char (168));

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

	dcl     pathname		 char (168);	/* directory under which resultant model is stored */
	dcl     db_index		 fixed bin (35);	/* local version of databsae opening index */
	dcl     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 (db_index, 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_rel_file:
     proc;

/* Procedure to delete a temporary relation. */

	dcl     j			 fixed bin;

	if rm_rel_array.rel_data.ri_ptr (tri) ^= null then do; /* if there */
		rmri_ptr = rm_rel_array.rel_data.ri_ptr (tri); /* clean up file stuff */

		no_recurse = "1"b;			/* prevent recursive tidy_up calls */

		if rm_rel_info.opening_id ^= "0"b then do; /* Don't close if not open */
			call mu_cursor_manager_$destroy_and_free_on_opening_id (
			     rm_rel_info.opening_id, dbcb.cursor_storage_area_ptr,
			     dbcb.cursor_ptrs_storage_ptr, dbcb.relmgr_entries.destroy_cursor,
			     dbcb.relmgr_entries.close, icode);
			if icode ^= 0
			then call error (icode);
			call dbcb.destroy_relation_by_path (
			     tr_dir, (rm_rel_info.name), icode);
			if icode ^= 0 then
			     call error (icode);
		     end;
		rm_rel_array.name.submodel (tri),
		     rm_rel_array.rel_data.model_name (tri) = "";
		rm_rel_array.rel_data.ri_ptr (tri) = null;

		if rmri_ptr ^= null then do;
			do j = 1 to rm_rel_info.num_attr; /* free attr infos */
			     rai_ptr = rm_rel_info.attr_ptrs (j);
			     if rai_ptr ^= null then do;
				     free rm_attr_info in (dbcb.static_area);
				     rai_ptr = null ();
				     rm_rel_info.attr_ptrs (j) = null ();
				end;
			end;
		     end;				/* freeing rel info */
		free rm_rel_info.id_list_ptr -> id_list in (dbcb.static_area);
		free rm_rel_info in (rm_db_info.static_area);
		no_recurse = "0"b;			/* turn off, so temp rel redefinition deletes
						   when no tuple found */
	     end;

     end delete_temp_rel_file;
%page;
create_temp_rel_file:
     proc;

/* Procedure to create a temporary relation. */

	dcl     actual_rel_pic	 pic "99";
	dcl     cibi_ptr		 ptr;		/* ptr to ci_build_index structure */
	dcl     1 ci_build_index	 based (cibi_ptr),	/* To record which attributes are indexed */
		2 num_indices	 fixed bin,	/* How many? */
		2 index_position	 (max_build_indices refer
				 (ci_build_index.num_indices)) fixed bin; /* Position in attribute */
	dcl     create_index_flags	 bit (36) aligned;	/* Flag bits for create_index call */
	dcl     i			 fixed bin;
	dcl     j			 fixed bin;
	dcl     max_build_indices	 fixed bin;	/* Maximum number of indices */
	dcl     retrieve_id_list_ptr	 ptr;		/* Pointer to id list to be used for gets */
	dcl     SORTING_STYLE	 fixed bin init (1) int static
				 options (constant);/* Create index index style */
	dcl     var_att_index	 fixed bin;

	rmri_ptr = null ();
	created_resultant = "1"b;
	actual_rel_pic = actual_rel_index;		/* for easier manipulation */
	natts_init = select_list.num_items;
	nvar_atts_init = 0;
	do i = 1 to select_list.num_items;
	     raip = select_list.item.ai_ptr (i);
	end;					/* counting varying attrs */
	nkey_attr_init = 0;
	do i = 1 to select_list.num_items;		/* count keys */
	     if select_list.item.key (i) then
		nkey_attr_init = nkey_attr_init + 1;
	end;
	if nkey_attr_init < 1 then
	     call error (mrds_error_$no_tr_keys);	/* must have key */

	allocate rm_rel_info in (rm_db_info.static_area);

	rm_rel_array.rel_data.ri_ptr (tri) = rmri_ptr;
	rm_rel_info.model_name, rm_rel_info.name,
	     rm_rel_array.name.submodel (tri),
	     rm_rel_array.rel_data.model_name (tri) =
	     unique_chars_ ("0"b) || "." || actual_rel_pic || ".temp_rel";
	rm_rel_info.ready_mode = SCOPE_UPDATE;
	rm_rel_info.file_type = TEMPORARY;
	rm_rel_info.tuple_id_len = 36;
	rm_rel_info.retrieve,
	     rm_rel_info.store,
	     rm_rel_info.delete,
	     rm_rel_info.modify = "1"b;

	rm_rel_info.status_perm,
	     rm_rel_info.delete_tuple_perm,
	     rm_rel_info.append_tuple_perm,
	     rm_rel_info.unused_perm = "1"b;

	rm_rel_info.total_key = "1"b;

	rm_rel_info.mdbm_secured = rm_db_info.mdbm_secured; /* temp secured if db is */

	rm_rel_info.last_model_attr_char_var,
	     rm_rel_info.indexed,
	     rm_rel_info.reserved = "0"b;

	rm_rel_info.nsec_inds,
	     rm_rel_info.max_key_len = 0;

	rm_rel_info.num_attr = natts_init;
	rm_rel_info.model_num_attr = natts_init;
	rm_rel_info.nkey_attr = nkey_attr_init;
	rm_rel_info.model_nkey_attr = nkey_attr_init;	/* added on 81-03-17 */
	rm_rel_info.scope_flags_ptr = null;/* temp. relation so no need scope. */
	var_att_index, key_order = 0;

	il_number_of_ids = select_list.num_items;
	allocate id_list in (rm_db_info.static_area) set (retrieve_id_list_ptr);
	retrieve_id_list_ptr -> id_list.version = ID_LIST_VERSION_1;
	retrieve_id_list_ptr -> id_list.number_of_ids = select_list.num_items;

/* Set up the structures needed to keep track of indices */

	allocate id_list in (work_area);
	id_list.version = ID_LIST_VERSION_1;
	id_list.number_of_ids = 0;

	max_build_indices = select_list.num_items;
	allocate ci_build_index in (work_area);
	ci_build_index.num_indices = 0;

	tva_number_of_vector_slots = 0;
	tva_number_of_dimensions = select_list.num_items;
	tva_maximum_dimension_name_length = 32;
	allocate typed_vector_array in (work_area);
	typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;

	do i = 1 to select_list.num_items;		/* do the attr infos */

	     raip = select_list.item.ai_ptr (i);	/* pick up one for source attr */
	     allocate rm_attr_info in (rm_db_info.static_area);
	     rm_attr_info.model_name, rm_attr_info.name = raip -> rm_attr_info.name;

	     do x = 1 by 1 to i - 1;			/* check for duplicate attr selection */
		temp_rai_ptr = select_list.item.ai_ptr (x);
		if rm_attr_info.name = temp_rai_ptr -> rm_attr_info.name then
		     icode = mrds_error_$dup_temp_rel_attr;
	     end;

	     rm_attr_info.key_attr = select_list.item.key (i);
	     rm_attr_info.index_attr, rm_attr_info.reserved, rm_attr_info.index_id =
		"0"b;

	     rm_attr_info.read_perm,
		rm_attr_info.modify_perm = "1"b;

	     rm_attr_info.index_id = "0"b;
	     rm_attr_info.mdbm_secured = rm_rel_info.mdbm_secured;
	     rm_attr_info.defn_order = i;
	     rm_attr_info.model_defn_order = i;
	     rm_attr_info.bit_length = raip -> rm_attr_info.bit_length;
	     retrieve_id_list_ptr -> id_list.id (i) = i;

/*  Save some of the attribute's information so that we can later create
    the relations and indices */

	     if select_list.item.index (i) then do;	/* is the attribute indexed? */
		     ci_build_index.num_indices =
			ci_build_index.num_indices + 1;
		     ci_build_index.index_position = i;
		end;

	     typed_vector_array.dimension_table (i).name =
		raip -> rm_attr_info.name;
	     typed_vector_array.dimension_table (i).descriptor_ptr =
		addr (raip -> rm_attr_info.domain_ptr ->
		rm_domain_info.db_desc);


/* ********************************************************************* */
/* 	compute the bit offset within the tuple			*/

	     rm_attr_info.domain_ptr, rdi_ptr = raip -> rm_attr_info.domain_ptr;

	     rm_rel_info.attr_ptrs (i) = rai_ptr;

	     if select_list.item.key (i) then do;
		     rm_attr_info.key_order, key_order = key_order + 1;
		     rm_rel_info.key_attr_ptrs (key_order) = rai_ptr;
		     rm_rel_info.max_key_len =
			rm_rel_info.max_key_len + rm_attr_info.bit_length;
		     id_list.number_of_ids = key_order;
		     id_list.id (key_order) = i;
		end;
	end;					/* initial attr loop */
	rm_rel_info.max_key_len = ceil (rm_rel_info.max_key_len / 9);

/* ******************************************************************* */

	rm_rel_info.id_list_ptr = retrieve_id_list_ptr;


/*  Now create the relation and the indices */

	allocate rel_creation_info in (work_area);
	allocate file_create_info in (work_area);
	file_create_info.version = FILE_CREATE_INFO_VERSION_2;
	file_create_info.ci_size_in_bytes = 4096;
	file_create_info.blocking_factor = mrds_data_$relation_blocking_factor;
	file_create_info.flags.protected = "0"b;
	file_create_info.flags.no_concurrency = "1"b;
	file_create_info.flags.no_rollback = "1"b;
	file_create_info.flags.mbz_1 = "0"b;
	file_create_info.ring_brackets (*) = 0;
	file_create_info.mbz_2 = 0;
	file_create_info.mbz_3 = "0"b;
	rel_creation_info.version = REL_CREATION_INFO_VERSION_2;
	rel_creation_info.file_create_info_ptr = file_create_info_ptr;
	rel_creation_info.esm_info_ptr, rel_creation_info.cism_info_ptr
	     = null ();

	rm_rel_info.opening_id = "0"b;		/* If open fails, we will
					  assume there has been no
					  new relation created */
	call dbcb.relmgr_entries.create_relation (tr_dir,
	     (rm_rel_info.name), rel_creation_info_ptr,
	     typed_vector_array_ptr, rm_rel_info.opening_id,
	     rm_rel_info.rel_id, icode);

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

/* We're done with the relation, now create the indices (and primary key) */

	create_index_flags = "0"b;
	relation_index_flags_ptr = addr (create_index_flags);
	relation_index_flags.relation_must_be_empty = "1"b;
	relation_index_flags.index_is_unique = "1"b;	/* For primary key */
	call dbcb.relmgr_entries.create_index (rm_rel_info.opening_id,
	     id_list_ptr, create_index_flags, SORTING_STYLE,
	     rm_rel_info.primary_key_index_id, icode);
	if icode ^= 0
	then call error (icode);

/*  Create the secondary indices */

	id_list.number_of_ids = 1;
	relation_index_flags.index_is_unique = "0"b;

	do j = 1 to ci_build_index.num_indices;
	     id_list.id (1) = ci_build_index.index_position (j);
	     call dbcb.relmgr_entries.create_index (rm_rel_info.opening_id,
		id_list_ptr, create_index_flags, SORTING_STYLE,
		rm_rel_info.attr_ptrs (ci_build_index.index_position (j))
		-> rm_attr_info.index_id, icode);
	     if icode ^= 0
	     then call error (icode);
	end;

     end create_temp_rel_file;
%page;
check_self_definition: proc (range_ptr, rel_index) returns (bit (1));

/*
   This procedure will return true if any of the  relations  in  the
   defining  SE  are  temporary relations and have an index equal to
   rel_index, i.e. it will return true if the requested temp rel  is
   to be defined in terms of itself.
*/

/* PARAMETERS */

	dcl     range_ptr		 ptr;		/* (input) pointer to the range structure */
	dcl     rel_index		 fixed bin (35);	/* (input) index of the temp rel to be defined */

/* AUTOMATIC */

	dcl     i			 fixed bin;	/* loop index */
	dcl     self_defined_flag	 bit (1) init ("0"b); /* true if the temp rel index appears in the */
						/* range of the defining SE */


	do i = 1 to range.num_vars while (^self_defined_flag);
	     if range.tup_var (i).temp_rel
	     then do;
		     if bin (substr (range.tup_var (i).ri_ptr -> rm_rel_info.name, 17, 2)) = rel_index
		     then self_defined_flag = "1"b;
		end;
	end;

	return (self_defined_flag);

     end;
%page;
complete_definition: proc;

/*
   This procedure completes the definition of a temp  rel  that  was
   defined  in  terms  of itself.
*/

/* AUTOMATIC */

	dcl     temporary_index	 fixed bin (35);	/* This will always be max_temp_rels + 1 */


	temporary_index = rel_index;
	rel_index = actual_rel_index;
	tri = rel_index;
	call delete_temp_rel_file;

	rm_rel_array.name (tri).submodel = rm_rel_array.name (temporary_index).submodel;
	rm_rel_array.rel_data (tri).model_name = rm_rel_array.rel_data (temporary_index).model_name;
	rm_rel_array.rel_data (tri).ri_ptr = rm_rel_array.rel_data (temporary_index).ri_ptr;
	rm_rel_array.rel_data (temporary_index).ri_ptr = null ();

	return;

     end;
%page;
error:
     proc (cd);					/* Internal error  procedure */

/* Error procedure */

	dcl     cd		 fixed bin (35);

	if entry_point_name = "del_trels"
	then goto exit;				/* Errors are ignored for that entry point */
	code = cd;				/* Return the error code to caller */
	if no_recurse then
	     cd = original_cd;
	else do;
		original_cd = cd;
		call tidy_up;
	     end;
	go to exit;

     end error;

	dcl     original_cd		 fixed bin (35);	/* The original error code, in case of recursive calls */
%page;
tidy_up:
     proc;

/* Cleanup procedure */





	if tri > 0 & tri <= mrds_data_$max_temp_rels + 1 then do;
		call delete_temp_rel_file;
		tri = 0;
	     end;
	if dbcb_ptr ^= null then
	     call mrds_dsl_delete_se (dbcb_ptr, (mrds_data_$caller_define_temp_rel), icode);

     end tidy_up;
%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;

	dcl     ignore_icode	 fixed bin (35);	/* Ignore errors from mu_cursor_manager_ */

/* Uncreate the resultant if necessary */

	if created_resultant & rmri_ptr ^= null () then do;
		do i = 1 to rm_rel_info.model_num_attr;
		     free rm_rel_info.attr_ptrs (i) -> rm_attr_info;
		end;


/* Destroy any cursors if the relation is open.  Ignore any errors. */

		if rm_rel_info.opening_id ^= "0"b
		then call mu_cursor_manager_$destroy_and_free_on_opening_id
			(rm_rel_info.opening_id, dbcb.cursor_storage_area_ptr,
			dbcb.cursor_ptrs_storage_ptr, dbcb.relmgr_entries.destroy_cursor,
			dbcb.relmgr_entries.close, ignore_icode);


/* Restore the rest of the data */

		free rm_rel_info;
		rmri_ptr, rm_rel_array.rel_data.ri_ptr (tri) = null ();
	     end;
	if self_defined
	then rel_index = actual_rel_index;
	appl_ptr = save_appl_ptr;
	adpl_ptr = save_adpl_ptr;
	num_args = save_num_args;

     end restore_significant_data;



should_rollback:
     proc returns (bit (1));
	return ("0"b);
						/* MRDS currently does not do rollbacks (or windows) */
     end should_rollback;

%page;
%include dm_rel_creation_info;
%page;
%include dm_file_create_info;
%page;
%include vu_typed_vector_array;
%page;
%include dm_id_list;
%page;
%include dm_relation_index_flags;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_range;
%page;
%include mrds_select_sets;
%page;
%include mrds_select_list;
%page;
%include mrds_tuple_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_arg_list;
%page;
%include mdbm_rs_info;
%page;
%include mdbm_descriptor;
%page;
%include vu_typed_vector;
%page;
/* Multics subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     sys_info$max_seg_size	 ext fixed bin;


/*  DBM Routines */

	dcl     mrds_dsl_delete_se	 entry (ptr, fixed bin (35), fixed bin (35));
	dcl     mrds_dsl_translate
				 entry (ptr, ptr, fixed bin, ptr, fixed bin, ptr, ptr, fixed bin,
				 fixed bin (35));
	dcl     mu_cursor_manager_$destroy_and_free_on_opening_id entry (bit (36) aligned, ptr, ptr, entry, entry,
				 fixed bin (35));
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mu_store$store_direct	 entry (ptr, ptr, ptr, fixed bin (35));

	dcl     (
	        mrds_data_$max_temp_rels,
	        mrds_data_$max_select_items,
	        mrds_data_$max_id_len
	        )			 fixed bin (35) ext;

	dcl     mrds_data_$caller_define_temp_rel fixed bin (17) ext;
	dcl     mrds_data_$max_attributes fixed bin (35) ext static;
          dcl     mrds_data_$relation_blocking_factor fixed bin (17) ext static;


	dcl     (
	        dm_error_$key_duplication,
	        mrds_error_$inval_dtr_expr,
	        mrds_error_$tuple_not_found,
	        mrds_error_$max_temp_rels,
	        mrds_error_$no_tr_keys,
	        mrds_error_$invalid_db_index
	        )			 ext fixed bin (35);

/* Based variable */

	dcl     code		 fixed bin (35) based (cd_ptr);
	dcl     database_index	 fixed bin (35) based (dbi_ptr);
	dcl     rel_index		 fixed bin (35) based (rel_index_ptr); /* Temp_rel index */
	dcl     work_area		 area based (area_ptr);

/* Pointers */

	dcl     (
	        se_ptr,				/* Points to the selection expression */
	        raip,				/* temp attr info ptr */
	        appl_ptr,				/* Points to the list of arg pointers for translate */
	        adpl_ptr,				/* Points to the list of arg descriptors for translate */
	        save_appl_ptr,			/* Copy of appl_ptr, in case of rollback */
	        save_adpl_ptr,			/* Copy of adpl_ptr, in case of rollback */
	        cd_ptr,				/* Points to callers return code */
	        rel_index_ptr,			/* Points to temp_relindex */
	        dbi_ptr
	        )			 ptr;		/* Points to the database index */


/* Others */

	dcl     (
	        nargs,				/* Number of arguments passed to this proc */
	        arg_len,
	        se_len,				/* Selection expression length */
	        tri,				/* temp rel index */
	        key_order,				/* current key attr index */
	        num_args,
	        save_num_args			/* Copy of num_args, in case of rollback */
	        )			 fixed bin;	/* Number of args passed to translate */

	dcl     icode		 fixed bin (35);	/* Internal error code */
	dcl     entry_point_name	 char (32);	/* What were we called as */
	dcl     tr_dir		 char (168);
	dcl     ntuples_retrieved	 fixed bin (35);	/* count of retrieved tuples */

	dcl     SCOPE_UPDATE	 fixed bin int static options (constant) init (6);
	dcl     TEMPORARY		 fixed bin int static options (constant) init (3);

	dcl     (any_other, cleanup, arg_error) condition;

	dcl     mrds_error_$undefined_temp_rel_index fixed bin (35) ext;
						/* index not previously defined */
	dcl     mrds_error_$dup_temp_rel_attr fixed bin (35) ext; /* non-unique attr names in relation */
	dcl     x			 fixed bin;	/* loop index for dup attr name check */
	dcl     temp_rai_ptr	 ptr;		/* temporary pointer for rm_attr_info, during dup name check */
	dcl     i			 fixed bin;	/* index for finding temporary relation index slot */
	dcl     no_recurse		 bit (1) init ("0"b); /* prevent recursive error calls to tidy up if on */
	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     mu_define_area$define_spec_temp_dir_area entry (ptr, fixed bin (35), char (11), fixed bin (35));
	dcl     a_db_index		 fixed bin (35);	/* opening index for get pop entry  */
	dcl     a_error_code	 fixed bin (35);	/* error code for get pop entry */
	dcl     temporary_relation_index fixed bin (35);	/* temp rel index desired */
	dcl     tuple_count		 fixed bin (35);	/* number of tuples in temp rel */
	declare se_len_ptr		 ptr;		/* temp for getting varying se len */
	declare se_len_ovrly	 fixed bin (35) based;
	dcl     mu_get_tuple	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     (fixed, null, ceil, addrel, bin, abs, addr, rel, substr) builtin;

	dcl     self_defined	 bit (1) init ("0"b); /* true if the temp_rel is defined in terms of itself */
	dcl     actual_rel_index	 fixed bin (35);	/* the index that the user actually supplied */
						/* This will not correspond to rel_index if the temp rel is defined in terms of itself */
	dcl     created_resultant	 bit (1);		/* During rollback, we must release a created resultant. This tells if one was made */
	dcl     dbi_pic		 picture "999";

     end mrds_dsl_define_temp_rel;




		    mrds_dsl_delete.pl1             10/16/89  1244.9rew 10/16/89  1242.5      155142



/****^  ***********************************************************
        *                                                         *
        * 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-04-19 by Thanh
     Nguyen. (see mrds #136)
  2) change(87-01-22,Hergert), approve(88-05-19,MCR7903),
     audit(88-05-19,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, changed references of sel_ptr to select_list_ptr.
  3) change(89-09-25,AWTaylor), approve(89-09-25,MCR8116),
     audit(89-10-12,Hussein), install(89-10-13,MR12.3-1093):	
     phx21249 - Created variable last_tuple_id to prevent redundent processing
     in while loop.
                                                   END HISTORY COMMENTS */


mrds_dsl_delete: delete: proc;

/* (database_index, selection_expression, values, code) */
%page;
/* NOTES:

   The purpose of this procedure is to implement the dsl_$delete function.
   This procedure calls translate with the selection expression then calls search and mu_delete.

   HISTORY:
   Written by R. D. Lackey January, 1976

   Modified for MR7.0 by JA Weeldreyer -- October, 1978.

   Modified by Al Kepner, March 26, 1979, to add caller parameter to
   mrds_dsl_translate.

   Modified by Al Kepner, Aug  6,  1979,  to  pick  up  the  correct
   var_index for the tuple being deleted.

   Modified by Jim Gray - - Nov. 1979,  to  correct  calculation  of
   num_args  that  will be passed to mrds_dsl_translate from nargs -
   2, to nargs - 3.

   Modified by Jim Gray - - Feb. 1980,  to  put  allocations  in  an
   extensible, non-freeing area managed by this routine.

   Modified by Jim Gray - - June 1980,  to  add  first_time_flag  to
   mu_delete interface, so allocated space could be reused.

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

   81-03-24 Jim Gray : added capability for user to delcare

   81-03-27 Jim  Gray  :  changed  dbi  parameter  to  mu_delete  to
   dbcb_ptr  as  part  of removing use of mus_ptr_man. the selection
   expression either char varying or nonvarying.

   81-07-07 Jim Gray : removed  reset  of  dbcb.last_store_rel_name,
   since  deletes  will  have no affect on store -another info. Also
   added change of statistics  update  count  by  number  of  tuples
   deleted.

   81-10-13 Davids: moved the code that sets the value  of  num_ptrs
   to  preceed  any  reference  that  would  need  that  value, this
   prevents possible subscriptrange errors if the  random  value  of
   num_ptrs is small.

   82-10-07 Mike Kubicar : converted to use the relation manager.  This
   involved deleting the call to mu_delete (the module has been deleted)
   and calling relmgr_$delete_tuples_by_id with an array of no more than
   100 tuples.  Any other functions of mu_delete needed have been moved to
   this routine (a few security checks).

   82-12-10 Davids: Modified the declaration of num_deleted to fixed bin (35)
   from fixed bin. This was needed because the declaration of the relation
   manager entries in the dbcb was changed from options variable to reality. 

   83-01-21 Mike Kubicar: Added transaction processing include files.

   83-02-16 Davids: Modified to not loop through collecting 100 tuple ids
   for tuples to be deleted when the selection expression was a -current
   just to get 1 tuple id.

   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-31 Mike Kubicar : Update relation manager calling sequences.

   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-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.
*/
%page;
/* INPUT CONDITIONS:
   database_index 		is the index of the database the used wishes to delete.

   selection_expression 	is the expression supplied by the user to select the tuplies to be modified.

   values			are any values used by the selection expression.
*/

/* OUTPUT CONDITIONS:
   If no errors are encountered the deletion was performed.

   code = 0;				If no errors are detected.

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

   code = mrds_error_$tuple_not_found;	If no tuples satisying the se. expr. were found.

   code = something else;  			If some other error was detected;


   If less then 3 arguments were passed to this procedure the
   condition arg_error will be signaled.
*/
%page;
	dbcb_ptr, area_ptr = null ();
	mstxn_txn_id = "0"b;
	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 = arg_list.arg_count / 2;		/* Get the number of arguments to this proc */
	if nargs < 3 then signal arg_error;		/* This returns to command level */


	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 do;
		num_ptrs = arg_list.arg_count;
		desc_ptr = arg_list.arg_des_ptr (nargs + 2);
	     end;
	else do;
		num_ptrs = arg_list.arg_count + 1;
		desc_ptr = arg_list.arg_des_ptr (nargs + 3);
	     end;
	if descriptor.type = 22 then do;
		se_len_ptr = addrel (se_ptr, -1);	/* get current length of varying string */
		se_len = se_len_ptr -> se_len_ovrly;
	     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 call error (mrds_error_$invalid_db_index);

	mstxn_transactions_needed = dbcb.transactions_needed;
	save_adpl_ptr = adpl_ptr;
	save_appl_ptr = appl_ptr;
	save_num_args = num_args;
	on cleanup call mstxn_cleanup;
	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;
	dbi_pic = dbcb.dbi;
	call mu_define_area$define_temp_dir_area (dbcb.delete_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.delete_area_ptr;
						/* Create a work area for mu_retrieve to allocate the value_for_user. */
	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_delete,
	     se_ptr, se_len, appl_ptr, adpl_ptr, num_args, icode);
	if icode ^= 0 then call error (icode);
	if ^dbcb.val_del then call error (mrds_error_$inval_del_expr);

	ti_ptr = dbcb.ti_ptr;
	range_ptr = dbcb.range_ptr;
	if dbcb.current_flag then select_list_ptr = dbcb.current_ptr;
	else select_list_ptr = dbcb.select_ptr;

	call mrds_dsl_search (dbcb_ptr, area_ptr, icode); /* look for first tuple */
	if icode ^= 0 then call error (icode);

	vi = select_list.item (1).var_index;		/* var_index for tuples to be deleted. */
	ntuples_deleted = 0;
	first_time_flag = "1"b;
	rmri_ptr = range.tup_var.ri_ptr (vi);

/* Do some checking to make sure we have the correct permissions */

	if rm_rel_info.ready_mode ^= SCOPE_UPDATE
	then call error (mrds_error_$inc_ready_mode);
	if ^rm_rel_info.delete
	then call error (mrds_error_$view_prevent);
	if rm_rel_info.mdbm_secured & ^rm_rel_info.delete_tuple_perm
	then call error (mrds_error_$inc_rel_acc);


/* So do the delete */

	call mu_cursor_manager_$get (database_index, 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);
	eil_number_of_elements = MAX_TUPLES_PER_CALL;
	allocate element_id_list in (work_area) set (element_id_list_ptr);
	element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
	element_id_list.number_of_elements = 0;

/* phx21249, AWTaylor. Init last_tuple_id */

	last_tuple_id = "0"b;

	do while (icode = 0);
	     if dbcb.current_flag
	     then do;
		     element_id_list.number_of_elements = 1;
		     element_id_list.id (element_id_list.number_of_elements)
			= tuple_info.tuple.tuple_id (vi);
		     icode = mrds_error_$tuple_not_found;
		end;
	     else do;
		     do while ((icode = 0)
			& (element_id_list.number_of_elements
			< MAX_TUPLES_PER_CALL));

/* phx21249, AWTaylor. Added a check to skip over redundant tuples */

			if ((element_id_list.number_of_elements = 0) |
			     (tuple_info.tuple_id(vi) ^= last_tuple_id)) then do;
			     element_id_list.number_of_elements
			     = element_id_list.number_of_elements + 1;
			     element_id_list.id (element_id_list.number_of_elements)
			     = tuple_info.tuple.tuple_id (vi);
			end;
			last_tuple_id = tuple_info.tuple.tuple_id(vi);
			call mrds_dsl_search (dbcb_ptr, area_ptr, icode);
		     end;
		end;
	     if (icode ^= 0) & (icode ^= mrds_error_$tuple_not_found)
	     then call error (icode);
	     num_deleted = 0;
	     if element_id_list.number_of_elements > 0 then do;
		     save_icode = icode;		/* Remember code from search */
		     call dbcb.relmgr_entries.delete_tuples_by_id (
			cursor_ptr, element_id_list_ptr, num_deleted, icode);
		     if icode ^= 0
		     then call error (icode);
		     icode = save_icode;
		end;
	     ntuples_deleted = ntuples_deleted + num_deleted;
	     element_id_list.number_of_elements = 0;
	end;

	if rm_rel_info.last_statistics_update_count ^= 0 & /* 0 => not stats got yet */
	     rm_rel_info.last_statistics_update_count <= mrds_data_$statistics_update_count_interval then do;
		rm_rel_info.last_statistics_update_count =
		     rm_rel_info.last_statistics_update_count + ntuples_deleted;
	     end;


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

	code = 0;

exit:

	if code = mrds_error_$tuple_not_found
	then mftxn_code = 0;
	else mftxn_code = code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0
	then code = mftxn_code;

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

	return;					/* Return to the caller with a code */
%page;
error: proc (cd);					/* Internal error  procedure */

	dcl     cd		 fixed bin (35);

	code = cd;				/* Return the error code to caller */
	go to exit;

     end error;

%page;
/**********
*
*  These routines are used by the transaction processing include files.
*  Restore_significant_data restores any data needed by delete to restart,
*  in case a rollback should occur.  Should_rollback decides if a rollback
*  is appropriate.  Right now, it never is.
*
**********/

restore_significant_data:
     proc;
	adpl_ptr = save_adpl_ptr;
	appl_ptr = save_appl_ptr;
	num_args = save_num_args;
	code = 0;
     end restore_significant_data;

should_rollback:
     proc returns (bit (1));
	return ("0"b);
						/* MRDS does not currently rollback transactions */
     end should_rollback;
%page;
%include dm_element_id_list;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_info;
%page;
%include mrds_range;
%page;
%include mrds_tuple_info;
%page;
%include mdbm_arg_list;
%page;
%include mrds_select_list;
%page;
%include mdbm_descriptor;
%page;

/* Multics subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));

	dcl     sys_info$max_seg_size	 ext fixed bin;


/*  DBM Routines */

	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     mu_cursor_manager_$get entry (fixed bin (35), ptr, fixed bin (35),
				 bit (36) aligned, entry, entry, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mrds_data_$caller_delete fixed bin (17) ext;
	dcl     mrds_data_$max_id_len	 ext fixed bin (35);

	dcl     (mrds_error_$tuple_not_found,
	        mrds_error_$inval_del_expr,
	        mrds_error_$invalid_db_index) ext fixed bin (35);

/* Based variable */

	dcl     work_area		 area based (area_ptr);
	dcl     code		 fixed bin (35) based (cd_ptr);
	dcl     database_index	 fixed bin (35) based (dbi_ptr);

/* Pointers */

	dcl     (se_ptr,				/* Points to the selection expression */
	        appl_ptr,				/* Points to the list of arg pointers for translate */
	        adpl_ptr,				/* Points to the list of arg descriptors for translate */
	        cd_ptr,				/* Points to callers return code */
	        cursor_ptr,				/* Cursor for relation to operate on */
	        dbi_ptr)		 ptr;		/* Points to the database index */


/* Others */

	dcl     any_other		 condition;
	dcl     cleanup		 condition;
	dcl     (nargs,				/* Number of arguments passed to this proc */
	        arg_len,
	        se_len,				/* Selection expression length */
	        vi,				/* index of tuple_variable for tuple being deleted. */
	        num_args)		 fixed bin;	/* Number of args passed to translate */

	dcl     num_deleted		 fixed bin (35);	/* Number of tuples deleted by relation manager */


	dcl     icode		 fixed bin (35);	/* Internal error code */
	dcl     save_icode		 fixed bin (35);	/* Temp save of icode */
	dcl     ntuples_deleted	 fixed bin (35);	/* deleted tuple counter */

	dcl     arg_error		 condition;	/* Condition signaled if less then 3 arguments
						   were passed to this proc */

	dcl     area_ptr		 ptr;
	dcl     mrds_data_$max_attributes fixed bin (35) ext static;
	dcl     mrds_data_$statistics_update_count_interval fixed bin (35) ext; /* number of updates/references before next stats update */
	dcl     mrds_error_$inc_ready_mode fixed bin (35) ext static; /* Update mode not correct */
	dcl     mrds_error_$inc_rel_acc fixed bin (35) ext static; /* Not allowed by submodel */
	dcl     mrds_error_$view_prevent fixed bin (35) ext static; /* Not allowed by submodel */
	dcl     first_time_flag	 bit (1) aligned;	/* on => first call to mu_delete */
	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     mu_define_area$define_spec_temp_dir_area entry (ptr, fixed bin (35), char (11), fixed bin (35));
dcl  last_tuple_id bit (36) aligned; /* Last tuple id used to check for redundancy */
	dcl     save_adpl_ptr	 ptr;		/* Saved copy of adpl_ptr in case of rollback */
	dcl     save_appl_ptr	 ptr;		/* Saved copy of appl_ptr in case of rollback */
	dcl     save_num_args	 fixed bin;	/* Saved copy of num_args in case of rollback */
	dcl     se_len_ptr		 ptr;		/* temp for getting varying se len */
	dcl     se_len_ovrly	 fixed bin (35) based;
	dcl     (null,
	        addr,
	        addrel,
	        fixed,
	        rel)		 builtin;
	dcl     MAX_TUPLES_PER_CALL	 fixed bin int static
				 options (constant) init (100);
						/* Number of tuples to delete (max) per call to relation manager */
	dcl     SCOPE_UPDATE	 fixed bin int static init (6)
				 options (constant);
						/* Update permission needed */
	dcl     dbi_pic		 picture "999";

     end;




		    mrds_dsl_delete_se.pl1          08/01/88  1347.3r w 08/01/88  1314.7       53388



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

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

mrds_dsl_delete_se: proc (dbcb_ptr, caller, code);

/*
                   BEGIN_DESCRIPTION
   This procedure clears selection expression values in the dbcb
   when a new selection expression is specified.  The select area (which
   contains all allocations for the previous selection expression)
   is initialized at this time.
                   END_DESCRIPTION
*/

/* HISTORY:

   Initially written by J. A. Weeldreyer -- March, 1976.

   Modified  by  J.  A.  Weeldreyer  to   free   complex   selection
   expressions and arithmetic expressions -- April, 1977.

   Modified by Oris D. Friesen to free resultant info for tuples  to
   be stored -- Dec. 1977.

   Modified by J.  A.  Weeldreyer  to  correctly  reset  DBCB  flags
   pertaining to select. expr. being deleted -- March, 1978.

   Modified for MR7.0 by JA Weeldreyer -- November, 1978.

   Modified by Al Kepner, June 8, 1979 to use select_area.

   Modified by E Brunelle,  9/80  to  free  all  temp  segments  for
   dsl_search for the specific dbi

   Modified by Jim Gray - - 80-10-20, to  change  temp  seg  routine
   name to mdbm_util_ standard

   Modified by Jim Gray - -  80-10-21,  to  call  free_all_temp_segs
   instead   of   relase_all_temp_segs,  so  that  the  overhead  of
   truncation will not be  incurred.  This  is  a  tradeoff  between
   capacity  and  performance,  since the temp segs will grow to the
   largest usage of a single selection expression  and  remain  that
   size until close time.

   Modified by Jim Gray - - 80-10-24, to add resetting of  new  dbcb
   bit  new_selct_expr,  so that mrds_dsl_search can properly manage
   tid_list space usage.

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

   81-07-06 Jim Gray : added increment of  current  select  expr  ID
   number.

   83-02-28 Davids: explicitly declared variables that were declared by
   context of implication and removed declarations to variables that
   were never referenced.

   84-10-20 Hergert: Added check to make sure the right select_area_ptr
   is going to be used. If we were called during a compile we leave it alone.
   If not, its possible that the last operation was done using a cse so 
   we have to reset the select_area_ptr to the default one. Also cleaned up
   duplicate initializations.
*/

/* INPUT CONDITIONS:

   dbcb_ptr points to a valid DBCB.
*/

/* OUTPUT DEFINITIONS:

   code = 0;  if no errors are encountered.
*/

/* ***************************************************************************************************************** */

	dbcb.another_flag,				/* reset s.e. flags */
	     dbcb.current_flag,
	     dbcb.dup_retain,
	     dbcb.prev_select,
	     dbcb.possible_op,
	     dbcb.sel_clause,
	     dbcb.val_mod,
	     dbcb.val_del,
	     dbcb.val_rtrv,
	     dbcb.val_dtr = "0"b;

	dbcb.ss_ptr,				/* null out appropriate dbcb pointers */
	     dbcb.range_ptr,
	     dbcb.select_ptr,
	     dbcb.ti_ptr,
	     dbcb.current_ptr,
	     dbcb.lit_ptr,
	     dbcb.so_ptr = null;

	dbcb.new_select_expr = "1"b;			/* tell search to start new tid_list management period */

/* BEGIN CHANGE 81-07-06 ************************************************** */

	dbcb.last_s_e_id_num =
	     mod (dbcb.last_s_e_id_num + 1, 999999);	/* increment the select expr ID for current S.E. */

/* END CHANGE 81-07-06 ************************************************ */

	if dbcb.compiled_se_info_ptr ^= null then 
	     if dbcb.select_area_ptr ^= dbcb.compiled_se_info_ptr -> compiled_se_info.real_select_area_ptr &
	     caller ^= mrds_data_$caller_compile then
	     dbcb.select_area_ptr = dbcb.compiled_se_info_ptr -> compiled_se_info.real_select_area_ptr;

	call mrds_dsl_init_select_area (dbcb_ptr, icode);
	if icode ^= 0 then call error (icode);
	dbi_pic = dbcb.dbi;

	call mu_temp_segments$free_all_temp_segments (mrds_data_$temp_seg_name || dbi_pic, icode);
	if icode ^= 0 & icode ^= error_table_$argerr then call error(icode) ;	/* no temp segs found */

	code = 0;					/* indicate successful completion */

exit:	return;

error: proc (cd);
	dcl     cd		 fixed bin (35) parm;
	code = cd;
	go to exit;
     end error;

%include mrds_dbcb;
%page;
%include mrds_compiled_se_info;

          dcl     caller                 fixed bin(35);
	dcl     code		 fixed bin (35);	/* Output -- return code */
	dcl     icode		 fixed bin (35);	/* internal error code */
	dcl     dbi_pic		 pic "999";
	declare mrds_data_$temp_seg_name char (23) ext;	/* common name for temp segments */
          dcl mrds_data_$caller_compile  fixed bin (35) ext;

	dcl     (sys_info$max_seg_size,
	        error_table_$argerr)	 fixed bin (35) ext;
	dcl     mrds_dsl_init_select_area entry (ptr, fixed bin (35));
	dcl     mu_temp_segments$free_all_temp_segments entry (char (*), bin (35));

	dcl     (null,
	        addr,
	        fixed,
	        mod,
	        rel)		 builtin;

     end mrds_dsl_delete_se;




		    mrds_dsl_dl_fscope.pl1          08/01/88  1347.3r w 08/01/88  1313.9      369774



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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-30 by Jim
     Lippard. (see mrds #140, phx19621)
                                                   END HISTORY COMMENTS */

mrds_dsl_dl_fscope: dl_fscope: procedure;

/*    DESCRIPTION:

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

   call dsl_$dl_fscope (db_index,rel_name,permit_ops,prevent_ops,...,rel_name,permit_ops,prevent_ops,code);

   ---------------------------------------------------------------------------

         
   %page;
   HISTORY:
   Written April 28, 1976 by R. G. Luebke
   Modified by Oris Friesen -- July 1977 -- to handle queueing of scope requests
   Changed to dl_fscope by Oris D. Friesen - Sept. 1978 - to handle scopes at file level rather than relation level
   Modified by Al Kepner, March 26, 1979, to allow deleting null fscope
   from a scope tuple which is already null.
   Modified by Jim Gray - - October 1979, to allow deleting null fscope
   from a file that has never had scope set.
   Modified by M. Pierret, December 1979, to change queueing strategy to
   wake up only first waiter, and to change the use of set_lock_ in
   detecting dead processes to use call by value.
   Modified by Lindsey L. Spratt, February 1980, to look for match of fil_name
   in rm_name_array.model_name instead of rm_name_array.name.  This is an
   issue when an opening is done through a submodel and the model_name and
   name are not the same.
   Modified by M.Pierret 13 April 1980 to remove priority queueing.
   Modified by Jim Gray - - June 1980, to not say dumb things like "no scope set"
   when it is told to delete all current scope, regardless of what it is.
   Modified 26 June 80 by M Pierret, changing fil_name to rel_name, file_name
   to model_rel_name and clearing up name/model_name issues for submodels.
   Also rewrote delete_scope, using more straightforward tests and
   modifications of scope.
   Modified 22 July 80 by M Pierret, removing unused variables

   80-12-10 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 for actual_permits/prevents, and actual_conflicts.
   The later was added to the check_conflict interface, in order
   to be able to report exact details of why a dl_scope failed.

   80-12-12 Jim Gray : added maintenance of the update bit in the fil_list structure.
   Also, did a check for setting passive_sw in user_list on, if the delete
   scope operation removed all active update type operation scope permission.

   80-12-15 Jim Gray : fixed error routine to set users error code parameter.

   80-12-30 Jim Gray : fixed routine sufficient_scope_exists, to look for model
   rather than submodel name in fil_list list, since submodel names are not
   known here. This allows close -all to work with submodels that have alias rel names.

   81-1-11 Jim Gray : added reseting of touched bit, when del scope request
   resulted in no more scope being set for a relation.
   This allows displaying when null scope has been set.

   81-05-29 Jim Gray : changed to use new resultant model structures.

   81-12-15 R. Lackey : Modified to search rm_rel_array correctly for ful rel_name. TR11887.

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

   82-10-01 Mike Kubicar : Converted to use relation manager.  Specifically
   this meant changing this module to calculate the total scopes set on a
   relation/database for the current process and pass that to relation
   manager.  If changing scopes for on db opening does not change the total
   scopes for the process, the relation manager call is not made as it
   wouldn't be needed.

   82-12-10 Davids: Modified the declarations of new_rmg_permits
   and new_rmg_prevents to bit (2) aligned from unaligned. This was
   needed because the declaration of the relation manager entries
   in the dbcb was changed from options variable to reality. 

   83-02-02 Davids: Added a call to hcs_$get_uid_seg to compare the uid of the
   segment the dbc_ptr currently points at with what it was originally. If the
   uids don't match or the uid cannot be obtained it is assumed that the
   original segment was deleted. There is no need to delete any scopes so this
   routine just returns without errors.

   83-02-07 Davids: Modified the delete_scope 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.

   85-07-30 Jim Lippard: Modified the cleanup handler to dequeue active
   users.  If the user tried to delete scope on a relation for which he
   didn't have scope set and he was listed as an active user, he would be
   left in the active users list.  Later calls to set_scope resulted in
   infinite loops.

   ------------------------------------------------------------------------- */
%page;
	dbc_ptr = null;				/* in case cleanup is called before dbc_ptr is set */
	num_filns = 0;
	entry_name = "dl_fscope";			/* normal entry */
	args_exp = 5;				/* 5 calling arguments */

	call cu_$arg_count (nargs);			/* get number of arguments */
	if nargs < args_exp
	then signal arg_error;			/* must be at least args_exp arguments (1 scope tuple */
						/* plus db_index plus code */

	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;
	call cu_$arg_ptr (1, dbi_ptr, arg_len, icode);	/* get db_index */
	if icode ^= 0
	then call error (icode);

common_label:
	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
						/* get dbcb_ptr corresponding to db_index */
	if dbcb_ptr = null ()
	then call error (mrds_error_$invalid_db_index);

pntr2:						/* entry here => dbc already locked by mrds_dsl_close */

/* Get pointers, see if user has some files readied (scope_ptr non-null) and make sure user has no active scope. */

	icode = 0;
	call hcs_$get_uid_seg (dbcb.dbc_ptr, temp_uid, icode);
	if icode ^= 0				/* if you cannot get the uid of the data base control */
	then do;					/* assume its been deleted. Return without errors since */
		code = 0;				/* the scopes have certainly been deleted */
		goto exit;
	     end;
	if temp_uid ^= dbcb.dbc_uid			/* if the uid's don't match the original control segment */
	then do;					/* was deleted and the segment number reused. Again don't */
		code = 0;				/* do anything */
		goto exit;
	     end;
	dbc_ptr = dbcb.dbc_ptr;			/* pointer to data base control segment */
	on cleanup call clean_up;

	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
	then call error ((mrds_error_$scope_empty));

/* Lock the DBC. (If entry was from dl_fscope_all_ptr, dbc is already locked) */

	if entry_name ^= "dl_fscope_all_pntr"
	then call set_lock_$lock (dbc.scope_lock, (mrds_data_$lock_wait_time), 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;					/* something is messed up in the dbc */
		dbc.trouble_switch = ON;		/* lock it to prevent further opens */
		call error (icode);
	     end;

/* Find user in user_list list */

	find_ul_ptr = convert (dbc_ptr, dbc.active_users_ofs);
	ul_ptr = null;

	my_pid = get_process_id_ ();
	do while (find_ul_ptr ^= null);
	     if find_ul_ptr -> user_list.process_id = my_pid
	     then do;
		     if find_ul_ptr -> user_list.rdbi_bits = addr (rdbi_ptr) -> ptr_bit_string
		     then do;
			     ul_ptr = find_ul_ptr;
			     find_ul_ptr = null;
			end;
		     else find_ul_ptr = convert (dbc_ptr, find_ul_ptr -> user_list.next_active_ofs);
		end;
	     else find_ul_ptr = convert (dbc_ptr, find_ul_ptr -> user_list.next_active_ofs);
	end;


	if ul_ptr = null
	then call error (mrds_error_$unknown_proc_id);

/* =======Enclosed code is executed only if entry was from dl_fscope====== */

	if entry_name = "dl_fscope"
	then do;
		if mod (nargs - 2, 3) = 0
		then num_tuples = divide (nargs - 2, 3, 17);
		else call error (error_table_$wrong_no_of_args);


		make_user_inactive = OFF;

		do i = 1 to num_tuples;		/* iterate once for each scope tuple */
		     arg_index = 3 * (i - 1) + 2;	/* move arg_index to point to 1st arg of scope tuple i */
		     call cu_$arg_ptr (arg_index, rel_ptr, rel_len, icode);
						/* get relation 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 ********************************************* */


/* Since relation names stored in the dbc are stored by the name the data model knows (as opposed to the name known
   by a submodel view) and the user may request scope giving the relation name seen in his view (rel_name), the model relation
   name must be found.  rm_rel_array.rel_data.name holds the name in the user's view, and rm_rel_array.rel_data.model_name
   holds the coresponding relation name in the model.  When rel_name is found, model_rel_name is set to rm...model_name */

/* BEGIN CHANGE 81-12-15 RDL *********************************************** */

		     rel_name_32 = rel_name;		/* Used to search rm_rel_array */
		     pos_in_rmfa = index (string (rm_rel_array.name), "!" || rel_name_32);

/* BEGIN CHANGE 81-12-15 RDL *********************************************** */

		     if pos_in_rmfa = 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;
			     pos_in_rmfa = ((pos_in_rmfa - 1) / 33) + 1;
			     model_rel_name = rm_rel_array.rel_data.model_name (pos_in_rmfa);
						/* Save rel name as per model */
			end;

		     rmri_ptr = rm_rel_array.rel_data.ri_ptr (pos_in_rmfa);

		     if rm_rel_info.ready_mode < 5	/* ready_mode must be =5(scope_retrieve)
						   or = 6 (scope_update)   */
		     then call error (mrds_error_$non_scope_ready);

/* Get permit, prevent ops */

		     call cu_$arg_ptr (arg_index + 1, permit_requests_ptr, arg_len, icode);
						/* get permit operations */
		     if icode ^= 0
		     then call error (icode);

		     call cu_$arg_ptr (arg_index + 2, prevent_requests_ptr, arg_len, icode);
						/* get prevent operations */
		     if icode ^= 0
		     then call error (icode);

/* Check for existence of relation in scope_info array, and then if adequate scope exists for that relation.
   scope_info.scope.name holds names of relations as per the data model, hence the check is made with model_rel_name */

		     do pos_in_si = 1 to scope_info.nfiles /* look for model_rel_name in file table */
			while (model_rel_name ^= scope_info.scope.name (pos_in_si));
		     end;
		     if pos_in_si > scope_info.nfiles	/* didn't find model_rel_name in view */
		     then call error (mrds_error_$unknown_relation_name);

		     if ^sufficient_scope_exists () then do; /* check that scope exists as it is to be deleted */
			     call report_scope_detail ();
			     call error (mrds_error_$scope_not_found);
			end;

/* Ready to delete */

		     call delete_scope;		/* OK, so delete */
		end;
	     end;

/* ------------END of dl_fscope block; goto COMMON -------------------- */

/* ============BEGIN code for dl_fscope_all(_pntr)===================== */

	if entry_name = "dl_fscope_all" | entry_name = "dl_fscope_all_pntr"
	then do;

/* note that it OK to delete_scope_all even when all files are not
   using scope modes, just as it is OK to delete all scope when no scope is set */


		do pos_in_si = 1 to scope_info.nfiles;
		     scope_info.scope (pos_in_si).flags = "0"b;
		end;

		scope_info.active_scopes = 0;
		make_user_inactive = ON;

	     end;

/* ---END of dl_fscope_all block ---- */

/* ====COMMON==== */

	if make_user_inactive			/* unlink from active user list */
	then call mu_de_queue_user (NO_DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr, icode);
	if icode ^= 0
	then call error (icode);

/* Finished deleting scope, now notify a waiting process that it may proceed to set scope */

	call examine_queue;

	code = 0;

	if entry_name ^= "dl_fscope_all_pntr"
	then call set_lock_$unlock (dbc.scope_lock, code);/* unlock scope lock */
exit:
	return;
%page;
mrds_dsl_dl_fscope_all:
dl_fscope_all:
     entry (a_db_index, a_code);

/* call dsl_$mrds_dsl_dl_fscope_all (db_index, code);

*/
	dcl     a_db_index		 fixed bin;	/* db$ata base index */
	dcl     a_code		 fixed bin (35);	/* return code */

	dbc_ptr = null;				/* in case cleanup is called before dbc_ptr is set */
	dbi_ptr = addr (a_db_index);
	cd_ptr = addr (a_code);

	args_exp = 2;				/* two calling arguments */
	entry_name = "dl_fscope_all";
	goto common_label;
%page;
pntr:
dl_fscope_all_pntr:
mrds_dsl_scope_all_pntr:
     entry (a_dbcb_ptr, a_cd_ptr);

/*
   call dsl_$mrds_dsl_dl_fscope_all_pntr (dbcb_ptr, code_ptr);

   this entry allows dl_fscope_all to be called with ptr arguments only
*/

	dcl     (
	        a_dbcb_ptr,				/* ptr to dbcb */
	        a_cd_ptr
	        )			 ptr;		/* ptr to status return code */

	entry_name = "dl_fscope_all_pntr";
	dbc_ptr = null;				/* in case cleanup is called before dbc_ptr is set */
	args_exp = 2;
	dbcb_ptr = a_dbcb_ptr;
	cd_ptr = a_cd_ptr;
	goto pntr2;
%page;
error:
     procedure (temp_code);

	dcl     temp_code		 fixed bin (35);

	if temp_code = mrds_error_$scope_empty & entry_name = "dl_fscope_all"
	then cd_ptr -> code = 0;
	else cd_ptr -> code = temp_code;

	call clean_up;
	go to exit;

     end error;
%page;
examine_queue:
     proc;

/*
   This routine will scan the priority and normal waiting queues until it comes across a waiting process that is
   eligble to set scope (ie, the scope requested does not conflict with current scopes now that the deleting process
   has deleted its scope).  If it  finds one such process, it will send it a wakeup, notifying it that it can proceed
   to set scope.  Only one (or none) such process will be awakened; it is the newly awakened process's job to see if
   another waiter is eligble to be awakened.
*/

	wakeup = OFF;				/* ON->wake this user up */
	QUE_FREE = fixed (unspec (CHAR_Q_F), 71);	/*  Wakeup message */

/* Check each waiting user. */

	ul_ptr = convert (dbc_ptr, dbc.waiting_users_ofs);

	do while (ul_ptr ^= null & ^wakeup);

	     if ^user_list.event_signal_sw		/* no awakeners */
	     then do;

/* Check each relation(file) for conflict. */

		     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 checking the files;
   if dead proc was updating (non-passive) this process will awaken waiting user-where its attempt to set will fail;
   if no dead proc, stop checking the files because there is a conflict with a live user, but continue checking */


			if conflict_sw		/* There was conflict */
			then do;
				call check_dead_proc (conflict_sw, status);
				if conflict_sw
				then wakeup = OFF;	/* conflict was not worked out */
			     end;

			fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
		     end;

/* Send the wakeup if user is eligble. */

		     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;

/* A record of how many times this process was examined and NOT awakened is kept.  After a set limit is
   surpassed (allowance_count) the process is made high priority. */

		     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);
						/* Next user */
	end;


     end examine_queue;
%page;
check_dead_proc:
     proc (conflict_sw, status);

/* this 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 and the dbc is somewhat cleaned up.
   if the process was non-passive then it could have died in the middle of an update and this running process
   can't do anything about it */

	dcl     (conflict_sw, status)	 bit (1);


/* Determine if process is alive or dead.  the technology for doing this is
   by calling set_lock_$lock and examining the returned code */

	if conflict_ul_ptr -> user_list.dead_proc
	then status = DEAD;
	else do;
		status = ALIVE;
		call set_lock_$lock ((conflict_ul_ptr -> user_list.db_lock_id), 0, state);
						/* Note that the lock_id arg is passed by value
						   so that the lock is not really set. */
		if state ^= 0
		then do;
			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 icode = state;
		     end;
	     end;

/* Now see what can be done if it is dead */

	if status = ALIVE
	then ;
	else 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);
	     end;

	else do;
		dbc.dead_proc_flag = ON;
		conflict_ul_ptr -> user_list.dead_proc = ON;
		user_list.dead_proc_conflict = ON;
	     end;

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

	return;

     end check_dead_proc;
%page;
report_scope_detail: procedure ();

/* this rotuine reports on exactly why sufficient scope was not found
   for this delete operation to be performed */

	if conflict_detail_known 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_ (mrds_error_$scope_not_found, caller_name, continue, info_ptr, return_value,
		     "^/^a^a^a^/^a^a^a^a^a",
		     "The scope delete request contained extra permits of """, permit_conflict,
		     """", "and/or extra prevents of """, prevent_conflict,
		     """ that were not present in the scope currently set, on the relation """,
		     conflict_relation, """.");

	     end;

	return;


	declare (permit_conflict, prevent_conflict) char (80) varying; /* extra scope that was not present */

     end;
%page;
sufficient_scope_exists:
     procedure () returns (bit (1));

/*	This procedure checks to be sure the scope to be deleted in fact exists	*/

	dcl     found		 bit (1);		/* ON => relation name found */

/* find the specified relation */
	fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);

	found = OFF;
	do while (^found);
	     if fl_ptr = null ()
	     then found = ON;
	     else if model_rel_name = fil_list.name
	     then found = ON;
	     else fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
	end;

/* Check the current scope */

	suf_scope = "1"b;				/* assume innocent til proven guilty */
	if fl_ptr = null then do;
		actual_conflict_detail.permits = permit_requests;
		actual_conflict_detail.prevents = prevent_requests;

		if permit_requests.modify_attr | permit_requests.read_attr |
		     permit_requests.append_tuple | permit_requests.delete_tuple |
		     prevent_requests.modify_attr | prevent_requests.read_attr |
		     prevent_requests.append_tuple | prevent_requests.delete_tuple
		then do;
			suf_scope = "0"b;		/* non-null scope deletion requested */
		     end;
		else suf_scope = "1"b;		/* it's ok to dl null scope on a
						   rel that never had scope set */
	     end;

	else do;
		conflict_detail_ptr = addr (actual_conflict_detail);
		call mu_check_conflict (DEL, fl_ptr, permit_requests_ptr, prevent_requests_ptr,
		     conflict_detail_ptr, conflict_sw);
		if conflict_sw then do;
			suf_scope = "0"b;
			conflict_detail_known = "1"b;
			conflict_relation = rel_name;
		     end;
	     end;

	return (suf_scope);

	declare suf_scope		 bit (1);		/* on => suf scope exists */

     end sufficient_scope_exists;
%page;
delete_scope: procedure;

/*    This routine deletes scope by updating accss bits in scope_info and dbc (fil_list), removes relation from dbc (fil_list)
   if all scope is deleted and flags the user to be deactivated if all scope on all relations is deleted. */

	dcl     (found_matching_fil_list, active_scope_seen, finished) bit (1);
	dcl     ds_rmri_ptr		 ptr;		/* pointer to the rm_rel_info structure */

/* Update resultant model scope_info -- access bits. */

	if permit_requests.read_attr then
	     scope_info.scope (pos_in_si).flags.permits.read_attr = OFF;

	if permit_requests.modify_attr then
	     scope_info.scope (pos_in_si).flags.permits.modify_attr = OFF;

	if permit_requests.append_tuple then
	     scope_info.scope (pos_in_si).flags.permits.append_tuple = OFF;

	if permit_requests.delete_tuple then
	     scope_info.scope (pos_in_si).flags.permits.delete_tuple = OFF;

	if prevent_requests.read_attr then
	     scope_info.scope (pos_in_si).flags.prevents.read_attr = OFF;

	if prevent_requests.modify_attr then
	     scope_info.scope (pos_in_si).flags.prevents.modify_attr = OFF;

	if prevent_requests.append_tuple then
	     scope_info.scope (pos_in_si).flags.prevents.append_tuple = OFF;

	if prevent_requests.delete_tuple then
	     scope_info.scope (pos_in_si).flags.prevents.delete_tuple = OFF;

	if string (scope_info.scope (pos_in_si).flags.prevents) = "0"b &
	     string (scope_info.scope (pos_in_si).flags.permits) = "0"b then
	     scope_info.scope (pos_in_si).flags.touched = OFF;

/* Find relation in fil_list list */

	fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);
	flo_ptr = addr (user_list.fil_list_ofs);
	found_matching_fil_list = OFF;

	do while (fl_ptr ^= null & ^found_matching_fil_list);
	     if model_rel_name = fil_list.name
	     then found_matching_fil_list = ON;
	     else do;
		     flo_ptr = addr (fil_list.next_ofs);/* save ptr for possible alteration next time around */
		     fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
		end;
	end;

/* Tell relation manager about the scope change if necessary.  Calculate
   scopes both before and after the deletion and call rel_mgr_ only if
   they are different */

	if fl_ptr ^= null
	then do;					/*  if it is null, then there was no scope
						   to be deleted for this fil */
		call calc_process_scopes (/* Find relmgr scope */
		     convert (dbc_ptr, dbc.active_users_ofs),
		     model_rel_name, addr (rdbi_ptr) -> ptr_bit_string,
		     other_rmg_permits, other_rmg_prevents, current_rmg_permits,
		     current_rmg_prevents);
		old_rmg_permits = other_rmg_permits | current_rmg_permits;
		old_rmg_prevents = other_rmg_prevents | current_rmg_prevents;
		new_rmg_permits = other_rmg_permits |
		     (permit_requests.read_attr || (permit_requests.append_tuple
		     | permit_requests.modify_attr
		     | permit_requests.delete_tuple));
		new_rmg_prevents = other_rmg_permits |
		     (^prevent_requests.read_attr ||
		     ^(prevent_requests.append_tuple
		     & prevent_requests.delete_tuple
		     & prevent_requests.modify_attr));
		if (old_rmg_permits ^= new_rmg_permits) |
		     (old_rmg_prevents ^= new_rmg_prevents) then do;
			ds_rmri_ptr = pointer (baseptr (baseno (fil_list.rmri_ptr)), rel (fil_list.rmri_ptr));
			call dbcb.relmgr_entries.set_scope (ds_rmri_ptr -> rm_rel_info.opening_id,
			     new_rmg_permits, new_rmg_prevents, icode);
			if icode ^= 0
			then call error (icode);
		     end;


/* Update dbc scope info -- fil_list access bits. */

		if string (scope_info.scope.flags (pos_in_si)) = "0"b
		then do;				/* all scope for this relation is being deleted */
			scope_info.active_scopes = scope_info.active_scopes - 1;
						/* so indicate one less scope tuple */
			flo_ptr -> ophset = fil_list.next_ofs;
			free fil_list in (dbc.static_area);
		     end;

		else do;				/* scope must be modified rather than deleted */

			fil_list.permits.read_attr = (fil_list.permits.read_attr &
			     ^(permit_requests.read_attr));
			fil_list.permits.modify_attr = (fil_list.permits.modify_attr &
			     ^(permit_requests.modify_attr));
			fil_list.permits.append_tuple = (fil_list.permits.append_tuple &
			     ^(permit_requests.append_tuple));
			fil_list.permits.delete_tuple = (fil_list.permits.delete_tuple &
			     ^(permit_requests.delete_tuple));
			fil_list.permits.update = (fil_list.permits.modify_attr |
			     fil_list.permits.append_tuple | fil_list.permits.delete_tuple);


			fil_list.prevents.read_attr = (fil_list.prevents.read_attr &
			     ^(prevent_requests.read_attr));
			fil_list.prevents.modify_attr = (fil_list.prevents.modify_attr &
			     ^(prevent_requests.modify_attr));
			fil_list.prevents.append_tuple = (fil_list.prevents.append_tuple &
			     ^(prevent_requests.append_tuple));
			fil_list.prevents.delete_tuple = (fil_list.prevents.delete_tuple &
			     ^(prevent_requests.delete_tuple));
			fil_list.prevents.update = (fil_list.prevents.modify_attr |
			     fil_list.prevents.append_tuple | fil_list.prevents.delete_tuple);
		     end;
	     end;

	if user_list.fil_list_ofs = NULL_OFS
	then make_user_inactive = ON;			/* All scope gone */

	saved_fl_ptr = fl_ptr;
	fl_ptr = pointer (dbc_ptr, user_list.fil_list_ofs);
	active_scope_seen = OFF;
	finished = OFF;
	do while (^finished);

	     if rel (fl_ptr) = NULL_OFS then
		finished = ON;
	     else if fil_list.permits.modify_attr | fil_list.permits.append_tuple |
		fil_list.permits.delete_tuple then do;
		     active_scope_seen = ON;
		     finished = ON;
		end;
	     else fl_ptr = pointer (dbc_ptr, fil_list.next_ofs);
	end;

	if ^active_scope_seen then
	     user_list.passive_sw = ON;		/* no longer holding update type of scope */


	fl_ptr = saved_fl_ptr;
	return;

     end delete_scope;
%page;
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;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This routine is used to find the total scopes set by  */
/* a process on a particular database.  This is needed   */
/* for the relation_manager_$set_scope entry point.      */
/* The routine will look through the active user list    */
/* in the dbc, combining scopes for the relation of      */
/* interest if there are scopes set by the current       */
/* process.  The scopes for the current db opening are   */
/* not included in this but are returned separately.     */
/* This is so that the combined scope just before and    */
/* after the scope setting can be predicted	       */
/*					       */
/* Parameters (input):			       */
/*					       */
/*  user_list_ptr - the active user list of the database */
/*                  of interest.		       */
/*  relation_name - the name of the relation of interest */
/*  rdbi_ptr_bits - bit representation of the pointer    */
/*                  to the rm_db_info structure. It is   */
/*                  used to tell which scopes	       */
/*                  correspond to the current opening    */
/*                  id.			       */
/*					       */
/* Results (output)				       */
/*					       */
/*  relmgr_my_permits - the permits (rw) of my process   */
/*                      for the database.  This would    */
/*		    not include the current opening  */
/*		    id.                              */
/*  relmgr_other_permit - everyone else's permits	       */
/*                        (prevents)		       */
/*  relmgr_except_my_permits - relmgr_ permits for the   */
/*                             current opening.	       */
/*  relmgr_except_other_permits - the prevents for       */
/*                                current	       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


calc_process_scopes:
     proc (user_list_ptr, relation_name, rdbi_ptr_bits, relmgr_my_permits,
	relmgr_other_permits, relmgr_except_my_permits,
	relmgr_except_other_permits);


/* Parameters */

	dcl     user_list_ptr	 ptr;
	dcl     relation_name	 char (30);
	dcl     rdbi_ptr_bits	 bit (72);
	dcl     relmgr_my_permits	 bit (2);
	dcl     relmgr_other_permits	 bit (2);
	dcl     relmgr_except_my_permits bit (2);
	dcl     relmgr_except_other_permits bit (2);


/* Automatic */

	dcl     f_ptr		 ptr;		/* Current file_list entry */
	dcl     my_process_id	 bit (36);	/* My pid */
	dcl     temp_relmgr_my_permits bit (2);		/* permits for one db open */
	dcl     temp_relmgr_other_permits bit (2);	/* prevents */
	dcl     u_ptr		 ptr;		/* Current user_list entry */


	u_ptr = user_list_ptr;
	my_process_id = get_process_id_ ();
	relmgr_my_permits, relmgr_other_permits = "00"b;
	do while (u_ptr ^= null ());			/* Search user list */
	     if u_ptr -> user_list.offsets.fil_list_ofs = NULL_OFS
	     then f_ptr = null ();
	     else f_ptr = ptr (u_ptr,
		     u_ptr -> user_list.offsets.fil_list_ofs);
	     if u_ptr -> user_list.ids.process_id = my_process_id then
		do while (f_ptr ^= null ());		/* Search file list */
		     if f_ptr -> fil_list.name = relation_name then do;
			     temp_relmgr_my_permits =
				f_ptr -> fil_list.permits.read_attr ||
				f_ptr -> fil_list.permits.update;
			     temp_relmgr_other_permits =
				^f_ptr -> fil_list.prevents.read_attr |
				^(f_ptr -> fil_list.prevents.modify_attr &
				f_ptr -> fil_list.prevents.append_tuple &
				f_ptr -> fil_list.prevents.delete_tuple);
			     if rdbi_ptr_bits ^=
				u_ptr -> user_list.ids.rdbi_bits then do;
				     relmgr_my_permits = relmgr_my_permits
					| temp_relmgr_my_permits;
				     relmgr_other_permits = relmgr_other_permits
					| temp_relmgr_other_permits;
				end;
			     else do;
				     relmgr_except_my_permits =
					temp_relmgr_my_permits;
				     relmgr_except_other_permits =
					temp_relmgr_other_permits;
				end;
			end;
		     if f_ptr -> fil_list.next_ofs = NULL_OFS
		     then f_ptr = null ();
		     else f_ptr = ptr (u_ptr,
			     f_ptr -> fil_list.next_ofs);
		end;
	     if u_ptr -> user_list.offsets.next_active_ofs = NULL_OFS
	     then u_ptr = null ();
	     else u_ptr = ptr (u_ptr,
		     u_ptr -> user_list.offsets.next_active_ofs);
	end;
     end calc_process_scopes;

%page;
clean_up:
     proc;
	if make_user_inactive
	then call mu_de_queue_user (NO_DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr, (0));

	if dbc_ptr ^= null
	then do;
		if code ^= error_table_$lock_wait_time_exceeded
		then do;				/* if a timeout then leave scope as is */
		     end;
		call set_lock_$unlock (dbc.scope_lock, icode);
	     end;
     end clean_up;


/* *************************************************************
   *    Logical end of program; include files of dcl's follow    *
   ************************************************************** */
%page;

	dcl     db_index		 fixed bin (35) based (dbi_ptr);
						/* index of data base to perform dl_fscope upon */
	dcl     rel_name		 char (rel_len) based (rel_ptr);
						/* relation name part of scope tuple */

/* operations to be prevented of other processes */
	dcl     state		 fixed bin (35),
	        code		 fixed bin (35) based (cd_ptr);
						/* standard system return code */


	dcl     my_pid		 bit (36);	/* Current process id */
	dcl     conflict_sw		 bit (1) unal;	/* ON => scope conflict exists */
	dcl     make_user_inactive	 bit (1) unal;	/* ON => no scope left, must takeoff the active list */
	dcl     status		 bit (1) unal;	/* ON => process is alive; OFF => dead */
	dcl     wakeup		 bit (1) unal;	/* ON => send a wakeup message to a waiting user */

	dcl     current_rmg_permits	 bit (2);		/* Current combined permits of opening to change */
	dcl     current_rmg_prevents	 bit (2);		/* Current combined prevents */
	dcl     new_rmg_permits	 bit (2) aligned;	/* Combined permits after scope deletion */
	dcl     new_rmg_prevents	 bit (2) aligned;	/* Combined prevents after scope deletion */
	dcl     old_rmg_permits	 bit (2);		/* Total combined permits */
	dcl     old_rmg_prevents	 bit (2);		/* Total combined prevents */
	dcl     other_rmg_permits	 bit (2);		/* Current combined permits of everything else */
	dcl     other_rmg_prevents	 bit (2);		/* Prevents of everything else */

	dcl     (
	        nargs,				/* number of arguments passed to dl_fscope */
	        arg_len,				/* argument length in chars */
	        num_tuples,				/* number of scope tuples represented by arg_list */
	        i,
	        pos_in_si,				/* index in scope_info array */
	        pos_in_rmfa,			/* index in rm_rel_array */
	        args_exp,				/* number of args in calling argument list */
	        arg_index,				/* index to current scope tuple in arg_list */
	        rel_len
	        )			 fixed bin;	/* length of rel_name */

	dcl     icode		 fixed bin (35);	/* internal status code */

	dcl     temp_uid		 bit (36) aligned;	/* uid of the segment that the dbc_ptr points to */

	dcl     ptr_bit_string	 bit (72) based;	/* bit string format of pointer variable */

	dcl     rel_name_32		 char (32);	/* Used to search rm_rel_array */
	dcl     entry_name		 char (32);	/* name by which this procedure was called */
	dcl     model_rel_name	 char (30);	/* relation name parameter used by check_scope
						   --check_scope only knows of model relation names */
	dcl     ophset		 bit (18) unal based; /* offset format */

	dcl     (
	        cd_ptr,				/* pointer to return code */
	        dbi_ptr,				/* pointer to data base index (db_index) */
	        rel_ptr,				/* pointer to rel_name */
	        find_ul_ptr,			/* ptr to user_list entry */
	        conflict_ul_ptr,			/* ptr to user who is causing a conflict with requested scopes */
	        flo_ptr				/* ptr to an offset to a file_list entry */
	        )			 ptr;		/* pointer to prevent operations */

	dcl     (cleanup, arg_error)	 condition;
	dcl     (addr, rel, null, string)
				 builtin;



/*		Multics subroutines 		*/

	dcl     cu_$arg_count	 entry (fixed bin),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, 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)),
	        hcs_$wakeup		 entry (bit (36), fixed bin (71), fixed bin (71), fixed bin (35)),
	        hcs_$get_uid_seg	 entry (ptr, bit (36) aligned, fixed bin (35)),
	        get_process_id_	 entry returns (bit (36));

/*		Other subroutines		*/

	dcl     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)),
	        mu_check_conflict
				 entry (bit (1), ptr, ptr, ptr, ptr, bit (1));

/*		External data		*/

	dcl     (error_table_$wrong_no_of_args,
	        error_table_$lock_wait_time_exceeded,
	        error_table_$invalid_lock_reset,
	        error_table_$locked_by_this_process,
	        mrds_data_$lock_wait_time,
	        mrds_error_$invalid_db_index,
	        mrds_error_$rel_name_too_long,
	        mrds_error_$scope_empty,
	        mrds_error_$unknown_relation_name,
	        mrds_error_$non_scope_ready,
	        mrds_error_$scope_not_found,
	        mrds_error_$unknown_proc_id,
	        sys_info$max_seg_size) fixed bin (35) ext;
	dcl     OFF		 bit (1) init ("0"b) static internal options (constant);
	dcl     ON		 bit (1) init ("1"b) static internal options (constant);
	declare 1 actual_permits	 like common;
	declare 1 actual_prevents	 like common;
	declare 1 actual_conflict_detail,		/* details of why dl_scope failed */
		2 permits		 like common,
		2 prevents	 like common;
	declare 1 unused_conflict_detail,		/* throw away detail */
		2 permits		 like common,
		2 prevents	 like common;
	declare sub_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (32) init ("mrds_dsl_dl_fscope"); /* name of calling routine */
	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); /* unused */
	declare conflict_relation	 char (32);	/* name of relation where tried to delete more scope than present */
	declare conflict_detail_known	 bit (1) init ("0"b); /* on => knwo details of conflict */
	declare saved_fl_ptr	 ptr;		/* remember old fl_ptr */
	dcl     divide		 builtin;
	dcl     fixed		 builtin;
	dcl     index		 builtin;
	dcl     length		 builtin;
	dcl     mod		 builtin;
	dcl     pointer		 builtin;
	dcl     baseno		 builtin;
	dcl     baseptr		 builtin;
	dcl     ptr		 builtin;
	dcl     rtrim		 builtin;
	dcl     unspec		 builtin;
%page;
%include mrds_dbcb;
%page;
%include mdbm_scope_requests;
%page;
%include mdbm_scope_info;
%page;
%include mdbm_dbc;
%page;
%include mdbm_users;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;



     end mrds_dsl_dl_fscope;





		    mrds_dsl_eval_expr.pl1          04/18/85  1433.7re  04/18/85  0907.3      117216



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

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

mrds_dsl_eval_expr:
eval_expr:
     proc (area_ptr, expr_ptr, rmri_ptr, simple_typed_vector_ptr, code);

/* DESCRIPTION:

   This routine evaluates functions and arithmetic expressions appearing in the
   where clause.


   MRDS_DEBUG_TOOL SWITCHES:

   bit 1 = display intermediate expressions.
   bits 2 through 9 = not used.


   HISTORY:

   79-02-01 J. A. Weeldreyer: Modified for MR7.0.

   79-05-10 Al Kepner: Modified to add a handler for the conversion condition.

   79-05-22 Al Kepner: Modified to prevent misuse of the expression stack which
   resulted in a subscriptrange condition.

   79-08-28  NSDavids:  Removed  special  handling of the first argument of the
   expression.   Why  it  was there I don't know but it was not handling a real
   argument and an expression type of complex correcly.

   79-11-30  Rickie  E.   Brinegar:  Modified  to  use mrds_debug_tool switches
   instead of the entry points db_on and db_off.

   79-12-01  Jim  Gray: Modified to make calls to mu_data_class$complex_data_class
   and $real_data_class for determining data categories, so that packed decimal
   was included.

   80-02-01 Jim Gray: Modified to add area_ptr parameter.

   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-08-01  Rickie  E.   Brinegar:  Modified  to  make  the stack structure an
   automatic variable and remove unreferenced declared variables not in include
   files.

   81-02-20  Rickie  E.  Brinegar: Changed calls to mdb_display_value_ to calls
   to  mdb_display_data_value$ptr.  The latter routine does not truncate at 256
   characters of output.

   81-06-01 Jim Gray : modified to use new resultant structure.

   82-08-25 Mike Kubicar : converted from tuple structure to simple typed
   vector.

*/

	display_intermed_expr = substr (db_mrds_dsl_eval_expr, 1, 1);
	num_dims = 0;

	on conversion goto conversion_error;


	wa_ptr = area_ptr;
	stack.top_entry = 0;			/* init for no operands */
	call determine_result_type (expr.nitems);	/* set result_type switch for the first entry in the expression structure */


/*
   now process each entry in the expression
*/

	do i = 1 to expr.nitems;

/* the operand will be DATA type or SCAL_FUN type
   which will be processed when an OPERATOR is encountered
*/


	     if expr.item.type (i) = DATA then do;
		     if expr.item.data_type (i) = DATABASE then
			call get_db_item (i);	/* must initialize ptr for assign_ */

		     if expr.item.desc (i) = expr.item.desc (expr.nitems)
						/* no need for conversion */
		     then call increment_stack (i, expr.item.assn_ptr (i));

		     else do;			/* must convert to intermediate type and precision */
			     stack.top_entry = stack.top_entry + 1; /* push up by 1 */
			     if result_type = CMPX then do; /* mode is complex */
				     assign_desc = CFLTD59;
				     op_ptr = addr (stack.operand.cmpx_op (stack.top_entry));
						/* ptr to intermediate value */
				end;

			     else do;		/* treat as if mode is rea */
				     assign_desc = RFLTD59;
				     op_ptr = addr (stack.operand.real_op (stack.top_entry));
				end;

			     call
				mu_convert$convert_data (expr.item.assn_ptr (i),
				addr (expr.item.desc (i)), op_ptr, addr (assign_desc), icode);
			     if icode ^= 0 then
				call error (icode);
			     stack.operand.index (stack.top_entry) = i; /* index to entry in expr structure */
			     stack.operand.data_ptr (stack.top_entry) = op_ptr;
						/* ptr to operand data */

			end;
		end;				/* end of DATA type processing;
						   */


/* is it a SCAL_FUN type */

	     else if expr.item.type (i) = SCAL_FUN then do; /* is a scalar function */
		     call
			mrds_dsl_eval_func (area_ptr, expr.item.fn_ptr (i), rmri_ptr,
			simple_typed_vector_ptr, icode);
		     if icode ^= 0 then
			call error (icode);
		     call increment_stack (i, expr.item.assn_ptr (i));
						/* result of function is predetermined to
						   be float dec (59)
						   add index and pointer to the operand stack
						   */
		end;

/* is it an OPERATOR type */

	     else if expr.item.type (i) = OPERATOR then do; /* is an operator,
						   so result of operation will be pointed to by this entry in the expr structure */
		     call process_op (i, result_type);
		     call increment_stack (i, expr.item.assn_ptr (i));
						/*
						   add the index and data pointer of the operand to the stack ...
						   it will always be float dec (59)
						   */

		end;
	end;					/* end of do loop which processes each item in the expr structure
						   list */

	code = 0;

	if display_intermed_expr then do;
		call ioa_$nnl ("Expression value: ");

/* 81-02-20 Rickie E. Brinegar: Start changes ****************************** */

		call
		     mdb_display_data_value$ptr (expr.item (expr.nitems).assn_ptr,
		     addr (expr.item (expr.nitems).desc));

/* 81-02-20 Rickie E. Brinegar: End changes ******************************** */

	     end;
exit:
	return;


conversion_error:
	;
	code = mrds_error_$conversion_condition;
	go to exit;

determine_result_type:
     proc (i);

/* is the mode for this entry complex or real
   or character or bit */

	dcl     i			 fixed bin;	/* index value to expression entry */

/* see if the mode for this entry is complex */

	if mu_data_class$complex_data_class (addr (expr.item.desc (i))) then
	     result_type = CMPX;

	else if mu_data_class$real_data_class (addr (expr.item.desc (i))) then
	     result_type = REAL;


	else result_type = CHAR_BIT;			/* mode is character or bit,
						   will be treated as real */

     end determine_result_type;

process_op:
     proc (indx, result_type);

/* This procedure performs the operation designated by the indx element of
   the expr structure upon
   the first operand comes from the top entry in the stack
   and the second operand comes from the next to top entry

   The result is placed in the location pointed to by the assn_ptr variable
   in the indx element of the expr structure.
*/

	dcl     indx		 fixed bin;	/* indx to the expr structure list */
	dcl     result_type		 bit (1) unal;	/* ON => complex mode;  OFF => real mode */

	goto case (expr.item.op_code (indx));

case (1):						/* ADDITION */
	if result_type = CMPX then
	     expr.item.assn_ptr (indx) -> op_cmpx =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_cmpx
		+ stack.operand.data_ptr (stack.top_entry) -> op_cmpx;

	else expr.item.assn_ptr (indx) -> op_real =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_real
		+ stack.operand.data_ptr (stack.top_entry) -> op_real;
	goto exit;


case (2):						/* SUBTRACTION */
	if result_type = CMPX then
	     expr.item.assn_ptr (indx) -> op_cmpx =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_cmpx
		- stack.operand.data_ptr (stack.top_entry) -> op_cmpx;

	else expr.item.assn_ptr (indx) -> op_real =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_real
		- stack.operand.data_ptr (stack.top_entry) -> op_real;
	goto exit;

case (3):						/* MULTIPLY */
	if result_type = CMPX then
	     expr.item.assn_ptr (indx) -> op_cmpx =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_cmpx
		* stack.operand.data_ptr (stack.top_entry) -> op_cmpx;

	else expr.item.assn_ptr (indx) -> op_real =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_real
		* stack.operand.data_ptr (stack.top_entry) -> op_real;
	goto exit;

case (4):						/* DIVISION */
	if result_type = CMPX then
	     expr.item.assn_ptr (indx) -> op_cmpx =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_cmpx
		/ stack.operand.data_ptr (stack.top_entry) -> op_cmpx;

	else expr.item.assn_ptr (indx) -> op_real =
		stack.operand.data_ptr (stack.top_entry - 1) -> op_real
		/ stack.operand.data_ptr (stack.top_entry) -> op_real;
	goto exit;


exit:						/* decrement the stack by 2 because we always operate on two
						   operands at a time
						   */
	stack.top_entry = stack.top_entry - 2;

	return;
     end process_op;

get_db_item:
     proc (ii);

/* procedure to move an attr. value out of the tuple, and decode it if necessary. */

	dcl     ii		 fixed bin;	/* item index */

	rai_ptr = expr.item.ai_ptr (ii);

	call
	     mu_get_data$get_data_item (rai_ptr, area_ptr,
	     (simple_typed_vector.dimension (rm_attr_info.defn_order).value_ptr),
	     expr.item.assn_ptr (ii), addr (expr.item.desc (ii)), icode);
	if icode ^= 0 then
	     call error (icode);

     end get_db_item;

error:
     proc (cd);

/* error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;


increment_stack:
     proc (indx, data_ptr);

/* this procedure adds an expression index value and a pointer to the

   relevant data to a stack to facilitate processing of the expression
   structure list
*/

	dcl     indx		 fixed bin;	/* index to the relevant entry in the expr structure list */
	dcl     data_ptr		 ptr;		/* pointer to the data to be used as an operand */

	if stack.top_entry ^< mrds_data_$max_expr_stack_size then
	     call error (mrds_error_$expr_stack_ovfl);

	stack.top_entry = stack.top_entry + 1;		/* push up by 1 */
	stack.operand.index (stack.top_entry) = indx;	/* index to entry in expr structure */
	stack.operand.data_ptr (stack.top_entry) = data_ptr; /* ptr to operand data */

     end increment_stack;

	declare area_ptr		 ptr;
	dcl     1 stack,
		2 top_entry	 fixed bin,	/* top entry in the operand stack */
		2 operand		 (mrds_data_$max_expr_stack_size), /* (expr.nitems refer (stack.top_entry)), */
		  3 index		 fixed bin,	/* index to expr structure for this operand */
		  3 data_ptr	 ptr,		/* ptr to data for this operand */
		  3 real_op	 real float dec (59) aligned, /* intermediate value for real operand */
		  3 cmpx_op	 complex float dec (59) aligned; /* intermediate value for complex operands */

	dcl     assign_desc		 bit (36);	/* descriptor for REAL or COMPLEX float dec (59) */
	dcl     op_cmpx		 complex float dec (59) aligned based; /* if mode is complex */
	dcl     op_real		 real float dec (59) aligned based; /* format for first operand if mode is real */

	dcl     (
	        display_intermed_expr,		/* debug_tool switch */
	        result_type
	        )			 bit (1) unal;	/* ON => complex; OFF => treat as real */

	dcl     (
	        op_ptr,				/* ptr to operand */
	        wa_ptr
	        )			 ptr;

	dcl     (
	        CHAR_BIT		 bit (1) unal init ("0"b), /* mode is char or bit */
	        CMPX		 bit (1) unal init ("1"b), /* complex mode */
	        REAL		 bit (1) unal init ("0"b)
	        )			 internal static options (constant); /* real mode */

	dcl     i			 fixed bin;	/* index value */

	dcl     (
	        code,				/* Output:  status code */
	        icode				/* internal status code */
	        )			 fixed bin (35);	/* to data in tuple.data */

	dcl     (addr, null, substr)	 builtin;

	dcl     conversion		 condition;

	dcl     ioa_$nnl		 entry options (variable);

/* 81-02-20 Rickie E. Brinegar: Start changes ****************************** */

	dcl     mdb_display_data_value$ptr entry (ptr, ptr);

/* 81-02-20 Rickie E. Brinegar: End changes ******************************** */

	dcl     mu_data_class$complex_data_class entry (ptr) returns (bit (1) aligned);
	dcl     mu_convert$convert_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$real_data_class entry (ptr) returns (bit (1) aligned);
	dcl     mrds_dsl_eval_func	 entry (ptr, ptr, ptr, ptr, fixed bin (35));

	dcl     mrds_data_$max_expr_stack_size fixed bin (35) ext;
	dcl     mrds_error_$conversion_condition fixed bin (35) ext;
	dcl     mrds_error_$expr_stack_ovfl fixed bin (35) ext;

%include mdbm_descriptor;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_rel_info;
%page;
%include mrds_debug_names;
%page;
%include mrds_expressions;
%page;
%include vu_typed_vector;

     end mrds_dsl_eval_expr;




		    mrds_dsl_eval_func.pl1          04/18/85  1433.7re  04/18/85  0907.3       34569



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

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

mrds_dsl_eval_func: proc (area_ptr, sfn_ptr, rmri_ptr, simple_typed_vector_ptr, code);

/* this routine evaluates functions appearing in
   the where clause.


*/

/* HISTORY:

   Modified for MR7.0 by JA Weeldreyer -- February, 1979

   Modified by NSDavids 27-aug-79 to initialize icode to zero rather than garbage

   Modified by Jim Gray - - Feb. 1980, to add area_ptr parameter.

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

   81-06-01 Jim Gray : modified to use new resultant structure.

   82-08-23 Mike Kubicar : converted from tuple structure to simple
   typed vector.

*/

	do i = 1 to scalfn.nargs;
	     if scalfn.arg.type (i) = EXPR
	     then call mrds_dsl_eval_expr (area_ptr, scalfn.arg.ef_ptr (i), rmri_ptr, simple_typed_vector_ptr, icode);

	     else if scalfn.arg.type (i) = SCAL_FUN
	     then call mrds_dsl_eval_func (area_ptr, scalfn.arg.ef_ptr (i), rmri_ptr, simple_typed_vector_ptr, icode);

	     else if scalfn.arg.type (i) = DATABASE
	     then call get_db_item;			/* go initialize appropriate assn_ptr and argument list ptr */
	     if icode ^= 0 then call error (icode);

	     if scalfn.arg.must_convert (i)
	     then call mu_convert$convert_data (scalfn.arg.assn_ptr (i),
		     addr (scalfn.arg.desc (i)),
		     scalfn.arg.arg_assn_ptr (i),
		     addr (scalfn.arg.arg_desc (i)),
		     icode);
	     if icode ^= 0 then call error (icode);

	end;

	call cu_$gen_call (scalfn.entry_ptr, scalfn.arg_list_ptr);

	code = 0;

exit:
	return;

get_db_item: proc;

/* procedure to move an attr. value out of the tuple, and decode it if necessary. */

	rai_ptr = scalfn.arg.ai_ptr (i);

	call mu_get_data$get_data_item (rai_ptr, area_ptr,
	     (simple_typed_vector.dimension (rm_attr_info.defn_order)
	     .value_ptr), scalfn.arg.assn_ptr (i),
	     addr (scalfn.arg.desc (i)), icode);

     end get_db_item;

error: proc (cd);

/* Error Procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;

	dcl     i			 fixed bin;	/* index value */

	dcl     code		 fixed bin (35);	/* Output:  status code */
	dcl     icode		 fixed bin (35) init (0); /* internal status code */

	dcl     (addr, null)	 builtin;

	dcl     mu_convert$convert_data entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     cu_$gen_call	 entry (ptr, ptr);

	dcl     mrds_dsl_eval_expr	 entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mu_get_data$get_data_item entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
	declare area_ptr		 ptr;

%include mrds_expressions;

%include mdbm_rm_rel_info;

%include mdbm_rm_attr_info;

%include vu_typed_vector;


     end mrds_dsl_eval_func;




		    mrds_dsl_expr_.pl1              08/01/88  1412.3rew 08/01/88  1300.0      166509



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

mrds_dsl_expr_:
    proc ();


/*
   BEGIN_DESCRIPTION
   This  procedure  translates  a  where-clause  arithmetic  expression into a
   postfix  polish  form which can be easily evaluated within mrds_dsl_search.
   END_DESCRIPTION



   HISTORY:

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

   78-02-01  J.   A.   Weeldreyer:  Modified to properly handle expr.  without
   variables.

   79-02-01 J. A. Weeldreyer: Modified for MR7.0.

   79-05-04   Al   Kepner:   Modified   to   add   set_type_and_len   proc  to
   condense_data_stack.

   79-06-01 Al Kepner: Modified to use select_area.

   79-09-01  NSDavids:  Modified  to correctly build a character or bit string
   literal  as  opposed to treating it like a number which was returned from a
   function call.  Also to handle the case were the result of an expression is
   a literal type.

   79-12-01 Jim Gray : Modified to change complex data type determination from
   internal  to a call to mu_data_class$complex_data_class so that the new packed
   decimal data types get included.

   80-02-01 Jim Gray : Modified to add area_ptr parameter.

   80-09-24  Davids:  added  to the code that handles attributes a check to be
   sure  that  the  user has read permission on the attribute, if not the code
   dies  with  an  incorrect  access  error.   also removed declared but never
   referenced variables including the include file mdbm_arg_list.  Modified by
   Jim Gray - - 80-11-05, to "and" the mdbm_secured bit with the r_perm bit in
   the rm_attr_info so that secure_mrds_db turns on this check.

   81-05-06  Rickie  E.   Brinegar:  Modified  to  make  use  of  the modified
   rm_domain_info stucture.

   81-06-01 Jim Gray : modified to use new resultant strucuture.
   Also took out unused assign_ parameters.

   81-09-21 Davids: enclosed several expr.item (i) = data_stack  (j)
   assignments  with  unspecs  because  pl1 has a bug which causes a
   subscriptrange  condition  to  occur  when  the   dimensions   of
   data_stack and item are not the same.

   81-09-22 Davids: another subscriptrange condition caused  by  the
   pl1 bug.

   81-11-04  Davids:  corrected  a  problem  that  would   cause   a
   subscriptrange  condition  to  occur when an expression had extra
   parens, i.e. ((1 + 2)). The fix was to check  for  the  condition
   nops = 0 when the token is a ")", i.e. token_proc (8).

   83-02-28 Davids: explicitly declared variables that were declared by
   context of implication and removed declarations to variables that
   were never referenced.

   83-09-13 R. Harvey: added knowledge of the range structure so that the
   needed bits could be set for the attributes. Also removed / operators
   to improve speed.

   84-09-20 Hergert: Made -compiled and .X. illegal tokens. Also fixed typo
   where label token_proc(4) was spelled troken_proc(4). If -where showed up
   in an expression.....

   84-11-01 John Hergert: added call to mu_print_error for error reporting.
*/


/****^  HISTORY COMMENTS:
  1) change(88-06-27,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-14,Dupuis), install(88-08-01,MR12.2-1073):
     Reworked for new parser.
                                                   END HISTORY COMMENTS */

init:
    entry (psi_ptr,level);

        if level=1 then do;
	   allocate data_stacks in (parser_work_area);
	   data_stacks.stack_top (*) = 0;
        end;
        else nstk_items = 0;

        return;

build_function:
    entry (psi_ptr,dbcb_ptr, efd_ptr, level, code);

        if nstk_items >= mrds_data_$max_expr_stack_size
        then
						/* make sure we dont overflow */
	   call error (mrds_error_$expr_stack_ovfl, LOUD, 0, WCE_TYPE,
	        "Too many items have been specified in an expression.");

        nstk_items = nstk_items + 1;			/* add function to data stack */
        data_stack.type (nstk_items) = SCAL_FUN;
        data_stack.op_code (nstk_items), data_stack.data_type (nstk_items) =
	   0;
        data_stack.desc (nstk_items) = exp_fun_data.descriptor;
        data_stack.loc_index (nstk_items) = exp_fun_data.loc_index;
        data_stack.bit_length (nstk_items) = exp_fun_data.bit_length;
        data_stack.assn_ptr (nstk_items) = exp_fun_data.assn_ptr;
        data_stack.ai_ptr (nstk_items) = null;
        data_stack.fn_ptr (nstk_items) = exp_fun_data.ef_ptr;

        code = 0;
        return;

build_attribute:
    entry (psi_ptr,dbcb_ptr, range_ptr, rel_index, ai_ptr, level, code);

dcl     ai_ptr		 ptr;
dcl     rel_index		 fixed bin;


        if nstk_items >= mrds_data_$max_expr_stack_size
        then
						/* check for overflow */
	   call error (mrds_error_$expr_stack_ovfl, LOUD, 0, WCE_TYPE,
	        "Too many items have been specified in an expression.");

        rai_ptr = ai_ptr;				/* save space to move attr. value */
        if rm_attr_info.mdbm_secured & ^(rm_attr_info.read_perm)
						/* if you don't have read access to an attribute */
        then call error (mdbm_error_$inc_attr_acc, LOUD, 0, AV_TYPE,
	        "You must have read access to use an attribute in an expression."
	        );				/* it shouldn't be in an expression */
        rdi_ptr = rm_attr_info.domain_ptr;

/* Say this attribute is needed */

        range.tup_var (rel_index).needed_bits.attr (rm_attr_info.defn_order) =
	   "1"b;

        li.encd_proc = "0"b;
        li.src_ptr, li.srcd_ptr, li.encdd_ptr = null;

        li.litd_ptr = addr (rm_domain_info.user_desc);
        li.encd_blen = 0;
        call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), code);
        if code ^= 0
        then
	   call error (code, LOUD, 0, WCE_TYPE, "");

        nstk_items = nstk_items + 1;			/* add tuple attr. to data stack */
        data_stack.type (nstk_items) = DATA;
        data_stack.op_code (nstk_items) = 0;
        data_stack.data_type (nstk_items) = DATABASE;
        data_stack.desc (nstk_items) = li.litd_ptr -> bit36;
        data_stack.loc_index (nstk_items) = li.lit_offset;
        data_stack.bit_length (nstk_items) = li.lit_blen;
        data_stack.assn_ptr (nstk_items) = li.lit_ptr;	/* we dont know this now */
        data_stack.ai_ptr (nstk_items) = ai_ptr;
        data_stack.fn_ptr (nstk_items) = null;

        code = 0;
        return;

build_literal:
    entry (psi_ptr,dbcb_ptr, a_ptr, d_ptr, char_sw, level, code);

/* Procedure to build a literal expr. item and add it to the data stack. */

dcl     (a_ptr, d_ptr)	 ptr;
dcl     lit_char		 char (lit_len) based (a_ptr);
dcl     lit_char_var	 char (lit_len) var based (a_ptr);
dcl     lit_len		 fixed bin;

        if nstk_items >= mrds_data_$max_expr_stack_size	/* check for overflow */
        then call error (mrds_error_$expr_stack_ovfl, LOUD, 0, WCE_TYPE,
	        "Too many items have been specified in a en expression.");

        nstk_items = nstk_items + 1;			/* add literal to data stack */

        lit_len = fixed (string (d_ptr -> descriptor.size));
        if ^char_sw then do;
	  if d_ptr -> descriptor.type = CHAR_VAR_TYPE
	  then
	       if index (lit_char_var, "i") ^= 0
	       then				/* check if could be complex */
		  desc_ptr = addr (CFLTD59);
	       else desc_ptr = addr (RFLTD59);

	  else if d_ptr -> descriptor.type = CHAR_TYPE
	       then
		  if index (lit_char, "i") ^= 0
		  then
		       desc_ptr = addr (CFLTD59);
		  else desc_ptr = addr (RFLTD59);

	       else if mu_data_class$complex_data_class (d_ptr)
		  then
		       desc_ptr = addr (CFLTD59);
		  else desc_ptr = addr (RFLTD59);
        end;

        data_stack.type (nstk_items) = DATA;
        data_stack.op_code (nstk_items) = 0;
        data_stack.data_type (nstk_items) = LITERAL;
        data_stack.ai_ptr (nstk_items), data_stack.fn_ptr (nstk_items) = null;

        if char_sw then do;
	  data_stack.desc (nstk_items) = d_ptr -> bit36;
	  li.litd_ptr = d_ptr;
        end;
        else do;
	  data_stack.desc (nstk_items) = desc_ptr -> bit36;
	  li.litd_ptr = desc_ptr;
        end;

        li.src_ptr = a_ptr;				/* make the literal */
        li.srcd_ptr = d_ptr;
        li.encd_proc = "0"b;
        li.encdd_ptr = null;
        li.encd_blen = 0;

        call mrds_dsl_make_literal (dbcb_ptr, addr (li), code);
        if code ^= 0
        then
	   call error (code, LOUD, 0, WCE_TYPE, "");

        data_stack.loc_index (nstk_items) = li.lit_offset;
        data_stack.bit_length (nstk_items) = li.lit_blen;
        data_stack.assn_ptr (nstk_items) = li.lit_ptr;

        code = 0;
        return;

condense_stack:
    entry (psi_ptr,dbcb_ptr, a_select_area_ptr, operator, level, code);

/* Procedure to combine the top 2 data_stack items, and the parameter operator
   into one sub_expression.  Space to hold the result is allocated in
   the literal pool. */

dcl     (i, j, k)		 fixed bin;
dcl     operator		 char (1) aligned;

        select_area_ptr = a_select_area_ptr;
        if data_stack.type (nstk_items - 1) ^= EXPR	/* two data items */
	   & data_stack.type (nstk_items) ^= EXPR then do;/* build new sub-expr */

	  nexp_items_init = mrds_data_$max_expr_items;	/* may grow to max */
	  allocate expr in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning of each new selection expression. */
	  expr.nitems = 3;				/* just starting */
	  unspec (expr.item (1)) = unspec (data_stack (nstk_items - 1));
	  unspec (expr.item (2)) = unspec (data_stack (nstk_items));
	  data_stack.type (nstk_items - 1) = EXPR;
	  data_stack.ai_ptr (nstk_items) = null;
	  data_stack.fn_ptr (nstk_items - 1) = expr_ptr;	/* reuse first data_stack item for new sub-expr */
	  data_stack.desc (nstk_items - 1) =
	       resolve_descs (data_stack.desc (nstk_items - 1),
	       data_stack.desc (nstk_items));
	  nstk_items = nstk_items - 1;		/* reduce data stack */
        end;					/* building new sub_expr */

        else if data_stack.type (nstk_items - 1) = EXPR	/* if both are sub-exprs */
	        & data_stack.type (nstk_items) = EXPR then do;
						/* combine both into one */
	       expr_ptr = data_stack.fn_ptr (nstk_items - 1);
						/* the first one will survive */
	       i = expr.nitems;			/* no. items in first */
	       expr_ptr1 = data_stack.fn_ptr (nstk_items);
	       j = expr_ptr1 -> expr.nitems;		/* no. items in second */
	       if i + j + 1 > mrds_data_$max_expr_items
	       then				/* check for overflow */
		  call error (mrds_error_$max_expr_items, LOUD, 0,
		       WCE_TYPE,
		       "Too many items have been specified in an expression."
		       );

	       expr.nitems = i + j + 1;		/* set count for combined expr */
	       do k = i + 1 to i + j;			/* append second expr. to first */
		 unspec (expr.item (k)) =
		      unspec (expr_ptr1 -> expr.item (k - i));

	       end;


	       data_stack.desc (nstk_items - 1) =
		  resolve_descs (data_stack.desc (nstk_items - 1),
		  data_stack.desc (nstk_items));
	       nstk_items = nstk_items - 1;		/* reduce stack size */
	   end;					/* condensing two sub-exprs */

	   else do;				/* adding data item to sub-expr */

	       if data_stack.type (nstk_items) = EXPR then do;
		 i = nstk_items;			/* i -> sub_expr */
		 j = nstk_items - 1;		/* j -> data item */
	       end;
	       else do;
		 i = nstk_items - 1;		/* ditto */
		 j = nstk_items;
	       end;

	       expr_ptr = data_stack.fn_ptr (i);	/* look at sub-expr */
	       if expr.nitems + 2 > mrds_data_$max_expr_items
	       then				/* check for overflow */
		  call error (mrds_error_$max_expr_items, LOUD, 0,
		       WCE_TYPE,
		       "Too many item have been specified in an expression."
		       )
		       ;

	       expr.nitems = expr.nitems + 2;		/* update count */
	       if i < j
	       then				/* if expr is first operand */
		  unspec (expr.item (expr.nitems - 1)) =
		       unspec (data_stack (j));
						/* CHANGE 81-09-21 append data item */
	       else do;				/* if data item is first */
		 do k = expr.nitems - 2 to 1 by -1;
		     expr.item (k + 1) = expr.item (k); /* move each item up one slot */
		 end;
		 unspec (expr.item (1)) = unspec (data_stack (j));
						/* CHANGE 81-09-21 move data item into first slot */
	       end;				/* if data item first */

	       data_stack.desc (i) =
		  resolve_descs (data_stack.desc (i), data_stack.desc (j));

	       if i = nstk_items
	       then				/* if sub-expr last item in stack */
		  data_stack (nstk_items - 1) = data_stack (nstk_items);
						/* move it down one */
	       nstk_items = nstk_items - 1;

	   end;					/* appending data item to sub-expr */

        li.encd_proc = "0"b;
        li.src_ptr,					/* reserve space for result */
	   li.srcd_ptr, li.encdd_ptr = null;

        li.litd_ptr = addr (data_stack.desc (nstk_items));
        li.encd_blen = 0;
        call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), code);
        if code ^= 0
        then
	   call error (code, LOUD, 0, WCE_TYPE, "");
        data_stack.loc_index (nstk_items) = li.lit_offset;
        data_stack.bit_length (nstk_items) = li.lit_blen;
        data_stack.assn_ptr (nstk_items) = li.lit_ptr;

        expr.item.type (expr.nitems) = OPERATOR;		/* now add operator to expr */
        expr.item.op_code (expr.nitems) = index (OPERATOR_LIST, operator);

        expr.item.desc (expr.nitems) = data_stack.desc (nstk_items);
        expr.item.loc_index (expr.nitems) = data_stack.loc_index (nstk_items);
        expr.item.bit_length (expr.nitems) =
	   data_stack.bit_length (nstk_items);
        expr.item.assn_ptr (expr.nitems) = data_stack.assn_ptr (nstk_items);
        expr.item.data_type (expr.nitems) = 0;
        expr.item.ai_ptr (expr.nitems), expr.item.fn_ptr (expr.nitems) = null;

        code = 0;
        return;

finish:
    entry (psi_ptr,efd_ptr, a_select_area_ptr, level);


        if nstk_items = 1
        then					/* special case of single function in expr */
	   if data_stack.type (1) = SCAL_FUN then do;
	       nexp_items_init = 1;
	       allocate expr in (a_select_area_ptr -> select_area);
	       expr.nitems = 1;
	       unspec (expr.item (1)) = unspec (data_stack (1));
	       data_stack.fn_ptr (1) = expr_ptr;
	   end;

        exp_fun_data.loc_index = data_stack.loc_index (1);	/* fill in result info for caller */
        exp_fun_data.bit_length = data_stack.bit_length (1);
        exp_fun_data.descriptor = data_stack.desc (1);
        exp_fun_data.assn_ptr = data_stack.assn_ptr (1);
        exp_fun_data.ef_ptr = data_stack.fn_ptr (1);

        return;

resolve_descs:
    proc (d1, d2) returns (bit (36) aligned);

/* Procedure to determine whether to use complex or real float dec (59). */

dcl     (d1, d2, rslt)	 bit (36) aligned;

        if mu_data_class$complex_data_class (addr (d1))
	   | mu_data_class$complex_data_class (addr (d2))
        then
	   rslt = CFLTD59;				/* if either input is complex */
        else rslt = RFLTD59;				/* if not */
        return (rslt);

    end resolve_descs;

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_se_info;
%page;
%include mrds_exp_fun_data;
%page;
%include mrds_expressions;
%page;
%include mdbm_descriptor;
%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;

dcl     expr_ptr1		 ptr;			/* another pointer to expr */

dcl     code		 fixed bin (35);
dcl     bit36		 bit (36) based;
dcl     1 li		 aligned like lit_info;

dcl     nstk_items		 fixed bin
			 based (addr (data_stacks.stack_top (level)));
						/* current number of items in data stack */
dcl     level		 fixed bin (17);
dcl     1 data_stack	 (mrds_data_$max_expr_stack_size) aligned like expr.item
			 based (addr (data_stacks.stack (level, 1)));

dcl     1 data_stacks	 (mrds_data_$max_nested_expr)
			 aligned based (parser_static_info.data_stacks_ptr),
	2 stack_top	 fixed bin,
	2 stack		 (mrds_data_$max_expr_stack_size)
			 aligned like expr.item;

dcl     CHAR_VAR_TYPE	 fixed bin (5) int static options (constant)
			 init (22);
dcl     CHAR_TYPE		 fixed bin (5) int static options (constant)
			 init (21);



dcl     (
        mrds_data_$max_attributes,
        mrds_data_$max_id_len,
        mrds_data_$max_expr_stack_size,
        mrds_data_$max_expr_items,
        mrds_data_$max_nested_expr,
        mrds_error_$expr_stack_ovfl,
        mrds_error_$max_expr_items,
        mdbm_error_$inc_attr_acc,
        sys_info$max_seg_size
        )			 fixed bin (35) ext;

dcl     (null, addr, fixed, string, index, unspec, rel)
			 builtin;

dcl     mrds_dsl_make_literal	 entry (ptr, ptr, fixed bin (35));
dcl     mrds_dsl_make_literal$alloc
			 entry (ptr, ptr, fixed bin (35));
dcl     mu_data_class$complex_data_class
			 entry (ptr) returns (bit (1) aligned);
						/* returns true if
						   descriptor pointed to = complex numeric */
dcl     char_sw		 bit (1) aligned;
dcl     LOUD		 bit (1) aligned internal static
			 options (constant) init ("1"b);
dcl     OPERATOR_LIST	 char (4) aligned internal static
			 options (constant) init ("+-*/");
dcl     se_info_ptr		 ptr;
dcl     a_select_area_ptr      ptr;
exit:
    end mrds_dsl_expr_;




		    mrds_dsl_func_.pl1              08/01/88  1412.4rew 08/01/88  1300.0      140130



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

mrds_dsl_func_:
    proc ();

/* NOTES:

   This  procedure translates a function reference within a -where clause into
   a  tabular representation easily processed by mrds_dsl_search.  An argument
   list  and  entry  pointer are set up so that the function may be called via
   cu_$gen_call.  Also, assign_ data is supplied to simplify conversions.



   HISTORY:

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

   78-02-01  J.   A.   Weeldreyer:  Modified to properly handle expr.  without
   variables.

   79-02-01 J. A. Weeldreyer: Modified for MR7.0.

   79-06-27 Al Kepner: Modified to use select_area.

   80-02-01 Jim Gray : Modified to add area_ptr parameter.

   80-09-24  Davids:  added  to the code that handles attributes a check to be
   sure  that  the  user has read permission on the attribute, if not the code
   dies  with  an  incorrect  access  error.   also removed declared but never
   referenced variables that did not occur in an include file.

   80-11-05  Jim Gray : Modified to "and" the mdbm_secured bit with the r_perm
   bit in the attr_info, so that secure_mrds_db turns on this check.

   81-05-06  Rickie  E.  Brinegar: Modified to use the modified rm_domain_info
   structure.

   81-06-01 Jim Gray : changed to use new resultant.


   81-06-23 Jim Gray : added call to mrds_dsl_get_builtins to get builtin
   scalar function definitions only on an as needed basis.

   81-07-20 Jim Gray : fixed search loop for scalar function  names,
   so that an unknown function name did not erference through a null
   ptr.

   83-09-13 R. Harvey : added knowledge of the range structure so that the
   needed_bits could be set. Also removed a / operator from automatic storage
   initialization.

   84-09-20 Hergert: Made -compiled and .X. illegal tokens in functions.

   84-11-01 John Hergert: added call to mu_print_error for error reporting.

*/

/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-05-19,MCR7903),
     audit(88-07-05,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser.
                                                   END HISTORY COMMENTS */


init:
    entry (psi_ptr,dbcb_ptr, fn_name, a_sfi_ptr, a_select_area_ptr, level, code);

dcl     a_sfi_ptr		 ptr parameter;

        sfi_ptr = a_sfi_ptr;
        select_area_ptr = a_select_area_ptr;
        done = "0"b;
        do while (^done);
	  if sfi_ptr = null ()
	  then done = "1"b;
	  else if fn_name = scalfn_info.name
	       then done = "1"b;
	       else sfi_ptr = scalfn_info.fwd_ptr;
        end;

        if sfi_ptr = null
        then					/* if didnt find it */
	   call error (mrds_error_$undef_fun, LOUD, 0, WCF_TYPE,
	        "Cannot find the function '" || fn_name || "'.");

        nsf_args_init = mrds_data_$max_sf_args;		/* all ok, alloc. fn. structure */
        allocate scalfn in (select_area);		/*  Allocations in select_area are never freed.  This area
						   is reinitialized for each new selection expression. */

        scalfn.nargs = 0;				/* initialize */
        scalfn.arg_list_ptr = null;
        scalfn.entry_ptr = scalfn_info.entry_ptr;

        if level=1 then allocate sfptrs in (parser_work_area);

        sfn_ptrs (level) = sfn_ptr;
        sfi_ptrs (level) = sfi_ptr;

        return;

build_attribute:
    entry (psi_ptr,dbcb_ptr, range_ptr, rel_index, ai_ptr, level, code);
						/* tuple attribute */

dcl     ai_ptr		 ptr;
dcl     rel_index		 fixed bin;

        sfn_ptr = sfn_ptrs (level);

        if scalfn.nargs >= mrds_data_$max_sf_args
        then					/* check for overflow */
	   call error (mrds_error_$max_sf_args, LOUD, 0, WCF_TYPE, "");

        rai_ptr = ai_ptr;
        if rm_attr_info.mdbm_secured & ^(rm_attr_info.read_perm)
						/* if you don't have read access to an attribute */
        then call error (mdbm_error_$inc_attr_acc, LOUD, 0, AV_TYPE,
	        "You must have read access to use an attribute in a function."
	        );				/* it shouldn't be in a function */
        rdi_ptr = rm_attr_info.domain_ptr;

/* Say this attribute is needed */
        range.tup_var (rel_index).needed_bits
	   .attr (rm_attr_info.defn_order) = "1"b;

        li.encd_proc = "0"b;
        li.src_ptr,
	   li.srcd_ptr,
	   li.encdd_ptr = null;

        li.litd_ptr = addr (rm_domain_info.user_desc);
        li.encd_blen = 0;
        call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), code);
        if code ^= 0 then call error (code, LOUD, 0, WCF_TYPE, "");

        scalfn.nargs = scalfn.nargs + 1;		/* add tuple attr. arg. */
        scalfn.arg.type (scalfn.nargs) = DATABASE;
        scalfn.arg.must_convert (scalfn.nargs) = "0"b;	/* for now */
        scalfn.arg.desc (scalfn.nargs) = li.litd_ptr -> bit36;
        scalfn.arg.loc_index (scalfn.nargs) = li.lit_offset;
        scalfn.arg.bit_length (scalfn.nargs) = li.lit_blen;
        scalfn.arg.ai_ptr (scalfn.nargs) = rai_ptr;
        scalfn.arg.ef_ptr (scalfn.nargs) = null;
        scalfn.arg.assn_ptr (scalfn.nargs) = li.lit_ptr;

        return;

build_expr_func:
    entry (psi_ptr,dbcb_ptr, efd_ptr, expression, level, code);

/* Procedure to fill in argument information, fiven the info in ef_data. */

dcl     expression		 aligned bit (1);

        sfn_ptr = sfn_ptrs (level);

        if scalfn.nargs >= mrds_data_$max_sf_args
        then					/* check for overflow */
	   call error (mrds_error_$max_sf_args, LOUD, 0, WCF_TYPE, "");


        scalfn.nargs = scalfn.nargs + 1;		/* add the argument */

        if expression
        then scalfn.arg.type (scalfn.nargs) = EXPR;
        else scalfn.arg.type (scalfn.nargs) = SCAL_FUN;

        scalfn.arg.must_convert (scalfn.nargs) = "0"b;
        scalfn.arg.desc (scalfn.nargs) = exp_fun_data.descriptor;
        scalfn.arg.loc_index (scalfn.nargs) = exp_fun_data.loc_index;
        scalfn.arg.bit_length (scalfn.nargs) = exp_fun_data.bit_length;
        scalfn.arg.assn_ptr (scalfn.nargs) = exp_fun_data.assn_ptr;
        scalfn.arg.ai_ptr (scalfn.nargs) = null;
        scalfn.arg.ef_ptr (scalfn.nargs) = exp_fun_data.ef_ptr;


        return;

build_literal:
    entry (psi_ptr,dbcb_ptr, a_ptr, d_ptr, level, code);

/* Procedure to add a literal argument to the function structure */

dcl     (a_ptr, d_ptr)	 ptr;

        sfn_ptr = sfn_ptrs (level);

        if scalfn.nargs >= mrds_data_$max_sf_args
        then					/* check for overflow */
	   call error (mrds_error_$max_sf_args, LOUD, 0, WCF_TYPE, "");

        scalfn.nargs = scalfn.nargs + 1;		/* add the literal arg. */
        scalfn.arg.type (scalfn.nargs) = LITERAL;
        scalfn.arg.must_convert (scalfn.nargs) = "0"b;
        scalfn.arg.desc (scalfn.nargs) = d_ptr -> bit36;
        scalfn.arg.ai_ptr (scalfn.nargs),
	   scalfn.arg.ef_ptr (scalfn.nargs) = null;
        li.src_ptr = a_ptr;				/* get place to put it, and move it in */
        li.srcd_ptr,
	   li.litd_ptr = d_ptr;

        li.encd_proc = "0"b;
        li.encdd_ptr = null;

        li.encd_blen = 0;
        call mrds_dsl_make_literal (dbcb_ptr, addr (li), code);
        if code ^= 0 then call error (code, LOUD, 0, WCF_TYPE, "");
        scalfn.arg.assn_ptr (scalfn.nargs) = li.lit_ptr;

        return;

finish:
    entry (psi_ptr,dbcb_ptr, a_select_area_ptr, area_ptr, efd_ptr, level, code);


        select_area_ptr = a_select_area_ptr;
        wa_ptr = area_ptr;
        sfi_ptr = sfi_ptrs (level);
        sfn_ptr = sfn_ptrs (level);
        dbcb.possible_op = "0"b;			/* arith. oper. not possible here */

/* At this point, the entire function arg list has been parsed.  We now finish the
   argument list. */

        if scalfn_info.info_ent_ptr ^= null then do;	/* function accepts variable input */
	  allocate arg_descs in (work_area);
	  do i = 1 to arg_descs.ndescs;		/* fill in descriptors for info entry */
	      arg_descs.desc (i) = scalfn.arg.desc (i);
	  end;
	  call cu_$ptr_call (scalfn_info.info_ent_ptr, ad_ptr,
	       scalfn.rslt_desc);			/* get descriptor for result */
	  if scalfn.rslt_desc = "0"b
	  then call error (mrds_error_$unaccep_fn_args, LOUD, 4, WCF_TYPE,
		  "Could not determine data type of function result.");
	  ad_ptr = null;
	  do i = 1 to scalfn.nargs;
	      scalfn.arg.must_convert (i) = "0"b;	/* no need to convert in this case */
	  end;
        end;					/* if function accepts variable input */

        else do;					/* if function accepts fixed args */
	  if scalfn.nargs ^= scalfn_info.nargs
	  then do;
	      call ioa_$rsnnl (
		 "^d argument^[ was^;s were^] supplied, ^d ^[was^;were^] expected.",
		 err_msg, err_msg_len,
		 scalfn.nargs, (scalfn.nargs = 1),
		 scalfn_info.nargs, (scalfn_info.nargs = 1));
	      call error (mrds_error_$unaccep_fn_args, LOUD, 4, WCF_TYPE,
		 err_msg);
	  end;
	  scalfn.rslt_desc = scalfn_info.rslt_desc;	/* get descriptor of result */
	  do i = 1 to scalfn.nargs;			/* check conversion requirements of each arg. */
	      if scalfn_info.arg_desc (i) ^= scalfn.arg.desc (i) then do;
						/* if needs conversion */
		scalfn.arg.must_convert (i) = "1"b;	/* remember to convert */

		li.encd_proc = "0"b;
		li.src_ptr,			/* make space for converted value */
		     li.srcd_ptr,
		     li.encdd_ptr = null;


		li.litd_ptr = addr (scalfn_info.arg_desc (i));
		li.encd_blen = 0;
		call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li),
		     code);
		if code ^= 0
		then call error (code, LOUD, 4, WCF_TYPE, "");
		scalfn.arg.arg_desc (i) = scalfn_info.arg_desc (i);
						/* required descriptor */
		scalfn.arg.arg_assn_ptr (i) = li.lit_ptr;
	      end;				/* if conversion required */
	      else scalfn.arg.must_convert (i) = "0"b;
	  end;					/* loop through args */
        end;					/* if fixed args */

        li.encd_proc = "0"b;
        li.src_ptr,					/* save space for result */
	   li.srcd_ptr,
	   li.encdd_ptr = null;

        li.litd_ptr = addr (scalfn.rslt_desc);
        li.encd_blen = 0;
        call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), code);
        if code ^= 0 then call error (code, LOUD, 4, WCF_TYPE, "");
        exp_fun_data.descriptor = scalfn.rslt_desc;	/* fill in result info */
        exp_fun_data.assn_ptr = li.lit_ptr;
        exp_fun_data.ef_ptr = sfn_ptr;
        exp_fun_data.loc_index = li.lit_offset;
        exp_fun_data.bit_length = li.lit_blen;

        nargs = scalfn.nargs + 1;			/* allocate and build arg list for calling function */
        num_ptrs = 2 * nargs;
        allocate arg_list in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized for each new selection expression. */
        scalfn.arg_list_ptr = al_ptr;
        arg_list.arg_count,				/* fill in arg list header */
	   arg_list.desc_count = num_ptrs;
        arg_list.code = NORM;
        arg_list.pad = 0;
        do i = 1 to scalfn.nargs;			/* fill in arg and desc pointers for all input args */
	  if scalfn.arg.must_convert (i) then do;	/* if separate arg pointers */
	      arg_list.arg_des_ptr (i) =
		 set_arg_ptr (scalfn.arg.arg_assn_ptr (i),
		 (scalfn.arg.arg_desc (i)));
	      arg_list.arg_des_ptr (i + nargs) =
		 addr (scalfn.arg.arg_desc (i));
	  end;
	  else do;				/* no separate arg pointers */
	      arg_list.arg_des_ptr (i) =
		 set_arg_ptr (scalfn.arg.assn_ptr (i),
		 (scalfn.arg.desc (i)));
	      arg_list.arg_des_ptr (i + nargs) = addr (scalfn.arg.desc (i));
	  end;
        end;					/* loop through input args */
        arg_list.arg_des_ptr (nargs) =
	   set_arg_ptr (exp_fun_data.assn_ptr, (exp_fun_data.descriptor));
						/* fill in info for result */
        arg_list.arg_des_ptr (2 * nargs) = addr (scalfn.rslt_desc);

        sfn_ptrs (level) = null;
        code = 0;					/* give caller good news */
        return;

set_arg_ptr:
    proc (a_ptr, a_desc) returns (ptr);

/* procedure to return a valid arg pointer given an internal pointer, i.e.
   resolves the var. str. problem. */

dcl     a_ptr		 ptr;
dcl     r_ptr		 ptr;
declare a_desc		 bit (36);

        if addr (a_desc) -> descriptor.type = 20
	   | addr (a_desc) -> descriptor.type = 22
        then
	   r_ptr = addrel (a_ptr, 1);
        else r_ptr = a_ptr;
        return (r_ptr);

    end set_arg_ptr;

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_se_info;
%page;
%include mrds_exp_fun_data;
%page;
%include mrds_expressions;
%page;
%include mdbm_arg_list;
%page;
%include mrds_scalfn_info;
%page;
%include mrds_lit_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_range;
%page;
%include mrds_select_area;
%page;
%include mdbm_seg_area;
%page;
%include mdbm_descriptor;

dcl     (
        nargs,					/* number of args in arg list */
        i						/* internal index */
        )			 fixed bin;		/* id of current token */

dcl     (
        wa_ptr,					/* pointer to work area */
        ad_ptr,
        a_select_area_ptr
        )			 ptr;			/* pointer to list of descriptors for info entry */

dcl     (
        code					/* Output:  status code */
        )			 fixed bin (35);		/* internal status code */

dcl     fn_name		 char (*);		/* Input:  name of functions */

dcl     1 arg_descs		 aligned based (ad_ptr),	/* list of descriptors for fn info entry */
	2 ndescs		 fixed bin,
	2 desc		 (scalfn.nargs refer (arg_descs.ndescs))
			 bit (36);

dcl     bit36		 bit (36) based;
dcl     work_area		 area (sys_info$max_seg_size) based (wa_ptr);
dcl     1 li		 aligned like lit_info;

dcl     NORM		 fixed bin (17) int static init (4)
			 options (constant);

dcl     (
        mrds_data_$max_attributes,
        mrds_data_$max_expr_stack_size,
        mrds_data_$max_id_len,
        mrds_data_$max_sf_args,
        mrds_error_$max_sf_args,
        mrds_error_$undef_fun,
        mrds_error_$unaccep_fn_args,
        mdbm_error_$inc_attr_acc,
        sys_info$max_seg_size
        )			 fixed bin (35) ext;

dcl     (null,
        addr,
        fixed,
        rel,
        addrel)		 builtin;

dcl     cu_$ptr_call	 entry options (variable);
dcl     mrds_dsl_make_literal	 entry (ptr, ptr, fixed bin (35));
dcl     mrds_dsl_make_literal$alloc
			 entry (ptr, ptr, fixed bin (35));
declare done		 bit (1);			/* on => get out of loop */
declare area_ptr		 ptr;
dcl     err_msg		 char (256);
dcl     err_msg_len		 fixed bin;
dcl     level		 fixed bin;
dcl     LOUD		 bit (1) aligned internal static
			 options (constant) init ("1"b);
dcl     se_info_ptr		 ptr;
dcl     1 sfptrs aligned based(parser_static_info.sfptrs_ptr),
          2 stack (mrds_data_$max_expr_stack_size),
            3 sfn_ptrs ptr,
            3 sfi_ptrs ptr;
dcl     ioa_$rsnnl		 entry () options (variable);
exit:
    end mrds_dsl_func_;




		    mrds_dsl_gen_srch_prog.pl1      08/01/88  1347.3rew 08/01/88  1300.0      406089



/****^  ***********************************************************
        *                                                         *
        * 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-14 by Thanh
     Nguyen. (see mrds #136 and #139, phx19906)
  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)
  3) change(86-06-13,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Added the word "aligned" to the declaration of current_scope_flags
     (mrds #155).
  4) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-05-23,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, modified the way the values of range_ptr and ti_ptr are
     set.  These values are now passed in and need not be calculated from
     ss_ptr.
                                                   END HISTORY COMMENTS */


mrds_dsl_gen_srch_prog: proc (dbcb_ptr, path_var_ptr, sv_ptr, so_ptr, code);

/* 
   BEGIN_DESCRIPTION
   This  procedure  generates the search operator tables necessary to evaluate
   an and group.  Input is the path structure produced by calc_cost and output
   is  the  search_vars and search_ops structures, which are the "program" for
   mrds_dsl_search.


   DEBUG SWITCHES:

   bit 1 - - for possible additional key searches after the  initial
   tuple  access via long key head, short key head, or indexed attr,
   use comparisons, rather than more key searches  if  this  bit  is
   one.

   bit 2 - - the opposite of bit 1, it forces  key  searches  rather
   than compares, regardless of the strategy for deciding when to do
   key searches versus compares.

   bit 3 - 9 - - - unused.
   END_DESCRIPTION

   HISTORY:

   79-02-01 J. A. Weeldreyer: Initially written.

   79-04-24 Al Kepner: Modified to initialize ti_ntuples_init.

   79-04-25  Al  Kepner: Modified to make pvp a local ptr so the corresponding
   input parameter won't get changed.

   79-05-24  Al  Kepner:  Modified  to  initialize index.mbz to "0"b and to do
   primary  initialization of move_info by setting the whole structure to zero
   in alloc_move_info.

   79-06-08 Al Kepner: Modified to use select_area.

   79-06-29  Al  Kepner:  Modified  to  provide  for comparing values within a
   single tuple.

   79-07-03  Al  Kepner:  Modified to use provide descriptors in move_info for
   use by mu_convert.

   79-09-07  Davids:  Modified  so  that move_info.t_ptr will now point to the
   structure  ind_sel_info  when move_info.encd_index = "1"b.  For the case of
   unique  index  a  ind_sel_info  structure  will  also  be allocated and the
   init_info.val_ptr   will   point   at   the  ind_sel_info.key  rather  then
   ind_sel_info.

   79-10-26   Davids:  init_info.val_ptr  will  now  point  to  the  structure
   ind_sel_info  rather than ind_sel_info.key.  Why it was not done originally
   is a good question.

   80-01-19  Davids:  key  search lists are now built only for cases were they
   can  be  used  i.e.  r,key < r.index cannot be used since there is no value
   for either key or index.

   80-02-13  Davids: internal procedure extract_attr now sets move_info.s_desc
   for  varying  attributes.   non-varying  attributes seem to work without it
   being  set so i haven't done anything about them (don't mess with a working
   system).

   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.

   81-05-06  Rickie  E.   Brinegar:  Modified to use the change rm_domain_info
   structure.

   81-05-22 Jim Gray : filled in descriptor information to move_info
   for  case  of  nonvarying attribute, in the extract_attr routine.
   This is needed in the case of a r1.key =  r2.key,  but  the  data
   types  differ.  Also  changed  build_ksl  to  know the difference
   between the key, and moving attr  descriptors,  and  to  force  a
   conversion type move_info, when the data types disagree.

   81-05-23 Jim Gray : commented out code referencing unsed parts of
   tuple  structure,  in  process  of  removing  them from the tuple
   structure.

   81-06-01 Jim Gray : changed to use new resultant structure,  thus
   blocked file code was deleted.

   81-06-12 Jim Gray : moved setting  of  rai_ptr  and  rdi_ptr  (to
   rm_attr_info  and rm_domain_info) inside of condition loop in the
   attr loop in the build_select_op routine. This was  done  because
   the  call  to complete_comparison_item was resetting these values
   from  the  attribute  being  comapred  against  to  one  of   the
   attributes   targeted   for  comparison.  This  caused  selection
   expressions such as -where ((r1.key = "x") & (((r1.key = r2.data)
   &  (r1.key  =  r3.data))  & (r2.data = r3.data))) to fail because
   after the keyed tuple is found, and r2's matching tuple is found,
   then two compares must be done against the one r3.data attribute,
   one for the r1.key value, and the other for the r2.data attribute
   value.  Of course if MRDS was smart, it would know it only had to
   make one of these comparisons because of  the  r1.key  =  r2.data
   clause.

   81-06-17 Jim Gray : added call to  mu_open_iocb_manager  so  that
   iocbs are obtained on an as needed basis.

   81-06-30 Jim Gray  :  changed  build_vfile_select_init_info  to  make  only  one
   init_info  for  the  case  10  <  x  < 20, so that a range on one
   attriubte could be done in one call to vfile select,  instead  of
   two.

   81-07-01 Jim Gray : modified  process_ind_hd  to  recognize  case
   when  the  first  N of M key attrs have only the "=" condition on
   them, and can thus be used as a pure key head.

   81-07-07 Jim Gray : changed  to  use  new  path_var.access_method
   encodings

   81-07-09 Jim Gray : changed logic, so  that  gen_srch_prog  could
   not  build  search  program  using  key_head  (if available) when
   permute said to use index attr instead.

   81-07-18 Jim Gray  :  changed  build_ksl  to  use  the  condition
   selected  by permute, rather than doing it's own thing. Also made
   it the only logic to do the removal of  a  key  search  condition
   from  further consideration. ALso removed routine proc_ind_hd, as
   it's job is done in permute. Renamed  the  finish_ind_hd  routine
   build_vfile_select_init_info,   and   gave   it  some  parameters
   (finish_ind_hd had none). Made separate logic  for  each  of  the
   vfile  select  access methods (long_key_head, short_key_head, and
   indexed_attr). Made each get it's  info  from  that  supplied  by
   permute,  on  which  attributes and conditions to be used for the
   access. Also  added  routine  check_for_additional_key_search  to
   find  out  if  it  is  cheaper  to do another vfile select on any
   conditions remaining against keys, or to leave  these  conditions
   to   be   handled   by   mu_compare_values,   as   specified   by
   build_select_op. Also put the  logic  for  doing  a  primary  key
   search  into  the  routine  build_vfile_seek_key_init_info. Added
   debug switch 1, to allow additional key conditions to  be  forced
   into being done via comparisons in mu_compare_values instead.

   81-07-19  Jim  Gray   :   added   logic   to   not   generate   a
   move-init-select  set of opreations for a tuple variable that has
   no effect on the select set. Previously this caused  not  in  and
   group  tuple varibles to be cross product with the results of the
   and group, even if they were not select. This way  the  user  can
   specify  if  he  wants  the  cross  product or not. Also, a tuple
   variable can particate in 1 of N and groups, not be in the select
   clause, and still not considered a no_tuple_effect T.V.

   81-07-21 Jim Gray :  added  logic  to  allow  use  of  a  permute
   specified range of values on a short key head or an indexed attr.

   81-07-22 Jim Gray :  added  a  simple  strategy  to  avoid  doing
   additional  key  searches  when  the number of primary key access
   tuples was small, thus improving performance  by  avoiding  vfile
   select  overhead  for small sets of data. The number used was put
   into a mrds data item.

   82-09-02 Mike Kubicar : added changes necessary to use the simple
   vector structure in place of the tuple structure.

   82-09-21 Davids: deleted references to file_io_array which was used
   to keep track of which solt in the rm_rel_info.iocb_ptr array an
   iocb was in. deleted the call to mu_open_iocb_manager and added a
   call to mu_cursor_manager_$get.

   82-10-01 Davids: changes to use the new search specification structure.
   This included creation of two new internal procedures.
   build_key_or_index_init_info took the place of build_vfile_seek_key_init_info
   and build_vfile_select_init_info. build_key_values_list takes the
   place of build_ksl the difference is that all conditions on the attributes
   that are part of the key are recorded and the flag is set indicating that
   the attributes have no more conditions on them. references to key_src_list
   have been removed and replaced with key_values_list. The key_values_list is
   what is actually passed to the search program, the search spec is created
   by the code that needs it.

   82-10-12 Davids: modifications so that the module will compile. Removed 
   the assignment to file_id which is no longer used. Removed from internal
   proc extract_attr references to rm_attr_info.varying which no longer
   exists. move_info.bit_move and move_info.var_move are no longer set
   in that routine. 

   82-10-25 Davids: In the internal proc alloc_init_info assigned
   init_info.val_ptr = null (). In the internal proc build_key_values_list
   assign key_values_list.fwd_ptr = null () after the structure is allocated.
   This assures that tests for null pointers will work.

   82-10-26 Davids: Modified so that long key head and short key head init
   infos correctly record their type instead of recording a type of total
   primary key. This required using the type parameter in the
   build_key_or_index_init_info internal proc that was there but not used.
   Also changed the collection_index for ordered sequential to be the rel_id
   instead of the primary_key id so that there is now no difference between
   ordered and unordered sequential (the implementation of 
   mu_sec_get_tuple$next requires the rel_id collection to be used).
   Also so that the new element in the search_vars.info structure,
   record_collection_cursor_ptr, is set. The record collection cursor is
   needed to do relation manager get_tuple_by_id calls. Both the cursor 
   pointed to by the cursor_ptr and the cursor pointed to by the 
   record_collection_cursor_ptr can be over the same tuple variable
   since the record_collection_cursor will not be used until the cursor
   has located all the tuples.

   82-10-27 Davids: changed the calls to build_key_or_index_init_info
   for the short key head  and index cases to pass a pointer to the
   array instead of the first element in the array which was incorrect.

   82-10-29 Added the assignment of move_info.bit_move and var_move
   in the internal proc extract_attr. These assignments were incorrected
   removed on 82-10-12. Since rm_attr_info.varying no longer exists a
   call to mu_data_class$varying in made instead.

   82-11-01 Davids: added code to set move_info.sbit_len in the extract_attr
   internal proc. This was inadvertenly removed eariler.

   82-11-11 Mike Kubicar: Put back code to make a distinction between ordered
   and unordered searches.  Due to a vrm_relmgr_ bug, primary key index ids
   must be used for ordered searches.

   83-02-28 Davids: explicitly declared variables that were declared by
   context of implication and removed declarations to variables that
   were never referenced.

   83-04-04 Mike Kubicar : Took out the distinction code again.  This time
   for sure.

   83-04-24 Mike Kubicar : Significant changes to the way search programs
   are generated have been added.  In addition to a comparason list,
   this module will now also generate a search specification.  This search
   spec will be given to relation manager when the searching task is being
   done.  The search spec is built by procedure "build_select_op".
   During the loop which counts the number of conditions on attributes,
   the condition is checked to see if it can be passed directly to relation
   manager.  If so, this is noted and the condition removed from the
   "attr_list" structure.  After the loop, a search spec is built in addition
   to the comparison list.  Also, since the search spec built is better than
   the one generated from key lists, "build_key_values_list" and
   "build_key_or_index_init_info" have been removed.  A search spec will
   be built which can retrieve keyed (indexed) tuples efficiently during
   a mrds_dsl_search "select" operation.

   83-05-24 R. Harvey: added the build_vectors routine which will build a
   simple_typed_vector and an id_list for each tuple variable based upon
   what is being returned to the caller and what is needed by MRDS for
   comparisons.

   83-05-31 Mike Kubicar : Updated to use the new (version 4) search spec
   and relation cursors.

   83-08-04 Mike Kubicar : Added code to set up all the element id lists
   needed by the search program.  The element_id_list_segment is evenly
   divided among all the tuple variables.

   84-07-08 Thanh Nguyen : Added code to set the c_ai_ptrs (attribute ptrs)
   of the comp_val_list.  These pointers make the rm_attr_info and then the
   rm_domain_info to be accessible for checking on the decoding of an
   attribute.

   85-01-06 Thanh Nguyen : Modified code to set the output descriptor to be
   the same as the user_desc when decode_declare is in used, and c_ai_ptrs
   for each element (of array not the entire array) in the comp_val_list.

   85-04-08 Thanh Nguyen - Added code to set the max_tids to be either 
   max_tids_returned_per_call or max_safe_tids_returned_per_call depending on 
   the scope of the relation is shared or not.

   85-06-14 Thanh Nguyen - Added code to set max_tids to be 
   max_tids_returned_per_call and not to check for the scope flags if the
   relation is temporary (rm_rel_info.file_type = 3).  Also rewrote
   the calculation method for the size of the element_id_list structure.

   85-10-13 John Hergert: Modified the fix of 84-07-08 to fix TR's phx19901
   and phx11536. This included adding code to find out that if an attribute
   that is being compared in a qualifier is being compared to an expression,
   the attribute should be decoded.
*/
%page;
	rdbi_ptr = dbcb.rdbi_ptr;			/* initialize */
	num_dims = 0;

	pvp = path_var_ptr;

	range_ptr = dbcb.range_ptr;
	ti_ptr = dbcb.ti_ptr;

	ti_ntuples_init = tuple_info.num_tuples;

	pa_ptr = null;
	select_area_ptr = dbcb.select_area_ptr;
	/* We start on a new select expression, so turn scopes_changed flag and shared mode flag off. */
	dbcb.scopes_changed = "0"b;
	dbcb.non_shared_to_shared = "0"b;


	sv_nvars_init = range.num_vars;		/* init search vars for and group */
	allocate search_vars in (select_area);		/* select_area allocs never freed. It
						   is re-init at the start of each new S.E.. */
	string (search_vars.new_val) = "0"b;

	so_nops_init = 3 * range.num_vars + 3;		/* set up search ops */
	allocate search_ops in (select_area);		/* select_area allocs never freed. It
						   is re-init at the start of each new S.E.. */

	search_ops.ic = 1;
	search_ops.nops = 1;

	search_ops.op.code (1) = PICKUP_SVP;		/* first op is to pick up search vars */
	search_ops.op.info_ptr (1) = sv_ptr;
	search_ops.op.var_ind (1) = 0;
	search_ops.op.good_xfer (1) = 1;
	search_ops.op.err_xfer = 0;

	i = 0;
	allocate pvp_array in (select_area);		/* select_area allocs never freed. It
						   is re-init at the start of each new S.E.. */
	do xp = pvp repeat xp -> path_var.fwd_thd while (xp ^= null);
	     i = i + 1;
	     pvp_array (i) = xp;			/* build array of path var ptrs */
	end;
	max_pv = i;
	next_element_id_list_ptr = dbcb.element_id_list_segment_ptr;

	do i = max_pv by -1 to 1;			/* process variables in determination order */

	     pvp = pvp_array (i);
	     vind = path_var.var_index;
	     alp = path_var.alp;
	     elp = path_var.elp;
	     rmri_ptr,
		search_vars.info.ri_ptr (vind) = range.tup_var.ri_ptr (vind); /* fill in search var info */

	     search_vars.info.ntids (vind),
		search_vars.info.ctid (vind) = 0;
	     current_max_tids_per_call = mrds_data_$max_tids_returned_per_call;
	     if rm_rel_info.file_type ^= 3 then do;
		/* file_type = 3 only when the relation is temporary */
		current_scope_ptr = rm_rel_info.scope_flags_ptr;
		if current_scopes_flags.permits.read_attr |
		   current_scopes_flags.permits.delete_tuple |
		   current_scopes_flags.permits.modify_attr then
		   if ^current_scopes_flags.prevents.modify_attr |
		     (^current_scopes_flags.prevents.append_tuple &
		      ^current_scopes_flags.prevents.delete_tuple) then
		      current_max_tids_per_call = mrds_data_$max_safe_tids_returned_per_call;
	     end;
	     search_vars.info.maxtids(vind) = current_max_tids_per_call;
	     search_vars.info.ta_ptr (vind) = next_element_id_list_ptr;
	     next_element_id_list_ptr = addrel (search_vars.info.ta_ptr (vind),
		current_max_tids_per_call + 2);	
	     /* There are two words of header in an element id list */
	     element_id_list_ptr = search_vars.info.ta_ptr (vind);
	     element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
	     element_id_list.number_of_elements = 0;

	     if path_var.in_select_clause | path_var.in_and_group then do; /* ignore un-used T.V.'s */

		     mi = search_ops.nops + 1;	/* set up the search operators */
		     ii = search_ops.nops + 2;
		     search_ops.nops,
			si = search_ops.nops + 3;

		     search_ops.op.code (mi) = MOVE;
		     search_ops.op.code (ii) = INIT;
		     search_ops.op.code (si) = SEL;
		     search_ops.op.var_ind (mi),
			search_ops.op.var_ind (ii),
			search_ops.op.var_ind (si) = vind;
		     search_ops.op.good_xfer (mi),
			search_ops.op.good_xfer (ii),
			search_ops.op.good_xfer (si) = 1;
		     search_ops.op.err_xfer (mi) = 0;
		     search_ops.op.err_xfer (ii) = -2;
		     search_ops.op.err_xfer (si) = -3;
		     search_ops.op.info_ptr (mi),
			search_ops.op.info_ptr (ii),
			search_ops.op.info_ptr (si),
			cur_mi_ptr,
			cur_ii_ptr = null;

		     go to process_var (path_var.access_method); /* go do stuff depend. on determ. method */


process_var (1):					/* total primary key */

		     j = rm_rel_info.nkey_attr;
		     aip_ptr = addr (rm_rel_info.key_attr_ptrs (1));
		     collection_index = rm_rel_info.primary_key_index_id;
		     go to cont2;

process_var (2):					/* long key head */

		     opr_ind = 0;
		     j = path_var.attr_index;		/* set number of key head attrs used */
		     aip_ptr = addr (rm_rel_info.key_attr_ptrs (1)); /* point to list of key attributes */
		     collection_index = rm_rel_info.primary_key_index_id;
		     goto cont2;

process_var (3):					/* short key head */

		     opr_ind = 0;			/* init opr insert. index */
		     j = 1;			/* only one key attribute used in a short key head */
		     collection_index = rm_rel_info.primary_key_index_id;
		     goto cont2;

process_var (4):					/* indexed attr */

		     opr_ind = 0;			/* init opr insert. index */

		     j = 1;			/* only one attr secondary key indexing allowed */
		     collection_index = rm_rel_info.attr_ptrs (path_var.attr_index) -> rm_attr_info.index_id;
		     go to cont2;



process_var (5):					/* unordered sequential */
process_var (6):					/* ordered sequential (not used) */


		     collection_index = rm_rel_info.rel_id;
		     go to cont2;

cont2:
		     call build_select_op ();
		     call mu_cursor_manager_$get (dbcb.dbi, rmri_ptr, (vind), collection_index,
			dbcb.relmgr_entries.create_cursor, dbcb.relmgr_entries.open,
			dbcb.cursor_ptrs_storage_ptr, dbcb.cursor_storage_area_ptr,
			search_vars.info.relation_cursor_ptr (vind), icode);
		     if icode ^= 0
		     then call error (icode);


		end;				/* end of processing one variable */
	end;					/* loop through variables of and group */

	rvi = search_ops.nops + 1;			/* fill in last search ops */
	search_ops.nops,
	     rni = search_ops.nops + 2;
	search_ops.op.code (rvi) = RETVAL;
	search_ops.op.code (rni) = RETNUL;
	search_ops.op.var_ind (rvi),
	     search_ops.op.var_ind (rni),
	     search_ops.op.good_xfer (rni),
	     search_ops.op.err_xfer (rvi),
	     search_ops.op.err_xfer (rni) = 0;
	search_ops.op.good_xfer (rvi) = -1;
	search_ops.op.info_ptr (rvi),
	     search_ops.op.info_ptr (rni) = null;

	call build_vectors;

	code = 0;

exit:	;
	return;
%page;
build_select_op: proc;

/* Procedure to build info for select operator */

	dcl     attr_desc		 bit (36) aligned;	/* Descriptor for the attribute currently being looked at */
	dcl     attr_rai_ptr	 ptr;		/* Pointer to attribute's rm_attr_info */
	dcl     attr_rdi_ptr	 ptr;		/* Pointer to attribute's rm_domain_info */

	dcl     1 constraint_entry	 based (constraint_entry_ptr), /* Info for a condition that can be in search spec */
		2 next_entry	 ptr,		/* Next constraint in list */
		2 constraint_info,
		  3 field_id	 fixed bin,	/* Attribute's position in relation */
		  3 operator_code	 fixed bin,	/* Comparison operator */
		  3 value_ptr	 ptr,		/* Value to be compared */
		  3 value_field_id	 fixed bin,	/* Field to be compared if not zero */
		  3 mbz		 bit (18);	/* To fill out structure */
	dcl     constraint_entry_ptr	 ptr;

	dcl     1 constraint_list,			/* The list of constraint_entries */
		2 number_of_constraints fixed bin,	/* How many in list */
		2 head_of_list	 ptr;		/* The list */

          dcl     expression             bit (1);
	dcl     k			 fixed bin;	/* Loop index */
	dcl     last_cond_ptr	 ptr;		/* Last condition looked at that can't be in search spec */
	dcl     pred_data_type	 fixed bin;	/* Constant, attribute value, or expression */
	dcl     pred_desc		 bit (36) aligned;	/* Predicate data descriptor */
	dcl     pred_ptr		 ptr;		/* Pointer to the node in the predicate
						   tree that contains the operand */
	dcl     pred_var_ind	 fixed bin;	/* Tuple variable id of predicate */
	dcl     ss_possible		 bit (1);		/* True if condition can be passed to relation manager */

	allocate select_info in (select_area);		/* set up select info */ /* select_area allocs never freed. It
   is re-init at the start of each new S.E.. */
	search_ops.op.info_ptr (si) = seli_ptr;
	select_info.tuple_info_index = vind;
	select_info.tid_ptr = addr (tuple_info.tuple.tuple_id (vind));
	constraint_list.number_of_constraints = 0;
	constraint_list.head_of_list = null ();
	if elp ^= null then /* if have exprs */
	     count = expr_list.nexprs;
	else /* if no exprs */
	     count = 0;
	expression = "1"b;

/*
*
*  Now we need to run through the list of condtions on attributes.  We are
*  going to create two structures.  A search specification to be passed
*  to relation manager, and a condition list for mrds to interpret at
*  tuple select time.  It is best to give things to relation manager so
*  we'll do this whenever we can.  A condition can be used by relmgr if it
*
*  1) Is not an expression to be evaluated after the tuple is retrieved
*  2) Does not compare attributes within the tuple to be retrieved
*  3) Compares the attribute to a constant with the same type descriptor
*
*  Otherwise mrds must do the comparison.  The following loop looks for
*  conditions which meet the above criteria.  If it finds one, it adds
*  an entry to the constraint list and removes it from the condition
*  list for the attribute.  Otherwise it merely increments the count of
*  the number of items in the mrds comparison list.
*
*/

	do k = 1 to attr_list.nattr;
	     last_cond_ptr = null ();
	     do condp = attr_list.info.cond_ptr (k) repeat cond.fwd_thd
		while (condp ^= null ());
		attr_rai_ptr = rm_rel_info.attr_ptrs (attr_list.info.index (k));
		attr_rdi_ptr = attr_rai_ptr -> rm_attr_info.domain_ptr;
		attr_desc = attr_rdi_ptr -> rm_domain_info.db_desc;
		pred_ptr = cond.pl_ptr;
		pred_var_ind = fixed (pred_ptr -> pred_leaf.id.var_id);
		pred_data_type = pred_ptr -> pred_leaf.data_type;
		if pred_data_type = EXPRES		/* Compare to an expression? */
		then ss_possible = "0"b;
		else do;
			if pred_data_type = CONST	/* Compare to constant? */
			then pred_desc = pred_ptr -> pred_leaf.lit_desc_ptr -> bit36a;
			else if pred_data_type = ATTR /* Compare to another attribute */
			then pred_desc = pred_ptr -> pred_leaf.ai_ptr ->
				rm_attr_info.domain_ptr -> rm_domain_info.db_desc;
			else call sub_err_ (mrds_error_$internal_error,
				MODULE_NAME, "s", null (), 0,
				"A predicate was found which is neither a constant, attribute, or expression.");
			ss_possible = (pred_desc = attr_desc)
			     & (pred_var_ind ^= vind);
		     end;
		if ^ss_possible then do;
			count = count + 1;
			last_cond_ptr = condp;	/* The last condition looked at that can't be passed to relmgr */

/*			range.tup_var (vind).needed_bits.attr (attr_rai_ptr -> rm_attr_info.defn_order) = "1"b; */
		     end;
		else do;

/* Add the condition to the constraint list */

			allocate constraint_entry in (select_area);
			constraint_entry.constraint_info.field_id =
			     attr_rai_ptr -> rm_attr_info.model_defn_order;
			if cond.op_code = OTT_EQ
			then constraint_entry.constraint_info.operator_code
				= EQUAL_OPERATOR_CODE;
			else if cond.op_code = OTT_NE
			then constraint_entry.constraint_info.operator_code
				= NOT_EQUAL_OPERATOR_CODE;
			else if cond.op_code = OTT_LT
			then constraint_entry.constraint_info.operator_code
				= LESS_OPERATOR_CODE;
			else if cond.op_code = OTT_LE
			then constraint_entry.constraint_info.operator_code
				= LESS_OR_EQUAL_OPERATOR_CODE;
			else if cond.op_code = OTT_GT
			then constraint_entry.constraint_info.operator_code
				= GREATER_OPERATOR_CODE;
			else if cond.op_code = OTT_GE
			then constraint_entry.constraint_info.operator_code
				= GREATER_OR_EQUAL_OPERATOR_CODE;
			else call sub_err_ (mrds_error_$internal_error,
				MODULE_NAME, "s", null (), 0,
				"An unknown comparison operator was found in an attribute's condition list.");
			if pred_data_type = CONST
			then constraint_entry.constraint_info.value_ptr
				= pred_ptr -> pred_leaf.lit_ptr;
			else do;

/*				range.tup_var (pred_var_ind).needed_bits.attr (fixed (pred_ptr -> pred_leaf.id.attr_id)) = "1"b; */
				call extract_attr (pred_var_ind,
				     pred_ptr -> pred_leaf.ai_ptr);
				constraint_entry.constraint_info.value_ptr
				     = move_info.t_ptr;
			     end;
			constraint_entry.value_field_id = 0;
			constraint_entry.mbz = "0"b;
			constraint_list.number_of_constraints
			     = constraint_list.number_of_constraints + 1;
			constraint_entry.next_entry =
			     constraint_list.head_of_list;
			constraint_list.head_of_list = constraint_entry_ptr;


/* Now splice the condition out of the condition list for the attribute */

			if last_cond_ptr = null ()	/* Delete head of list */
			then attr_list.info (k).cond_ptr = cond.fwd_thd;
			else last_cond_ptr -> cond.fwd_thd = cond.fwd_thd;
		     end;
	     end;
	end;


/* Now build the search specification */


	rss_maximum_number_of_constraints = constraint_list.number_of_constraints;
	if rss_maximum_number_of_constraints = 0
	then rss_number_of_and_groups = 0;
	else rss_number_of_and_groups = 1;
	allocate relation_search_specification in (select_area);
	relation_search_specification.head.version = SPECIFICATION_VERSION_4;
	relation_search_specification.head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE;
	relation_search_specification.head.pad = "0"b;
	relation_search_specification.head.subset_specification_ptr = null ();
	relation_search_specification.maximum_number_of_constraints =
	     rss_maximum_number_of_constraints;
	relation_search_specification.number_of_and_groups =
	     rss_number_of_and_groups;
	relation_search_specification.flags.return_unique_tuples = "0"b;
	relation_search_specification.flags.mbz = "0"b;
	relation_search_specification.range.type = LOW_RANGE_TYPE;
	relation_search_specification.range.size = current_max_tids_per_call;
	relation_search_specification.and_group (1).number_of_constraints =
	     rss_maximum_number_of_constraints;
	relation_search_specification.and_group (1).flags
	     .collection_id_supplied = "1"b;
	relation_search_specification.and_group (1).flags.mbz = "0"b;
	relation_search_specification.and_group (1).search_collection_id =
	     collection_index;
	constraint_entry_ptr = constraint_list.head_of_list;


/*
*
*   Now fill in the constraint list.  Note that if there is nothing in
*   the constraint list, the search spec generated will be for every
*   tuple in the relation.
*
*/

	do k = 1 to constraint_list.number_of_constraints;
	     relation_search_specification.and_group (1).constraint (k) =
		constraint_entry.constraint_info, by name;
	     constraint_entry_ptr = constraint_entry.next_entry;
	end;
	select_info.relation_search_specification_ptr = relation_search_specification_ptr;


/* Now build the comparison array */

	if count = 0 then
	     select_info.cvla_ptr = null;		/* no conditions, select everything in range */
	else do;					/* must build comp val array */

		cvla_nlists_init = 1;		/* Will be greater if we allow ors */
		allocate cvl_array in (select_area);	/* select_area allocs never freed. It
						   is re-init at the start of each new S.E.. */
		select_info.cvla_ptr = cvla_ptr;
		cvl_nvals_init = count;		/* build comp val list */
		call alloc_comp_val_list;
		cvl_array.list_ptr (1) = cvl_ptr;
		nv = 0;				/* init. val counter */
		comp_val_list.rel_id = rm_rel_info.rel_id;
%page;
		do k = 1 to attr_list.nattr;		/* find remaining conditions in attr list */

		     if attr_list.info.cond_ptr (k) ^= null then do;
			     do condp = attr_list.info.cond_ptr (k) repeat cond.fwd_thd while (condp ^= null);

				rai_ptr = rm_rel_info.attr_ptrs (attr_list.info.index (k));
				rdi_ptr = rm_attr_info.domain_ptr;

				nv = nv + 1;	/* incr. val counter */
				comp_val_list.val.attr_ind (nv) = attr_list.info.index (k);
				comp_val_list.val.op (nv) = cond.op_code;
				comp_val_list.val.exp_ptr (nv),
				     comp_val_list.val.erslt_ptr (nv) = null;
				comp_val_list.val.desc1 (nv) = rm_domain_info.db_desc;
				pl_ptr = cond.pl_ptr; /* go process the operand */
				comparison_var_id = fixed (pred_leaf.id.var_id);
				compare_within_tuple = (comparison_var_id = vind);

				call complete_comparison_item (pred_leaf.data_type, compare_within_tuple, ^expression);
			     end;			/* loop through conditions */
			end;			/* if attr referenced and not used */
		end;				/* loop through attr list */
%page;
		if elp ^= null then /* have expressions to look at */

		     do k = 1 to expr_list.nexprs;

			pl_ptr = expr_list.info.epl_ptr (k);
			nv = nv + 1;
			comp_val_list.val.op (nv) = expr_list.info.op_code (k);
			comp_val_list.val.exp_ptr (nv) = pred_leaf.expr_ptr;
			comp_val_list.val.erslt_ptr (nv) = pred_leaf.lit_ptr;
			comp_val_list.val.desc1 (nv) = pred_leaf.rslt_desc;

			pl_ptr = expr_list.info.pl_ptr (k); /* go process the comparand */
			comparison_var_id = fixed (pred_leaf.id.var_id);
			compare_within_tuple = (comparison_var_id = vind);
			call complete_comparison_item (pred_leaf.data_type, compare_within_tuple, expression);
		     end;				/* loop through exprs */
	     end;					/* building comp val array */

     end build_select_op;
%page;
complete_comparison_item: proc (data_type, compare_within_tuple, expr_caller_sw);
	dcl     data_type		 fixed bin parm;	/* INPUT: 1 => constant
						   2 => attribute
						   3 => expression */
	dcl     compare_within_tuple	 bit (1) parm;	/* INPUT: ON => both items to be compared
						   depend on the same tuple. */
          dcl     expr_caller_sw          bit (1) parm;     /* INPUT: ON => called when evaluating exprsession */


/*	if data_type = ATTR
	then range.tup_var (fixed (pred_leaf.id.var_id)).needed_bits.attr (fixed (pred_leaf.id.attr_id)) = "1"b;
	else if data_type = EXPR
	then range.tup_var (fixed (pred_leaf.id.var_id)).whole_tuple_selected = "1"b;
*/
          comp_val_list.c_ai_ptr2(nv) = null;

	if ^compare_within_tuple then do;
		go to between_tuples (data_type);

between_tuples (1): ;				/* constant */
		comp_val_list.val.match_ptr (nv) =
		     pred_leaf.lit_ptr;
		comp_val_list.val.desc2 (nv) =
		     pred_leaf.lit_desc_ptr -> bit36a;
		go to end_between_tuples;

between_tuples (2): ;				/* attr. in db. */
		call extract_attr (fixed (pred_leaf.id.var_id), pred_leaf.ai_ptr);
		comp_val_list.val.match_ptr (nv) =
		     move_info.t_ptr;
		rai_ptr = pred_leaf.ai_ptr;
		rdi_ptr = rm_attr_info.domain_ptr;

		comp_val_list.val.desc2 (nv) = rm_domain_info.db_desc;
		comp_val_list.val.attr_ind2 (nv) = fixed (pred_leaf.id.attr_id);
		go to end_between_tuples;

between_tuples (3): ;				/* expressions */
		call make_eval_expr_mi (pred_leaf.expr_ptr, (fixed (pred_leaf.id.var_id)),
		     fixed (pred_leaf.id.var_id));
		comp_val_list.val.match_ptr (nv) =
		     pred_leaf.lit_ptr;
		comp_val_list.val.desc2 (nv) = pred_leaf.lit_desc_ptr -> bit36a;
		go to end_between_tuples;
end_between_tuples: ;
	     end;					/* between_tuples */
	else do;					/* within_tuple */
		go to within_tuple (data_type);
within_tuple (1):	;				/* constant */
						/* This case should not occur because a constant
						   does not depend on values out of a tuple. */

		go to between_tuples (1);

within_tuple (2):	;				/* attr. in db. */
		comp_val_list.val.attr_ind2 (nv) = fixed (pred_leaf.id.attr_id);
		call prepare_attr_cvl (expr_caller_sw);
		go to end_within_tuple;

within_tuple (3):	;				/* expressions */
		call prepare_expr_cvl;
		go to end_within_tuple;
end_within_tuple:	;
	     end;					/* within_tuple */

     end complete_comparison_item;
%page;
prepare_expr_cvl: proc;

/* This routine sets up values in the comp_val_list
   when the second item to be compared is an expression
   and both values to be compared are from the same tuple. */
	comp_val_list.val.desc2 (nv) = pred_leaf.lit_desc_ptr -> bit36a;
	comp_val_list.val.exp_ptr2 (nv) = pred_leaf.expr_ptr;
	comp_val_list.val.erslt_ptr2 (nv) = pred_leaf.lit_ptr;
     end prepare_expr_cvl;
%page;
prepare_attr_cvl: proc (expr_sw);

dcl expr_sw bit(1) parm; /* indicates that first attribute is an expression. That
	             means this value must be decoded. */

/* This routine sets up values in the comp_val_list
   when the second item to be compared is a db attribute
   and both values to be compared are from the same tuple. */
	rai_ptr = pred_leaf.ai_ptr;
	rdi_ptr = rm_attr_info.domain_ptr;
	if expr_sw then do;  /* must decode to compare */
	     comp_val_list.c_ai_ptr2 (nv) = pred_leaf.ai_ptr;
	     comp_val_list.val.desc2 (nv) = rm_domain_info.user_desc;
	end;
	else /* can compare internally */
	     comp_val_list.val.desc2 (nv) = rm_domain_info.db_desc;

     end prepare_attr_cvl;
%page;
alloc_comp_val_list: proc;

/* Allocate comp_val_list structure and peform a partial initialization. */
	allocate comp_val_list in (select_area);	/* select_area allocs never freed. It
						   is reinitialized for each new selection expression. */
	unspec (comp_val_list.val) = "0"b;
	do i = 1 to cvl_nvals_init;
	     match_ptr,
		comp_val_list.val (i).exp_ptr,
		comp_val_list.val (i).exp_ptr2,
		comp_val_list.val (i).erslt_ptr2,
		comp_val_list.val (i).erslt_ptr = null ();
	end;					/* loop thru comp_val_list.val */
	dcl     i			 fixed bin;
     end alloc_comp_val_list;
%page;
alloc_move_info: proc;

/* Procedure to allocate and link in a move info structure */

	allocate move_info in (select_area);		/* select_area allocs never freed. It
						   is re-init at the start of each new S.E.. */
	if cur_mi_ptr = null then /* if first */
	     search_ops.op.info_ptr (mi) = mi_ptr;
	else cur_mi_ptr -> move_info.fwd_thd = mi_ptr;
	unspec (move_info) = "0"b;
	move_info.fwd_thd = null;
	move_info.s_ptr,
	     move_info.t_ptr = null ();
	cur_mi_ptr = mi_ptr;

     end alloc_move_info;
%page;
extract_attr: proc (var_ind, raip);

/* procedure to set up a move info to extract an attribute value from
   a tuple and place it in the literal pool, stored in accordance with Multics
   data type standards. */

	dcl     raip		 ptr;
	dcl     var_ind		 fixed bin;

	rdi_ptr = raip -> rm_attr_info.domain_ptr;
	call alloc_move_info;
	call alloc_lit (addr (rm_domain_info.db_desc),
	     move_info.t_ptr, move_info.tbit_len);
	move_info.extr_attr = "1"b;
	move_info.bit_move = ^(mu_data_class$varying (
	     addr (raip -> rm_attr_info.domain_ptr -> rm_domain_info.db_desc)));
	move_info.var_move = ^move_info.bit_move;
	move_info.var_ind = var_ind;
	move_info.sbit_len = raip -> rm_attr_info.bit_length;
	move_info.s_desc = rm_domain_info.db_desc;
	move_info.tuple_var_index = var_ind;
	move_info.tuple_attr_index = raip -> rm_attr_info.defn_order;
     end extract_attr;
%page;
make_eval_expr_mi: proc (ep, tp, vi);

/* procedure to make a move_info to evaluate an expression */

	dcl     ep		 ptr;
	dcl     tp		 fixed bin;
	dcl     vi		 fixed bin;

	call alloc_move_info;
	move_info.expr = "1"b;
	move_info.s_ptr = ep;
	move_info.tuple_var_index = tp;
	move_info.var_ind = vi;

     end make_eval_expr_mi;
%page;
alloc_lit: proc (ldp, lp, lbl);

/* Procedure to allocate a literal in the literal pool */

	dcl     lbl		 fixed bin (35);
	dcl     (ldp, lp)		 ptr;

	li.encd_proc = "0"b;
	li.src_ptr,
	     li.srcd_ptr,
	     li.encdd_ptr = null;
	li.litd_ptr = ldp;
	li.encd_blen = 0;
	call mrds_dsl_make_literal$alloc (dbcb_ptr, addr (li), icode);
	if icode ^= 0 then call error (icode);
	lbl = li.lit_blen;
	lp = li.lit_ptr;

     end alloc_lit;
%page; build_vectors: proc;

/* Here is where we build the 'shortened' simple_typed_vector for each tuple variable.
   If the whole tuple has been selected, the 'whole' one in the resultant is used. */

	do i = 1 to range.num_vars;
	     bv_stv_ptr = tuple_info.tuple (i).tuple_ptr; /* simple_typed_veector for whole 'view' */
	     bv_ri_ptr = range.tup_var (i).ri_ptr;	/* rm_rel_info ptr */
	     bv_idl_ptr = bv_ri_ptr -> rm_rel_info.id_list_ptr; /* id_list for whole 'view' */
	     if range.tup_var (i).whole_tuple_selected
	     then do;				/* just grab what's already available */
		     range.tup_var (i).stv_ptr = bv_stv_ptr;
		     range.tup_var (i).idl_ptr = bv_idl_ptr;
		end;
	     else do;				/* Build a simple_typed_vector and an id_list */
		     il_number_of_ids = bv_ri_ptr -> rm_rel_info.num_attr; /* Build it oversize */
		     allocate id_list in (select_area) set (id_list_ptr);
		     id_list.version = ID_LIST_VERSION_1;
		     range.tup_var (i).idl_ptr = id_list_ptr;

		     id_list.number_of_ids = 0;
		     do k = 1 to il_number_of_ids;
			if range.tup_var (i).needed_bits.attr (k)
			then do;			/* get the proper id for relation */
				id_list.number_of_ids = id_list.number_of_ids + 1;
				id_list.id (id_list.number_of_ids) = bv_idl_ptr -> id_list.id (k);
			     end;
		     end;
		     if id_list.number_of_ids ^= 0
		     then do;
			     stv_number_of_dimensions = id_list.number_of_ids;
			     allocate simple_typed_vector in (select_area) set (simple_typed_vector_ptr);
			     simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
			     range.tup_var (i).stv_ptr = simple_typed_vector_ptr;

			     stv_number_of_dimensions = 0; /* use for walking through the vector */
			     do k = 1 to il_number_of_ids; /* walk the WHOLE relation */
				if range.tup_var (i).needed_bits.attr (k)
				then do;
					stv_number_of_dimensions = stv_number_of_dimensions + 1;
					simple_typed_vector.dimension (stv_number_of_dimensions).value_ptr =
					     bv_stv_ptr -> simple_typed_vector.dimension (k).value_ptr;
				     end;
			     end;
			end;			/* ids to move */
		     else do;			/* no ids to move */
			     range.tup_var (i).stv_ptr = null ();
			end;
		end;				/* build simple_typec_vector */
	end;					/* walk through tuple vars */


	dcl     bv_idl_ptr		 ptr;
	dcl     bv_stv_ptr		 ptr;
	dcl     bv_ri_ptr		 ptr;
	dcl     i			 fixed bin;
	dcl     k			 fixed bin;

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

/* Error Procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;
%page;
	dcl     path_var_ptr	 ptr parm;	/* Input: ptr to path through tuple variables */
	dcl     (xp,				/* work ptr */
	        pa_ptr,				/* to pvp_array */
	        cur_ii_ptr,				/* current pointers for alloc routines */
	        cur_mi_ptr,
                  next_element_id_list_ptr,
	        aip_ptr)		 ptr;		/* to array of attr info ptrs */

	dcl     (code,				/* Output:  status code */
	        icode)		 fixed bin (35);	/* internal status code */

	dcl     (i, j,				/* internal indexes */
	        vind,				/* current var index */
	        ii, mi, si, rni, rvi,			/* indexes into search ops */
	        opr_ind,				/* index to indicate when to add inter op. */
	        count,				/* counter */
	        nv,
	        max_pv)		 fixed bin;	/* highest path var */



	dcl     1 ed		 aligned,		/* encode descriptor */
		2 const		 bit (12) init ("101011000000"b) unal,
		2 len		 fixed bin (23) unal;

	dcl     rotate_ops		 (6) fixed bin init (1, 2, 5, 6, 3, 4); /* used to rotate inequalities
						   rotate_ops(1) =>  = becomes  =
						   rotate_ops(2) => ^= becomes ^=
						   rotate_ops(3) =>  < becomes  >
						   rotate_ops(4) => <= becomes >=
						   rotate_ops(5) =>  > becomes  <
						   rotate_ops(6) => >= becomes <= */
	dcl     pvp_array		 (sv_nvars_init) ptr based (pa_ptr);
	dcl     1 li		 aligned like lit_info;
	dcl     1 current_scopes_flags aligned based (current_scope_ptr) like scope_flags;
          dcl     current_scope_ptr      ptr;

	dcl     (mrds_data_$max_attributes,
	        mrds_data_$max_id_len,
	        mrds_data_$max_safe_tids_returned_per_call,
	        mrds_data_$max_tids_returned_per_call,
	        mrds_data_$max_select_items) ext fixed bin (35);

	dcl     (addr,
                   addrel,
	        fixed,
	        null,
	        rel,
	        string,
	        unspec)		 builtin;

	dcl     bit36a		 bit (36) aligned based;
	dcl     MODULE_NAME		 char (22) init ("mrds_dsl_gen_srch_prog");
	dcl     mrds_dsl_make_literal$alloc entry (ptr, ptr, fixed bin (35));
	dcl     mrds_error_$internal_error fixed bin (35) ext static;
	dcl     comparison_var_id	 fixed bin;	/* Index of tuple variable for second comparison value of zero. */
	dcl     compare_within_tuple	 bit (1);		/* 1 => both comparison values depend on the
						   same tuple. */
	dcl     collection_index	 bit (36) aligned;	/* index of the collection to be searched */
	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     mu_data_class$varying	 entry (ptr) returns (bit (1) aligned);
	dcl     sub_err_		 entry () options (variable);
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     current_max_tids_per_call fixed bin (35);
%page;
%include mdbm_scope_info;
%page;
%include dm_element_id_list;
%page;
%include dm_operator_constants;
%page;
%include dm_range_constants;
%page;
%include dm_relation_spec;
%page;
%include dm_specification_head;
%page;
%include vu_typed_vector;
%page;
%include dm_id_list;
%page;
%include mrds_dbcb;
%page;
%include mrds_predicate_tree;
%page;
%include mrds_optimize_tables;
%page;
%include mrds_search_ops;
%page;
%include mrds_search_vars;
%page;
%include mrds_range;
%page;
%include mrds_tuple_info;
%page;
%include mrds_lit_info;
%page;
%include mrds_expressions;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_index;
%page;
%include mdbm_rtrv_info;
%page;
%include mdbm_ind_sel_info;
%page;
%include mdbm_comp_val_list;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_debug_names;

     end mrds_dsl_gen_srch_prog;




		    mrds_dsl_get_attribute_list.pl1 08/01/88  1347.3r w 08/01/88  1314.0      106641



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

mrds_dsl_get_attribute_list: get_attribute_list: procedure (db_index, relation_name, area_ptr,
	structure_version, mrds_attribute_list_ptr, error_code);

/* DESCRIPTION:

   Given a database opening index, and a pointer to a freeing area,
   and the name of a relation for which information is desired,
   this routine will return a structure containing the names
   of all the attributes in the model that the opening has in it's view.
   It indicates whether this was a submodel
   opening, and returns submodel alias names as well in that case.
   The name of the attributes domain is returned, along with
   descriptors for both the database and user views of the data type
   (these will be the same unless a domain -decode_dcl was used in the CMDB source)
   It also indicates whether the attribute can be used as indexed.
*/

/* PARAMETERS:

   db_index - - (input) fixed bin(35), the database opening index as returned from dsl_$open,
   this may be an opening through either a model or submodel of any version.

   relation_name - - (input) char(*), the name of the relation for which attriubtes
   detailed information is to be returned. If this is a submodel opening,
   then the submodel name of the relation should be used.

   area_ptr - - (input) ptr, pointer to a freeing area in which the returned
   structure is to be allocated. Allow about 40 words per expected attribute for the area size.

   structure_version - - (input) fixed bin, the desired version of the structure
   that is to be returned.

   mrds_attribute_list_ptr - - (output) ptr, points to the allocated structure
   as defined in the include file mrds_attribute_list.incl.pl1

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

/* HISTORY:

   Originally written by Jim Gray - - March 1981

   81-06-01 Jim Gray : modified to use new resultant structure.

   81-12-15 R. Lackey : Modified to search rm_rel_array for full name. TR11887

   83-02-18 B. G. Moberg : Added check to detect long relation names

   83-04-07 Davids: Explicitly declared the builtin function length.
*/

/* initialize */

	error_code = 0;
	mrds_attribute_list_ptr = null ();
	clean_up_condition = "0"b;

	on cleanup begin;
		clean_up_condition = "1"b;
		call clean_up ();
	     end;

/*  check for a valid opening index */

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

/* good opening index, check for a good area */

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

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

/* check for a known structure version */

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

/* check for a supported database version */

					rdbi_ptr = dbcb.rdbi_ptr;
					if rm_db_info.db_version ^= 4 then
					     error_code = mrds_error_$version_not_supported;
					else do;

/* check on the user class for secured databases */

						call mrds_dm_authorization$get_user_class
						     (rtrim (rm_db_info.db_path), addr (local_area),
						     mrds_authorization_structure_version, mrds_authorization_ptr, error_code);

/* check for a known relation name */

						if error_code = 0 then
						     call check_relation ();

						if error_code = 0 then do;

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

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

/* fill in the info in a structure in the users area */

							mrds_attribute_list_num_attrs_init = rm_rel_info.num_attr;
							allocate mrds_attribute_list set (mrds_attribute_list_ptr) in (users_area);
							revert area;

							unspec (mrds_attribute_list) = "0"b;
							mrds_attribute_list.version = mrds_attribute_list_structure_version;
							mrds_attribute_list.num_attrs_in_view = mrds_attribute_list_num_attrs_init;
							mrds_attribute_list.submodel_view = dbcb.dsm_sw;

							if rm_db_info.mdbm_secured then
							     mrds_attribute_list.access_info_version = 5;
							else mrds_attribute_list.access_info_version = 4;

/* fill in the details for each attribute in the view */

							do i = 1 to mrds_attribute_list_num_attrs_init;

							     call get_attribute_data ();

							end;

						     end;
					     end;
				     end;
			     end;
		     end;
	     end;

skip_allocate:

	return;

check_relation: procedure ();

/* routine to check for a good relation name, and get the
   acl's set on it for use as the attribute acl */

	rmra_ptr = rm_db_info.ra_ptr;
	i = 1;

/* see if the given name is in this view of the database */


/* BEGIN CHANGE 81-12-15 RDL ********************************************** */

	if length (rtrim (relation_name)) > 30
	then do;
		error_code = mrds_error_$rel_name_too_long;
		return;
	     end;
	rel_name_32 = rtrim (relation_name);
	i = index (string (rm_rel_array.name), "!" || rel_name_32);

/* BEGIN CHANGE 81-12-15 RDL ********************************************** */


	if i = 0 then
	     error_code = mrds_error_$unknown_relation_name;
	else do;

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

/* good relation name, get it's multics acls */

		rmri_ptr = rm_rel_array.rel_data (i).ri_ptr;

		call mu_get_relation_acl (rtrim (rm_db_info.db_path),
		     rtrim (rm_rel_info.model_name),
		     mrds_authorization.administrator,
		     read_acl, write_acl, error_code);

		if error_code = 0 then do;

			multics_access_string = "";

			if read_acl then
			     multics_access_string = multics_access_string || "r";

			if write_acl then
			     multics_access_string = multics_access_string || "w";

			if multics_access_string = "" then
			     multics_access_string = "n";
		     end;

	     end;

     end;

get_attribute_data: procedure ();

/* routine to get the data for an individual attribute in the users view */

	rai_ptr = rm_rel_info.attr_ptrs (i);
	mrds_attribute_list.attribute (i).submodel_name = rm_attr_info.name;
	rdi_ptr = rm_attr_info.domain_ptr;
	mrds_attribute_list.attribute (i).user_data_type =
	     rm_domain_info.user_desc;
	mrds_attribute_list.attribute (i).indexed =
	     ((rm_attr_info.index_attr) |
	     ((rm_attr_info.key_attr) & (rm_attr_info.key_order = 1)));

/* only DBA's can know model names in a secured db */

	if rm_db_info.mdbm_secured & ^mrds_authorization.administrator then do;
		mrds_attribute_list.attribute (i).domain_name = " ";
		mrds_attribute_list.attribute (i).model_name = " ";
	     end;
	else do;
		mrds_attribute_list.attribute (i).model_name = rm_attr_info.model_name;
		mrds_attribute_list.attribute (i).domain_name = rm_domain_info.name;
	     end;

/* find out what the multics acls are on this attribute */

	mrds_attribute_list.attribute (i).system_acl = multics_access_string;

	if mrds_attribute_list.access_info_version = 4 then
	     mrds_attribute_list.attribute (i).mrds_access,
		mrds_attribute_list.attribute (i).effective_access =
		mrds_attribute_list.attribute (i).system_acl;

/* fill in the access for submodel security */

	else do;					/* version 5 submodel security */

		mrds_access_string = "";

		if rm_attr_info.read_perm then
		     mrds_access_string = mrds_access_string || "r";
		if rm_attr_info.modify_perm then
		     mrds_access_string = mrds_access_string || "m";
		if mrds_access_string = "" then
		     mrds_access_string = "n";

		mrds_attribute_list.attribute (i).mrds_access = mrds_access_string;

/* fill in the effective access for attribute level security */

		if write_acl then
		     mrds_attribute_list.attribute (i).effective_access = mrds_access_string;
		else if read_acl &
			index (mrds_access_string, "r") ^= 0 then
		     mrds_attribute_list.attribute (i).effective_access = "r";
		else mrds_attribute_list.attribute (i).effective_access = "n";
	     end;
     end;

clean_up: procedure ();

/* routine to get rid of allocated space, if an error
   occurs, or cleanup is signaled */

	if clean_up_condition then do;

		if mrds_attribute_list_ptr ^= null () then do;

			free mrds_attribute_list_ptr -> mrds_attribute_list in (users_area);

			mrds_attribute_list_ptr = null ();

		     end;

	     end;

     end;

	declare area		 condition;	/* happens when space too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets details on the area */
	declare area_ptr		 ptr;		/* points to a freeing area */
	declare clean_up_condition	 bit (1);		/* set on if cleanup signaled */
	declare cleanup		 condition;	/* occurs upon quit/release */
	declare db_index		 fixed bin (35);	/* database opening index */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$area_too_small fixed bin (35) ext; /* area too small error */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* unknown structure version */
	declare i			 fixed bin;	/* loop index */
	declare local_area		 area (1024);	/* space for return args */
	declare mu_get_relation_acl	 entry (char (*), char (*),
				 bit (1), bit (1), bit (1), fixed bin (35)); /* gets Multics acl's */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets pointer to resultant model */
	declare mrds_access_string	 char (4) varying;	/* mrds access encoding */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* gets user class */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* bad opening index */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* area without freeing attribute */
	declare mrds_error_$rel_name_too_long fixed bin (35) ext; /* name too long */
	declare mrds_error_$unknown_relation_name fixed bin (35) ext; /* name not in opening view */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 or later */
	declare multics_access_string	 char (4) varying;	/* multics access encoding */
	declare read_acl		 bit (1);		/* on => "r" Multics acl on relation data */
	declare relation_name	 char (*);	/* name of relation for which info is desired */
	dcl     rel_name_32		 char (32);	/* Used to search rm_rel_array */
	declare structure_version	 fixed bin;	/* desired version of structure */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare users_area		 area (sys_info$max_seg_size) based (area_ptr); /* overlay for input area */
	declare write_acl		 bit (1);		/* on => "w" Multics acl on relation data */
	declare (addr, empty, fixed, index, null,
	        rel, rtrim, string, length, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local storage for area details */

%include mrds_attribute_list;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_authorization;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_db_info;
%page;
%include area_info;

     end;




		    mrds_dsl_get_builtins.pl1       08/01/88  1347.3r w 08/01/88  1315.0       70704



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

mrds_dsl_get_builtins: procedure (dbcb_ptr, error_code);

/*
                   BEGIN_DESCRIPTION
   This routine builds a threaded list of known mrds builtin
   scalar functions from the object mrds_builtin_ and puts the
   head of that list in a pointer at dbcb.sfi_ptr.
                   END_DESCRIPTION
*/

/* PARAMETERS:

   dbcb_ptr - - (input) pointer, pointer to the dbcb structure (mrds_dbcb.incl.pl1)
   for the database opening involved.

   error_code - - (output) fixed bin (35), status error code

*/

/* HISTORY:

   81-06-23 Jim Gray : moved code from mrds_dsl_open  into  separate
   routine,  to  be  called  only  when  a builtin function is first
   referenced, for performance purposes.

   81-09-15 Davids: changed declaration of caller_name to char  (21)
   from  char  (15)  since caller name is 21 characters and the code
   will not compile when -prefix stringsize is used.

   81-09-21 Davids: modified code to determine if external entry  is
   a  function to first check the length of the name and if its less
   than 6 characters assume its a  function  name  since  since  all
   _info  entries  are  at  least  6  characters.  This  prevents  a
   stringrange error from occuring when a subtr is done on the  name
   to determine if the last 5 characters are _info

   83-02-28 Davids: explicitly declared variables that were declared by
   context of implication and removed declarations to variables that
   were never referenced.
*/


	call cu_$decode_entry_value (mrds_builtin_, mb_ptr, ptr_sink); /* get pointer to mrds_builtin_ object */
	if mb_ptr = null () then do;
		error_code = mrds_error_$bad_builtin_obj;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
		     "No mrds_builtin_ object segment was found.");
	     end;
	else do;					/* if found segment */

/* get the object info for the segment */

		mb_ptr = ptr (mb_ptr, 0);		/* point to base of seg */

		call hcs_$status_mins (mb_ptr, mb_type, mb_bc, error_code); /* get bit count */
		if error_code ^= 0 then
		     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
			"Unable to get bit count of mrds_builtin_ object segment.");
		else do;

			call object_info_$brief (mb_ptr, mb_bc, addr (obj_info), error_code); /* get object data */
			if error_code ^= 0 then
			     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
				"Unable to get the object data for mrds_builtin_ object segment.");
			else do;

/* find the mrds_builtin_ definition in the object segment */

				found = "0"b;
				end_of_def = "0"b;
				do d_ptr = addrel (obj_info.defp, obj_info.defp -> bit18) /* search for class 3 defn */
				     repeat addrel (obj_info.defp, d_ptr -> definition.value)
				     while (^found & ^end_of_def);

				     if addrel (obj_info.defp, d_ptr -> definition.symbol) -> acc.string = MB then do;
					     found = "1"b;
					     saved_d_ptr = d_ptr;
					end;
				     else if addrel (obj_info.defp, d_ptr -> definition.forward) -> bit18 ^= "0"b then ;
				     else end_of_def = "1"b;

				end;

				if ^found then do;
					error_code = mrds_error_$bad_builtin_obj;
					call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
					     "Unable to find a definition for mrds_builtin_ in the object segment.");
				     end;
				else do;

/* look through all entry points in this block */

					d_ptr = saved_d_ptr;

					do d_ptr = addrel (obj_info.defp, d_ptr -> definition.segname)
					     repeat addrel (obj_info.defp, d_ptr -> definition.forward)
					     while (d_ptr -> definition.class ^= SEG
					     & error_code = 0 & d_ptr -> definition.forward ^= "0"b);

/* is this an external entry point */

					     if d_ptr -> definition.class ^= TEXT
						| d_ptr -> definition.flags.ignore
						| ^d_ptr -> definition.flags.entry then ;
					     else do; /* if external entry point */

/* is this external entry a function */

						     acc_ptr = addrel (obj_info.defp, d_ptr -> definition.symbol); /* entry ptr */

/* BEGIN CHANGE 81-09-21 */

						     flag = "0"b;
						     if acc.len < 6
						     then flag = "1"b;
						     else
							if substr (acc.string, acc.len - 4, 5) ^= "_info" & acc.string ^= MB
						     then flag = "1"b;

						     if flag
						     then do; /* if not info or mrds_builtin_ entry */

/* END    CHANGE 81-09-21 */

/* entry = function, thread it onto the list */

							     call mrds_dsl_thread_fn_list (dbcb_ptr,
								addrel (obj_info.textp, d_ptr -> definition.value), error_code);
							     if error_code = 0 then ;
							     else call sub_err_ (error_code, caller_name, continue,
								     info_ptr, return_value, "^/^a",
								     "Unable to add a function info to the list of builtins.");
							end; /* if true function entry */
						end; /* if text entry */
					end;	/* entry point loop */

/* make sure at least one function was defined */

					if dbcb.sfi_ptr ^= null | error_code ^= 0 then ;
					else do;	/* if did not find any builtins */
						error_code = mrds_error_$bad_builtin_obj;
						call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a",
						     "No builtin function definitions were found in the object mrds_builtin_.");
					     end;
				     end;
			     end;
		     end;
	     end;					/* if builtin segment found */

	dcl     1 acc		 aligned based (acc_ptr), /* template for acc string */
		2 len		 fixed bin (8) unal,
		2 string		 char (0 refer (acc.len)) unal;

	dcl     SEG		 init ("011"b) bit (3) int static options (constant);
	dcl     TEXT		 init ("000"b) bit (3) int static options (constant);

	declare mb_ptr		 ptr;
	declare d_ptr		 ptr;
	declare ptr_sink		 ptr;
	declare acc_ptr		 ptr;
	declare found		 bit (1);		/* on => class 3 definition for mrds_builtin_ found */
	declare end_of_def		 bit (1);		/* on => end of definition section */
	declare saved_d_ptr		 ptr;		/* temporary storage for pointer to found definition */
	declare MB		 char (13) init ("mrds_builtin_"); /* name of object definition */
	declare sub_err_		 entry options (variable); /* error reporting routine */
	declare caller_name		 char (21) init ("mrds_dsl_get_builtins");
						/* CHANGE 81-09-15 name of calling routine */
	dcl     flag		 bit (1) unal;	/* CHANGE 81-09-21 a decision flag */
	declare continue		 char (1) init ("c"); /* don't stop after printing */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare error_code		 fixed bin (35);	/* error status encoding */
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     cu_$decode_entry_value entry (entry, ptr, ptr);
	declare mrds_builtin_	 entry ();
	dcl     mrds_dsl_thread_fn_list entry (ptr, ptr, fixed bin (35));
	declare mrds_error_$bad_builtin_obj fixed bin (35) ext;
	declare sys_info$max_seg_size	 fixed bin (35) ext;
	declare (fixed, addr, addrel, rel, null, ptr, substr) builtin;

	dcl     bit18		 bit (18) based;	/* template */
	dcl     mb_bc		 fixed bin (24);	/* bit count of builtin seg */
	dcl     mb_type		 fixed bin (2);	/* seg type code for mrds_builtin_ */
	dcl     1 obj_info		 aligned like object_info;

%include mrds_dbcb;
%page;
%include definition;
%page;
%include object_info;

     end;




		    mrds_dsl_get_fn_info.pl1        08/01/88  1347.3r w 08/01/88  1315.0       31842



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

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

mrds_dsl_get_fn_info: get_fn_info: proc (dbi, fn_name, area_ptr, info_ptr, code);

/* NOTES:

   Procedure  to  return  the  scalfn_info  block  corresponding  to the given
   function name.



   HISTORY:

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

   79-05-01 J. B. Picone: Modified to correct the setting of sfi_ptr.

   81-06-17  Rickie E.  Brinegar: Modified to call dsl_v1_$get_fn_info for old
   version databases.

   81-06-23 Jim Gray : added call to mrds_dsl_get_builtins in order to
   get builtin function definitions on an as needed basis.

   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)
*/

	call mu_database_index$get_resultant_model_pointer (dbi, dbcb_ptr); /* get dbcb ptr */
	if dbcb_ptr = null then
	     call error (mrds_error_$invalid_db_index);

/* BEGIN CHANGE 81-06-23 ********************************************** */

	if dbcb.sfi_ptr = null () then do;
		call mrds_dsl_get_builtins (dbcb_ptr, icode);
		if icode ^= 0 then call error (icode);
	     end;

/* END CHANGE 81-06-23 ********************************************** */

	do sfi_ptr = dbcb.sfi_ptr repeat scalfn_info.fwd_ptr /* search for function block */
	     while (sfi_ptr ^= null);
	     if fn_name = scalfn_info.name then
		go to null_sfi_ptr;
	end;
null_sfi_ptr: ;
	if sfi_ptr = null then
	     call error (mrds_error_$undef_fun);

	nsfi_args_init = scalfn_info.nargs;
	allocate scalfn_info in (wk_area) set (info_ptr);
	info_ptr -> scalfn_info = scalfn_info;		/* copy to callers area */

	code = 0;
exit:
	return;

error: proc (cd);

/* error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;

%include mrds_dbcb;
%page;
%include mrds_scalfn_info;

	dcl     (code,				/* Output:  status code */
	        dbi)		 fixed bin (35);	/* Input:  data base index */

	dcl     fn_name		 char (*);	/* Input:  name of function */

	dcl     info_ptr		 ptr;		/* Input:  pointer to recieving structure */
	dcl     area_ptr		 ptr;		/* Input: pointer to alloc. area */
	dcl     wk_area		 area (sys_info$max_seg_size) based (area_ptr);

	dcl     (mrds_error_$invalid_db_index,
	        mrds_error_$undef_fun,
	        sys_info$max_seg_size) fixed bin (35) ext;

	dcl     (null,
	        addr,
	        rel,
	        fixed)		 builtin;

	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	declare icode		 fixed bin (35);	/* temp error code */
	declare mrds_dsl_get_builtins	 entry (ptr, fixed bin (35)); /* defines builtins */

     end mrds_dsl_get_fn_info;




		    mrds_dsl_get_population.pl1     08/01/88  1347.3r w 08/01/88  1314.0      143595



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

/* HISTORY:

   Originally written by Jim Gray - - March 1981

   81-03-27 Jim Gray : added dbcb_ptr parameter to mu_get_rel_size
   as part of getting rid of mus_ptr_man module.

   81-06-01 Jim Gray : changed to use new resultant structure.

   81-12-15 R. Lackey : Modified to correcly search rm_rel_array for rel_name. TR11887.

   82-09-24 Davids: Modified to call mu_rel_statistics$return_tuple_count
   instead of mu_get_rel_size. This required testing rm_rel_info.opening_id
   and calling dbcb.relmgr_entries.open if the relation wasn't open yet,
   and that required including the mdbm_rm_rel_info include file.

   82-12-10 Davids: Modified the call to dbcb.relmgr_entries.open by
   enclosing the db_path 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 is declared as character aligned in
   the include file while the entry expects character unaligned.

   83-02-01 Mike Kubicar : added an "error" procedure and removed the horrible
   nestings used to handle error codes.  This was needed in order to insert
   the transaction processing include files.  Transaction processing was
   also added.

   83-02-18 Bert Moberg : Added check for relation names greater than 30 chars

   83-04-07 Davids: Explicitly declared the builtin function length.

   83-05-23 Mike Kubicar : converted for new mu_rel_statistics calling
   sequence.

   85-01-23 Delight Hurst : Maked sure that get_population calls to
   relmgr_entries.open with the model name and not to return as an error in
   a submodel opening.
*/

mrds_dsl_get_population: get_population: procedure ();

/* DESCRIPTION:

   This routine will return the current tuple count for either
   permanent or temporary relations. If the relation identifier
   given is numeric, or character and not starting with a letter,
   then a temp rel index is assumed, and the temp rel population
   routine is called, otherwise mu_rel_statistics$return_tuple_count
   is called for the permanent relation name.

*/
%page;
/* PARAMETERS:

   db_index - - (input) fixed bin(35), is the integer returned from
   a call to dsl_$open, for the desired opening of the database.

   relation_identifier - - (input) char or fixed bin(35), if this argument
   is fixed bin (35), or char and does not start with a letter, it is assumed
   to be a temporary relation index. If it is char starting with a letter,
   it is assumed to be a permanent relation name. In either case,
   it indicates which relation in this opening view is to have it's current
   tuple count returned.

   tuple_count - - (output) fixed bin(35), is the current tuple count
   of the relation specified by the relation_identifier

   error_code - - (output) is the standard status code. It will be 0 unless
   the relation or specified opening are unknown, or some other error occurs.

*/
%page;
/* initialize */

	error_code = 0;
	tuple_count = 0;
	mstxn_txn_id = "0"b;

/* make sure that we were called with 4 args,   and that the entry was declared options (variable) */

	call cu_$arg_list_ptr (al_ptr);
	nargs = arg_list.desc_count / 2;
	if nargs ^= 4 then do;
		call sub_err_ (error_table_$wrong_no_of_args, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a^a",
		     "The number of arguments =", nargs,
		     "was not the required 4",
		     ", or the entry was not declared ""options (variable)"".");
		return;
	     end;

/* get the offset of the descriptors in the argument list */

	if arg_list.code = SPECIAL then
	     desc_index = nargs + 1;
	else desc_index = nargs;
	num_ptrs = desc_index + nargs;

/* get the database index argument */

	call mu_convert_parameter$convert_input_parameter (arg_list.arg_des_ptr (1),
	     arg_list.arg_des_ptr (desc_index + 1),
	     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"".");
		call error (error_code);
	     end;

/* check for a valid database index, and get the 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.");
		call error (error_code);
	     end;

/* check that the database version is supported */

	rdbi_ptr = dbcb.rdbi_ptr;
	if rm_db_info.db_version < 4 then
	     call error (mrds_error_$version_not_supported);


/* Start transactions */
	mstxn_transactions_needed = dbcb.transactions_needed;
	on cleanup call mstxn_cleanup;
	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;

/* get the relation identifier, and decide if we are
   to get the population of a temporary relation or a permanent relation
   first try converting the argument to a fixed bin (35) temp rel index */

	call mu_convert_parameter$convert_input_parameter
	     (arg_list.arg_des_ptr (2), arg_list.arg_des_ptr (desc_index + 2),
	     temp_rel_index_ptr, addr (fixed_bin_35_descr), addr (local_area), error_code);
	if error_code = 0 then
	     call mrds_dsl_define_temp_rel$get_temp_rel_population
		(db_index, temp_rel_index, tuple_count, error_code);
	else do;

/* not a temp rel index, check for character argument */

		error_code = 0;
		desc_ptr = arg_list.arg_des_ptr (desc_index + 2);
		if descriptor.type = 21 | descriptor.type = 22 then do;
			rel_name_ptr = arg_list.arg_des_ptr (2);
			if descriptor.type = 21 then
			     rel_name_len = fixed (string (descriptor.size));
			else do;			/* get current length for varying strings */
				rel_name_len_ptr = addrel (rel_name_ptr, -1);
				rel_name_len = rel_name_len_ptr -> fixed_bin_35_ovrly;
			     end;
			call get_perm_rel_population (db_index, dbcb_ptr, rel_name,
			     tuple_count, error_code);
		     end;
		else do;

/* bad relation identifier parameter */

			error_code = error_table_$bad_arg;
			call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^a",
			     "The relation identifier argument was not character,",
			     "and could not be converted to ""fixed binary (35) aligned"".");
			call error (error_code);
		     end;
	     end;

/* assign the output values for the error code and the tuple count */

	if arg_list.arg_des_ptr (desc_index + 3) -> bit_36_ovrly = fixed_bin_35_descr then
	     arg_list.arg_des_ptr (3) -> output_tuple_count = tuple_count;
	else do;
		error_code = error_table_$badcall;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "^/^a^/^a ^d",
		     "The tuple_count variable was not declared ""fixed bin (35) aligned"".",
		     "The tuple_count value is =", tuple_count);
		call error (error_code);
	     end;


exit:
	mftxn_code = error_code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0
	then error_code = mftxn_code;
	if arg_list.arg_des_ptr (desc_index + 4) -> bit_36_ovrly = fixed_bin_35_descr then
	     arg_list.arg_des_ptr (4) -> output_error_code = error_code;
	else do;
		call convert_status_code_ (error_code, short_info, long_info);
		call sub_err_ (error_table_$badcall, caller_name, continue, info_ptr, return_value,
		     "^/^a^/^a^/^a",
		     "The error code (last) argument was not declared ""fixed bin (35) aligned"".",
		     "The error_code expands to the following message:", long_info);
	     end;
%page;
error:
     proc (cd);

	dcl     cd		 fixed bin (35);

	error_code = cd;
	goto exit;
     end error;

%page;
get_perm_rel_population: procedure (dbi, dbcb_ptr, relation, count, err_code);

/* routine to get the number of tuples currently stored in   a permanent relation, for the given opening
   PARAMETERS:
   dbi - - (input) fixed bin (35), the database opening index

   dbcb_ptr - - (input) pointer, pointer to the resultant model

   relation - - (input) char(*), the name of the permanent
   relation in the users view of the database for this opening

   count - - (output) fixed bin(35), the number of tuples currently
   stored in the given relation

   err_code - - (output) fixed bin(35), the error status encoding
*/

/* first check for a legal relation name, known in this opening */

	rmra_ptr = rm_db_info.ra_ptr;

/* BEGIN CHANGE 81-12-15 RDL ********************************************* */

	if length (rtrim (relation)) > 30 then call error (mrds_error_$rel_name_too_long);
	rel_name_32 = rtrim (relation);		/* Used to seach rel_array */
	i = index (string (rm_rel_array.name), "!" || rel_name_32);

/* END   CHANGE 81-12-15 RDL ********************************************* */

	if i = 0 then
	     err_code = mrds_error_$unknown_relation_name;
	else do;

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

/* good name, call to get the tuple count */

/*make sure you have the model name, not the submodel name */
		model_relation = rm_rel_array.rel_data.model_name (i);
		rel_ptr = rm_rel_array.rel_data.ri_ptr (i);
		if rel_ptr -> rm_rel_info.opening_id = "0"b
		then call dbcb.relmgr_entries.open ((rm_db_info.db_path), model_relation, rel_ptr -> rm_rel_info.opening_id, err_code);
		if err_code = 0
		then call mu_rel_statistics$return_tuple_count (
			db_index, dbcb.relmgr_entries.create_cursor,
			dbcb.relmgr_entries.open,
			dbcb.relmgr_entries.get_count,
			dbcb.cursor_ptrs_storage_ptr,
			dbcb.cursor_storage_area_ptr, rel_ptr,
			count, err_code);

	     end;
%page;
	dcl     dbcb_ptr		 ptr;		/* points to resultant model for opening */
	dcl     i			 fixed bin;	/* array index */
	dcl     model_relation	 char (30);	/* name of relation in model */
	dcl     mrds_error_$unknown_relation_name fixed bin (35) ext; /* name not in view */
	dcl     mrds_error_$rel_name_too_long fixed bin (35) ext; /* name too long */
	dcl     mu_rel_statistics$return_tuple_count entry (fixed bin (35), entry, entry, entry, ptr, ptr, ptr,
				 fixed bin (35), fixed bin (35));
	dcl     rel_ptr		 ptr;		/* points to rm_rel_info structure */
	dcl     dbi		 fixed bin (35);	/* database opening index */
	dcl     relation		 char (*);	/* name of relation in users view */
	dcl     count		 fixed bin (35);	/* current tuple count */
	dcl     err_code		 fixed bin (35);	/* error status encoding */

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



should_rollback:
     proc returns (bit (1));
	return ("0"b);
						/* No intention of rolling back any transactions at this point. */
     end should_rollback;
%page;
	dcl     SPECIAL		 fixed bin init (8);/* extra point in arg list */
	dcl     (addrel, index, null, fixed, addr,
	        rel, string, empty, length, rtrim) builtin;
	dcl     any_other		 condition;
	dcl     bit_36_ovrly	 bit (36) based;	/* overlay for looking at argument descriptors */
	dcl     caller_name		 char (32) init ("mrds_dsl_get_population"); /* name of calling routine */
	dcl     cleanup		 condition;
	dcl     continue		 char (1) init ("c"); /* dont stop after printing mesg */
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned); /* gets error code message */
	dcl     cu_$arg_list_ptr	 entry (ptr);	/* gets pointer to arg list */
	dcl     db_index		 fixed bin (35) based (db_index_ptr); /* database opening index */
	dcl     db_index_ptr	 ptr;		/* points to database index arg */
	dcl     desc_index		 fixed bin;	/* offset of descriptors in arg list array */
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     error_table_$bad_arg	 fixed bin (35) ext;/* rel id not temp rel index or rel name */
	dcl     error_table_$badcall	 fixed bin (35) ext;/* variables not fixed bin(35) */
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext; /* arg count ^= 4 */
	dcl     fixed_bin_35_descr	 bit (36) init ("100000100000000000000000000000100011"b); /* descriptor for FB35 variable */
	dcl     fixed_bin_35_ovrly	 fixed bin (35) based; /* overlay for 35 variable */
	dcl     info_ptr		 ptr init (null ());/* unused */
	dcl     local_area		 area (1024);	/* space for parameter conversion */
	dcl     long_info		 char (100) aligned;/* long error code mesg */
	dcl     mu_convert_parameter$convert_input_parameter entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); /* gets user data */
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* checks for good db index */
	dcl     mrds_dsl_define_temp_rel$get_temp_rel_population entry
				 (fixed bin (35), fixed bin (35), fixed bin (35), fixed bin (35)); /* gets temp rel tuple count */
	dcl     mrds_error_$invalid_db_index fixed bin (35) ext; /* index not to open db */
	dcl     mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 db */
	dcl     nargs		 fixed bin;	/* number of arguments */
	dcl     output_error_code	 fixed bin (35) based; /* for assigning users error code */
	dcl     output_tuple_count	 fixed bin (35) based; /* for assigning users tuple count */
	dcl     rel_name		 char (rel_name_len) based (rel_name_ptr); /* perm rel name */
	dcl     rel_name_len	 fixed bin (21);	/* length of perm rel name */
	dcl     rel_name_len_ptr	 ptr;		/* points to count field of varyingf string */
	dcl     rel_name_ptr	 ptr;		/* points to perm rel name arg */
	dcl     rel_name_32		 char (32);	/* Used to search rm_rel_array */
	dcl     return_value	 fixed bin (35) init (0); /* unused */
	dcl     short_info		 char (8) aligned;	/* short error code mesg */
	dcl     sub_err_		 entry options (variable); /* reports error details */
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	dcl     temp_rel_index	 fixed bin (35) based (temp_rel_index_ptr); /* temp rel indicator */
	dcl     temp_rel_index_ptr	 ptr;		/* points to temp rel index */
	dcl     tuple_count		 fixed bin (35);	/* number of tuples in perm or temp rel */
%page;
%include mdbm_descriptor;
%page;
%include mdbm_arg_list;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_db_info;


     end;




		    mrds_dsl_get_relation_list.pl1  08/01/88  1347.3r w 08/01/88  1314.0       83250



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


mrds_dsl_get_relation_list: get_relation_list: procedure (db_index, area_ptr, structure_version,
	mrds_relation_list_ptr, error_code);

/* DESCRIPTION:

   Given a database opening index, and a pointer to a freeing area,
   this routine will return a structure containing the names
   of all the relations in the model that the opening has in it's view.
   It indicates whether this was a submodel
   opening, and returns submodel alias names as well in that case.
   For secured databases, no model information is returned,
   unless the user is  a DBA.

*/

/* PARAMETERS:

   db_index - - (input) fixed bin(35), the database opening index as returned from dsl_$open,
   this may be an opening through either a model or submodel of any version.

   area_ptr - - (input) ptr, pointer to a freeing area in which the returned
   structure is to be allocated. Allow about 30 words per expected relation for the area size.

   structure_version - - (input) fixed bin, the desired version of the
   relation info structure to be returned.

   mrds_relation_list_ptr - - (output) ptr, points to the allocated structure
   as defined in the include file mrds_relation_list.incl.pl1

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

*/

/* HISTORY:

   Originally written by Jim Gray - - March 1981

*/

/* initialize */

	error_code = 0;
	mrds_relation_list_ptr = null ();
	clean_up_condition = "0"b;

	on cleanup begin;
		clean_up_condition = "1"b;
		call clean_up ();
	     end;

/*  check for a valid opening index */

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

/* good opening index, check for a good area */

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

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

/* check for a known structure version */

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

/* check for a supported database version */

					rdbi_ptr = dbcb.rdbi_ptr;
					if rm_db_info.db_version ^= 4 then
					     error_code = mrds_error_$version_not_supported;
					else do;

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

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

/* fill in the info in a structure in the users area */

						rmra_ptr = rm_db_info.ra_ptr;
						mrds_relation_list_num_rels_init = rm_rel_array.num_rels;
						allocate mrds_relation_list set (mrds_relation_list_ptr) in (users_area);
						revert area;

						unspec (mrds_relation_list) = "0"b;
						mrds_relation_list.version = mrds_relation_list_structure_version;
						mrds_relation_list.num_rels_in_view = mrds_relation_list_num_rels_init;
						mrds_relation_list.submodel_view = dbcb.dsm_sw;

						if rm_db_info.mdbm_secured then
						     mrds_relation_list.access_info_version = 5;
						else mrds_relation_list.access_info_version = 4;

/* check on the user class for secured databases */

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

/* fill in the details for each relation in the view */

							do i = 1 to mrds_relation_list_num_rels_init while (error_code = 0);

							     call get_relation_data ();

							end;

						     end;
					     end;
				     end;
			     end;
		     end;
	     end;

/* clean up before returning */

	call clean_up ();

skip_allocate:
	return;

get_relation_data: procedure ();

/* routine to get the data for an individual relation in the users view */

	rmri_ptr = rm_rel_array.rel_data (i).ri_ptr;
	mrds_relation_list.relation (i).submodel_name = rm_rel_info.name;

/* only DBA's can know model names in a secured db */

	if rm_db_info.mdbm_secured & ^mrds_authorization.administrator then
	     mrds_relation_list.relation (i).model_name = " ";
	else mrds_relation_list.relation (i).model_name = rm_rel_info.model_name;

/* find out what the multics acls are on this relation */

	call mu_get_relation_acl (rtrim (rm_db_info.db_path),
	     rtrim (rm_rel_info.model_name), mrds_authorization.administrator,
	     read_acl, write_acl, error_code);

	if error_code = 0 then do;

		multics_access_string = "";

		if read_acl then
		     multics_access_string = multics_access_string || "r";

		if write_acl then
		     multics_access_string = multics_access_string || "w";

		if multics_access_string = "" then
		     multics_access_string = "n";

		mrds_relation_list.relation (i).system_acl = multics_access_string;

		if mrds_relation_list.access_info_version = 4 then /* relation, not attribute level, security */
		     mrds_relation_list.relation (i).mrds_access,
			mrds_relation_list.relation (i).effective_access =
			mrds_relation_list.relation (i).system_acl;

/* fill in the access for submodel security */

		else do;				/* version 5 submodel security */

			mrds_access_string = "";


			if rm_rel_info.append_tuple_perm then
			     mrds_access_string = mrds_access_string || "a";

			if rm_rel_info.delete_tuple_perm then
			     mrds_access_string = mrds_access_string || "d";

			if mrds_access_string = "" then
			     mrds_access_string = "n";

			mrds_relation_list.relation (i).mrds_access = mrds_access_string;

/* fill in the effective access for attribute level security */

			if write_acl then
			     mrds_relation_list.relation (i).effective_access = mrds_access_string;
			else mrds_relation_list.relation (i).effective_access = "n";
		     end;
	     end;

     end;

clean_up: procedure ();

/* routine to get rid of allocated space, if an error
   occurs, or cleanup is signaled */

	if clean_up_condition | error_code ^= 0 then do;

		if mrds_relation_list_ptr ^= null () then do;

			free mrds_relation_list_ptr -> mrds_relation_list in (users_area);

			mrds_relation_list_ptr = null ();

		     end;

	     end;

     end;

	declare area		 condition;	/* happens when space too small */
	declare area_info_		 entry (ptr, fixed bin (35)); /* gets details on the area */
	declare area_ptr		 ptr;		/* points to a freeing area */
	declare clean_up_condition	 bit (1);		/* set on if cleanup signaled */
	declare cleanup		 condition;	/* occurs upon quit/release */
	declare db_index		 fixed bin (35);	/* database opening index */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$area_too_small fixed bin (35) ext; /* area too small error */
	declare error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	declare error_table_$unimplemented_version fixed bin (35) ext; /* unknown structure version */
	declare i			 fixed bin;	/* loop index */
	declare local_area		 area (1024);	/* space for return args */
	declare mu_get_relation_acl	 entry (char (*), char (*),
				 bit (1), bit (1), bit (1), fixed bin (35)); /* gets users  acls on relation data */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets pointer to resultant model */
	declare mrds_access_string	 char (4) varying;	/* mrds access encoding */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* gets user class */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* bad opening index */
	declare mrds_error_$not_freeing_area fixed bin (35) ext; /* area without freeing attribute */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 or later */
	declare multics_access_string	 char (4) varying;	/* multics access encoding */
	declare read_acl		 bit (1);		/* on => user has "r" on relation data */
	declare structure_version	 fixed bin;	/* desired version of structure */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare users_area		 area (sys_info$max_seg_size) based (area_ptr); /* overlay for input area */
	declare write_acl		 bit (1);		/* on => user has "w" on relation data */
	declare (addr, empty, fixed, null, rel, rtrim, unspec) builtin;
	declare 1 my_area_info	 like area_info;	/* local storage for area details */

%include mrds_relation_list;
%page;
%include mrds_authorization;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_rm_db_info;
%page;
%include area_info;

     end;




		    mrds_dsl_get_rslt_info.pl1      08/01/88  1347.3r w 08/01/88  1314.0      117315



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

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

mrds_dsl_get_rslt_info:
     proc;

exit:
	return;

/* HISTORY:

   77-05-01  J. C. C. Jagernauth: Initially written.

   78-09-01 J. C. C. Jageranuth: Modified for MR7.0.

   80-02-26  Lindsey  L.   Spratt: Modified to fix submodel bug, get_file_rels
   was  using  mr_ptr  instead of model_files_ptr; due to position in argument
   lists, mr_ptr and area_ptr were basically the same piece of storage, what's
   done to one happened to the other.

   80-06-01 Jim Gray : Modified to take advantage of the new open_mode info in
   the  dbcb,  and  return  it from the get_pn entry, so that list_db in linus
   would work as documented.

   80-06-02  Jim  Gray : Modified to correctly pass back an error code for tne
   entries  get_rels  and  get_file_relations,  when  an unknown file name was
   given on input, instead of passing back the code from close.

   80-06-03  Jim  Gray : Modified to fix linus submodel bug, during linus_open
   of  a submodel, model_files were getting written on during setting of scope
   data  because of successive calls to get_file_names and get_relation_names,
   where  linus  was  passing  a  pointer  to  a  non-freeing  area,  but  the
   mrds_dsm_dsmd  interface  expects a freeing area, and was thus doing a free
   of some temporary storage it used(in mrds_dsm_read_file_rels).  the same is
   true  of  the  dmd_  interface for models, when a cleanup is signaled.  The
   fix(temporaryily)  was  to  install  a local area, that is freeing, in this
   routine  to  buffer linus from the problem, and do the allocation here into
   the linus(or other caller) area.

   80-12-10  Jim  Gray  :  declared  the  scope  structure  passed back by the
   get_scope_info   entry  to  be  "like"  the  mdbm_scope_info  include  file
   structure,  which  changed  to support r-s-m-d scope modes, rather than r-u
   modes.   Linus  will  now  have to call this entry, rather than maintaining
   it's own internal static scope mode information.

   81-02-11  Jim  Gray  : changed calls to dsmd_, into mrds_dsm_dsmd calls, in
   order to call internal, not external bound segment names

   81-04-22  Jim  Gray  :  removed  use  of  the mrds_dm_get_file_rels module,
   instead  making the relation name(s) returned equal to the input file name,
   on the premise that blocked files will never be implemented.

   81-05-13  Rickie  E.  Brinegar: added the get_security_info entry to return
   the  mrds_security_info  structure  which  consist of a security bit and an
   administrator bit.

   81-05-14  Rickie  E.   Brinegar: modified the get_rslt_data procedure to be
   sensitve  to  the mdbm_secured and administrator bits in the resultant.  No
   key information is returned, the key head attribute is flagged as being and
   index,  and  the  domain  name  is  not  returned for non-administrators on
   secured databases.

   81-06-08  Davids:  removed  all  references  to  mrds_dsm_dsmd$*  from  the
   get_file_relations entry and just have the code return as the relation name
   the file name for submodels (this is what the mrds_dsm_dsm code did anyway,
   also  it  has  already  been done for the model). Also changed the get_rels
   entry so that references  to  mrds_dsm_dsm$*  have  been  replaced  by  the
   internal mrds interface modules.

   81-06-16 Rickie E.  Brinegar: Changed get_file_names entry to get_rslt_rels
   and  modified  get_rslt_rels  to call dsl_v1_$get_rslt_rels for old version
   databases.

   81-06-17  Rickie  E.   Brinegar:  Modified  the get_rslt_info entry to call
   dsl_v1_$get_rslt_info  for  old  version  databases.   At  the  same  time,
   get_rslt_data  was  modified  to  fill in the descriptor information in the
   rslt_info_structure.    Also  modified  the  get_temp_info  entry  to  call
   dsl_v1_$get_temp_info for old version database.

   81-06-19  Rickie  E.   Brinegar:  Removed the unused entries get_rslt_desc,
   get_temp_desc, get_file_relations and get_rels.

   81-08-24  Rickie  E.   Brinegar:  Modified the get_scope_info entry to call
   dsl_v1_$get_scope_info to get the scope info for old version models, and to
   convert the old version info structure to a new version info structure.

   82-08-20 D. Woodka : Deleted reference to rm_attr_info.bit_offset for
   DMS conversion.

   83-02-18 B. Moberg : Modified to tell users which attributes are part of
   the key of a relation in a secure database

   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)
*/

get_rslt_info:
     entry (db_index, rel_name, in_area_ptr, out_rslt_ptr, code);

	declare out_rslt_ptr	 ptr;
	area_ptr = in_area_ptr;

/* return attribute info for a permanent relation */

	call init;				/* get dbcb pointer */

	rmra_ptr = rm_db_info.ra_ptr;			/* point to rel array */
	do i = 1 to rm_rel_array.num_rels /* locate relation name */
	     while (rel_name ^= rm_rel_array.name.submodel (i));
	end;
	if i > rm_rel_array.num_rels then do;		/* relation is not defined */
		code = mrds_error_$undef_rel;
		rslt_ptr = null;
	     end;
	else do;
		rmri_ptr = rm_rel_array.rel_data.ri_ptr (i); /* point to resultant model relation information */
		call get_rslt_data (rslt_ptr);	/* fill in rslt_info structure */
	     end;

	out_rslt_ptr = rslt_ptr;

	return;					/* end get_rslt_info */
get_temp_info:
     entry (db_index, rel_index, in_area_ptr, temp_rslt_ptr, code);

	declare temp_rslt_ptr	 ptr;
	area_ptr = in_area_ptr;

/* return attribute info for a temporary relation */

	call init;				/* get dbcb pointer */

	rmra_ptr = rm_db_info.tra_ptr;
	if rel_index < 1 | rel_index > mrds_data_$max_temp_rels then do;
						/* undef temp rel */
		code = mrds_error_$undef_temp_rel;
		rslt_ptr = null;
	     end;
	else do;					/* if is defined */
		rmri_ptr = rm_rel_array.rel_data.ri_ptr (rel_index);
						/* get pointer to temp rel info */
		call get_rslt_data (rslt_ptr);
	     end;					/* if rel defined */

	temp_rslt_ptr = rslt_ptr;

	return;					/* end get_temp_info */

get_scope_info:
     entry (db_index, in_area_ptr, sci_ptr, code);
	area_ptr = in_area_ptr;

/* return scope info for each permanent relation */

	dcl     1 scp_info		 aligned like scope_info based (sci_ptr);
	dcl     sci_ptr		 ptr;




	sci_ptr = null;
	call init;				/* get dbcb pointer */

	scope_ptr = dbcb.scope_ptr;			/* point to scope info structure */
	max_file_init = scope_ptr -> scope_info.nfiles;
	allocate scp_info set (sci_ptr) in (area_ptr -> wk_area);
	unspec (sci_ptr -> scp_info) = unspec (scope_ptr -> scope_info);
						/* init user scope_ptr->scope information */

get_scope_info_exit:
	return;					/* end get_scope_info */

get_pn:
     entry (db_index, db_path, mode, code);

/* return the database pathname, and opening mode */

	declare mode		 char (20);
	declare mode_code		 fixed bin;

	call init;				/* get dbcb pointer */

	db_path = rm_db_info.sm_path;

/* set the mode argument */

	mode_code = fixed (dbcb.open_mode);
	if mode_code = 0 then
	     mode = "Mode not available";
	else if mode_code = 1 then
	     mode = "retrieval";
	else if mode_code = 2 then
	     mode = "update";
	else if mode_code = 3 then
	     mode = "exclusive_retrieval";
	else if mode_code = 4 then
	     mode = "exclusive_update";
	else mode = "Unknown opening mode";

	return;					/* end get_pn */

get_rslt_rels:
     entry (db_index, in_area_ptr, mr_ptr, code);
	area_ptr = in_area_ptr;


/* return model or sub-model file names */

	call init;

	rmra_ptr = rm_db_info.ra_ptr;
	num_relations_alloc = rm_rel_array.num_rels;
	allocate model_relations set (mr_ptr) in (area_ptr -> wk_area);
	do i = 1 to model_relations.nrels;
	     if dbcb.dsm_sw then
		mr_ptr -> model_relations.relation_name (i) =
		     rm_rel_array.name.submodel (i);
	     else mr_ptr -> model_relations.relation_name (i) =
		     rm_rel_array.rel_data.model_name (i);
	end;

	return;

get_db_version:
     entry (db_index, db_version, code);

/* return version number of data base manager */

	dcl     db_version		 fixed bin;

	call init;				/* get dbcb pointer */

	db_version = rm_db_info.db_version;

	return;


/* 81-05-13 Rickie E. Brinegar: Start added code *************************** */

get_security_info:
     entry (db_index, security_info_area_ptr, security_ptr, code);

	dcl     (security_info_area_ptr, security_ptr) ptr;

	call init;

	allocate mrds_security_info set (security_ptr)
	     in (security_info_area_ptr -> wk_area);
	mrds_security_info_ptr = security_ptr;
	mrds_security_info.db_secure = rm_db_info.mdbm_secured;
	mrds_security_info.administrator = rm_db_info.administrator;
	mrds_security_info.pad = "0"b;
	code = 0;
	return;

/* 81-05-13 Rickie E. Brinegar: End added code ***************************** */

init:
     proc;

/* initialize the dbcb pointer */

	code = 0;
	call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
	if dbcb_ptr = null then do;			/* undefined */
		code = mrds_error_$invalid_db_index;
		go to exit;
	     end;
	rdbi_ptr = dbcb.rdbi_ptr;

     end init;

get_rslt_data:
     proc (rslt_ptr);

	declare rslt_ptr		 ptr;

/*  fill rslt info structure using the resultant model
   relation, attribute and domain information */

	rslt_alloc = rm_rel_info.num_attr;
	allocate rslt_info set (rslt_ptr) in (area_ptr -> wk_area);
	rslt_ptr -> rslt_info.num_key_attr = rm_rel_info.nkey_attr;
	rslt_ptr -> rslt_info.key_length = rm_rel_info.max_key_len;
	rslt_ptr -> rslt_info.retrieve, rslt_ptr -> rslt_info.total_key = "1"b;
	rslt_ptr -> rslt_info.modify, rslt_ptr -> rslt_info.store,
	     rslt_ptr -> rslt_info.delete, rslt_ptr -> rslt_info.inversion = "0"b;
	do i = 1 to rm_rel_info.num_attr;		/* init attr info */
	     rai_ptr = rm_rel_info.attr_ptrs (i);	/* point to attribute information */
	     rdi_ptr = rm_attr_info.domain_ptr;		/* point to domain information */

/* 81-05-14 Rickie E. Brinegar: Start changed code ************************* */

	     rslt_ptr -> rslt_info.attr.attr_name (i) = rm_attr_info.name;
	     rslt_ptr -> rslt_info.attr.attr_length (i) = rm_attr_info.bit_length;

	     rslt_ptr -> rslt_info.attr.inver_flag (i) = rm_attr_info.index_attr;
	     rslt_ptr -> rslt_info.attr.key_flag (i) = rm_attr_info.key_attr;
	     rslt_ptr -> rslt_info.attr.key_attr_order (i) = rm_attr_info.key_order;
	     if ^rm_db_info.mdbm_secured | rm_db_info.administrator then do;
		     rslt_ptr -> rslt_info.attr.domain_name (i) = rm_domain_info.name;
		end;
	     else do;
		     rslt_ptr -> rslt_info.attr.domain_name (i) = "";
		end;

/* 81-05-14 Rickie E. Brinegar: End changed code *************************** */

	     rslt_ptr -> rslt_info.attr (i).descriptor = rm_domain_info.user_desc;
	     if rslt_ptr -> rslt_info.attr.inver_flag (i) then
		rslt_ptr -> rslt_info.inversion = "1"b;
	end;					/* attribute loop */

     end get_rslt_data;

	dcl     area_ptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     db_index		 fixed bin (35);
	dcl     db_path		 char (168) var;
	dcl     i			 fixed bin (35);	/* internal index */
	dcl     in_area_ptr		 ptr;
	dcl     local_area		 area (4096);
	dcl     mrds_data_$max_temp_rels fixed bin (35) ext;
	dcl     mrds_error_$invalid_db_index fixed bin (35) ext;
	dcl     mrds_error_$undef_rel	 fixed bin (35) ext;
	dcl     mrds_error_$undef_temp_rel fixed bin (35) ext;
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     rel_index		 fixed bin (35);	/* Input: temp rel index */
	dcl     rel_name		 char (*);
	dcl     submodel_iocb_ptr	 ptr init (null ());
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;
	dcl     wk_area		 area (sys_info$max_seg_size) based (area_ptr);
	dcl     (addr, empty, fixed, null, rel, unspec) builtin;

%include mrds_model_relations;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_rslt_info;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_scope_info;
%page;
%include mrds_security_info;

     end mrds_dsl_get_rslt_info;





		    mrds_dsl_get_scope.pl1          08/01/88  1347.3r w 08/01/88  1315.0       60273



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 1981

   83-04-04 Davids: explicitly declared the builtin function empty which was
   implicitly declared.

   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)
*/

mrds_dsl_get_scope: get_scope: procedure
	(db_index, relation_name, permits, prevents, scope_mode_version, error_code);

/* DESCRIPTION:

   This routine will return the scope permit/prevent ops currently
   set on a given relation for a particular database opening.
   It also returns the version of the concurrency control in effect,
   so that the user may know whether to interpret the
   encodings of 0-1-2-4-8 as n-r-s-d-m or n-r-a-d-m.
   The permit and prevent arguments are encoded in the same
   fashion as for the dsl_$set/dl_scope routines.
   The database opening index may be to a model or submodel opening
   of any version MRDS database. If the opening is through
   a submodel, the submodel relation name should be used.

*/

/* PARAMETERS:

   db_index - - (input) fixed bin(35), the database opening index as returned
   from a call to dsl_$open. This may be either a model or submodel
   opening of any version MRDS database.

   relation_name - - (input) char(*), the name of the relation for which the
   current scope information is desired. If the opening was through a submodel,
   then this should be the submodel name of the relation.

   permits - - (output) fixed bin, the sum of the permited scope modes
   taken from the encodings 0 = null, 1 = read_attr, 2 = store or append_tuple,
   4 = delete_tuple, 8 = modify_attr as used by dsl_$set/dl_scope.

   prevents - - (output) fixed bin, the sum of the prevented scope modes
   for this relation, using the same encodings as for permits.

   scope_mode_version - - (output) fixed bin, the concurrency control
   version be used by the database. 5 => r-a-m-d, earlier versions
   make use of r-s-m-d. (outmoded 4 using r-u will not be encountered)

   error_code - - (output) fixed bin(35), the error status encoding, 0 for
   a successfull operation. It will be mrds_error_$scope_not_set
   if no scope is currently set on the relation. An error code of 0,
   with permit/prevents = 0 indicates null scope has been set.

*/

/* initialize */

	permits, prevents, scope_mode_version, error_code = 0;

/* check for a valid database index */

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

/* get the version of the scope modes */

		dbc_ptr = dbcb.dbc_ptr;
		scope_mode_version = dbc.version;

/* set up the overlay pointers */

		permit_requests_ptr = addr (permits);
		prevent_requests_ptr = addr (prevents);

		call get_new_scope;

	     end;

get_new_scope: procedure ();

/* routine to get r-a-m-d type scope using the latest version of
   scope_info in the new version resultant model */

	scope_ptr = dbcb.scope_ptr;
	if scope_ptr = null then
	     error_code = mrds_error_$non_scope_ready;
	else do;

		found, finished = OFF;
		i = 1;

		do while (^finished);

		     if relation_name = scope_info.scope (i).sm_name then do;

			     permit_requests.read_attr = scope_info.scope (i).flags.permits.read_attr;
			     permit_requests.modify_attr = scope_info.scope (i).flags.permits.modify_attr;
			     permit_requests.append_tuple = scope_info.scope (i).flags.permits.append_tuple;
			     permit_requests.delete_tuple = scope_info.scope (i).flags.permits.delete_tuple;

			     prevent_requests.read_attr = scope_info.scope (i).flags.prevents.read_attr;
			     prevent_requests.modify_attr = scope_info.scope (i).flags.prevents.modify_attr;
			     prevent_requests.append_tuple = scope_info.scope (i).flags.prevents.append_tuple;
			     prevent_requests.delete_tuple = scope_info.scope (i).flags.prevents.delete_tuple;

			     finished, found = ON;

			end;

		     else if i < scope_info.nfiles then
			i = i + 1;

		     else finished = ON;

		end;

		if ^found then
		     error_code = mrds_error_$unknown_relation_name;

		else if ^scope_info.scope (i).flags.touched then
		     error_code = mrds_error_$scope_not_set;

	     end;

%include mdbm_scope_info;
     end;

	declare db_index		 fixed bin (35);	/* opening index for database */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets pointer from open index */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* not good opening index */
	declare relation_name	 char (*);	/* the submodel or model name of the relation */
	declare permits		 fixed bin;	/* the permited scope modes */
	declare prevents		 fixed bin;	/* the prevented scope modes */
	declare scope_mode_version	 fixed bin;	/* the dbc structure version */
	declare error_code		 fixed bin (35);	/* the error status encoding */
	declare mrds_error_$scope_not_set fixed bin (35) ext; /* no scope set for relation */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare (addr, null, rel, empty, fixed) builtin;
	declare i			 fixed bin;	/* loop index */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare found		 bit (1);		/* on => given name found in resultant model */
	declare finished		 bit (1);		/* loop exit control */
	declare work_area		 area (4096);	/* space for returned structures about scope */
	declare mrds_error_$unknown_relation_name fixed bin (35) ext; /* name not in view */
	declare mrds_error_$non_scope_ready fixed bin (35) ext; /* relation not readied for scope concurrency */

%include mrds_dbcb;

%include mdbm_scope_requests;

%include mdbm_dbc;

     end;




		    mrds_dsl_get_version.pl1        03/08/88  1538.0rew 03/08/88  1528.4      185526



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


/****^  HISTORY COMMENTS:
  1) change(88-01-11,Blair), approve(88-02-26,MCR7840),
     audit(88-03-03,Dupuis), install(88-03-08,MR12.2-1034):
     Get the list of mrds search_paths and loop through them to find the
     pathname of the database.
  2) change(88-02-26,Blair), approve(88-02-26,MCR7840),
     audit(88-03-03,Dupuis), install(88-03-08,MR12.2-1034):
     Create a local area in which to put the 'mrds' search_list infos.
                                                   END HISTORY COMMENTS */

/* HISTORY:

   Originally written by Jim Gray - - February 1980

   Modified by Jim Gray - - April 1980, to work with submodels.

   Modified   by   Jim   Gray   -   -    21-June-80,    to    return
   mrds_error_$no_model_submodel instead of $no_database.

   80-12-24 Jim Gray : changed error returned when  null  access  to
   db_model  or  a submodel msf, to new mrds_error_$no_model_access,
   instead of no database model/submodel found.

   81-01-22 Jim Gray : changed  $header  entry  into  get_path_info,
   with  a new structure for the interface, that contains additional
   info, in order to make an isolated (from  mrds  structures)  user
   interface.

   81-02-11 Jim Gray : changed calls to  external  dsmd_,  into  the
   internal interface rmds_dsm_dsmd.

   81-04-22 Jim Gray : modified logic to work with mrds_dm_open that
   now  used  mrds_dm_check_path,  and may automatically add the .db
   suffix  on  it's  own,  and  returns  mrds_error_$no_model_access
   rather than error_table_$moderr.

   81-06-02 Davids: changed from mrds_dsm_header_str.incl.pl1  which
   dcld   dsm_header_record  to  mrds_dsm_header.incl.pl1  which
   declares   mrds_dsm_header.   Also   changed   from   calls    to
   mrds_dsm_dsmd$  to  calls to various mrds_dsm_* routines (changes
   are from the user view to the internal mrds view).

   82-01-19 R. Lackey : modified to to look for a database foo.db if a
   directory foo was found that was not a database.

   82-06-23 R. Lackey : changed returned pathname to not have two "db"
   suffixes if error not_database was returned.
   
   82-06-28 D. Woodka : changed return pathname to not have "dsm.db"
   suffix if the path was a submodel.
 
   82-12-21 Roger Lackey : Fixed subscript range error for checking for
   .dsm suffix.

   82-12-21 Roger Lackey : Added length, rtrim and substr declarations.

   83-01-07 Roger Lackey : Added code to return mrds_error_$no_model_access
                           for the case where a submodel was found but no 
		       use did not have access  to it.

   83-01-17 Roger Lackey : Added call to mrds_dm_check_path which now handles
                           the adding of db suffix.

   83-03-08 Mike Kubicar : Added the entry point $get_path_info_and_view_name
   which does the same thing as $get_path_info plus returns the path
   expansion of in_path with the proper suffix added.  This is needed by the
   dsl_$open routine when this expansion differs from the absolute pathname.

   83-06-16 Davids: Modified to return the error mrds_error_$version_3_db
   if its a version 3 database or mrds_error_$version_1_dsm if its a
   version 1 submodel (this error code is actually returned by mrds_dsm_open).
*/

mrds_dsl_get_version: get_db_version: procedure (in_path_A, out_path, version, code_a);
%page;
/* BEGIN DESCRIPTION:

   given a pathname, this routine will determine what version
   database that pathname refers to, and return it, along with the
   "true" pathname of the database, having the ".db" suffix added to
   the input path, if it was not given, and this database was a
   version that has this suffix.  The $get_path_info entry will
   return the complete header inforamtion, rather than just the
   version number.  The $get_path_info_and_view_name will also
   contain the expanded pathname of the relative pathname supplied
   by the user with suffixes added as necessary.

   END DESCRIPTION 
*/

/* PARAMETERS:

   in_path - - (input) char(168) for  the  get_version  entry,  else
   char(*),  the  relative pathname of the database, with or without
   the ".db" suffix, if the database has that suffix.

   out_path - - (output) char(168), for the get_version entry  only,
   the  absolute  pathname of the database with the ".db" suffix, if
   the database has that suffix.

   version - - (output) fixed bin, for the get_version  entry  only,
   the  version  number  of the database, currently between 1 and 4.
   this is the output from the normal entry.

   area_ptr - - (input) pointer, for the get_path_info entries only,
   pointer  to  a  freeing  area  supplied  by  the  user, where the
   structure can be allocated.

   structure_version  -  -  (input) fixed bin, for the get_path_info
   entries  only,  the desired version of the structure, normaly set
   to the version in the include file.

   mrds_path_info_ptr  -  -  (output) pointer, for the get_path_info
   entries  only,  points  to  the  allocated  copy of the structure
   defined  in mrds_path_info.incl.pl1, which will be filled in with
   the  data  model  information.   this  filled in structure is the
   output from the $get_path_info entry.
   
   view_dir     -     -     (output)     char     (*),    for    the
   get_path_info_and_view_name entry only, the directory name of the
   relative pathname in_path.
   
   view_entry     -     -     (output)    char    (*),    for    the
   get_path_info_and_view_name  entry only, the entry name, possibly
   with suffix added, of in_path.

   error_code - - (output) fixed bin(35), the error status encoding,
   0 unless an error occured in expanding a pathname, or getting the
   version of a database(such as path does not refer to a database).

*/
%page;
/* normal entry to get version number */

	entry_name = "get_db_version";
	if length (rtrim (in_path_A)) > length (in_path) then do;
		code_a = error_table_$dirlong;
		return;
	     end;
	in_path = rtrim (in_path_A);
	version = 0;

	call common ();

	code_a = error_code;

	return;
%page;
/* entry to get complete header information plus the path expansion
   of in_path */

get_path_info_and_view_name:
     entry (in_path_B, area_ptr, structure_version, mrds_path_info_ptr,
	view_dir, view_entry, code_b);
	entry_name = "get_path_info_and_view_name";
	go to GET_PATH_INFO_COMMON;
%page;
/* entry to get complete header information */

get_path_info: entry (in_path_B, area_ptr, structure_version, mrds_path_info_ptr, code_b);

	entry_name = "get_path_info";

GET_PATH_INFO_COMMON:
	if length (rtrim (in_path_B)) > length (in_path) then do;
		code_b = error_table_$dirlong;
		return;
	     end;
	in_path = rtrim (in_path_B);

/* initialize */

	abs_path = " ";
	code_b, error_code = 0;

	mrds_path_info_ptr = null ();

/* check the caller's arguments */


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

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

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

/* set of the path info structure in the users area */

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

				     on cleanup begin;
					     if mrds_path_info_ptr ^= null () then do;
						     free mrds_path_info in (work_area);
						     mrds_path_info_ptr = null ();
						end;
					end;

				     allocate mrds_path_info set (mrds_path_info_ptr) in (work_area);
				     revert area;

				     unspec (mrds_path_info) = "0"b;
				     mrds_path_info.version = mrds_path_info_structure_version;
				end;
			end;
	     end;

skip_allocate:


/*  put the rest of the details of the path
   into the users structure */

	if error_code = 0 then
	     call common ();			/*  get the path information */

	code_b = error_code;

	return;
%page;
common: procedure ();

/* routine common to both entry points */

/* try the path as a model path first, with or without suffix */

	suffix_tried = "";
	use_search_paths = "0"b;
	if search (in_path,"<>") = 0 then do;
	     use_search_paths = "1"b;
	     call search_paths_$get (MRDS_SEARCHLIST, sl_control_default, "", null (), addr(local_area), sl_info_version_1, mrds_search_list_ptr, error_code);
	     loop_idx = mrds_search_list_ptr -> sl_info.num_paths;
	     end;
	else do;
	     call absolute_pathname_ (in_path, abs_path, error_code);
	     loop_idx = 1;
	     end;
	
	if error_code = 0 then do;
	     error_code = 1;
	     do idx = 1 to loop_idx while (error_code ^= 0);
		if use_search_paths then abs_path = pathname_ (mrds_search_list_ptr -> sl_info.paths(idx).pathname, in_path);
		call get_version (abs_path);

		if error_code = mrds_error_$no_database then do; /* if the database was not found */

			saved_code = error_code;	/* save the error_code and path, in case submodels fail */
			saved_path = abs_path;

/* unable to get version as a database model,
   now try it as a submodel, adding the ".dsm" suffix */


			suffix_tried = "dsm";
			call absolute_pathname_$add_suffix (abs_path, "dsm", abs_path, error_code);
			if error_code = 0 then do;

				call get_dsm_version ();

				if error_code ^= 0 then do; /* if it was not a submodel */
					if error_code ^= error_table_$moderr &
					     error_code ^= mrds_error_$version_1_dsm then do; /* Got a dsm but no access or old version */
						error_code = saved_code;
						abs_path = saved_path; /* restore the original name */

					     end;
				     end;
			     end;
		     end;

	if error_code ^= 0 then do;

		if error_code = mrds_error_$no_database then do;
			mrds_path_info_ptr -> mrds_path_info.type.not_mrds = "1"b;
			suffix_tried = "db";
			call absolute_pathname_$add_suffix (in_path, "db",
			     abs_path, dummy_code);
		     end;

		else if error_code = mrds_error_$no_model_access | error_code = error_table_$no_info then
		     error_code = mrds_error_$no_model_access;
		else do;
			if error_code = error_table_$moderr then do;
				mrds_path_info_ptr -> mrds_path_info.type.not_mrds = "0"b;
				error_code = mrds_error_$no_model_access;
			     end;
			else do;
				mrds_path_info_ptr -> mrds_path_info.type.not_mrds = "1"b;
				if error_code ^= mrds_error_$version_3_db &
				     error_code ^= mrds_error_$version_1_dsm
				then error_code = mrds_error_$no_model_submodel;
			     end;
		     end;
	     end;
	end;
     end;


	if entry_name = "get_db_version" then
	     out_path = abs_path;
	else mrds_path_info_ptr -> mrds_path_info.absolute_path = abs_path;
	if entry_name = "get_path_info_and_view_name" then
	     if suffix_tried = "dsm" then do;
		     call expand_pathname_$add_suffix (abs_path, suffix_tried,
			view_dir, view_entry, saved_code);
		     if error_code = 0
		     then saved_code = error_code;
		end;
	     else call mrds_dm_check_path (abs_path, view_dir, view_entry,
		     view_new_db, saved_code);

     end;
%page;
get_version: procedure (get_version_abs_path);

/* try opening the database model at this pathname */

	dcl     get_version_abs_path	 char (168) parameter;

	call mrds_dm_check_path (get_version_abs_path, containing_dir, db_dir, new_found, error_code);
	if error_code = 0
	then do;
		if ^new_found
		then error_code = mrds_error_$version_3_db;
		else do;
			get_version_abs_path = rtrim (containing_dir) || ">";
			get_version_abs_path = rtrim (get_version_abs_path) || db_dir;

			call mrds_dm_open (get_version_abs_path, 2 /* retrieval */, data_model_ptr, error_code);
		     end;
	     end;
	if error_code = mrds_error_$no_model_access then do;
		saved_code = error_code;		/* remember access problem */
		get_version_abs_path = rtrim (containing_dir) || ">";
		get_version_abs_path = rtrim (get_version_abs_path) || db_dir;

		if entry_name = "get_db_version" then ;
		else mrds_path_info_ptr -> mrds_path_info.type.model = "1"b;
	     end;

	else if error_code = 0 then do;

/* get the path from the model pointer, in case a suffix was added to the supplied path */

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

			if index (model_name, ".area.linker") ^= 0 then ; /* old version db */
			else get_version_abs_path = db_path; /* new version db, possiblily with suffix */


/* good database path, get the header information */

			local_area_ptr = addr (header_space);
			call mrds_dm_get_header (data_model_ptr, local_area_ptr, dmh_ptr, error_code);
			if error_code = 0 then do;

				if entry_name = "get_db_version" then
				     version = dmh_ptr -> dm_header.dmd_version;
				else do;
					mrds_path_info_ptr -> mrds_path_info.type.model = "1"b;
					mrds_path_info_ptr -> mrds_path_info.mrds_version = dmh_ptr -> dm_header.dmd_version;
					mrds_path_info_ptr -> mrds_path_info.creator_id = dmh_ptr -> dm_header.creator_id;
					mrds_path_info_ptr -> mrds_path_info.creation_time = dmh_ptr -> dm_header.create_time;
				     end;

			     end;

		     end;

/* close the opened model */

		call mrds_dm_close (data_model_ptr, discard_code);

	     end;

     end;
%page;
get_dsm_version: procedure ();

/* try opening a submodel using the path with ".dsm" suffix */

	call mrds_dsm_open$read (abs_path, submodel_iocb_ptr, error_code);
	if error_code = error_table_$no_info then do;
		saved_code = error_code;		/* remember access problem */
		if entry_name = "get_db_version" then ;
		else mrds_path_info_ptr -> mrds_path_info.type.submodel = "1"b;
	     end;
	else if error_code = 0 then do;

/* good submodel pathname, get the header information */

		local_area_ptr = addr (header_space);
		call mrds_dsm_read_header (local_area_ptr, hd_ptr, submodel_iocb_ptr, error_code);
		if error_code = 0
		then do;
			if entry_name = "get_db_version" then
			     version = hd_ptr -> mrds_dsm_header.dsm_generator_version;
			else do;
				mrds_path_info_ptr -> mrds_path_info.type.submodel = "1"b;
				mrds_path_info_ptr -> mrds_path_info.mrds_version =
				     hd_ptr -> mrds_dsm_header.dsm_generator_version;
				mrds_path_info_ptr -> mrds_path_info.creator_id =
				     hd_ptr -> mrds_dsm_header.creator_id;
				mrds_path_info_ptr -> mrds_path_info.creation_time =
				     hd_ptr -> mrds_dsm_header.date_time_generated;
			     end;
		     end;

/* close the open submodel */

	     end;

	call mrds_dsm_close$force (submodel_iocb_ptr);


     end;
%page;
          dcl     MRDS_SEARCHLIST        char (4) int static options (constant) init ("mrds");
	dcl     abs_path		 char (168);	/* working version of path */
	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35)); /* gets absolute from relative path */
	dcl     absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); /* gets abs path with suffix */
	dcl     area		 condition;
	dcl     area_info_		 entry (ptr, fixed bin (35)); /* gets details about area */
	dcl     area_ptr		 ptr;		/* pointer to users supplied area */
	dcl     cleanup		 condition;	/* signaled upon quit/release */
	dcl     code_a		 fixed bin (35);	/* temp for mrds_dsl_get_version entry */
	dcl     code_b		 fixed bin (35);	/* temp for get_path_info entry */
	dcl     containing_dir	 char (168);
	dcl     data_model_ptr	 ptr;		/* points to the database model */
	dcl     db_dir		 char (32);
	dcl     db_path		 char (168);	/* real path of database */
	dcl     discard_code	 fixed bin (35);	/* unused */
	dcl     dummy_code		 fixed bin (35);
	dcl     entry_name		 char (32);	/* Entry point used */
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     error_table_$area_too_small fixed bin (35) ext; /* allocate failed */
	dcl     error_table_$badcall	 fixed bin (35) ext;/* null area ptr */
	dcl     error_table_$dirlong	 fixed bin (35) ext static;
	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     error_table_$no_info	 fixed bin (35) ext;/* insufficient access to return any info */
	dcl     error_table_$unimplemented_version fixed bin (35) ext; /* bad structure_version */
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); /* gets path from ptr */
	dcl     hd_ptr		 ptr;		/* points to submodel header info */
	dcl     header_space	 area (1000);	/* area to hold dm_header structure */
          dcl     idx                    fixed bin;         /* idx for search path loop */
	dcl     in_path		 char (168);	/* the input relative path */
	dcl     in_path_A		 char (168);	/* parameter for get version entry */
	dcl     in_path_B		 char (*);	/* parameter for get path entry */
	dcl     ldn		 fixed bin;	/* char length of db_path */
          dcl     local_area             area (2048);
	dcl     local_area_ptr	 ptr;		/* points to header_space area */
          dcl     loop_idx               fixed bin;         /* idx for list of search path infos */
	dcl     model_name		 char (32);	/* name of model segment */
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35)); /* closes data model */
	dcl     mrds_dm_get_header	 entry (ptr, ptr, ptr, fixed bin (35)); /* gets header inbfo from model */
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35)); /* opens data base model */
	dcl     mrds_dm_check_path	 entry (char (*), char (*), char (*), bit (1), fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35)); /* opens a submodel for reading */
	dcl     mrds_dsm_read_header	 entry (ptr, ptr, ptr, fixed bin (35)); /* reads a submodel header record */
	dcl     mrds_dsm_close$force	 entry (ptr);	/* closes a submodel without returning an error code */
	dcl     mrds_error_$no_model_access fixed bin (35) ext; /* no r access on db_model */
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext; /* nothing found */
	dcl     mrds_error_$not_freeing_area fixed bin (35) ext; /* no freeing attr to area */
	dcl     out_path		 char (168);	/* path returned to user */
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$version_3_db fixed bin (35) external static;
	dcl     mrds_error_$version_1_dsm fixed bin (35) external static;
          dcl     mrds_search_list_ptr ptr;                 /* pointer to list of search_path infos */
	dcl     new_found		 bit (1);
          dcl     pathname_ entry (char(*), char(*)) returns(char(168));
	dcl     saved_code		 fixed bin (35);	/* temp for error error_code */
	dcl     saved_path		 char (168);	/* temp for remembering path */
          dcl     search  builtin;
          dcl     search_paths_$get entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35));           
	dcl     structure_version	 fixed bin;	/* desired version of returned structure */
	dcl     submodel_iocb_ptr	 ptr;		/* pointer to the submodel's iocb */
	dcl     suffix_tried	 char (3);	/* Last suffixed tried in db match */
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
          dcl     use_search_paths       bit (1);
	dcl     version		 fixed bin;	/* the version number of the database */
	dcl     view_dir		 char (*);	/* directory of in_path after expansion */
	dcl     view_entry		 char (*);	/* entry name of in_path, maybe with suffix */
	dcl     view_new_db		 bit (1);		/* scratch bit for mrds_dm_check_path */
	dcl     work_area		 area (sys_info$max_seg_size) based (area_ptr); /* overlay for users area */
	dcl     (addr, empty, index, length, null, rtrim, unspec) builtin;
	dcl     1 my_area_info	 like area_info;	/* local copy */
%page;
%include mrds_path_info;
%page;
%include mrds_dm_header;
%page;
%include area_info;
%page;
%include mrds_dsm_header;
%page;
%include sl_info;
%page;
%include sl_control_s;
%page;

     end;




		    mrds_dsl_init_res.pl1           10/17/90  0819.9rew 10/17/90  0817.0      514260



/****^  ***********************************************************
        *                                                         *
        * 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):
     Deleted some unused declarations (see mrds #141)
  2) change(86-02-12,Spitzer), approve(86-02-12,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     added checks to see if there are any domains or relations in the database
     now that rmdb can make these kind of database. if none, set various ptrs
     in the dbcb to null or to null structures.
     changed mu_temp_segments$free_segments to release them instead (so they get
     truncated).
  3) change(86-08-13,Hergert), approve(88-07-13,MCR7903),
     audit(88-07-13,Dupuis), install(88-08-01,MR12.2-1073):
     Removed changes made on 84-08-31 and reinstalled the old MR10.2 code. The
     way it was doing domain proc initiations was very slow.
  4) change(87-01-22,Hergert), approve(88-07-13,MCR7903),
     audit(88-07-13,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, added initializtion of dbcb.se_info_ptr.
  5) change(90-10-10,Zimmerman), approve(90-10-10,MCR8215),
     audit(90-10-15,Gray), install(90-10-17,MR12.4-1044):
     Add dm_not_available handler to execute clean shutdown if an attempt is
     made to open a data_management db when data_management is not available.
                                                   END HISTORY COMMENTS */


mrds_dsl_init_res: init_res: proc (view_dir, view_ent, dsm_sw, ready_mode, db_index, dbcb_ptr, administrator, error_code);

/*
                   BEGIN_DESCRIPTION:

   This  routine,  given  the  path name of a database model or submodel, will
   "open"  that  database,  returning a pointer to the resultant model created
   upon  opening,  and  a database index to be used in all future reference to
   the  database  for  file  ready/finish,  data retrieve/modify, and database
   close operations.
                   END_DESCRIPTION

Known Bugs:
   82-08-23 Davids: The values of the access_costs for a page_file type
   database must be determined (it wouldn't hurt to redetermine the values for
   the vfile case either)

Other Problems:

   PARAMETERS:

   view_dir  -  - (input) char (*) database model or submodel pathname down to
   the directory level

   view_ent - - (input) char(*) database model or submodel entryname under the
   above directory

   dsm_sw - - (input) bit(1), on => submodel to be opened, else model

   ready_mode - - (input) fixed bin, 5 => retrieve mode, 6 => update mode.

   db_index  -  -  (output)  fixed bin(35) variable holding the database index
   returned for the newly opened database, whose value will be 0 upon error or
   incomplete open

   dbcb_ptr - - (output) pointer to the resultant model built during opening

   administrator - - (output) bit (1) "1"b -> if the opener is a DBA

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

   sub_error_  -  -  (output)  condition, signaled upon detection of error for
   further info



   HISTORY:

   78-08-01 Oris Friesen: Originally written.

   79-03-14 Al Kepner: Modified to remove quiesce_sw parameter.

   79-03-23 Al Kepner: Modified to set dbcb.transact_ctl_seg.

   79-05-31  Al  Kepner:  Modified to create the segment for current selection
   expression allocations.

   79-07-01 Jim Gray : Rewritten to
   1) add sub_err_ reporting of errors and structured error handling
   2) correct handling of submodels
   3) correct db_index subroutine calls
   4) add backing out of an open upon error
   5) correctly initialize dbcb
   6) improve interface to init_res
   7) add proper initialization
   8) document the modules logic

   80-10-01  Lindsey  Spratt:  Modified  to  use new submodel system; calls to
   dsmd_$foo  were  altered  to  be calls to the actual mrds_dsm_foo module, a
   submodel_iocb_ptr  (in  external  static)  was  added  to keep track of the
   "current"  submodel  opening  (a  better  technology  might  be to have the
   submodel iocb ptr part of the dbcb).

   80-10-24  Jim  Gray  :  Modified  to  add  initialization  of  new dbcb bit
   "new_select_expr".

   80-11-03  Jim  Gray  :  Modified to change delete_$ptr to hcs_$delentry_seg
   calls for performance.

   80-11-07  Jim Gray : Modified to add opening security checks so that if the
   database model is secured, it can not be opened via the model and if opened
   by  a  submodel,  the  submodel  must  reside in the submodel dir under the
   database.

   80-11-18  Jim  Gray  :  Modified to remove link access violation trick with
   db_model when doing a secure open (allowed submodel not being under db_dir)

   80-11-19 Jim Gray : Modified to compare uid's of given submodel, and actual
   db_dir>sm_dir>submodel,  so add_names on submodel_dir could be used.  Also,
   links  into  the submodels are allowed, but links out from the submodel dir
   are not.

   80-12-09  Jim Gray : only the latest version control segment is now allowed
   to  be  used  in opening a database until an AMDB -rs is done to update the
   version  of the dbc to 5, and the seg name to "db.control" This is done via
   the mu_concurrency_control$open_control_segment routine.

   80-12-24 Jim Gray : improved error message for cases where no "w" access to
   database control segment, when attempting to log new opener.

   81-01-12 Jim Gray : added submodel version parameter to mu_sec_init_res,
   and now init it from the submodel header, when a submodel opening is used.

   81-01-22  Davids:  changed  mrds_dsm_open_read to mrds_dsm_open$read.  also
   removed the mrds_dsm_entry_dcls include file.

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

   81-02-10  Jim  Gray  :  made the check for the submodel being in the sm_dir
   when the database is secured, an external routine mrds_dm_secured_submodel,
   so that other commands could make use of it.

   81-04-06  Jim Gray : added ability of DBA to be allowed to open through the
   model view for a secured database.

   81-04-30  Jim Gray : added ability of a DBA to open through an un-installed
   submodel.

   81-05-13  Rickie  E.   Brinegar : Modified to fill the administrator bit in
   the resultant.

   81-06-05 Davids: changed the include file mrds_dsm_header_str  to
   mrds_dsm_header,  (user  interface  include file to internal mrds
   include file).

   81-07-06   Jim   Gray   :   added   init   for    dbcb.open_mode,
   new_select_expr,         no_optimize,         print_search_order,
   last_store_rel_name, last_s_e_id_num

   81-12-07 Roger Lackey : change the initization of the variable caller_name
   from mrds_dsl_open to mrds_dsl_init_res.

   82-08-20 Mike Kubicar : Added the initialization of dbcb.store_vector to
   the init_dbcb routine.

   82-08-23 Davids: added code to initialize the dbcb.relmgr_entries and
   dbcb.access_cost substructures depending on type of database, i.e.
   vfile or page_file.

   82-09-09 Mike Kubicar : Added the initialization of dbcb.modify_vector.

   82-10-12 Davids: modifications so that module would compile - 
   changed references to dbcb.store_vector and modify_vector to store and
   modify_vector_ptr. Changed references to dbcb.relmgr_entries.delete_tuple_by_id
   and modify_tuple_by_id to delete and modify_tuples_by_id. Deleted reference
   to dbcb.transact_ctl_seg and replaced it with dbcb.transactions_needed
   which is set to "1"b if the db_model_db_type ^= 1. Also set the value of
   dbcb.relmgr_entries.put_tuple and dbcb.cursor_ptrs_storage_ptr and
   dbcb.cursor_storage_area_ptr. This included adding to the clean_up
   procedure to delete cursor_storage_area_ptr.

   82-10-13 Davids: changed vrm_* entries to vfile_relmgr_$*

   82-10-15 Davids: removed call to mu_define_area to set up the cursor
   storage area (dbcb.cursor_storage_area_ptr) and the code in the clean_up
   routine to clean it up. The area is no set up by mu_cursor_manager_$get

   83-01-25 Roger Lackey : Applied get_shortest_path_ to db_path and dsm_path
                           so sub_err_ messages (limited to 256 chars) would
		       display more of the message.

   83-02-02 Davids: Added call to hcs_$get_uid_seg to set the dbcb.dbc_uid
   element in the internal proc init_dbcb. Added the exit_init_dbcb label
   to branch to incase of an error.

   83-02-10 Mike Kubicar : Removed the call to get shortest path since it
   caused the database names printed by dmod and friends to be somewhere
   between non-obvious and wrong.

   83-02-14 Davids: modified to use the new db_type_flags in the db_model
   structure instead of the old numeric db_type.

   83-02-25 Davids: modified to set the new concurrency_on and rollback_on
   elements in the dbcb structure. 

   83-04-25 Davids: Modified to reduce deep nesting by having error states
   call the new error_exit procedure which cleans up and does a non-local
   goto to leave this procedure. Removed the call to get a temp segment to
   base an area on when the opening is via a submodel so that space will be
   avaialble to read the submodel header, instead just increased the size of
   the local_area variable by 100 (to 200) to allow space to allocate the 
   header. Added code in-line to close the submodel after the call to
   mu_sec_init_res so that a normal exit does not need to call the clean up
   handler. Modified the error handling in the internal procedure init_dbcb
   so that it calls the error_exit procedure instead of goto the exit_init_dbcb
   label which just caused the procedure to return. Eliminated the extra rtrim
   on the view_ent variable when the input_path is built in
   get_model_path_and_pointer. Modified the allocation of the simple and
   general type vectors to be allocated in the dbcb.static_area instead of the
   system free area.

   83-05-02 Davids: Deleted references to the dm_specification include file
   since mike removed the get_next_search_specification pointer from the dbcb.
   Removed code in the init_dbcb internal proc that set the pointer and
   allocated and filled in the structure. Modified so that instead of calling
   hcs_$make_seg to create the curdat, stadat, and select_area segments a call
   to mu_temp_segments$get_temp_segments is made. The clean_up procedure was
   modified to call either mu_temp_segments$free_all_temp_segments if the 
   temp_dir is the pdir or delete_all_temp_segments if its some other temp dir.
   the db_pic variable was created to be a character representation of the db
   index so that it could be used to make the caller to mu_temp_segments
   unique. the res_in_pdir was created to keep track of where the segments were
   created. The new flag in the dbcb resultant_in_pdir is set from res_in_pdir.
   All this was done so that multiple openings (when using the pdir as a temp
   dir) will be faster. The first opening will be somewhat slower since there
   is more overhead in using temp segments than in just creating a segment.

   83-05-04 Davids: Changed the name that the temp segments are gotten with
   from mrds_dsl_init_resDBI to MRDSDBI so that all temp segments can be 
   cleaned up with 1 call in mrds_dsl_close.

   83-05-06 Davids: Modified so that the cleanup handler does not explicitly
   delete the rdbi segment in case of an error but just calls mu_temp_segments
   to do the correct thing (delete or release). This should have been done 
   yesterday! It caused strange segment number problems if an opening failed
   because the segment was gone but mu_temp_segments was still handing out
   a pointer to it.

   83-05-17 Davids: Renamed the internal procedure create_resultant to
   create_resultant_segments since it does not actually fill in the
   dbcb and rdbi structures. Also create_resultant_segments now gets four
   temp segments instead of 3, the fourth is four the rdbi segment which
   is no longer obtained in the mu_sec_init_res module. Created the
   internal procedures copy_resultant_data and generate_resultant_data.
   copy will copy the dbcb and rdbi segments from the database dir if they
   exist and update the process dependent values while generate will generate
   the resultant data from the model as it used to do (its the same code just
   moved into an internal proc).

   83-05-18 Davids: Added a new input parameter - ready_mode. This is needed
   to update the rm_rel_info structures in the rdbi segment if the segment is
   copied from a saved version. Added the internal procedures (with calls in
   copy_resultant_data) update_rm_domain_info and update_rm_rel_info (which
   also updates the rm_attr_info structure). These procedures complete the
   process of updating the rdbi structures so that they can be used by this
   process in this database opening. The internal proc build_entry was also
   added. this entry was copied from mu_sec_make_res and is used to make an
   entry varaible given a path_name$entry_name. Also cahnged the init_dbcb
   internal proc to set the res_laready_made element of the dbcb to OFF while
   copy_resultant_data internal proc sets it to "1"b. 

  83-05-20 Davids: Added the entries report_on_res_creation_(on off) and the
  internal static variable report_on_res_creation. These are debugging aids 
  to report how the resultant was actually created. Also added code in the
  copy_resultant_data procedure to check the version of the saved resultant
  and not use it if it is not equal to the mrds_data_$saved_res_version
  element.

  83-05-23 Davids: Added the new output parameter administrator. "1"b ->
  that the opener is a DBA for the database. This is needed so that open
  does not also have to determine if the opener is a DBA. If the opener is
  a DBA and the resultant is made from scratch than open will create a 
  copy of the resultant in the db dir. Also the rm_db_info.mdbm_secured
  bit is not set based on the db_model.mdbm_secured bit instead of relying
  on the stored value.

  83-05-26 Davids: Modified so that the rm_db_info.db_path and dsm_path are
  updated from the saved value when the saved resultant is used to open the
  db. This was needed because the path that was used to open the db might not
  be the actual db_path, i.e. links and the path the user actual used should be
  used. Added the call to error_exit in build_entry after the sub_err_ call
  reporting that the encode procedure could not be found, this prevents the
  database from being opened anyway. Added code in update_rm_rel_info to try
  to initiate the the relation models and report and error and fail to open
  if the opener does not have access to read the model. Also to check the
  version number of the id_list structure and if its not the expected value, i.e.
  1 to not use the saved resultant in the opening.

  83-06-01 Davids: Removed the reference to the dm_specification include file
  which was not used. Also fixed the loop that adjusted the key_attr_ptrs
  pointers in rm_rel_info so that it looped though all the key_attr_ptrs
  instead of just the last one.

  83-06-02 Mike Kubicar : Updated relation manager calling sequence
  declarations.

  83-06-09 Davids: Modified internal proc copy_resultant_data to
  give the dba access if he doesn't have it and to just generate
  a resultant from scratch if a non-DBA doesn't have access to the
  saved dbcb and rdbi segments or if any other error occurs.

  83-08-03 Mike Kubicar : Added code to initialize the new dbcb entry
  element_id_list_segment_ptr which points to the segment which contains
  the static element id lists.  It also gets this segment at database
  opening time.

  84-08-31 Thanh Nguyen:  Modified the build_entry proc to handle the case
  of same entry name for check or encode or decode procs but located in
  different directory.  

  84-09-04 John Hergert: Added the initialization of dbcb.compiled_se_info_ptr

  84-10-16 Thanh Nguyen:  Modified the build_entry proc to call hcs_$make_entry
  with the entrypoint name because it may be different than the entry name.

  84-11-22 John Hergert: Fixed bug where trying to open large dbs caused
  strange problems. This was because the variable chars was declared fb17
  which wasn't large enough to handle the number of bits in the rdbi seg
  in the resultant_segs dir. Changed it to fb24.

  85-01-15 Thanh Nguyen:  Added the initialization of dbcb.work_area_ptr.

  85-04-14 Thanh Nguyen: Added code to automatically update the rdbi and dbcb
  segments under resultant_segs.dir when the saved_res_version is changed.
  Also added code to initialize new reserved ptrs, words and entries of the
  new dbcb structure.
*/
%page;
/* initialize */

	error_code = 0;
	submodel_version, db_index = 0;
	dbcb_ptr, rdbi_ptr = null ();
	curdat_ptr, stadat_ptr = null ();
	model_seg_ptr = null ();
	clean_up_condition = OFF;
	submodel_open = OFF;
	res_in_pdir = OFF;
	db_pic = 0;

/* establish handler to undo loose ends if users does a quit/release */

	on cleanup begin;
		clean_up_condition = ON;
		if ^substr (db_mrds_dsl_init_res, 1, 1) then ;
		else on sub_error_ ;		/* ignore sub_err_ calls during cleanup */
		call clean_up ();
	     end;

/* establish handler to exit gracefully if an attempt is made to open a Data_Management file when DM is not running.  */

	
on dm_not_available_ begin;

		error_code = dm_error_$system_not_initialized;
                    call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "");
		call error_exit;

	     end;

/* construct pathnames of the model, the submodel if needed, and get
   a pointer to the db_model segment in the database */

	call get_model_path_and_pointer ();


/* set up the concurrent access control */

	call mu_concurrency_control$open_control_segment (db_path, dbc_ptr, bc, error_code);
	if error_code ^= 0
	then call error_exit;


/* now the non-secure resultant segments can be made,
   and a database index obtained for this opening */

	call create_resultant_segments ();

	if ^dsm_sw
	then call copy_resultant_data;
	else call generate_resultant_data;

/* this user must be added to the list of database openers */

	call mu_sec_reg_user (dbcb.dbc_ptr, rdbi_ptr, error_code);
	if error_code ^= 0
	then call error_exit;			/* error is reported to user in a lower routine */
	else dbcb.dbc_incr = ON;

exit_mrds_dsl_init_res:
	return;
%page;
report_on_res_creation_on: entry;

	report_on_res_creation = "1"b;

	return;



report_on_res_creation_off: entry;

	report_on_res_creation = "0"b;

	return;
%page;
get_model_path_and_pointer: procedure ();

/* obtain the pathname to the database model,   directly if this is for a model opening,
   indirectly if this is a submodel opening,   and also get the submodel pathname */

	if length (rtrim (view_dir)) + length (rtrim (view_ent)) + 1 > length (input_path)
	then do;
	          error_code = error_table_$dirlong;
		call error_exit;
	     end;
	else input_path = rtrim (view_dir) || ">" || rtrim (view_ent);

	if ^dsm_sw
	then do;					/* model opening */
		db_path = input_path;
		dsm_path = db_path;			/* equal since model opening */
	     end;
	else do;					/* submodel opening */
		dsm_path = input_path;
		call mrds_dsm_open$read /* get the model path from the submodel */
		     (dsm_path, 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 open the submodel using the pathname """, dsm_path, """.");
			call error_exit;
		     end;

		submodel_open = ON;

		call mrds_dsm_read_header (addr (local_area), header_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 header information from the submodel using the pathname """,
			     dsm_path, """.");
			call error_exit;
		     end;

		db_path = header_ptr -> mrds_dsm_header.database_pn;
		submodel_version = header_ptr -> mrds_dsm_header.dsm_generator_version;
	     end;

	call initiate_file_ /* get a pointer to the common model segment */
	     (db_path, "db_model", R_ACCESS, dbm_ptr, (0), code);
	if code = error_table_$moderr
	then do;
		call mrds_dm_authorization$set_needed_access (rtrim (db_path), code); /* fails if caller not DBA */
		if code ^= 0
		then code = error_table_$moderr;
		else call initiate_file_ (db_path, "db_model", R_ACCESS, dbm_ptr, (0), code);
	     end;
	if dbm_ptr = null ()
	then do;
		error_code = code;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
		     "Unable to get a pointer to db_model under the database directory """, db_path, """.");
		call error_exit;
	     end;

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

	administrator = mrds_authorization.administrator; /* send the type of user back to mrds_dsl_open */

	if db_model.mdbm_secured
	then do;					/* if database has been secured */
		if ^mrds_authorization.administrator
		then do;				/* administrators can always open */
			if ^dsm_sw		/* normal users must open via a submodel */
			then do;

				error_code = mrds_error_$inc_secure_open;
				call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
				     "^/^a^a^a ^a",
				     "The path """, db_path,
				     """ refers to a database that has been secured,",
				     "and can only be be opened via a secure submodel by a non-DBA.");
				call error_exit;
			     end;

			if ^mrds_dm_secured_submodel /* it must be a secure submodel */
			     (rtrim (db_path), rtrim (view_dir), rtrim (view_ent))
			then do;
				error_code = mrds_error_$inc_secure_open;
				call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
				     "^/^a^a^a^a^a ^a^a^a",
				     "The submodel """, dsm_path, """ refers to a database """,
				     db_path, """ that has been secured,",
				     "but the submodel itself is not in the databases inferior directory """,
				     mrds_data_$submodel_dir_name, """.");
				call error_exit;
			     end;
		     end;
	     end;
     end;
%page;
create_resultant_segments: procedure ();

/* the dbcb(database control) segment, and select area segments must be created,
   and a database index must be obtained for this opening */

/* create the dbcb segment */

	resultant_dir = mrds_dsl_resultant_storage$get ();
	if substr (resultant_dir, 2, 15) = "process_dir_dir"
	then resultant_dir = ">pdd>" || substr (resultant_dir, 18);

	call hcs_$make_seg (resultant_dir, unique_chars_ ("0"b) || ".mrds.dbcb", "",
	     RW, dbcb_ptr, error_code);
	if dbcb_ptr = null ()
	then do;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a^a^a^a^a",
		     "Unable to create the resultant model dbcb segment under the directory """,
		     resultant_dir, """ for the database """, dsm_path, """.");
		call error_exit;
	     end;

	call mu_database_index$get_database_index /* get a database opening index for the user */
	     (db_index, dbcb_ptr);			/* save ptr and get index for it */
	if db_index = 0
	then do;
		error_code = mrds_error_$too_many_dbs;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value, "^/^a ^d ^a^a^a",
		     "The maximum number of database openings =", mrds_data_$max_dbs, "has been exceeded by """,
		     dsm_path, """.");
		call error_exit;
	     end;
	db_pic = db_index;

	process_dir = get_pdir_ ();
	if substr (process_dir, 2, 15) = "process_dir_dir"
	then process_dir = ">pdd>" || substr (process_dir, 18);

	if resultant_dir = process_dir
	then res_in_pdir = "1"b;
	else res_in_pdir = "0"b;

	call mu_temp_segments$get_temp_segments (db_index, "MRDS" || db_pic, ptr_array, error_code);
	if error_code ^= 0
	then do;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "Could not create temporary segments for the opening of ^a", dsm_path);
		call error_exit;
	     end;
	curdat_ptr = ptr_array (1);			/* tuple retrieve area */
	stadat_ptr = ptr_array (2);			/* "first selerct tuple" retrieve area */
	model_seg_ptr = ptr_array (3);		/* select area segment */
	rdbi_ptr = ptr_array (4);			/* rdbi segment */
	el_id_seg_ptr = ptr_array (5);		/* Element id lists */

	model_area_ptr = pointer (model_seg_ptr, size (model_seg));
	dbcb.select_area_ptr = model_area_ptr;
	call mrds_dsl_init_select_area /* initialize the select area segment */
	     (dbcb_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 initialize the select area for database """,
		     dsm_path, """.");
		call error_exit;
	     end;
     end;
%page;
copy_resultant_data: proc;

	dcl     saved_rdbi_ptr	 ptr;		/* pointer to the saved copy of the rdbi segment */
	dcl     rdbi_bit_count	 fixed bin (24);	/* bit count of the saved rdbi segment */
	dcl     saved_dbcb_ptr	 ptr;		/* pointer to the saved copy of the dbcb segment */
	dcl     dbcb_bit_count	 fixed bin (24);	/* bit count of the saved dbcb segment */
	dcl     chars		 fixed bin (24);	/* number of characters in the rdbi and dbcb segments */
	dcl     chars_overlay	 char (chars) based;/* character overlay for copying the segments */
	dcl     bad_id_list_version	 bit (1);		/* "1"b => the structure of the id_list has changed */

	call initiate_file_ (rtrim (db_path) || ">resultant_segs.dir", "rdbi", R_ACCESS,
	     saved_rdbi_ptr, rdbi_bit_count, error_code);
	if error_code = error_table_$moderr | error_code = error_table_$no_info
	then do;					/* see if access can be set */
		call mrds_dm_authorization$set_needed_access (rtrim (db_path), code);
		if code = 0
		then call initiate_file_ (rtrim (db_path) || ">resultant_segs.dir", "rdbi", R_ACCESS,
			saved_rdbi_ptr, rdbi_bit_count, error_code);
	     end;
	if error_code ^= 0				/* if there is any error just */
	then do;					/* give up and generate a copy */
		call generate_resultant_data;
		goto exit_copy_resultant_data;
	     end;

	call initiate_file_ (rtrim (db_path) || ">resultant_segs.dir", "dbcb", R_ACCESS,
	     saved_dbcb_ptr, dbcb_bit_count, error_code);
	if error_code = error_table_$moderr | error_code = error_table_$no_info
	then do;					/* see if access can be set */
		call mrds_dm_authorization$set_needed_access (rtrim (db_path), code);
		if code = 0
		then call initiate_file_ (rtrim (db_path) || ">resultant_segs.dir", "dbcb", R_ACCESS,
			saved_dbcb_ptr, dbcb_bit_count, error_code);
	     end;
	if error_code ^= 0				/* if there is any error just */
	then do;					/* give up and generate a copy */
		call generate_resultant_data;
		goto exit_copy_resultant_data;
	     end;

	if saved_rdbi_ptr -> rm_db_info.saved_res_version ^= mrds_data_$saved_res_version
	then do;
		call generate_resultant_data;
		if mrds_authorization.administrator then do;
						/* He/She is a DBA so let update the saved_res_version and the dbcb struture for resultant_segs.dir */
			saved_rdbi_ptr -> rm_db_info.saved_res_version = mrds_data_$saved_res_version;
			saved_dbcb_ptr -> dbcb = dbcb;
		     end;
		goto exit_copy_resultant_data;
	     end;

	chars = divide (rdbi_bit_count, 9, 24, 0) + 1;	/* add 1 to make sure that any bits after */
	rdbi_ptr -> chars_overlay = saved_rdbi_ptr -> chars_overlay; /*  the last full character are also copyed */

	rm_db_info.administrator = mrds_authorization.administrator;
	rm_db_info.mdbm_secured = db_model.mdbm_secured;
	rm_db_info.db_path = db_path;
	rm_db_info.sm_path = dsm_path;
	rm_db_info.ra_ptr = ptr (rdbi_ptr, rel (rm_db_info.ra_ptr));
	rm_db_info.tra_ptr = ptr (rdbi_ptr, rel (rm_db_info.tra_ptr));
	if rm_db_info.domain_list_ptr ^= null
	then do;
	     rm_db_info.domain_list_ptr = ptr (rdbi_ptr, rel (rm_db_info.domain_list_ptr));

	     call update_rm_domain_info;
	     end;

	bad_id_list_version = "0"b;
	call update_rm_rel_info (bad_id_list_version);
	if bad_id_list_version
	then do;
		call generate_resultant_data;
		goto exit_copy_resultant_data;
	     end;

	chars = divide (dbcb_bit_count, 9, 17, 0) + 1;
	dbcb_ptr -> chars_overlay = saved_dbcb_ptr -> chars_overlay;

	call hcs_$get_uid_seg (dbc_ptr, dbcb.dbc_uid, error_code);
	if error_code ^= 0
	then do;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "Unable to obtain the unique identifier of the data base control segment, opening will be aborted");
		call error_exit;
	     end;
	dbcb.work_area_ptr = null ();			/* just make sure it is null. */
	dbcb.reserved_ptrs (*) = null ();
	dbcb.dbc_ptr = dbc_ptr;
	dbcb.select_area_ptr = model_area_ptr;
	dbcb.current_data_ptr = curdat_ptr;
	dbcb.static_data_ptr = stadat_ptr;
	dbcb.rdbi_ptr = rdbi_ptr;
	dbcb.element_id_list_segment_ptr = el_id_seg_ptr;
	dbcb.resultant_in_pdir = res_in_pdir;
	dbcb.dbi = db_index;
	dbcb.res_already_made = "1"b;
	if dbcb.scope_ptr = null
	then do;
	     max_file_init = 0;
	     allocate scope_info set (scope_ptr) in (dbcb.static_area);
	     scope_info.mbz1 = "0"b;
	     scope_info.active_scopes = 0;
	     dbcb.scope_ptr = scope_ptr;
	     end;
	else dbcb.scope_ptr = ptr (dbcb_ptr, rel (dbcb.scope_ptr));
	dbcb.store_vector_ptr = ptr (dbcb_ptr, rel (dbcb.store_vector_ptr));
	dbcb.modify_vector_ptr = ptr (dbcb_ptr, rel (dbcb.modify_vector_ptr));
	if db_model.db_type_flags.vfile_type
	then do;					/* vfile type data base */
		dbcb.relmgr_entries.open = vfile_relmgr_$open;
		dbcb.relmgr_entries.close = vfile_relmgr_$close;
		dbcb.relmgr_entries.create_cursor = vfile_relmgr_$create_cursor;
		dbcb.relmgr_entries.destroy_cursor = vfile_relmgr_$destroy_cursor;
		dbcb.relmgr_entries.set_scope = vfile_relmgr_$set_scope;
		dbcb.relmgr_entries.delete_tuples_by_id = vfile_relmgr_$delete_tuples_by_id;
		dbcb.relmgr_entries.modify_tuples_by_id = vfile_relmgr_$modify_tuples_by_id;
		dbcb.relmgr_entries.get_tuple_by_id = vfile_relmgr_$get_tuple_by_id;
		dbcb.relmgr_entries.get_tuples_by_spec = vfile_relmgr_$get_tuples_by_spec;
		dbcb.relmgr_entries.get_tuple_id = vfile_relmgr_$get_tuple_id;
		dbcb.relmgr_entries.put_tuple = vfile_relmgr_$put_tuple;
		dbcb.relmgr_entries.get_count = vfile_relmgr_$get_count;
		dbcb.relmgr_entries.get_population = vfile_relmgr_$get_population;
		dbcb.relmgr_entries.get_duplicate_key_count = vfile_relmgr_$get_duplicate_key_count;
		dbcb.relmgr_entries.create_relation = vfile_relmgr_$create_relation;
		dbcb.relmgr_entries.create_index = vfile_relmgr_$create_index;
		dbcb.relmgr_entries.destroy_relation_by_path = vfile_relmgr_$destroy_relation_by_path;
	     end;
	else do;					/* page_file type database */

                    dm_system_state = dm_gate_$dm_get_system_state();   /* 12.4 This will signal dm_not_available if the dm system is down. */
		dbcb.relmgr_entries.open = relation_manager_$open;
		dbcb.relmgr_entries.close = relation_manager_$close;
		dbcb.relmgr_entries.create_cursor = relation_manager_$create_cursor;
		dbcb.relmgr_entries.destroy_cursor = relation_manager_$destroy_cursor;
		dbcb.relmgr_entries.set_scope = relation_manager_$set_scope;
		dbcb.relmgr_entries.delete_tuples_by_id = relation_manager_$delete_tuples_by_id;
		dbcb.relmgr_entries.modify_tuples_by_id = relation_manager_$modify_tuples_by_id;
		dbcb.relmgr_entries.get_tuple_by_id = relation_manager_$get_tuple_by_id;
		dbcb.relmgr_entries.get_tuples_by_spec = relation_manager_$get_tuples_by_spec;
		dbcb.relmgr_entries.get_tuple_id = relation_manager_$get_tuple_id;
		dbcb.relmgr_entries.put_tuple = relation_manager_$put_tuple;
		dbcb.relmgr_entries.get_count = relation_manager_$get_count;
		dbcb.relmgr_entries.get_population = relation_manager_$get_population;
		dbcb.relmgr_entries.get_duplicate_key_count = relation_manager_$get_duplicate_key_count;
		dbcb.relmgr_entries.create_relation = relation_manager_$create_relation;
		dbcb.relmgr_entries.create_index = relation_manager_$create_index;
		dbcb.relmgr_entries.destroy_relation_by_path = relation_manager_$destroy_relation_by_path;

	     end;

	if report_on_res_creation
	then call ioa_ ("Resultant has been created by copying from the saved copy: version is ^a",
		saved_rdbi_ptr -> rm_db_info.saved_res_version);

exit_copy_resultant_data:
	return;

     end;
%page;
update_rm_domain_info: proc;

	dcl     domain_header_ptr	 ptr;
	dcl     found		 bit (1);
	dcl     NULLOFFSET		 bit (18) init ((18)"1"b) internal static options (constant);

	domain_header_ptr = ptr (dbm_ptr, db_model.domain_ptr);
	rdi_ptr = rm_db_info.domain_list_ptr;
	do while (rdi_ptr ^= null ());
	     if (rm_domain_info.ck_proc | rm_domain_info.encd_proc | rm_domain_info.decd_proc)
	     then do;
		     di_ptr = domain_header_ptr;
		     found = "0"b;
		     do while (^found & di_ptr ^= null ());
			if domain_info.name = rm_domain_info.name
			then found = "1"b;
			else
			     if domain_info.fwd_thread = NULLOFFSET
			then di_ptr = null ();
			else di_ptr = ptr (dbm_ptr, domain_info.fwd_thread);
		     end;
		     if ^found
		     then do;
			     error_code = mrds_error_$incons_db;
			     call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
				"The domain ^a is listed in the saved rdbi structure but not in the model.",
				rm_domain_info.name);
			     call error_exit;
			end;
		     if rm_domain_info.ck_proc
		     then rm_domain_info.ck_proc_entry = build_entry (domain_info.check_path_ptr, dbm_ptr, "check");
		     if rm_domain_info.encd_proc
		     then rm_domain_info.encd_proc_entry = build_entry (domain_info.encd_path_ptr, dbm_ptr, "encode");
		     if rm_domain_info.decd_proc
		     then rm_domain_info.decd_proc_entry = build_entry (domain_info.decd_path_ptr, dbm_ptr, "decode");
		end;
	     if rm_domain_info.next_domain_ptr = null ()
	     then rdi_ptr = null ();
	     else do;
		     rm_domain_info.next_domain_ptr = ptr (rdbi_ptr, rel (rm_domain_info.next_domain_ptr));
		     rdi_ptr = rm_domain_info.next_domain_ptr;
		end;
	end;

	return;

     end;
%page;
update_rm_rel_info: proc (urri_bad_id_list_version);

	dcl     urri_bad_id_list_version bit (1);
	dcl     (i, j)		 fixed bin;
	dcl     SCOPE_UPDATE	 fixed bin init (6) internal static options (constant);
	dcl     rel_model_ptr	 ptr;		/* used to be sure that opener still has access to the relation model segments */

	rmra_ptr = rm_db_info.ra_ptr;
	do i = 1 to rm_rel_array.num_rels;
	     rm_rel_array.rel_data (i).ri_ptr = ptr (rdbi_ptr, rel (rm_rel_array.rel_data (i).ri_ptr));
	     rmri_ptr = rm_rel_array.rel_data (i).ri_ptr;
	     call initiate_file_ ((rm_db_info.db_path), rtrim (rm_rel_info.model_name) || ".m", R_ACCESS, rel_model_ptr, (0), 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 call initiate_file_ ((rm_db_info.db_path), rtrim (rm_rel_info.model_name) || ".m", R_ACCESS, rel_model_ptr, (0), error_code);
		     else error_code = error_table_$moderr;
		end;
	     if rel_model_ptr = null ()
	     then do;
		     call sub_err_ (error_code, caller_name, "c", null (), return_value,
			"^/Unable to get a pointer to the model segment ""^a>^a.m""", rm_db_info.db_path, rm_rel_info.model_name);
		     call error_exit;
		end;
	     rm_rel_info.modify = (ready_mode = SCOPE_UPDATE);
	     rm_rel_info.store = rm_rel_info.modify;
	     rm_rel_info.delete = rm_rel_info.modify;
	     rm_rel_info.mdbm_secured = rm_db_info.mdbm_secured;
	     rm_rel_info.ready_mode = ready_mode;
	     rm_rel_info.id_list_ptr = ptr (rdbi_ptr, rel (rm_rel_info.id_list_ptr));
	     if rm_rel_info.id_list_ptr -> id_list.version ^= ID_LIST_VERSION_1
	     then do;
		     urri_bad_id_list_version = "1"b;
		     goto exit_update_rm_rel_info;
		end;
	     rm_rel_info.scope_flags_ptr = ptr (dbcb_ptr, rel (rm_rel_info.scope_flags_ptr));
	     do j = 1 to rm_rel_info.nkey_attr;
		rm_rel_info.key_attr_ptrs (j) = ptr (rdbi_ptr, rel (rm_rel_info.key_attr_ptrs (j)));
	     end;
	     do j = 1 to rm_rel_info.num_attr;
		rm_rel_info.attr_ptrs (j) = ptr (rdbi_ptr, rel (rm_rel_info.attr_ptrs (j)));
		rai_ptr = rm_rel_info.attr_ptrs (j);
		rm_attr_info.domain_ptr = ptr (rdbi_ptr, rel (rm_attr_info.domain_ptr));
		rm_attr_info.mdbm_secured = rm_db_info.mdbm_secured;
	     end;
	end;

exit_update_rm_rel_info:
	return;

     end;
%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 */
	dcl     proc_type		 char (*);	/* type of procedure being set up */
	dcl     path_entry_offset	 bit (18);	/* offset in the given area to the path_entry struct */
	dcl     base_pointer	 ptr;		/* base of segment for given path_entry */
	dcl     cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry);

	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;
		call sub_err_ (error_code, caller_name, "c", null (), return_value,
		     "^/Unable to build an entry variable for the ""^a"""
		     || " procedure using the path$entry = ^a$^a for the domain ^a",
		     proc_type, path_entry.path, path_entry.entry, rm_domain_info.name);
		error_code = mrds_error_$bad_domain_proc;
		call error_exit;
	     end;

	return (output_entry);

     end build_entry;
%page;
generate_resultant_data: proc;

/* now fill in the dbcb(database control block) structure */

	call init_dbcb ();

/* the secure resultant model structures must be filled in,
   after obtaining the secure resultant segment, and a pointer to
   it must be returned to be saved in the non-secure portion */

	call mu_sec_init_res (dsm_path, submodel_version, db_path,
	     dbm_ptr, dbcb_ptr, rdbi_ptr, error_code);
	if error_code ^= 0				/* init_res reports it's own errors */
	then call error_exit;

	if report_on_res_creation
	then call ioa_ ("Resultant has been created from scratch: version is ^a",
		rm_db_info.saved_res_version);

	if submodel_open				/* can now close the submodel, if one was opened */
	then do;
		call mrds_dsm_close (submodel_iocb_ptr, error_code);
		submodel_open = OFF;
		if error_code ^= 0
		then do;
			call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			     "Unable to close the submodel """, dsm_path, """.");
			call error_exit;
		     end;
	     end;

	rm_db_info.administrator = mrds_authorization.administrator;
	dbcb.rdbi_ptr = rdbi_ptr;

	return;

     end;

%page;
init_dbcb: procedure ();

/* initialize the database control block structure,
   the non-secure portion of the resultant model */

	call hcs_$get_uid_seg (dbc_ptr, dbcb.dbc_uid, error_code);
	if error_code ^= 0
	then do;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "Unable to obtain the unique identifier of the data base control segment, opening will be aborted");
		call error_exit;
	     end;
	dbcb.dbc_ptr = dbc_ptr;
	dbcb.rdbi_ptr = null ();
	dbcb.range_ptr = null ();
	dbcb.select_ptr = null ();
	dbcb.sv_ptr = null ();
	dbcb.so_ptr = null ();
	dbcb.ti_ptr = null ();
	dbcb.lit_ptr = null ();
	dbcb.current_ptr = null ();
	dbcb.ss_ptr = null ();
	dbcb.retr_info_ptr = null ();
	dbcb.trel_info_ptr = null ();
	dbcb.sti_ptr = null ();
	dbcb.sfi_ptr = null ();
	dbcb.scope_ptr = null ();
	dbcb.select_area_ptr = model_area_ptr;
	dbcb.current_data_ptr = curdat_ptr;
	dbcb.static_data_ptr = stadat_ptr;
	dbcb.element_id_list_segment_ptr = el_id_seg_ptr;
	dbcb.store_area_ptr = null ();
	dbcb.retrieve_area_ptr = null ();
	dbcb.modify_area_ptr = null ();
	dbcb.delete_area_ptr = null ();
	dbcb.def_temp_rel_area_ptr = null ();
	dbcb.compiled_se_info_ptr = null ();
	dbcb.work_area_ptr = null ();
	dbcb.se_info_ptr = null ();
	dbcb.reserved_ptrs (*) = null ();
	dbcb.cursor_ptrs_storage_ptr = null ();
	dbcb.cursor_storage_area_ptr = null ();
	dbcb.parser_work_area_ptr = null ();

	dbcb.another_flag = OFF;
	dbcb.current_flag = OFF;
	dbcb.dbc_incr = OFF;
	dbcb.delete_flag = OFF;
	dbcb.dup_retain = OFF;
	dbcb.prev_select = OFF;
	dbcb.possible_op = OFF;
	dbcb.sel_clause = OFF;
	dbcb.dsm_sw = dsm_sw;
	dbcb.val_rtrv = OFF;
	dbcb.val_mod = OFF;
	dbcb.val_del = OFF;
	dbcb.val_dtr = OFF;
	dbcb.resultant_in_pdir = res_in_pdir;
	dbcb.transactions_needed = db_model.db_type_flags.transactions_needed;
	dbcb.concurrency_on = db_model.db_type_flags.concurrency_on;
	dbcb.rollback_on = db_model.db_type_flags.rollback_on;

	dbcb.open_mode = OFF;
	dbcb.new_select_expr = ON;
	dbcb.no_optimize = OFF;
	dbcb.print_search_order = OFF;
	dbcb.res_already_made = OFF;
	dbcb.user_started_transaction = OFF;
	dbcb.non_shared_to_shared = OFF;
	dbcb.reserved = OFF;

	dbcb.nseq_sch = 0;
	dbcb.nind_sch = 0;
	dbcb.nhash_sch = 0;
	dbcb.nlk_sch = 0;
	dbcb.cur_lit_offset = 0;
	dbcb.dbi = db_index;
	dbcb.last_s_e_id_num = 0;
	dbcb.se_transaction_id = "0"b;
	dbcb.last_store_rel_name = " ";
	dbcb.reserved_words (*) = 0;
	if db_model.db_type_flags.vfile_type
	then do;					/* vfile type data base */
		dbcb.relmgr_entries.open = vfile_relmgr_$open;
		dbcb.relmgr_entries.close = vfile_relmgr_$close;
		dbcb.relmgr_entries.create_cursor = vfile_relmgr_$create_cursor;
		dbcb.relmgr_entries.destroy_cursor = vfile_relmgr_$destroy_cursor;
		dbcb.relmgr_entries.set_scope = vfile_relmgr_$set_scope;
		dbcb.relmgr_entries.delete_tuples_by_id = vfile_relmgr_$delete_tuples_by_id;
		dbcb.relmgr_entries.modify_tuples_by_id = vfile_relmgr_$modify_tuples_by_id;
		dbcb.relmgr_entries.get_tuple_by_id = vfile_relmgr_$get_tuple_by_id;
		dbcb.relmgr_entries.get_tuples_by_spec = vfile_relmgr_$get_tuples_by_spec;
		dbcb.relmgr_entries.get_tuple_id = vfile_relmgr_$get_tuple_id;
		dbcb.relmgr_entries.put_tuple = vfile_relmgr_$put_tuple;
		dbcb.relmgr_entries.get_count = vfile_relmgr_$get_count;
		dbcb.relmgr_entries.get_population = vfile_relmgr_$get_population;
		dbcb.relmgr_entries.get_duplicate_key_count = vfile_relmgr_$get_duplicate_key_count;
		dbcb.relmgr_entries.create_relation = vfile_relmgr_$create_relation;
		dbcb.relmgr_entries.create_index = vfile_relmgr_$create_index;
		dbcb.relmgr_entries.destroy_relation_by_path = vfile_relmgr_$destroy_relation_by_path;
		dbcb.access_costs.total_primary_key_cost = 11;
		dbcb.access_costs.access_cost = 7.95;
		dbcb.access_costs.access_overhead = 250;
		dbcb.access_costs.us_access_cost = 2.6;
		dbcb.access_costs.os_access_cost = 6.0;
	     end;
	else do;					/* page_file type database */
	          dm_system_state = dm_gate_$dm_get_system_state();   /* 12.4 This will signal dm_not_available_ if the dm system is down. */
		dbcb.relmgr_entries.open = relation_manager_$open;
		dbcb.relmgr_entries.close = relation_manager_$close;
		dbcb.relmgr_entries.create_cursor = relation_manager_$create_cursor;
		dbcb.relmgr_entries.destroy_cursor = relation_manager_$destroy_cursor;
		dbcb.relmgr_entries.set_scope = relation_manager_$set_scope;
		dbcb.relmgr_entries.delete_tuples_by_id = relation_manager_$delete_tuples_by_id;
		dbcb.relmgr_entries.modify_tuples_by_id = relation_manager_$modify_tuples_by_id;
		dbcb.relmgr_entries.get_tuple_by_id = relation_manager_$get_tuple_by_id;
		dbcb.relmgr_entries.get_tuples_by_spec = relation_manager_$get_tuples_by_spec;
		dbcb.relmgr_entries.get_tuple_id = relation_manager_$get_tuple_id;
		dbcb.relmgr_entries.put_tuple = relation_manager_$put_tuple;
		dbcb.relmgr_entries.get_count = relation_manager_$get_count;
		dbcb.relmgr_entries.get_population = relation_manager_$get_population;
		dbcb.relmgr_entries.get_duplicate_key_count = relation_manager_$get_duplicate_key_count;
		dbcb.relmgr_entries.create_relation = relation_manager_$create_relation;
		dbcb.relmgr_entries.create_index = relation_manager_$create_index;
		dbcb.relmgr_entries.destroy_relation_by_path = relation_manager_$destroy_relation_by_path;
		dbcb.access_costs.total_primary_key_cost = 11;
		dbcb.access_costs.access_cost = 7.95;
		dbcb.access_costs.access_overhead = 250;
		dbcb.access_costs.us_access_cost = 2.6;
		dbcb.access_costs.os_access_cost = 6.0;


	     end;



	dbcb.static_area = empty ();

	stv_number_of_dimensions = mrds_data_$max_attributes;
	allocate simple_typed_vector in (dbcb.static_area) set (dbcb.store_vector_ptr);

	gtv_number_of_dimensions = mrds_data_$max_attributes;
	allocate general_typed_vector in (dbcb.static_area) set (dbcb.modify_vector_ptr);

	return;

     end;
%page;
error_exit: procedure ();

	call clean_up;

	goto exit_mrds_dsl_init_res;

     end;
%page;
clean_up: procedure ();

	if submodel_open
	then do;
		call mrds_dsm_close (submodel_iocb_ptr, code);
		submodel_open = OFF;
		if code = 0 | clean_up_condition then ;
		else call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to close the submodel """, dsm_path, """.");
	     end;

	if res_in_pdir				/* segments in pdir may be resused */
	then call mu_temp_segments$release_all_temp_segments ("MRDS" || db_pic, code);
	else call mu_temp_segments$delete_all_temp_segments ("MRDS" || db_pic, code);
	if code ^= 0 & code ^= error_table_$argerr
	then call sub_err_ (code, caller_name, continue, info_ptr, return_value,
		"Could not free the temp segments created.");

	if db_index ^= 0
	then do;
		call mu_database_index$reset_resultant_model_pointer (db_index, (dbcb_ptr));
		db_index = 0;
	     end;

	if dbcb_ptr ^= null ()
	then do;
		call hcs_$delentry_seg (dbcb_ptr, code);
		if code ^= 0
		then call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/^a^a^a",
			"Unable to delete the dbcb segment for database """, dsm_path, """.");
		dbcb_ptr = null ();
	     end;
     end;
%page;
	dcl     (header_ptr,			/* points to dsm header record */
	        dbc_ptr)		 ptr;		/* point to the data base control segment */

	dcl     bc		 fixed bin (24);	/* bit count of data base control segment */
	dcl     code		 fixed bin (35);	/* return status code */

	dcl     dsm_sw		 bit (1);		/* ON => data submodel name is being used */

	dcl     ready_mode		 fixed bin;	/* mode that the database will be opened with */

	dcl     administrator	 bit (1);		/* "1"b => that the user is a DBA */

	dcl     db_index		 fixed bin (35);	/* data base index value */
	dcl     db_path		 char (168);	/* absolute path name of data base */
	dcl     dsm_path		 char (168);	/* submodel path name */
	dcl     view_dir		 char (*);	/* view path directory */
	dcl     view_ent		 char (*);	/* view path entry name */

	dcl     RW		 fixed bin (5) int static init (01010b) options (constant); /* code for read/write access */
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     mu_temp_segments$get_temp_segments entry (fixed bin (35), char (*), (*) ptr, fixed bin (35));
	dcl     mu_temp_segments$release_all_temp_segments entry (char (*), fixed bin (35));
	dcl     hcs_$get_uid_seg	 entry (ptr, bit (36) aligned, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));


	dcl     (null,
	        addr,
	        fixed,
	        length,
	        pointer,
	        rel,
	        rtrim,
	        substr,
	        empty,
	        divide,
	        ptr)		 builtin;

	dcl     cleanup		 condition;
	dcl     clean_up_condition	 bit (1);		/* on => cleanup signaled */

	dcl     mrds_data_$max_attributes ext fixed bin (35);
	dcl     mrds_data_$saved_res_version ext char (8);
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     mrds_dsm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mu_sec_init_res	 entry (char (168), fixed bin, char (168), ptr, ptr, ptr, fixed bin (35));
	dcl     mu_sec_reg_user	 entry (ptr, ptr, fixed bin (35));
	dcl     OFF		 bit (1) init ("0"b); /* false value */
	dcl     ON		 bit (1) init ("1"b); /* true value */
	dcl     mu_database_index$get_database_index entry (fixed bin (35), ptr); /* gets database index definition */
	dcl     sub_err_		 entry options (variable); /* error reporting routine */
	dcl     caller_name		 char (20) init ("mrds_dsl_init_res"); /* name of calling routine */
	dcl     continue		 char (1) init ("c"); /* don't stop after printing mesg */
	dcl     info_ptr		 ptr init (null ());/* unused */
	dcl     return_value	 fixed bin (35) init (0); /* unused */
	dcl     submodel_open	 bit (1);		/* on => submodel has been opened */
	dcl     submodel_iocb_ptr	 ptr ext init (null); /* External static pointer to iocb
						   of submodel.  Used by mu_sec_init_res,
						   mus_get_relation_names, and
						   mus_get_attribute_names to
						   refer to a common opening of the submodel. */
	dcl     error_code		 fixed bin (35);	/* error type status encoding */
	dcl     input_path		 char (168);	/* path input by user */
	dcl     hcs_$delentry_seg	 entry (ptr, fixed bin (35)); /* delets segs without ref names */
	dcl     mu_database_index$reset_resultant_model_pointer entry (fixed bin (35), ptr); /* removes db index definition */
	dcl     mrds_data_$max_dbs	 fixed bin (35) ext;/* max number of open databases */
	dcl     sub_error_		 condition;	/* signaled when sub_err_ called */
	dcl     mrds_dsl_init_select_area entry (ptr, fixed bin (35)); /* selection expre area init */
	dcl     mrds_error_$too_many_dbs fixed bin (35) ext; /* >64 databases open attempt */
	dcl     resultant_dir	 char (168);	/* storage location of resultant model */
	dcl     process_dir		 char (168);	/* path to the process directory */
	dcl     mrds_dsl_resultant_storage$get entry returns (char (168)); /* gets resultant model directory */
	dcl     ptr_array		 (5) ptr;		/* array of pointers for mu_temp_segment */
	dcl     curdat_ptr		 ptr;		/* points to current data segment */
	dcl     stadat_ptr		 ptr;		/* points to static data segment */
	dcl     el_id_seg_ptr	 ptr;		/* points to element id list segments */
	dcl     delete_seg		 bit (6) init ("000100"b); /* switches to delete segment */
          dcl     dm_error_$system_not_initialized fixed bin (35) ext static;
	dcl     mrds_error_$inc_secure_open fixed bin (35) ext; /* incorrect method for opening secure db */
	dcl     mrds_error_$incons_db	 fixed bin (35) ext static;
	dcl     mrds_error_$bad_domain_proc fixed bin (35) ext static;
	dcl     mrds_data_$submodel_dir_name char (16) ext; /* name of submodel dir under db dir */
	dcl     mrds_dm_secured_submodel entry (char (*), char (*), char (*))
				 returns (bit (1)); /* returns true if submodel in submodel dir */
	dcl     mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* DBA detecter */
	dcl     local_area		 area (200);	/* space for submodeldsm header and DBA info */
	dcl     mu_concurrency_control$open_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35)); /* get ptr to control seg */
	dcl     submodel_version	 fixed bin;	/* version of submodel opened, or 0 */
	dcl     error_table_$moderr	 fixed bin (35) ext;/* incorrect access */
	dcl     error_table_$no_info	 fixed bin (35) ext static; /* no access to seg and no s access on dir */
	dcl     error_table_$dirlong	 fixed bin (35) ext static;
	dcl     mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35)); /* sets access for DBA types */
	dcl     res_in_pdir		 bit (1);		/* true ==> resultant created in pdir */
	dcl     db_pic		 pic "999";
	dcl     report_on_res_creation bit (1) internal static init ("0"b);
						/* "1"b => message indicating how resultant was created will be sent to terminal */
          dcl     dm_system_state        char (4) aligned;  /* Results from dm_gate_$dm_get_system_state. Not used: call checks for dm. */
	dcl     ioa_		 entry options (variable);
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     mu_temp_segments$delete_all_temp_segments entry (char (*), fixed bin (35));
	dcl     error_table_$argerr	 fixed bin (35) ext;

	dcl     vfile_relmgr_$open	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$close	 entry (bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$create_cursor entry (bit (36) aligned, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$destroy_cursor entry (ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$set_scope entry (bit (36) aligned, bit (2) aligned, bit (2) aligned, fixed bin (35));
	dcl     vfile_relmgr_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$delete_tuples_by_id entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$modify_tuples_by_id entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$get_tuples_by_spec entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$get_count entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$get_population entry (ptr, fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$get_duplicate_key_count entry entry (ptr, bit (36) aligned, fixed bin (17), fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$create_relation entry (char (*), char (*), ptr, ptr,
				 bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$create_index entry (bit (36) aligned, ptr, bit (36) aligned,
				 fixed bin, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$destroy_relation_by_path entry (bit (36) aligned,
				 fixed bin (35));
	dcl     relation_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$close entry (bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$create_cursor entry (bit (36) aligned, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$destroy_cursor entry (ptr, ptr, fixed bin (35));
	dcl     relation_manager_$set_scope entry (bit (36) aligned, bit (2) aligned, bit (2) aligned, fixed bin (35));
	dcl     relation_manager_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$delete_tuples_by_id entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     relation_manager_$modify_tuples_by_id entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     relation_manager_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$get_tuples_by_spec entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$get_count entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     relation_manager_$get_population entry (ptr, fixed bin (35), fixed bin (35));
	dcl     relation_manager_$get_duplicate_key_count entry (ptr, bit (36) aligned, fixed bin (17), fixed bin (35), fixed bin (35));
	dcl     relation_manager_$create_relation entry (char (*), char (*), ptr, ptr,
				 bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$create_index entry (bit (36) aligned, ptr, bit (36) aligned,
				 fixed bin, bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$destroy_relation_by_path entry (bit (36) aligned,
				 fixed bin (35));
          dcl     dm_gate_$dm_get_system_state entry () returns (char(4) aligned);
          dcl     dm_not_available_      condition;


%page;
%include access_mode_values;
%page;
%include dm_id_list;
%page;
%include status_structures;
%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_rm_attr_info;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_dsm_header;
%page;
%include mdbm_db_model;
%page;
%include mdbm_scope_info;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_debug_names;
%page;
%include mrds_authorization;
%page;
%include vu_typed_vector;
%page;
     end mrds_dsl_init_res;






		    mrds_dsl_init_select_area.pl1   08/01/88  1347.3r w 08/01/88  1315.0       28314



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

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

mrds_dsl_init_select_area: proc (dbcbp, code);
	dcl     dbcbp		 ptr parm;	/* ptr to the dbcb (INPUT) */
	dcl     code		 fixed bin (35) parm; /* error code (OUTPUT) */

/* NOTES:
   This procedure initializes the area used for all selection expression allocations.
   */

/* HISTORY:
   Originally written by Al Kepner, June 1, 1979.

   82-12-09 Davids: changed the area to a freeing area so that the
   page_file relation manager will work. It should be changed back
   to a freeing area on Jan 15, 1983.

   83-04-04 Davids: Explicit declaration of the builtin functions null, 
   pointer, and rel.

   83-04-04 Davids: Changed the area back to non-freeing

   83-05-04 Mike Kubicar : Changed the area back to freeing (temporarily)

   84-09-05 John Hergert: removed call to hcs_$truncate_seg for 
   performance improvement. Also took out 2nd parameter 'select_area_ptr'
   since it is already in the dbcb. No point in passing it in twice.

*/
	dbcb_ptr = dbcbp;
	select_area_ptr = dbcb.select_area_ptr;

	code = 0;
	call mu_define_area (select_area_ptr, size (model_area), "MRDS.select",
	     "0"b /* not extensible */, "0"b /* no freeing */, "0"b, "0"b /* no zeroing */, icode);
	if icode ^= 0 then call error (icode);
	allocate select_area_struct in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	model_seg_ptr = pointer (select_area_ptr, 0);
	model_seg.struct_offset = rel (select_area_struct_ptr);
	select_area_struct.version = 1;
	select_area_struct.dbcb_ptr = dbcb_ptr;
exit:	;
	return;

error: proc (icode);
	dcl     icode		 fixed bin (35) parm;
	code = icode;
	go to exit;
     end error;

/* VARIABLES FOR MRDS_DSL_INIT_SELECT_AREA */

	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin (18), fixed bin (35));
	dcl     icode		 fixed bin (35);
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;
	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));
	dcl     (null, pointer, rel)	 builtin;

%include mdbm_seg_area;

%include mrds_select_area;

%include mrds_dbcb;
     end mrds_dsl_init_select_area;




		    mrds_dsl_make_literal.pl1       10/24/88  1651.0r w 10/24/88  1359.4       95247



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

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

mrds_dsl_make_literal: proc (dbcb_ptr, lip, code);

/*  NOTES:

   This  procedure  builds  a  literal  entry  in  the dbcb literal pool.  The
   literal is aligned, zero padded, and encoded if necessary.


   HISTORY:

   79-02-01 J. A. Weedreyer: Initially written.

   79-06-06 Al Kepner: Modified to use select_area.

   79-08-28 NSDavids: Modified to initialize the internal status code to zero.

   79-12-02  Mary  Ward:  Modified  to pass data descriptors "by value" rather
   than  just  give  the  user  a  pointer  into  the  resultant  model and to
   initialize the pointer and descriptor for the return code to be used by the
   encode procedure.

   79-12-01      Jim      Gray:      Modified      to     add     calls     to
   mu_data_class$valid_scalar_data_type,   and   mu_data_class$real_data_class,  and
   $complex_data_class,  so  that  packed  decimal  could  be handled also the
   routines mu_data_length$_data_bit_length, and mu_data_align$align_data_item are
   called instead of internal calculation, for the same reason.

   81-05-06  Rickie  E.   Brinegar:  Modified  to  make  use  of  the modified
   rm_domain_info   structure   and   to   use  cu_$generate_call  instead  of
   cu_&gen_call.

   83-04-04 Davids: Removed declarations to things that are no longer
   used: addrel, align_array, arith_len, cleanup, mod,
   mu_data_class$complex_data_class mu_data_class$real_data_class,
   num_desc, string.

   83-09-26 Mike Kubicar - Added code to check if a stringsize condition has
   occurred while converting the literal.  If so, just move the original
   literal into the literal pool and let the compare code handle things.

*/
%page;
	alloc_sw = "0"b;				/* remember main entry */
	go to common;

alloc: entry (dbcb_ptr, lip, code);

/* Entry to merely alocate space, without moving in value */

	alloc_sw = "1"b;

common:
	num_dims = 0;
	stringsize_occurred = "0"b;
	select_area_ptr = dbcb.select_area_ptr;
	if dbcb.lit_ptr = null then do;		/* must alloc lit area */
		allocate literal_string in (select_area); /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning of each new selection expression. */
		literal_string = "0"b;
		dbcb.cur_lit_offset = 0;
	     end;


	lit_info.lit_blen = mu_data_length$get_data_bit_length (lit_info.litd_ptr -> descriptor_overlay);

	dbcb.cur_lit_offset = dbcb.cur_lit_offset +
	     mu_data_align$align_data_item (lit_info.litd_ptr, dbcb.cur_lit_offset);

	if dbcb.cur_lit_offset + lit_info.lit_blen > mrds_data_$lit_string_size - 1 then
	     call error (mrds_error_$lit_string_ovfl);	/* if about to overflow the literal pool */

	lit_info.lit_offset = dbcb.cur_lit_offset;	/* set up output for caller */
	lit_info.lit_ptr = addr (literal_array (lit_info.lit_offset));

	if ^alloc_sw then do;			/* if also moving in value */

		if ^mu_valid_data_type$valid_scalar_data_type (lit_info.srcd_ptr -> descriptor_overlay) then
		     call error (mrds_error_$inv_literal_type);

		on conversion call error (mrds_error_$bad_arith_const);
		on overflow call error (mrds_error_$bad_arith_const);
		on underflow call error (mrds_error_$bad_arith_const);

		if lit_info.encd_proc then do;	/* if must encode */
			if lit_info.srcd_ptr -> bit36 ^= lit_info.encdd_ptr -> bit36 then do; /* if must first convert */
				lit_info.encd_blen = mu_data_length$get_data_bit_length (lit_info.encdd_ptr -> descriptor_overlay);
				if lit_info.encd_blen > 2376 then do; /* if long, must alloc. */
					allocate encd_bs in (select_area); /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning of each new selection expression. */
				     end;
				else eb_ptr = addr (wkspc); /* if can use stack work space */
				encd_bs = "0"b;	/* clear the space */
				call mu_convert$convert_data (lit_info.src_ptr,
				     lit_info.srcd_ptr,
				     eb_ptr,
				     lit_info.encdd_ptr,
				     icode);
				if icode ^= 0 then call error (icode);
				encode_list.uv_ptr = eb_ptr;
			     end;			/* if needed to convert */

			else encode_list.uv_ptr = lit_info.src_ptr; /* if no need to convert */

			user_descriptor = lit_info.encdd_ptr -> bit36; /* move user descriptor into temporary */
			encode_list.ud_ptr = addr (user_descriptor);
			if lit_info.encdd_ptr -> descriptor.type = varying_char_dtype /* see if need to adjust ptr */
			     | lit_info.encdd_ptr -> descriptor.type = varying_bit_dtype then
			     encode_list.uv_ptr = addr (encode_list.uv_ptr -> varying.string);
			db_descriptor = lit_info.litd_ptr -> bit36; /* move db descriptor into temporary */
			encode_list.dbd_ptr = addr (db_descriptor);
			if lit_info.litd_ptr -> descriptor.type = varying_char_dtype
			     | lit_info.litd_ptr -> descriptor.type = varying_bit_dtype then
			     encode_list.dbv_ptr = addr (lit_info.lit_ptr -> varying.string);
			else encode_list.dbv_ptr = lit_info.lit_ptr;

			encode_list.code_ptr = addr (icode);
			encode_list.coded_ptr = addr (FB35_DESC);
			call cu_$generate_call (lit_info.encd_entry, addr (encode_list));
			if icode ^= 0 then call error (icode); /* encode the value */


		     end;				/* if encoding */

		else do;				/* if not encoding */

			if lit_info.srcd_ptr -> bit36 ^= lit_info.litd_ptr -> bit36 then do; /* if must convert */


/*
*
*  First, just try to convert to the target data type.  If a stringsize
*  occurs, then just move the given type to the literal pool.  Conversion
*  will occur at comparison time.  That code is better suited to deal with
*  them.
*
*/

				on stringsize
				     stringsize_occurred = "1"b;
				call mu_convert$convert_data (lit_info.src_ptr,
				     lit_info.srcd_ptr,
				     lit_info.lit_ptr,
				     lit_info.litd_ptr,
				     icode);
				revert stringsize;
				if icode ^= 0 then call error (icode);
				if stringsize_occurred then do; /* It's not safe to convert */
					lit_info.lit_blen = mu_data_length$get_data_bit_length (
					     lit_info.srcd_ptr -> descriptor_overlay);
					dbcb.cur_lit_offset = dbcb.cur_lit_offset +
					     mu_data_align$align_data_item (lit_info.srcd_ptr, dbcb.cur_lit_offset);
					if dbcb.cur_lit_offset + lit_info.lit_blen > mrds_data_$lit_string_size - 1
					then call error (mrds_error_$lit_string_ovfl);

					lit_info.lit_offset = dbcb.cur_lit_offset; /* set up output for caller */
					lit_info.lit_ptr = addr (literal_array (lit_info.lit_offset));
					lit_info.litd_ptr = lit_info.srcd_ptr;
					lit_bit_str = lit_info.src_ptr -> lit_bit_str;
				     end;
			     end;
			else lit_bit_str = lit_info.src_ptr -> lit_bit_str; /* if no conversion */

		     end;				/* if not encoding */


	     end;					/* if moving in value */

	dbcb.cur_lit_offset = dbcb.cur_lit_offset + lit_info.lit_blen; /* update the cursor */

	code = 0;

exit:
	return;
%page;
error: proc (cd);

/* Error Procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

     end error;
%page;
%include mrds_dbcb;
%page;
%include mrds_lit_info;
%page;
%include mrds_literal_string;
%page;
%include mdbm_descriptor;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include std_descriptor_types;
%page;
	dcl     (code,				/* Output:  status code */
	        icode		 init (0)) fixed bin (35); /* internal status code */

	dcl     FB35_DESC		 bit (36) aligned static options (constant)
				 init ("100000100000000000000000000000100011"b); /* descriptor for decode return code */

	dcl     db_descriptor	 bit (36) aligned;	/* temp for db descriptor */
	dcl     user_descriptor	 bit (36) aligned;	/* temp for encode descriptor */

	dcl     stringsize_occurred	 bit (1);		/* True if a strinsize condition occurred
	     					   during literal conversion */
	dcl     eb_ptr		 ptr;		/* to bit str. containing converted val, ready for encoding */

	dcl     bit36		 bit (36) based;	/* template */
	dcl     alloc_sw		 bit (1);
	dcl     encd_bs		 bit (lit_info.encd_blen) based (eb_ptr); /* conv. val. ready for encoding */
	dcl     wkspc		 (33) fixed bin (71); /* work space to save alloc. */
	dcl     lit_bit_str		 bit (lit_info.lit_blen) based (lit_info.lit_ptr); /* final literal */

	dcl     1 varying		 unaligned based,	/* template of varying string */
		2 length		 fixed bin (35),	/* length word */
		2 string		 char (0);	/* string begins here */

	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;

	declare descriptor_overlay	 bit (36) unal based; /* overlay for descriptor */
	declare mu_data_length$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); /* storage bit length of data */
	declare mu_data_align$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin); /* alignment needed for data,
						   given last used offset */
	declare mu_valid_data_type$valid_scalar_data_type entry (bit (36)) returns (bit (1) aligned); /* decides if supported data type */

	dcl     (mrds_data_$lit_string_size,
	        mrds_error_$bad_arith_const,
	        mrds_error_$inv_literal_type,
	        mrds_error_$lit_string_ovfl,
	        sys_info$max_seg_size) ext fixed bin (35);

	dcl     (conversion,
	        stringsize,
	        underflow,
	        overflow)		 condition;

	dcl     (null,
	        addr,
	        fixed,
	        rel)		 builtin;

	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     mu_convert$convert_data entry (ptr, ptr, ptr, ptr, fixed bin (35));

     end mrds_dsl_make_literal;




		    mrds_dsl_modify.pl1             10/16/89  1244.9rew 10/16/89  1241.8      160110



/****^  ***********************************************************
        *                                                         *
        * 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-04-19 by Thanh
     Nguyen. (see mrds #136)
  2) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-06,Dupuis), install(88-08-01,MR12.2-1073):
     Changed references of sel_ptr to select_list_ptr for new parser.
  3) change(89-09-25,AWTaylor), approve(89-09-25,MCR8116),
     audit(89-10-12,Hussein), install(89-10-16,MR12.3-1093):	
     phx21249 - Created variable last_tuple_id to prevent redundant processing
     in do while loop
                                                   END HISTORY COMMENTS */


mrds_dsl_modify: modify: proc;

/* (database_index, selection_expression, values, code)

   BEGIN_DESCRIPTION

   The purpose of this procedure is to implement the dsl_$modify function.

   This  procedure  calls  translate  with the selection expression then calls
   search and mu_modify.



   INPUT CONDITIONS:

   database_index: is the index of the database the used wishes to modify.

   selection_expression:  is the expression supplied by the user to select the
   tuplies to be modified.

   values: are any values used by the selection expression.



   OUTPUT CONDITIONS:

   If no errors are encountered the deletion was performed.

   code = 0; If no errors are detected.

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

   code  =  mrds_error_$tuple_not_found; If no tuples satisying the se.  expr.
   were found.

   code = something else; If some other error was detected;


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


   HISTORY:

   76-01-01 R. D. Lackey: Initially written.

   78-10-01 J. A. Weeldreyer: Modified for MR7.0.

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

   79-08-06  Al  Kepner:  Modified to pick up the correct var_index for tuples
   being modified.

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

   80-06-01  Jim  Gray  :  Modified  to  add  first_time_flag  to  util modify
   interface,  so  allocated  space  could  be  reused  for  large tuple count
   modifies.

   81-01-29 Jim Gray : removed references to mdbm_data_$current_version, using
   a constant instead so that future db version expansion is possible.

   81-03-24 Jim Gray : added capability for selection expression

   81-03-27 Jim Gray : changed dbi parameter to mu_modify to dbcb_ptr, as part
   of  removing  use  of  mus_ptr_man  to  be declared char varying as well as
   nonvarying.

   81-09-29  Rickie E.  Brinegar: fixed the setting of num_ptrs to come before
   the referencing of any elements of the argument_list arrays which use it as
   an array limit.

   82-09-20 Davids: Modified for the new DMS interface. Removed call to
   mu_modify and replaced in with calls to mu_cursor_manager_$get, and
   dbcb.relmgr_entries.modify_tuples_by_id. Modify_tuples_by_id is called
   with an array to 100 tuple_ids to reduce the number of calls. the checks
   on ready_mode and scope were moved from mu_modify to this routine.

   82-10-12 Davids: Modified so that module would compile. Used the new
   names of cursor_ptrs_storage_ptr and cursor_storage_area_ptr in the
   call to mu_cursor_manager_$get

   82-11-29 Davids: Modified so that if the selection expression is a -current
   then after the modify operation the copy of the tuple in the tuple_info
   str is updated, this way modify -current; retrieve -current retrieves the
   new values not the old values. Also corrected the loop that accumulates
   100 tuples_ids to be modified for the -current case. For the current case
   no looping is needed since only 1 tuple can be current.

   82-12-07 Roger Lackey : Removed dcl mu_modify not referenced and
                           added  dcl for addrel which was not declared.

   83-01-24 Davids: added transaction code

   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-31 Mike Kubicar : Updated relation manager calling sequence.

   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-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.
*/
%page;
	dbcb_ptr, area_ptr = null ();
	mstxn_txn_id = "0"b;

	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 = arg_list.arg_count / 2;		/* Get the number of arguments to this proc */
	if nargs < 3 then
	     signal arg_error;			/* This returns to command level */


	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);

/* BEGIN CHANGE 81-03-24 *************************************** */

	if arg_list.code = 4 then do;
		num_ptrs = arg_list.arg_count;	/* Determine number of ptrs in arg list */
		desc_ptr = arg_list.arg_des_ptr (nargs + 2);
		adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 3));
	     end;
	else do;
		num_ptrs = arg_list.arg_count + 1;
		desc_ptr = arg_list.arg_des_ptr (nargs + 3);
		adpl_ptr = addr (arg_list.arg_des_ptr (nargs + 4));
	     end;

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

/* END CHANGE 81-03-24 **************************************** */


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

	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
	     call error (mrds_error_$invalid_db_index);

	mstxn_transactions_needed = dbcb.transactions_needed;

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

	on cleanup call mstxn_cleanup;

	on any_other call mstxn_any_other;
%page;
%include mrds_start_transaction;

	if mstxn_code ^= 0
	then call error (mstxn_code);
%page;
	dbcb.user_started_transaction = user_started_transaction;
	dbi_pic = dbcb.dbi;
	call
	     mu_define_area$define_temp_dir_area (dbcb.modify_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.modify_area_ptr;
						/* Create a work area for mu_retrieve to allocate the value_for_users. */
	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_modify,
	     se_ptr, se_len, appl_ptr, adpl_ptr, num_args, icode);
	if icode ^= 0 then
	     call error (icode);
	if ^dbcb.val_mod then
	     call error (mrds_error_$inval_mod_expr);

	ti_ptr = dbcb.ti_ptr;
	range_ptr = dbcb.range_ptr;
	if dbcb.current_flag then
	     select_list_ptr = dbcb.current_ptr;
	else select_list_ptr = dbcb.select_ptr;
	vi = select_list.item (1).var_index;		/* Pick up var_index for tuples to be modified. */
	rmri_ptr = range.tup_var.ri_ptr (vi);

	if rm_rel_info.ready_mode ^= SCOPE_UPDATE	/* check opening mode and scope to */
	then call error (mdbm_error_$inc_ready_mode);	/* be sure that the relation can be modified */
	if ^rm_rel_info.modify
	then call error (mdbm_error_$view_prevent);

	ntuples_modified = 0;
	done = "0"b;

	collection_id = rm_rel_info.rel_id;
	call mu_cursor_manager_$get (database_index, rmri_ptr, 0, collection_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 mu_build_tuple (rmri_ptr, area_ptr, dbcb.modify_vector_ptr, move_list_array.ml_ptr (1), "1"b, icode);
	if icode ^= 0
	then call error (icode);
	eil_number_of_elements = 100;
	allocate element_id_list in (wa);
	element_id_list.version = ELEMENT_ID_LIST_VERSION_1;

/* phx21249, AWTaylor. Init last_tuple_id */

	last_tuple_id = "0"b;

	do while ((icode = 0) & ^(done));		/* while we are still finding tuples */
	     if ^dbcb.current_flag			/* if selection expression is not -current */
	     then do;
		     element_id_list.number_of_elements = 0;
		     do i = 1 to 100 while (icode = 0);
			call mrds_dsl_search (dbcb_ptr, area_ptr, icode);
			if icode = 0
			then do;

/* phx21249, AT. Added a check to skip over redundant tuples */

			     if ((element_id_list.number_of_elements = 0) |

			     (tuple_info.tuple_id(vi) ^= last_tuple_id)) then do;
				element_id_list.number_of_elements = element_id_list.number_of_elements + 1;
				element_id_list.id (element_id_list.number_of_elements) = tuple_info.tuple.tuple_id (vi);
				end;
				last_tuple_id = tuple_info.tuple.tuple_id(vi);
			     end;
		     end;
		     if icode ^= mrds_error_$tuple_not_found & icode ^= 0
		     then call error (icode);
		     else if icode = mrds_error_$tuple_not_found
		     then do;
			     if (element_id_list.number_of_elements < 1) &
				(ntuples_modified < 1)
			     then call error (icode);
			     icode = 0;
			     done = "1"b;
			end;
		end;
	     else do;				/* selection expression is -current */
		     element_id_list.number_of_elements = 1;
		     call mrds_dsl_search (dbcb_ptr, area_ptr, icode);
		     if icode = 0
		     then element_id_list.id (element_id_list.number_of_elements) = tuple_info.tuple.tuple_id (vi);
		     else call error (icode);
		     done = "1"b;
		end;

	     call dbcb.relmgr_entries.modify_tuples_by_id
		(cursor_ptr, element_id_list_ptr, dbcb.modify_vector_ptr, number_of_tuples_modified, icode);
	     if icode ^= 0
	     then call error (icode);

	     ntuples_modified = ntuples_modified + number_of_tuples_modified;
	end;					/* modify loop */

	if icode ^= 0 then
	     call error (icode);
	else if ntuples_modified < 1 then
	     call error (icode);

	code = 0;

	if dbcb.current_flag			/* If this is -current, update the copy of the current */
	then do;					/* tuple to what it looks like after the modify */
		simple_typed_vector_ptr = tuple_info.tuple.tuple_ptr (vi);
		general_typed_vector_ptr = dbcb.modify_vector_ptr;
		do i = 1 to general_typed_vector.number_of_dimensions;
		     attr_no = general_typed_vector.dimension (i).identifier;
		     bit_length = rm_rel_info.attr_ptrs (attr_no) ->
			rm_attr_info.bit_length;
		     simple_typed_vector.dimension (attr_no).value_ptr -> bit_string =
			general_typed_vector.dimension (i).value_ptr -> bit_string;
		end;
	     end;
%page;
exit:
	if dbcb_ptr = null () then
	     ;
	else if dbcb.modify_area_ptr ^= null then
	     call mu_release_area (dbcb.modify_area_ptr);

	if code = mrds_error_$tuple_not_found
	then mftxn_code = 0;
	else mftxn_code = code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then code = mftxn_code;

	return;					/* Return to the caller with a code */


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

	return ("0"b);

/* No rollbacks requested by this module at this point in time. */

     end should_rollback;

restore_significant_data: proc;

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

	if dbcb_ptr ^= null ()
	then do;
		if dbcb.modify_area_ptr ^= null ()
		then do;
			call mu_release_area (dbcb.modify_area_ptr);
		     end;
	     end;

	return;

     end restore_significant_data;
%page;
error:
     proc (cd);					/* Internal error  procedure */

	dcl     cd		 fixed bin (35);

	code = cd;				/* Return the error code to caller */
	go to exit;

     end error;

%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mrds_range;
%page;
%include mrds_select_list;
%page;
%include mrds_tuple_info;
%page;
%include mdbm_arg_list;
%page;
%include mdbm_descriptor;
%page;
%include dm_element_id_list;
%page;
%include vu_typed_vector;
%page;

/* Multics subroutines */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));

	dcl     sys_info$max_seg_size	 ext fixed bin;


/*  DBM Routines */

	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     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     mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr);


	dcl     mrds_data_$caller_modify fixed bin (17) ext;
	dcl     mrds_data_$max_attributes ext static fixed bin (35);
	dcl     mrds_data_$max_id_len	 ext fixed bin (35);

	dcl     (
	        mdbm_error_$inc_ready_mode,
	        mdbm_error_$view_prevent,
	        mrds_error_$tuple_not_found,
	        mrds_error_$inval_mod_expr,
	        mrds_error_$invalid_db_index
	        )			 ext fixed bin (35);

/* Based variable */

	dcl     code		 fixed bin (35) based (cd_ptr);
	dcl     database_index	 fixed bin (35) based (dbi_ptr);
	dcl     wa		 area (sys_info$max_seg_size) based (area_ptr);


/* Pointers */

	dcl     (
	        cursor_ptr,				/* points to the cursor to be used for the modify */
	        se_ptr,				/* Points to the selection expression */
	        appl_ptr,				/* Points to the list of arg pointers for translate */
	        adpl_ptr,				/* Points to the list of arg descriptors for translate */
	        cd_ptr,				/* Points to callers return code */
	        dbi_ptr
	        )			 ptr;		/* Points to the database index */


/* Others */

	dcl     SCOPE_UPDATE           static fixed bin options (constant) init (6);
						/* scope update ready mode */

	dcl     (
	        nargs,				/* Number of arguments passed to this proc */
	        arg_len,
	        se_len,				/* Selection expression length */
	        vi,				/* index of tuple_variable for relation being modified. */
	        num_args
	        )			 fixed bin;	/* Number of args passed to translate */


	dcl     icode		 fixed bin (35);	/* Internal error code */
	dcl     ntuples_modified	 fixed bin (35);	/* modified tuple counter */

	dcl     arg_error		 condition;	/* Condition signaled if less then 3 arguments
						   were passed to this proc */

	dcl     (addrel, null, addr, fixed, rel) builtin;
	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));
	declare area_ptr		 ptr;
	declare mu_release_area	 entry (ptr);
	declare se_len_ptr		 ptr;		/* temp for getting varying se len */
	declare se_len_ovrly	 fixed bin (35) based;
	dcl     mu_define_area$define_spec_temp_dir_area entry (ptr, fixed bin (35), char (11), fixed bin (35));
dcl  last_tuple_id bit (36) aligned; /* Last tuple id used to check for redundancy */
	dcl     attr_no		 fixed bin;
	dcl     bit_length		 fixed bin (35);
	dcl     bit_string		 bit (bit_length) unal based;
	dcl     done		 bit (1);		/* true => mrds_dsl_search found no more tuples */
	dcl     i			 fixed bin;	/* loop counter */
	dcl     number_of_tuples_modified fixed bin (35); /* number of tuples by the call to modify_tuples_by_id */
	dcl     collection_id	 bit (36) aligned;	/* collection id with a declaration suitable for passing to mu_cursor_manager_ */

	dcl     cleanup		 condition;
	dcl     any_other		 condition;

	dcl     original_appl_ptr	 ptr;		/* original values stored so that we can start over */
	dcl     original_adpl_ptr	 ptr;		/* in case of rollback */
	dcl     original_num_args	 fixed bin;
	dcl     dbi_pic		 picture "999";

     end mrds_dsl_modify;




		    mrds_dsl_open.pl1               08/01/88  1347.3r w 08/01/88  1315.0      318825



/****^  ***********************************************************
        *                                                         *
        * 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-05-02 by
     John Hergert (mrds #135, phx19372).
  2) change(86-06-09,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Changed the call to save_index_of_opening (phx20208, mrds 151).
  3) change(86-06-11,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Changed the call to default_error_handler_$add_finish_handler.
     (phx20097, mrds 152).
                                                   END HISTORY COMMENTS */


mrds_dsl_open:
open:
     procedure ();
	goto common;

finish_handler_entry: entry ();

	call finish_handler;

	return;
/*
                    BEGIN_DESCRIPTION

   this routine is to be called with "entry options(variable)", with a minimum
   of  4  arguments,  1)  the  pathname  of  a database model or submodel 2) a
   database index argument, 3) the opening mode, and 4) and error code.  there
   may  be  any  number  of  pathname/index  pairs,  as  long as the number of
   database already open plus the number of requests does not exceed 128.  the
   function  is  to "open" a database using either a submodel or model view as
   specifed   by   the  given  pathname,  making  it  ready  for  "ready_file"
   operations.   upon  successfull  completion  of  open,  a database index is
   returned  that  is  used  in all further reference to the database via dsl_
   routines that ready/finish/close or manipulate data.


   PARAMETERS:

   call  dsl_$open  (database_path1,  database_index1,  usage_mode1,  .  .  .,
   database_pathN, database_indexN, usage_modeN, error_code) ;


   database_pathN  -  -  (input) char(*), the relative or absoulte pathname of
   either   a  model  or  submodel  view  of  a  database,  as  obtained  when
   create_mrds_db  or  create_mrds_dsm  was  invoked.   the  suffix  ".db" for
   models(new)  or ".dsm" for submodels need not be given if no ambiguity will
   result  as  to  whether  a  model  or  submodel  is meant.  this may be the
   pathname  of  either  an  old  or  new  version database model or submodel,
   however, versions can not be mixed in the same call to open.

   database_indexN - - (output) fixed bin(35), an integer from 1 to 128, to be
   used  in  all further references to the open data base in data manipulation
   or other operations using either dsl_ or mrds_call interfaces.

   usage_modeN  -  - The usage mode must be declare fixed binary (35) aligned,
   and be a value between 1 and 4 for the allowed modes of:
   1 - retrieve
   2 - update
   3 - exclusive retrieve
   4 - exclusive update
   where the first two allow concurrent access via the scope mechanism.

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

   sub_error_  -  - (output) condition, signaled upon detection of an error to
   provide futher error information
   END_DESCRIPTION

   HISTORY:

   78-08-01 Oris Friesen: written

   79-03-08 Al Kepner: to restrict opening of quiesced data bases.

   79-03-14   Al   Kepner:   to  remove  quiesce_sw  parameter  from  call  to
   mrds_dsl_init_res.

   79-07-01 Jim Gray: rewritten to
   1) add sub_err_ reporting of errors and structured error handling
   2) remove restriction of having all databases opened at once
   3) add ".db" model suffix logic
   4) correct the logic detecting model/submodel - old/new version
   5) correct the finish and cleanup handlers
   6) add detection of mixed versions in open list
   7) document and simplify the modules logic

   79-09-01  Jim  Gray:  to  accept  old  style  calls  with  scope usage mode
   argument.

   80-01-01 Jim Gray: to enforce use of a mode in the open call.

   80-03-01 Jim Gray: to capture db indexes used by old version open.

   80-09-16  Jim  Gray:  to keep looking for foo.db, when foo given as path to
   open, and the segment foo is found first.

   80-12-10  Jim  Gray  : changed exclusive open calls to scope setting to ask
   for  new r-s-m-d type scope modes rather than r-u types.  Also added use of
   mrds_new_scope_modes and mrds_opening_modes_ include files.

   80-12-22  Jim Gray : changed submodel version check to allow either version
   4  or version 5 dsmd_version_number submodels to be considered "new", since
   the old bound_v1_ code only handles earlier versions.

   80-12-24  Jim  Gray  : improved error message from no_database to no_access
   for case where user has null access to db_model

   81-01-21  Jim Gray : added call to mrds_dm_authorization$set_needed_access,
   so  that DBA's will have any needed access set automatically, this was done
   in the get_model_version routine.

   81-02-11  Jim  Gray  :  changed  calls to external dsmd_, into calls to the
   internal interface rmds_dsm_dsmd.

   81-04-30   Jim   Gray   :   added   capture  of  error_table_$no_info  from
   hcs_$initiate  so  that mrds_error_$no_model_access could be returned, when
   user has no acl on db dir or db_model.

   81-06-02  Davids:  removed  declared  but  unreferenced  variables, changed
   references  of  mrds_dsm_dsmd  to the appropriate mrds_dsm_** routine (user
   interface  to  internal  mrds  interface)  in  the get_submodel_version and
   cleanup internal procedures.

   81-06-23  Jim  Gray  :  removed  code  defining builtin functions, to allow
   definition   on   an   as   needed   basis,   and   put  into  the  routine
   mrds_dsl_get_builtins.

   81-08-07  Rickie  E.   Brinegar:  modified  to recognize that multi-segment
   files without the ".dsm" are not submodels and to not attempt to treat them
   as submodels.

   81-09-25 Davids: Modified so that determining if the  input  path
   has a ".db" or ".dsm" suffix is not done with a substr since this
   can cause stringrange conditions to occur for short entry  names.
   The  reason  why  the  strings  are  reversed  is  so that a name
   "X.db.dsm"  will  be   identified   as   a   submodel.   declared
   reversed_MODEL_SUFFIX and reversed_SUBMODEL_SUFFIX

   82-01-26 R. Lackey : This is put in to handle the case where a directories
   foo and foo.db reside in the same directory where foo is NOT a db and
   foo.db is a db.  Associated with TR12288.

   82-04-15 Davids: added code to check the consistancy bit in the db_model
   and fail to open if the db is not consistant. code was added in the
   get_model_version procedure.

   82-04-29 Davids: updated to new calling sequence of mu_db_inconsistent

   82-05-21 Mike Kubicar : fixed the bug where the wrong error code would
   be returned when trying to open a quiesced database.  Also modified code
   so that a database that is waiting to be quiesced by another process
   can not be opened.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   83-01-10  Roger Lackey : Modified to correct the use of view path for submodels.

   83-02-01  Roger Lackey : Modified by removing 300 lines of code that 
   included 4 internal procedures that determined db_version or submodel
   and replaced with call to mrds_dsl_get_version$get_path_info.
   Also removed the getting and releasing of tempseg for area replacing it with
   an automatic area.

  83-02-04 Roger Lackey :  Replaced code to check for inconsistent db.
                           and fixed to open old submodels.


  83-02-05  Roger Lackey : Fixed bug that would not allow open of old db 
                           followed by new until old was closed.

  83-03-08  Mike Kubicar : Changed call of mrds_dsl_get_version$get_path_info
  to mrds_dsl_get_version$get_path_info_and_view_name so that opening links
  will store the correct opening name in the resultant.

  83-04-19 Davids: Modified to remove deep nesting by adding the label
  exit_mrds_dsl_open and doing a goto after setting the error code. Also
  changed the sense of some if statements so that null then clauses are
  not needed.

  83-04-21 Davids: Replaced use of index "/" operator with the divide
  builtin. Removed the code that checked the default resultant storage
  directory and set it to the pdir if it wasn't set since the code that
  manages the resultant storage directory already did that. This was called
  only during the first call to in a process. Removed rtrim's from around
  paths which occur at the end of error messages. Rearanged the code in
  process_path_index_pairs so that the code that is executed for a new version
  database is controled with only 1 if instead of lots of ifs in lots of
  places. Added the internal procedure error_exit which calls cleanup and then
  goes to exit_mrds_dsl_open also added code to reset the invocation flag
  during a normal exit, this removed the need to call clean_up on a normal
  exit. Deleted variable BLANK, entries mrds_dsl_resultant_storage$get, $set,
  and get_pdir, and builtin rtrim. Added builtin divide.

  83-04-22 Davids: Deleted the entries mode_off which set a switch which
  allowed openings without an opening mode. Also the mode_on entry which
  reset the switch. Deleted the variable allow_new_open (which was the
  above switch)

  83-05-18 Davids: Split the internal procedure process_usage_mode into the
  procedures get_usage_ready_modes and process_usage_mode. The get procedure
  gets the usage mode argument, makes sure its the right type and in the 
  correct range and sets the ready_mode based on the useage mode. (no changes
  to the code). The process procedure sets the dbcb.open_mode based on the
  usage mode, calls mrds_dsl_ready_all if the resultant still needs to be
  built, and sets scopes. The only change is that ready_all is now called only
  if the resultant still needs to be built (dbcb.res_already_made = "0"b). The
  split was needed so that the ready_mode could be obtained before the call
  to mrds_dsl_init_res which needs the ready mode to update the saved copy of
  the resultant.

  83-05-23 Davids: Added code after the call to mrds_dsl_ready_all to create
  a copy of the resultant under the db_dir if the user is the db's DBA. This
  required adding the administrator flag to the mrds_dsl_init_res parameter
  list.

  83-05-26 Davids: Corrected clean_up procedure to allways call mrds_dsl_close,
  instead of doing it only if the clean_up_condition was signled. This cleans
  up from all errors. Added check so that a saved resultant is not created if
  the opening is via a submodel.

  83-06-13 Davids: Changed call to sub_err_ for the case of tring to open an
  inconsistent database so that error_code is passed to the sub_error handler
  via the info pointer and the following call to error_exit is made only if the
  error_code is still 0 when sub_err_ returns.

  83-06-21 Davids: Removed code dealing with old and new database versions.
  If its an old database version an error will be returned from
  mrds_dsl_version$get_path_info.

  85-05-02 John Hergert:  Moved location of call to save_index_of_opening.
  The way it was prevented open from cleaning up when it discovered that
  the DB was awaiting quiesceing or quiesced.  This left phantom users
  registered.

/* initialize */

common:
	area_ptr = null ();
	clean_up_condition = OFF;
	open_index_list_ptr = null ();
	num_ptrs, num_dims = 0;

/* check for correct argument count */

	call cu_$arg_list_ptr (al_ptr);
	nargs = divide (arg_list.desc_count, 2, 17, 0);	/* = number of args if called via entry options(variable) */

	if nargs < 3 then do;
		code = error_table_$wrong_no_of_args;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value,
		     "^/^a ^d ^a ^a", "The number of arguments given =",
		     arg_list.arg_count / 2, "was less than the minimum of 3,",
		     "or the entry was not declared ""options (variable)"".");
		call error_exit;
	     end;

	if arg_list.code = SPECIAL			/* initialize the error code argument */
	then desc_index = nargs + 1;
	else desc_index = nargs;
	num_ptrs = desc_index + nargs;
	desc_ptr = arg_list.arg_des_ptr (desc_index + nargs);
	if desc_ptr -> descriptor_ovrly ^= fixed_bin_35_descr then do;
		code = error_table_$bad_arg;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value,
		     "^/^a",
		     "The error code(last) argument was not declared ""fixed binary (35) aligned""."
		     );
		call error_exit;
	     end;

	error_code_ptr = arg_list.arg_des_ptr (nargs);
	error_code, code = 0;			/* initialize */

	if previous_invocation			/* make sure this is not a recursive call */
	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 procedure recursively, a release must be done first."
		     );
		call error_exit;
	     end;
	previous_invocation = "1"b;

	if first_time				/* set up a handler to clean up a dying process */
	then do;
		error_code = add_epilogue_handler_ (finish_handler_entry);
		if error_code = 0
		then first_time = OFF;
		else do;
			call sub_err_ (error_code, caller_name, continue, info_ptr,
			     return_value, "^/^a",
			     "Unable to add a finish handler to the default error handler."
			     );
			call error_exit;
		     end;
	     end;

	on cleanup /* set up a handler in case the user does a quit/release */
	     begin;
		clean_up_condition = "1"b;
		call clean_up ();
	     end;

	if ^too_many_open ()			/* check that the user is not exceeding the maximum number of openings allowed */
	then call process_path_index_pairs ();		/* go through all pairs of model/submodel pathnames and open indexes */

	previous_invocation = OFF;			/* reset the invocation flag */

exit_mrds_dsl_open:
	return;
%page;
process_path_index_pairs:
     procedure ();

/* look at each pair of pathname/index in the argument list,
   and try to open the model/submodel at that location, returning the database opening index */

	arg_count = 1;

/* get some work space */

	area_ptr = addr (work_area);

	do while (arg_count < nargs);

/* get the pathname argument */

	     desc_ptr = arg_list.arg_des_ptr (desc_index + arg_count);
	     if descriptor.type ^= CHAR_NONVAR
	     then do;
		     error_code = error_table_$bad_arg;
		     call sub_err_ (error_code, caller_name, continue, info_ptr,
			return_value, "^/^a ^d ^a", "The database pathname argument",
			(arg_count + 1) / 2,
			"was not declared ""character nonvarying"".");
		     call error_exit;
		end;

	     view_path_ptr = arg_list.arg_des_ptr (arg_count);
	     view_path_len = fixed (string (descriptor.size));

/* get the database opening index argument */

	     dbi_arg_count = arg_count + 1;

/* find out from the pathname suffix, if any, and the status of the location addressed what type of entry we are
   dealing with, a submodel or a model, and either an old version or a new version database. */

	     call mrds_dsl_get_version$get_path_info_and_view_name
		(view_path, area_ptr,
		mrds_path_info_structure_version,
		mrds_path_info_ptr, view_dir, view_entry,
		error_code);
	     abs_path = mrds_path_info.absolute_path;

	     if error_code ^= 0
	     then do;
		     if error_code = mrds_error_$no_model_access
		     then do;
			     if mrds_path_info.model
			     then error_message = "^/Unable to read the model using the database path " || abs_path;
			     else error_message = "^/Unable to open the multi-segment file as a submodel using the path "
				     || abs_path;
			     call sub_err_ (error_code, caller_name, continue,
				info_ptr, return_value, error_message);
			end;
		     else
			if error_code = mrds_error_$no_database
		     then do;
			     error_message = "^/No data base found using the path "
				|| abs_path;
			     call sub_err_ (error_code, caller_name, continue,
				info_ptr, return_value, error_message);
			end;
		     call error_exit;
		end;

	     if mrds_path_info.model
	     then do;				/* It is a database path */
		     dsm_sw = "0"b;

		     call hcs_$initiate (abs_path, "db_model", "", 0, 0, data_model_ptr, error_code);
		     if data_model_ptr ^= null ()
		     then do;			/* seg db_model => new version */
			     error_code = 0;
			     call mdbm_util_$inconsistent_get_info
				(data_model_ptr, incon_sw, incon_name, incon_message, incon_undo_request);
			     if incon_sw
			     then do;
				     error_code = mrds_error_$inconsistent_database;
				     call sub_err_ (error_code, caller_name, continue, addr (error_code), return_value,
					"^a:   ^a", incon_name, incon_message);
				     if error_code ^= 0 /* error_code may be reset */
				     then call error_exit; /* by sub_error condition handler */
				end;
			end;
		end;
	     else dsm_sw = "1"b;			/* It is a submodel */

	     db_index = 0;

	     if mod (nargs - 1, 3) ^= 0
	     then do;				/* mode argument not given */
		     error_code = error_table_$noarg;
		     call sub_err_ (error_code, caller_name, continue,
			info_ptr, return_value, "^/^a^a^a",
			"No opening mode was given for database """,
			abs_path, """.");
		     call error_exit;
		end;

	     call open_new_version;
	     call process_usage_mode ();
	     call /* assign the database index value to the user's argument */
		mu_convert_parameter$convert_output_parameter (
		addr (db_index), addr (fixed_bin_35_descr),
		arg_list.arg_des_ptr (dbi_arg_count),
		arg_list.arg_des_ptr (desc_index + dbi_arg_count),
		error_code);
	     if error_code ^= 0
	     then do;
		     call sub_err_ (error_code, caller_name, continue,
			info_ptr, return_value, "^/^a^a^a ^a",
			"The database index argument for database """,
			abs_path,
			""" could not be converted to user's data type",
			"from ""fixed binary (35) aligned"".");
		     call error_exit;
		end;

/* advance to the next pathname/index/mode triplet */

	     arg_count = arg_count + 3;
	end;

     end process_path_index_pairs;
%page;
get_usage_and_ready_modes: proc;

	call mu_convert_parameter$convert_input_parameter (arg_list
	     .arg_des_ptr (arg_count + 2), desc_ptr, usage_mode_ptr,
	     addr (fixed_bin_35_descr), area_ptr, code);
	if code ^= 0
	then do;
		error_code = code;
		call sub_err_ (code, caller_name, continue, info_ptr, return_value,
		     "^/^a^a^a", "The opening scope usage mode for database """,
		     abs_path,
		     """ could not be converted to ""fixed binary (35) aligned"".");
		call error_exit;
	     end;

/* get usage mode argument */

	if usage_mode < RETRIEVAL | usage_mode > EXCLUSIVE_UPDATE
	then do;
		error_code = error_table_$bad_arg;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "^/^a ^d ^a^a^a^/^a^/^a", "The opening scope usage mode =",
		     usage_mode, "given for database """, abs_path,
		     """ was not between 1 and 4.", "Allowed modes are:",
		     "1(retrieval), 2(update), 3(exclusive retrieval), 4(exclusive update).");
		call error_exit;
	     end;

	if usage_mode = RETRIEVAL | usage_mode = EXCLUSIVE_RETRIEVAL then
	     ready_mode = 5;			/* scope retrieve */
	else ready_mode = 6;			/* scope update */

	return;

     end;
%page;
process_usage_mode:
     procedure ();

	dbcb.open_mode = addr (usage_mode) -> mode_ovrly.bit_3;

	if ^dbcb.res_already_made
	then do;
		call mrds_dsl_ready_all (db_index, ready_mode, error_code);
		if error_code ^= 0
		then call error_exit;
		if administrator & ^dsm_sw
		then do;
			call mrds_dsl_create_res_copy$db_already_open
			     (abs_path, dbcb_ptr, error_code);
			if error_code ^= 0
			then do;
				call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
				     "^/Could not create a copy of the resultant under the db directory" ||
				     "^/Database has been successfully opened");
				error_code = 0;	/* allow the opening to continue */
			     end;
		     end;
	     end;


/* exclusive usage modes will have equivalent file scopes set on all files,
   this method is chosen because 1) opens may now be done in different calls, not
   all in one call as in MR6, thus the old protocall can't be used.
   2) this version of the open call interface is meant to be primarily a transition tool
   3) it is the simplest method, that does not require major changes to
   existing code, all of the mechanism can be contained in this module. */


	if usage_mode > UPDATE
	then do;					/* exclusive modes */
		if usage_mode = EXCLUSIVE_RETRIEVAL	/* exclusive retrieve */
		then do;
			permit_operations = READ_ATTR;/* retrieve */
			prevent_operations = UPDATE_OPS; /* update (store, delete, modify) */
		     end;
		else do;				/* exclusive update */
			permit_operations = ALL_OPS;	/* retrieve, update (store, delete, modify) */
			prevent_operations = permit_operations; /* nothing allowed */
		     end;

		call mrds_dsl_set_fscope$set_fscope_all (db_index,
		     permit_operations, prevent_operations, wait_sec, error_code);

		if error_code ^= 0
		then do;
			call sub_err_ (error_code, caller_name, continue, info_ptr,
			     return_value, "^/^a^a^a ^d ^a",
			     "Unable to obtain exclusive scope settings on all files for database """
			     , abs_path, """ in order to make this mode =",
			     usage_mode, "an exclusive mode opening.");
			call error_exit;
		     end;
	     end;
     end;
%page;
too_many_open:
     procedure () returns (bit (1));

/* add the number already open to the number of requests,
   and make sure that the number of openings allowed
   has not been exceeded by this request */

	current_number_of_openings = mu_database_index$get_number_open_dbs ();

	number_of_requests = divide ((nargs - 1), 2, 17, 0);

	if (number_of_requests + current_number_of_openings) <= mrds_data_$max_dbs
	then max_opening_overflow = OFF;
	else do;
		max_opening_overflow = "1"b;
		error_code = mrds_error_$too_many_dbs;
		call sub_err_ (error_code, caller_name, continue, info_ptr, return_value,
		     "^/^a ^d ^a ^d ^a ^d", "The number of open requests =",
		     number_of_requests, "plus the current number of openings =",
		     current_number_of_openings,
		     "exceed the maximum number of openings allowed =",
		     mrds_data_$max_dbs);
		call error_exit;
	     end;

	return (max_opening_overflow);


	declare max_opening_overflow	 bit (1);		/* on => too many databases would be open */

     end;
%page;
open_new_version:
     procedure ();

/* the resultant model can now be built for this opening,
   initially only the dbcb(database control block) segment
   rm_db_info(rdbi) segments will be created with a
   file and rel array saved in the secure(rdbi) section of the resultant.
   ready_file will later complete the building of the resultant */

	dcl     quiesce_lock_copy	 bit (36) aligned;	/* Working copy of the quiesce lock */

	desc_ptr = arg_list.arg_des_ptr (desc_index + arg_count + 2);
	call get_usage_and_ready_modes;

	call mrds_dsl_init_res (view_dir, view_entry, dsm_sw, ready_mode, db_index, dbcb_ptr, administrator,
	     error_code);

/* errors are reported by the lower routine */

	if db_index ^= 0
	then call save_index_of_opening ();		/* remember openings made, in case we have to back out */

/* If the entire data base has been quiesced, only the quiescing process is allowed to open it. */

	if error_code ^= 0
	then call error_exit;

	dbc_ptr = dbcb.dbc_ptr;

/* Now check to see that the database is not quiesced or awaiting quiesce.
   Note that no locks have to be set to check this.  The open list has
   already been modified to show this user has the database open so no
   further quiescing can take place.  If the database is found to be already
   quiesced then this opening will be backed out.  */

	quiesce_lock_copy = dbc.proper.quiesce_lock;
	call set_lock_$lock (quiesce_lock_copy, 0, code);
	if code ^= 0
	then do;
		if code = error_table_$invalid_lock_reset
		then do;
			error_code = mrds_error_$quiesced_dead_db;
			dbc.proper.flags.trouble_switch = "1"b;
		     end;
		else
		     if code = error_table_$lock_wait_time_exceeded
		then do;
			if dbc.proper.flags.quiesce_sw
			then error_code = mrds_error_$quiesced_db;
			else error_code = mrds_error_$quiesce_pending;
		     end;
		else
		     if code ^= error_table_$locked_by_this_process
		then error_code = code;

		if error_code ^= 0
		then do;
			call sub_err_ (error_code, caller_name, continue,
			     info_ptr, return_value, "^/The database, ^a, could not be opened.",
			     abs_path);
			call error_exit;
		     end;
	     end;
     end;
%page;
save_index_of_opening:
     procedure ();

/* remember the database index for this opening, in case we
   have to close the databases already opened, due to an error */

	allocate db_open set (open_index_ptr) in (work_area);

	db_open.path = abs_path;
	db_open.dsm_sw = dsm_sw;
	db_open.index = db_index;
	db_open.next = null ();

/* link it into the list in order */

	if open_index_list_ptr = null ()
	then do;
		open_index_list_ptr = open_index_ptr;
		last_open_index_ptr = open_index_ptr;
	     end;
	else do;
		last_open_index_ptr -> db_open.next = open_index_ptr;
		last_open_index_ptr = open_index_ptr;
	     end;
     end;
%page;
error_exit: procedure ();

	call clean_up;

	goto exit_mrds_dsl_open;

     end;
%page;
clean_up:
     procedure ();

/* remove used space, close opened databases if cleanup condition, or error,
   and reset the invocation flag */

	if clean_up_condition
	then do;
		if substr (db_mrds_dsl_open, 1, 1)
		then on sub_error_ ;		/* ignore this condition if cleanup was signaled */
	     end;

	if open_index_list_ptr ^= null ()
	then do;
		do open_index_ptr = open_index_list_ptr repeat saved_ptr
		     while (open_index_ptr ^= null ());

		     saved_ptr = db_open.next;
		     close_index = db_open.index;

		     call mrds_dsl_close (close_index, discard_code);
		     if ^clean_up_condition & discard_code ^= 0
		     then call sub_err_ (discard_code, caller_name, continue, info_ptr,
			     return_value, "^/^a ^d",
			     "Unable to close a database using opening index =",
			     close_index);
		end;

		open_index_list_ptr = null ();
	     end;

	previous_invocation = OFF;

	declare saved_ptr		 ptr;		/* temporary storage for next on list pointer */

     end;
%page;
finish_handler:
     procedure ();

/* before the process dies, we must close any open databases
   the error code and sub_error_ condition from close will be ignored */

	if ^substr (db_mrds_dsl_open, 1, 1) then
	     ;
	else on sub_error_ ;			/* ingore this condition */


	number_of_openings = mu_database_index$get_number_open_dbs ();

	number_closed = 0;
	do close_index = 1 by 1 to mrds_data_$max_dbs
	     while (number_closed < number_of_openings);

	     call
		mu_database_index$get_resultant_model_pointer (close_index,
		dbcb_ptr);

	     if dbcb_ptr = null () then
		;				/* not a valid index */
	     else do;

		     call mrds_dsl_close (close_index, discard_code);
		     number_closed = number_closed + 1;

		end;

	end;

     end finish_handler;
%page;
	declare sub_error_		 condition;	/* signaled when sub_err_ called */

	declare view_path_len	 fixed bin;	/* length of pathname */

	declare db_index		 fixed bin (35);	/* index to data base (Output) */
	declare code		 fixed bin (35);	/* internal status code */

	dcl     nargs		 fixed bin;	/* number of arguments */


	dcl     previous_invocation	 bit (1) static init ("0"b); /* indicates if ever entered and not finished */

	dcl     first_time		 bit static init ("1"b);

	dcl     dsm_sw		 bit (1);		/* ON => arg. list refers to data submodel */

	dcl     cleanup		 condition;

	dcl     (substr, mod, null, addr, empty, fixed, divide, string, rel) builtin;

/*	Multics Subroutines		*/

	dcl     add_epilogue_handler_  entry (entry) returns (fixed bin(35));

	dcl     cu_$arg_list_ptr	 entry (ptr);

/*	Other dsl routines		*/

	dcl     mrds_dsl_close	 entry options (variable),
	        mu_database_index$get_number_open_dbs entry returns (fixed bin),
	        mrds_dsl_init_res	 entry (char (*), char (*), bit (1), fixed bin, fixed bin (35), ptr, bit (1), fixed bin (35));


/*	System error_table_		*/

	dcl     error_table_$invalid_lock_reset ext fixed bin (35);
	dcl     error_table_$locked_by_this_process fixed bin (35) ext static;
	dcl     error_table_$lock_wait_time_exceeded ext fixed bin (35);

/*	mrds_error_table_		*/

	dcl     (
	        mrds_error_$no_recursion,
	        mrds_error_$too_many_dbs
	        )			 fixed bin (35) ext;

	dcl     mrds_error_$quiesced_db ext fixed bin (35);
	dcl     mrds_error_$quiesced_dead_db ext fixed bin (35);
	dcl     mrds_error_$quiesce_pending ext fixed bin (35);

/*	mrds_data_		*/

	dcl     mrds_data_$max_dbs	 fixed bin ext;
	declare sys_info$max_seg_size	 fixed bin (35) ext static;
	declare sub_err_		 entry options (variable); /* error reporting routine */
	declare caller_name		 char (15) init ("mrds_dsl_open"); /* name of calling routine */
	declare continue		 char (1) init ("c"); /* don't stop after printing */
	declare info_ptr		 ptr init (null ());/* unused */
	declare return_value	 fixed bin (35) init (0); /* unused */
	declare error_code		 fixed bin (35) based (error_code_ptr); /* error status code */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare 1 db_open		 aligned based (open_index_ptr), /* list of open database indexes for this call */
		2 path		 char (168),	/* users pathname argument */
		2 dsm_sw		 bit (1),		/* on => submodel, else model */
		2 index		 fixed bin (35),	/* database index for this opening */
		2 next		 ptr;		/* to next in list */
	declare open_index_ptr	 ptr;		/* to db_open list element */
	declare open_index_list_ptr	 ptr;		/* to first on list */
	declare last_open_index_ptr	 ptr;		/* to last on list */
	declare arg_count		 fixed bin;	/* current arg number being processed */
	declare clean_up_condition	 bit (1);		/* on => cleanup has been signaled */
	declare chase		 fixed bin (1) init (1b); /* 1 => chase links */
	declare MODEL_SUFFIX	 char (3) init (".db"); /* suffix on new models */
	declare reversed_MODEL_SUFFIX	 char (3) init ("bd."); /* model suffixed reversed */
	declare SUBMODEL_SUFFIX	 char (4) init (".dsm"); /* suffix on submodels */
	declare reversed_SUBMODEL_SUFFIX char (4) init ("msd."); /* submodel suffix reversed */
	declare current_number_of_openings fixed bin;	/* number of databases alrady open */
	declare number_of_requests	 fixed bin;	/* number of path/index pairs */
	declare view_path_ptr	 ptr;		/* pointer to pathname argument */
	declare view_path		 char (view_path_len) based (view_path_ptr);
	declare view_dir		 char (500);	/* Dir name of the db specified by the user */
	declare view_entry		 char (32);	/* Entry name of the db specified by the user */
	declare error_code_ptr	 ptr;		/* pointer to error code argument */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* <3 or even number of args */
	declare SEGMENT		 fixed bin init (1);/* type = 1 => segment */
	dcl     DIRECTORY		 fixed bin init (2);/* type = 2 => directory or segment */
	declare LINK		 fixed bin init (0);/* type = 0 => link */
	declare DIRECTORY_BIT_COUNT	 fixed bin init (0);/* type = 2 & bit count = 0 => dir */

	declare discard_code	 fixed bin (35);	/* unused error code */
	declare number_closed	 fixed bin;	/* number closed so far during clean/finish */
	declare number_of_openings	 fixed bin;	/* number currently open */
	declare close_index		 fixed bin (35);	/* database index for db to be closed */
	declare mu_database_index$get_resultant_model_pointer
				 entry (fixed bin (35), ptr); /* get ptr given index */
	declare descriptor_ovrly	 bit (36) unal based; /* overlay for descriptor word */
	declare fixed_bin_35_descr	 bit (36)
				 init ("100000100000000000000000000000100011"b); /* descriptor for fixed bin(35) aligned */
	declare SPECIAL		 fixed bin init (8);/* special form of arg list code */
	declare desc_index		 fixed bin;	/* offset to descriptors in arg list ptr array */
	declare CHAR_NONVAR		 fixed bin init (21); /* character nonvarying data type */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* bad subroutine argument */

	declare area_ptr		 ptr;		/* points to work area */
	declare work_area		 area (2500);	/* work space for paramenter */
	declare abs_path		 char (168);	/* expanded user input pathname */
	declare usage_mode		 fixed bin (35) based (usage_mode_ptr); /* opening scope usage mode  argument */
	declare usage_mode_ptr	 ptr;		/* points to usage mode argument */
	declare ready_mode		 fixed bin (17);	/* file ready mode parameter to ready_all */
	declare administrator	 bit (1);		/* indicates that the user is a DBA */
	declare mrds_dsl_ready_all
				 entry (fixed bin (35), fixed bin (17), fixed bin (35));
						/* readies all files in database */
	declare mrds_dsl_create_res_copy$db_already_open entry (char (168), ptr, fixed bin (35));
	declare mrds_dsl_set_fscope$set_fscope_all entry options (variable);
						/* sets scope on all files */
	declare permit_operations	 fixed bin;	/* operations to allow caller */
	declare prevent_operations	 fixed bin;	/* operations to dis-allow others */
	declare wait_sec		 fixed bin (35) int static options (constant) init (30);
						/* time to wait on busy file */
	declare mu_convert_parameter$convert_input_parameter
				 entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); /* gets input in form needed */
	declare mu_convert_parameter$convert_output_parameter
				 entry (ptr, ptr, ptr, ptr, fixed bin (35)); /* assigns output values */
	declare dbi_arg_count	 fixed bin;	/* remembered argument count of database index in arg_list */
	declare error_table_$noarg	 fixed bin (35) ext;/* missing mode argument */
	dcl     error_message	 char (256);
	dcl     data_model_ptr	 ptr;
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     incon_message	 char (200);
	dcl     incon_name		 char (32);
	dcl     incon_sw		 bit (1);
	dcl     incon_undo_request	 char (100);
	dcl     mrds_error_$inconsistent_database fixed bin (35) ext static;
	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     mrds_error_$no_model_access fixed bin (35) ext static;
	dcl     mrds_error_$no_database fixed bin (35) ext static;

	declare 1 mode_ovrly	 unal based,	/* for assigning opening mode */
		2 unused		 bit (33),
		2 bit_3		 bit (3);


	declare set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     mrds_dsl_get_version$get_path_info_and_view_name entry (char (*), ptr, fixed bin, ptr, char (*), char (*),
				 fixed bin (35));


%include mdbm_descriptor;
%page;
%include mrds_opening_modes_;
%page;
%include mrds_new_scope_modes;
%page;
%include mdbm_arg_list;
%page;
%include mrds_dbcb;
%page;
%include definition;
%page;
%include mdbm_dbc;
%page;
%include mrds_path_info;
%page;
%include mrds_debug_names;

     end mrds_dsl_open;




		    mrds_dsl_optimize.pl1           08/01/88  1347.3rew 08/01/88  1300.0      558540



/****^  ***********************************************************
        *                                                         *
        * 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-14 by Thanh
     Nguyen. (see mrds #137, #139 (phx19906)
  2) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-06,Dupuis), install(88-08-01,MR12.2-1073):
     For the new parser, modified the way that the range and select list
     pointers are set.
                                                   END HISTORY COMMENTS */


mrds_dsl_optimize: proc (dbcb_ptr, pred_ptr, so_ptr, code);

/*
   .                        BEGIN_DESCRIPTION
   This  procedure performs final processing and optimization of the predicate
   tree  resulting  from  the -where clause.  All "not" nodes are removed, and
   all  "or" node are moved so that none appears subordinate to an "and" node.
   At  this point, the usefulness of the tree structure disappears, and so the
   tree  is  converted  into a list of "and groups".  After the predicate tree
   optimization, a "program" for mrds_dsl_search is generated.



   INPUT CONDITIONS:

   dbcb_ptr  points  to  a valid DBCB and pred_ptr points to a valid
   predicate tree.



   OUTPUT DEFINITIONS:

   dbcb.pred_ptr will point to an array of "and groups".

   code = 0;  if no errors are detected.

   code  = mrds_error_$node_stack_ovfl; if one of the internal stacks used for
   traversing the tree overflows.

   code = mrds_error_$max_and_groups;  if there are too many and groups.

   code  =  mrds_error_$max_and_terms; if there are too many terms to fit into
   an and group;

   code  = mrds_error_$var_stack_ovfl; if the variable stack used for ordering
   terms within an and group overflows.

   code  = mrds_error_$no_tuple_effect; if there are tuple variables that have
   no effect on the select set.

  HIGH LEVEL VIEW:
       a. If no predicate tree (no where clause)
	do  cross	 product	over  all	 tuple  variables,	if  a
	relation	has  no tuples  the search  program generated
	will  cause the  tuple not  found error	 to be returned
	with out causing any i/o to the database
       b. else
	  1. convert predicate  tree to disjuctive  normal form
	     and go from a tree to a list.
	  2. loop
	       a. determine	 optimium	 search	path  for	 each
		and-group (mrds_dsl_permute)
	       b. generate	search  program for	 each and-group
		(mrds_dsl_gen_srch_prog)
	  3. build  global	search program  over  all and-group
	     search programs.   Done by sorting	 each and-group
	     search  program  and building  the global  list by
	     putting  the  ones with	the smallest  cost first,
	     and-groups with zero cost are removed.

  NOTES:
       1. if  no-optimize is	set than	and-group search programs
	are not sorted  by cost or if cross  product not sorted
	by relation size.
       2. output from print_search_order is done from optimize.
   .                        END_DESCRIPTION

   MRDS_DEBUG_TOOL SWITCH DEFINITIONS:

   bit 1 = perdicate tree display switch

   bit 2 = search paths display switch

   bit 3 = use calc_cost in addition to permute to determine search paths

   bits 4 thru 9 = not used



   HISTORY:

   76-03-01 J. A. Weeldreyer: Initially written.

   76-08-01 J. A. Weeldreyer: Modified to create  pseudo  terms  for
   undetermined free terms.

   76-09-01 J.  A.  Weeldreyer:  Modified  to  fix  and_group  shift
   problem.

   77-04-01 J. A. Weeldreyer: Modified  to  fix  a  term  reordering
   problem.

   77-09-01 J. A. Weeldreyer:  Modified  to  fix  yet  another  term
   reordering problem.

   77-04-01 J. A. Weeldreyer: Modified to incorporate MR6.0 changes.

   77-09-01 J. A. Weeldreyer: Modified to eliminate concept of bound
   variables.

   78-03-01 J. A. Weeldreyer: Modified to  fix  more  bugs  in  term
   reordering and copying.

   78-11-01 J. A. Weeldreyer: Modified for MR7.0.

   79-04-24  Al  Kepner:  Modified  to  (1)   initialize   cost   in
   path_array, (2) to rewrite combining of all search op tables into
   one in create_search_lists.

   79-06-01 Al Kepner: Modified by to use select_area.

   79-07-16 NSDavids: Modified to build  a  search  path  using  all
   tuple  variables  in  range  clause.  also  to  check for a tuple
   variable that has no effect on  the  select  set  and  return  an
   error.

   79-10-22 Rickie E. Brinegar: Modified to call mrds_dsl_permute to
   get  the  absolute  minmum  cost  path,  and  to  make use of the
   mrds_debug_tool with mrds_debug_names.

   80-01-21 Rickie E. Brinegar: Modified  to  properly  account  for
   range variables not used in a particular and group.

   80-01-23 Davids: modified determine_min_cost_segment so  that  if
   all  paths  have  already  been  looked  at it returns a null pvp
   pointer   rather   than   just   returning   what   was    given.
   create_search_lists  has  been modifed to work with the case of a
   returned null pointer.

   80-01-24  Davids:  path_var_flags  is  reset  to  "0"  for   each
   and-group rather than retaining flag values from last and group.

   80-04-11 Rickie E. Brinegar: Modified  to  make  mdb_calc_cost  a
   debug tool using debug switch number 3.

   80-09-23 Jim Gray: Modified to capture max_and_groups overflow in
   the routine cannonize_pred in one case that was overlooked.

   81-03-27 Jim Gray : added dbcb_ptr parameter  to  mu_get_rel_size
   as part of getting rid of mus_ptr_man module.

   81-03-30 Jim Gray : for TR 9457, moved a check for  only  a  left
   branch  "or",  in the canonize_pred routine, to handle both right
   and left branches. Problem  symptom  was  that  (a|b)&(c|d)&(e|f)
   type queries would not return all matching tuples.

   01-06-01 Jim Gray : changed to use new resultant structure.  Also
   renamed rmds_dsl_calc_cost to mdb_calc_cost.

   81-06-17  Jim  Gray  :  added  call  to  mu_open_iocb_manager  to
   implement attach/open of iocbs on an as needed basis.

   81-06-23 Jim  Gray  :  changed  sort  order  for  the  cross_prod
   routine,  so  that  search program generated is to do the smaller
   relations first.


   81-06-24 Jim Gray : added capture of case when cross product will
   be  empty, so that no retrieves have to be done to find this out.
   This  can  only  be  done  for  non   set   operation   selection
   expressions.

   81-06-26 Roger Lackey : added  code  to  handle  no_optimize  and
   print_search_order

   81-07-01 Jim Gray : modified  print_search_order  for  the  cross
   product case to use the real search order, not the tuple variable
   order.

   81-07-02 Jim Gray : changed method  of  getting  tuple  count  in
   cross_prod,  to  get  it from rm_rel_info statistics, rather than
   calling mu_get_rel_size. Also changed -no_optimize, to only avoid
   sorting, noptimize the getting of rel sizes.

   81-07-09 Jim Gray  :  removed  code  dealing  with  mdb_calc_cost
   logic,  as  this  routine  does  not  support  the  new  path_var
   structure and constants.

   81-07-14 Jim Gray : changed -print_search_order display to output
   additional  info  now  available  in  path_var  structure, and to
   separate and group info.  Also  added  logic  to  display  access
   method  as  indexed  attr  if  the  user  is  a peon on a secured
   database and actually has  a  key  access  method.  Added  proper
   handling  of  temp rel names, and changed internal form of access
   method names to better user visible ones. Revamped output format.

   81-07-15 Jim Gray : changed method of determining whether a tuple
   variable  has an effect on the select set for the case of a where
   clause.  The  previous  method  relied  on   mdb_calc_cost.   Now
   existance of conditions in the where clause is determined as well
   as use in the select clause. One or the other must exist. If only
   present in the select clause we have a cross product effect. Also
   removed all  use  of  the  path_array  which  was  only  used  by
   mdb_cal_cost.

   81-07-16 Jim Gray : changed cross product print search order  ioa
   parameters  so that the order in the array was used for the ORDER
   output, and also so that the size  was  gotten  from  the  proper
   place  in  the  array. Also changed tuple_no_effect logic for the
   where clause case, so that tuple variables appearing last in  the
   list with no conditions, but really used are properly handled.

   81-07-17 Jim Gray : modified method by  which  several  and_group
   search  programs  were  made into a single search_op program. The
   individual and_group search_op programs are now sorted  based  on
   their cost. This will help improve the performance of getting the
   first tuple from a multiple and group select expr.

   81-07-18 Jim Gray : added logic to make a phony search program of
   just  return_null  for  the  case where all and groups contain an
   unpopulated  relation,  and  thus  can  not  be  satistied.  Also
   extended  the  fix to the cross product case, to make it work for
   set S.E.'s, and allow display of the -pso  output  regardless  of
   the situation.

   81-07-19 Jim Gray : extended  the  fix  for  the  no_tuple_effect
   detection  so it could handle the case -select A -where (A & B) |
   (A & C) or the case -select A -where A | B.

   81-07-21 Jim Gray : modified -pso output, where clause  case,  to
   show both conditions when permute used a range against a key head
   or indexed attr.

   81-07-23  Roger  Lackey  :   set   dbcb.pred_ptr   for   use   by
   mrds_dsl_retrieve auto dup

   81-07-24 Jim Gray : changed setting of  dbcb.pred_ptr  to  handle
   case  of  where  clause. The input pred_ptr is to the root of the
   predicate tree. This value is changed in cannonize_pred to  point
   to the pred_array.

   81-09-10  Rickie E.  Brinegar: Removed (no-subrg) prefix that was
   buried in the code as (subrg) is not on except in the development.

   81-09-11 Davids: enclosed both target and source of two assigment
   statements  with  unspec.  This  was done to get around a pl1 bug
   which causes the subscriptrange condition to be signaled when the
   module  is  compiled  with the subscriptrange prefix. The pl1 bug
   was reported as tr11508.

   81-09-19  Davids:  changed  the  lowest  index   reference   into
   path_var_pointer_array  to 1 from 0. The reference to index 0 was
   causing a subscriptrange condition to occur.

   81-09-29 Davids: modified section of code dealing with zero  cost
   and-groups. moved the setting of the err_xfer within the scope of
   the if cost ^= 0 statement, it was just outside the scope,  which
   resulted  in  subscriptrange  conditions when begin_and_group was
   not set.

   82-06-14 Davids: added high level view and notes.

   82-09-01 Mike Kubicar : converted from using the tuple structure to
   using the vector structure.  In this module, this means using an index
   into the tuple structure (select_info.tuple_info_index) instead of
   a pointer to where a tuple will be place (select_info.t_ptr).

   82-09-23 Davids: removed references to the file_io_array and the 
   rm_rel_info.iocb_ptr array and mu_open_iocb_manager and replaced
   them with a call to mu_cursor_manager_$get.

   82-10-26 Davids: Modified so the cursor set up in the cross_prod
   internal proc always uses the record collection (rel_id). It was
   using the record collection if the ready_mode was retrieval and the
   primary key collection if the ready mode was update.

   82-11-12 Mike Kubicar : Due to problems with vrm_relmgr_, the previous
   change had to be backed out.

   82-11-29 Davids: Modified so name of a temp rel dispalyed by the -pso
   option is the temp rel index. This was inadvertently changed when the
   use of the rm_rel_info.rel_id element changed to be a relation manager
   identifier.

   83-04-04 Mike Kubicar : Removed distinction between unordered and ordered
   sequential searches.  -pso should only print out sequential search.
   Also, for cross products, only generate a record collection cursor ptr.

   83-04-22 Mike Kubicar : If there is no where clause, cross_product must
   generate a search specification that will select the entire relation.
   Also, removed all references to the obsolete structure init_info.

   83-05-03 Mike Kubicar : Added initialization of rtrv_info (or its alias)
   .maxtids.

   83-05-25 Ron Harvey : Added the build_vectors routine to support the 
   shortened simple_typed_vector changes.

   83-05-31 Mike Kubicar : Updated to use the new (version 4) search
   specification.

   83-08-04 Mike Kubicar : Added code to set up all the element id lists
   needed by the search program.  The element_id_list_segment is evenly
   divided among all the tuple variables.

   83-08-05 Ron Harvey : Modified the build_vectors routine to back out the
   shortened simple_typed_vector changes.

   83-10-24 Mike Kubicar - Changed to only request
   mrds_data_$max_tids_returned_per_call tuple ids be returned in the element
   id list instead of as many as possible.  This is due to a customer request
   that mrds be more interactive (i.e. they liked it the old way).

   85-04-08 Thanh Nguyen - Added code to set the max_tids to be either 
   max_tids_returned_per_call or max_safe_tids_returned_per_call depending on 
   the scope of the relation is shared or not.

   85-06-14 Thanh Nguyen - Added code to check if the relation is temporary
   (rm_rel_info.file_type = 3) then set max_tids to be 
   max_tids_returned_per_call and not validate the scopes.  Also rewrote
   the calculation method for the size of element_id_list structure.
*/
%page;

	display_predicate_tree = substr (db_mrds_dsl_optimize, 1, 1);
	display_search_paths = substr (db_mrds_dsl_optimize, 2, 1);
	num_ptrs = 0;
	rdbi_ptr = dbcb.rdbi_ptr;
          range_ptr = dbcb.range_ptr;
	select_list_ptr = dbcb.select_ptr;
	ti_ptr = dbcb.ti_ptr;

	select_area_ptr = dbcb.select_area_ptr;
	sa_alloc = "0"b;
	sap = null ();
	or_top = 0;
	if pred_ptr = null then do;			/* if no pred. */
		dbcb.pred_ptr = null ();		/* no and groups */
		call cross_prod;			/* either rel dump, or cross prod. */
	     end;

	else do;					/* if pred. specified */
		call canonize_pred;			/* put in disjunctive normal form */

		dbcb.pred_ptr = pred_ptr;		/* to pred_array */

		call create_search_lists;		/* generate the program for search */

	     end;

	code = 0;					/* tell caller the good news */

exit:	return;
%page;
cross_prod: proc;

/* Procedure to build search info for select block with no where clause.  THis
   implies either a relation dump or a cross product. */

	dcl     (i,
	        j,
	        ii,
	        si,
	        vi,
	        rvi,
	        rni)		 fixed bin;
	dcl     sz		 fixed bin (35);
	dcl     next_element_id_list_ptr ptr;

	dcl     sub_err_		 entry options (variable);
	dcl     retval		 fixed bin (35);	/* to make sub_err_ happy */

	sa_nvars = range.num_vars;			/* init */
	if sa_nvars < 4				/* try to use stack space */
	then sa_ptr = addr (wkspc1);
	else do;					/* if must allocate */
		allocate size_array in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
		sa_alloc = "1"b;
	     end;

	code = 0;
	do i = 1 to sa_nvars;			/*  get size of each relation */

	     size_array.var_index (i) = i;
	     size_array.size (i) = range.tup_var (i).ri_ptr -> rm_rel_info.current_tuple_population;
	     if size_array.size (i) = 0 then
		icode = mrds_error_$tuple_not_found;
	end;

	if ^dbcb.no_optimize then do;			/* don't sort if -no_optimize specified */

		nxchng = sa_nvars;
		do i = sa_nvars by -1 to 2 while (nxchng > 0); /* sort by size */
		     nxchng = 0;
		     do j = 2 to i;


/* do the smaller relations first in the cross product */

			if size_array.size (j) < size_array.size (j - 1) then do; /* must exchange */
				sz = size_array.size (j);
				vi = size_array.var_index (j);
				size_array.size (j) = size_array.size (j - 1);
				size_array.var_index (j) = size_array.var_index (j - 1);
				size_array.var_index (j - 1) = vi;
				size_array.size (j - 1) = sz;
				nxchng = nxchng + 1;
			     end;			/* exchanging */
		     end;				/* j loop */
		end;				/* i loop */
	     end;					/* END of else do   to optimize */


/* if a 0 size relation was detected, we can not ever return
   any tuples from a cross product involving it. Thus we can improve
   performance by generating a search program that does not do I/O,
   but simply does the return_null operation instead. */

	if icode = mrds_error_$tuple_not_found then do;

/* null cross product becuase of 0 size relation,
   force a dummy search program that will work with set S.E.'s
   and not do any I/O, just return the tuple_not_found error */

		so_nops_init = 1;
		allocate search_ops in (select_area);

		search_ops.ic = 1;
		search_ops.nops = 1;
		search_ops.op.code (1) = RETNUL;
		icode,				/* reset to not really error at this point */
		     search_ops.op.var_ind (1),
		     search_ops.op.good_xfer (1),
		     search_ops.op.err_xfer (1) = 0;
		search_ops.op.info_ptr (1) = null ();

	     end;
	else do;
	          /* We start on a new select expression, so turn scopes_changed flag and shared mode flag off. */
	          dbcb.non_shared_to_shared = "0"b;
	          dbcb.scopes_changed = "0"b;
		sv_nvars_init = sa_nvars;		/* init. search tables */
		so_nops_init = 2 * sa_nvars + 3;
		allocate search_vars in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
		string (search_vars.new_val) = "0"b;
		allocate search_ops in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */



		search_ops.ic = 1;
		search_ops.op.code (1) = PICKUP_SVP;	/* init to pick up sv ptr */
		search_ops.op.info_ptr (1) = sv_ptr;
		search_ops.op.var_ind (1) = 0;
		search_ops.op.good_xfer (1) = 1;
		search_ops.op.err_xfer = 0;
		next_element_id_list_ptr = dbcb.element_id_list_segment_ptr;

		do i = 1 to sa_nvars;		/* fill in search tables for each var. */

		     if ^range.tup_var (i).used	/* if ^a tuple variable has been defined */
		     then do;			/* but is not used in the select set */
			     call sub_err_ (mrds_error_$no_tuple_effect, "mrds_dsl_optimize", "c", null (), retval,
				"A Useless tuple variable is ^a", range.tup_var (i).name);

			     call error (mrds_error_$no_tuple_effect);
			end;
		     rmri_ptr,
			search_vars.info.ri_ptr (i) = range.tup_var.ri_ptr (i); /* fill search vars info */

		     call mu_cursor_manager_$get (dbcb.dbi, rmri_ptr, (i), rm_rel_info.rel_id,
			dbcb.relmgr_entries.create_cursor, dbcb.relmgr_entries.open, dbcb.cursor_ptrs_storage_ptr,
			dbcb.cursor_storage_area_ptr, search_vars.info.relation_cursor_ptr (i), icode);
		     if icode ^= 0
		     then call error (icode);
		     search_vars.info.ntids (i),
			search_vars.info.ctid (i) = 0;
		     current_max_tids_per_call = mrds_data_$max_tids_returned_per_call;
		     if rm_rel_info.file_type ^= 3 then do;
			/* we have a real relation here. */
			current_scope_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
			     current_max_tids_per_call = mrds_data_$max_safe_tids_returned_per_call;
		     end;
		     search_vars.info.maxtids (i) = current_max_tids_per_call;
		     search_vars.info.ta_ptr (i) = next_element_id_list_ptr;
		     next_element_id_list_ptr = addrel (search_vars.info.ta_ptr (i),
			current_max_tids_per_call + 2);
		     /* There are two words of header in an element id list */
		     element_id_list_ptr = search_vars.info.ta_ptr (i);
		     element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
		     element_id_list.number_of_elements = 0;
		     ii = 2 * i;
		     si = 2 * i + 1;
						/* fill in search op items */

		     search_ops.op.info_ptr (ii) = null ();
		     allocate select_info in (select_area); /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
		     search_ops.op.info_ptr (si) = seli_ptr;
		     select_info.cvla_ptr = null;
		     do j = 1 to tuple_info.num_tuples while (tuple_info.tuple.var_index (j) ^= size_array.var_index (i));
		     end;
		     select_info.tuple_info_index = j;
		     select_info.tid_ptr = addr (tuple_info.tuple.tuple_id (j));
		     rss_number_of_and_groups = 0;
		     rss_maximum_number_of_constraints = 0;
		     allocate relation_search_specification in (select_area);
		     relation_search_specification.head.version = SPECIFICATION_VERSION_4;
		     relation_search_specification.head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE;
		     relation_search_specification.head.pad = "0"b;
		     relation_search_specification.head.subset_specification_ptr = null ();
		     relation_search_specification.maximum_number_of_constraints =
			rss_maximum_number_of_constraints;
		     relation_search_specification.number_of_and_groups =
			rss_number_of_and_groups;
		     relation_search_specification.range.type = LOW_RANGE_TYPE;
		     relation_search_specification.range.size = current_max_tids_per_call;
		     relation_search_specification.flags.return_unique_tuples = "0"b;
		     relation_search_specification.flags.mbz = "0"b;
		     select_info.relation_search_specification_ptr = relation_search_specification_ptr;
		     search_ops.op.code (ii) = INIT;
		     search_ops.op.code (si) = SEL;
		     search_ops.op.var_ind (ii),
			search_ops.op.var_ind (si) = size_array.var_index (i);
		     search_ops.op.good_xfer (ii) = 1;
		     search_ops.op.good_xfer (si) = 1;
		     if i = 1 then do;		/* if first set of ops */
			     search_ops.op.err_xfer (ii) = 2 * sa_nvars + 1;
			     search_ops.op.err_xfer (si) = 2 * sa_nvars;
			end;
		     else do;
			     search_ops.op.err_xfer (ii) = -1;
			     search_ops.op.err_xfer (si) = -2;
			end;

		end;				/* fill ing in var and op info */
		rvi = 2 * sa_nvars + 2;
		rni = 2 * sa_nvars + 3;
		search_ops.op.code (rvi) = RETVAL;	/* fill in return search ops */
		search_ops.op.code (rni) = RETNUL;
		search_ops.op.var_ind (rvi),
		     search_ops.op.var_ind (rni),
		     search_ops.op.good_xfer (rni),
		     search_ops.op.err_xfer (rni),
		     search_ops.op.err_xfer (rvi) = 0;
		search_ops.op.good_xfer (rvi) = -1;
		search_ops.op.info_ptr (rvi),
		     search_ops.op.info_ptr (rni) = null;

	     end;

/* Set up the simple typed vector  and id list ptrs */

	call build_vectors;

	if dbcb.print_search_order then do;		/* Print the order tuple variable are used  */

		call ioa_ ("^/Tuple variables listed in search order - - all accessed sequentially.");
		do z = 1 to sa_nvars;

		     i = size_array.var_index (z);

		     if range.tup_var.temp_rel (i) then
			rel_name = ltrim (before (after (range.tup_var.ri_ptr (i) -> rm_rel_info.model_name, "."), "."), "0")
			     || " (temp rel index)";
		     else rel_name = range.tup_var.ri_ptr (i) -> rm_rel_info.name;

		     call ioa_ ("^/Order: ^d  Tuple variable: ""^a""^5xRelation name: ""^a""^/^11xRelation size: ^d",
			z, range.tup_var.name (i), rel_name, size_array.size (z));
		end;
		call ioa_ ("");			/* give um a line feed */

	     end;					/* END if print_search_order */
     end cross_prod;
%page;
canonize_pred: proc;

/* Procedure to convert predicate tree to disjunctive normal form. */

/* This first section eliminates not nodes from the tree by negating the operator of the descendent node */

	top = 1;					/* init. the node stack */
	node_stack (top) = pred_ptr;

	do while (top > 0);				/* while we have not exhausted the stack */

	     pn_ptr = node_stack (top);		/* look at top node in stack */
	     top = top - 1;

	     if pred_node.id.op_code = AND_OP /* if and node or or node */
		| pred_node.id.op_code = OR_OP then do;

		     if top + 2 > mrds_data_$max_pred_depth then
			call error (mrds_error_$node_stack_ovfl); /* if we would overflow the stack */
		     node_stack (top + 1) = pred_node.rbr; /* add branches to stack */
		     node_stack (top + 2) = pred_node.lbr;
		     top = top + 2;

		end;				/* and or or node */

	     else if pred_node.id.op_code = NOT_OP then do; /* if a not node */

		     c_ptr = pred_node.lbr;		/* point to child */
		     if c_ptr -> pred_node.term then /* if child is term */
			c_ptr -> pred_node.id.op_code = neg_op (fixed (c_ptr -> pred_node.id.op_code));
						/* negate the opcode of child */
		     else if c_ptr -> pred_node.id.op_code = AND_OP /* if child is and or or */
			| c_ptr -> pred_node.id.op_code = OR_OP then do;

/* ^(a & b) => ^a | ^b, ^(a | b) => ^a & ^b */

			     if c_ptr -> pred_node.id.op_code = AND_OP then /* reverse the op code */
				c_ptr -> pred_node.id.op_code = OR_OP;
			     else c_ptr -> pred_node.id.op_code = AND_OP;

			     allocate pred_node in (select_area) set (notr_ptr);
						/* alloc. temp not nodes */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     allocate pred_node in (select_area) set (notl_ptr);
						/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */

/* it is not necessary to completely fill in these nodes, since they will exist only through the next iteration */

			     notl_ptr -> pred_node.type,
				notr_ptr -> pred_node.type = NODE;
			     notl_ptr -> pred_node.id.op_code,
				notr_ptr -> pred_node.id.op_code = NOT_OP;
			     string (notl_ptr -> pred_node.id.lleaf_id),
				string (notl_ptr -> pred_node.id.rleaf_id),
				string (notr_ptr -> pred_node.id.lleaf_id),
				string (notr_ptr -> pred_node.id.rleaf_id),
				notl_ptr -> pred_node.root,
				notr_ptr -> pred_node.root,
				notl_ptr -> pred_node.term,
				notr_ptr -> pred_node.term = "0"b;
			     notl_ptr -> pred_node.lbr = c_ptr -> pred_node.lbr; /* splice new not nodes between
						   child & his branches */
			     notr_ptr -> pred_node.lbr = c_ptr -> pred_node.rbr;
			     notl_ptr -> pred_node.parent,
				notr_ptr -> pred_node.parent = c_ptr;
			     c_ptr -> pred_node.lbr = notl_ptr;
			     c_ptr -> pred_node.rbr = notr_ptr;

			     if top + 2 > mrds_data_$max_pred_depth then /* if we would overflow stack */
				call error (mrds_error_$node_stack_ovfl);

			     node_stack (top + 1) = notr_ptr; /* add new nodes to stack */
			     node_stack (top + 2) = notl_ptr;
			     top = top + 2;

			end;			/* if & or | node */

		     else if c_ptr -> pred_node.id.op_code = NOT_OP then do; /* if child is not */

/* ^^a => a */

			     pred_node.lbr = c_ptr -> pred_node.lbr; /* remove lower ^ node */
			     if top + 1 > mrds_data_$max_pred_depth then /* if we would overflow stack */
				call error (mrds_error_$node_stack_ovfl);

			     node_stack (top + 1) = pred_node.lbr;
			     top = top + 1;

			end;			/* if ^ node */

		     if pred_node.root then do;	/* if current is root, have no parent */
			     pred_ptr = c_ptr;	/* child now becomes root */
			     c_ptr -> pred_node.root = "1"b;
			end;
		     else /* if not root then have parent */
			if pred_node.parent -> pred_node.lbr = pn_ptr then /* if current is left br. */
			pred_node.parent -> pred_node.lbr = c_ptr; /* remove current node */
		     else /* current is right br. */
			pred_node.parent -> pred_node.rbr = c_ptr;

		end;				/* if current was ^ node */

	end;					/* loop to remove not nodes */

/* Have now eliminated all not nodes from the tree.  Now we rearrange the
   remainder of the tree so that no | nodes are subordinate to any & nodes (disjunctive normal form). */

	top = 1;					/* init node stack */
	node_stack (top) = pred_ptr;

	do while (top > 0);				/* while stack is not exhausted */

	     pn_ptr = node_stack (top);		/* pick up top node from stack */
	     top = top - 1;

	     if ^pred_node.term then do;		/* if and or or */
		     if top + 2 > mrds_data_$max_pred_depth then /* if we would overflow the stack */
			call error (mrds_error_$node_stack_ovfl);
		     node_stack (top + 1) = pred_node.rbr; /* add branches to stack */
		     node_stack (top + 2) = pred_node.lbr;
		     top = top + 2;
		end;				/* if & or | */

	     if pred_node.id.op_code = OR_OP & ^pred_node.root then /* if or which may need moving */
		if pred_node.parent -> pred_node.id.op_code = AND_OP then do;

			p_ptr = pred_node.parent;	/* pick up parent pointer */
			c_ptr = pn_ptr;		/* current node becomes child */
			done = "0"b;		/* init compl. flag */

			do while (^done);		/* while the or needs to  be moved upward in the tree */

			     allocate pred_node in (select_area) set (and_ptr);
						/* alloc. new and node */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     and_ptr -> pred_node.type = NODE; /* and fill it in */
			     and_ptr -> pred_node.id.op_code = AND_OP;
			     and_ptr -> pred_node.root = "0"b;
			     and_ptr -> pred_node.term = "0"b;
			     string (and_ptr -> pred_node.id.lleaf_id) = "0"b;
			     string (and_ptr -> pred_node.id.rleaf_id) = "0"b;
			     and_ptr -> pred_node.parent = p_ptr;

			     if c_ptr = p_ptr -> pred_node.lbr then do; /* if the | is a left branch */

				     call copy_subtree (p_ptr -> pred_node.rbr, copy_ptr, and_ptr);
						/* make a copy of right branch */
				     call move_subtree (c_ptr -> pred_node.rbr, and_ptr -> pred_node.lbr, and_ptr);
				     and_ptr -> pred_node.rbr = copy_ptr;
				     call move_subtree (p_ptr -> pred_node.rbr, c_ptr -> pred_node.rbr, c_ptr);
				     p_ptr -> pred_node.rbr = and_ptr;

				end;		/* if the | was a left branch */

			     else do;		/* if the | is a right branch */

				     call copy_subtree (p_ptr -> pred_node.lbr, copy_ptr, and_ptr);
						/* copy the left branch */
				     call move_subtree (c_ptr -> pred_node.lbr, and_ptr -> pred_node.rbr, and_ptr);
				     and_ptr -> pred_node.lbr = copy_ptr;
				     call move_subtree (p_ptr -> pred_node.lbr, c_ptr -> pred_node.lbr, c_ptr);
				     p_ptr -> pred_node.lbr = and_ptr;


				end;		/*  if | is right branch */


/* for either a right or left branch */

			     if top + 1 > mrds_data_$max_pred_depth then /* if stack is overflowing */
				call error (mrds_error_$node_stack_ovfl);

/* In this case, we can guarantee that all nodes will be looked at by placing copy_ptr in stack */

			     top = top + 1;
			     node_stack (top) = copy_ptr;
			     p_ptr -> pred_node.id.op_code = OR_OP; /* parent is now an | node */
			     c_ptr -> pred_node.id.op_code = AND_OP; /* and the current is now an & node */

			     c_ptr = p_ptr;		/* go up one level */
			     p_ptr = p_ptr -> pred_node.parent;

			     if c_ptr -> pred_node.root then done = "1"b; /* if no farther to go */
			     else if p_ptr -> pred_node.id.op_code ^= AND_OP then done = "1"b; /* or we have hit ors */

			end;			/* bubbling this or */

		     end;				/* if or node */

	end;					/* search for ors */

/* Have now eliminated all not nodes from the tree, and have rearranged the tree so that no and nodes have
   subordinate or nodes.  Hence, the tree has now degenerated into a set of "and groups", i.e. a set
   of requirements lists which must be met for tuple to be selected.  Thus, in order to facilitate further
   manipulation, we first discard the tree structure in favor of a list of and groups.  For each and group, we
   then group all terms in like variables together */

	if display_predicate_tree then
	     call mdb_display_pred_tree$display_pred_tree_ (pred_ptr, /* ptr to root of tree */
		"0"b,				/* ^brief mode */
		"1"b,				/* long mode */
		10,				/* maximum depth */
		1,				/* => inorder */
		dbcb_ptr);
	or_top = 1;				/* init. or stack */
	or_stack (or_top) = pred_ptr;

	num_ands_init = mrds_data_$max_and_groups;
	allocate pred_array in (select_area);
						/* alloc. array for and groups */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	pred_array.type = ARRAY;			/* init. it */
	pred_array.num_ands = 0;

	do while (or_top > 0);			/* for every and group */

	     pn_ptr = or_stack (or_top);		/* pick up top node from or_stack */
	     or_top = or_top - 1;

	     if pred_node.term then do;		/* and_group consists of single term */
		     if pred_array.num_ands + 1 > num_ands_init then /* if we will exceed list size */
			call error (mrds_error_$max_and_groups);
		     pred_array.num_ands = pred_array.num_ands + 1;
		     num_terms_init = 1;
		     allocate and_group in (select_area);
						/* alloc. and group of single or double term */
						/* Allocations in select_area are never freed.  It
						   is reinitialized at the beginning
						   of each new selection expression. */
		     and_group.num_terms = num_terms_init;
		     and_group.term_ptr (1) = pn_ptr;	/* fill it in */
		     pred_array.and_ptr (pred_array.num_ands) = ag_ptr; /* add it to  and group array */
		end;				/* if node was a term */

	     else if pred_node.id.op_code = OR_OP then do;/* if this is an or node */
		     if or_top + 2 > mrds_data_$max_pred_depth then /* if we would overflow the stack */
			call error (mrds_error_$node_stack_ovfl);
		     or_stack (or_top + 1) = pred_node.rbr; /* just add the two branches to the stack */
		     or_stack (or_top + 2) = pred_node.lbr;
		     or_top = or_top + 2;
		end;				/* if was or node */

	     else do;				/* if node is an and node, => top of and group */

		     num_terms_init = mrds_data_$max_and_terms;
		     allocate and_group in (select_area);
						/* alloc. max sized and group */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
		     and_group.num_terms = 0;		/* init it */

		     pred_array.num_ands = pred_array.num_ands + 1; /* and add it to group array */
		     if pred_array.num_ands > num_ands_init then
			call error (mrds_error_$max_and_groups);
		     pred_array.and_ptr (pred_array.num_ands) = ag_ptr;

		     and_top = 2;
		     and_stack (1) = pred_node.rbr;	/* init. and stack */
		     and_stack (2) = pred_node.lbr;

		     do while (and_top > 0);		/* look through every node in the and group */

			pn_ptr = and_stack (and_top); /* pick off top stack element */
			and_top = and_top - 1;

			if pred_node.term then do;	/* if this is a term */
				if and_group.num_terms + 1 > num_terms_init then /* if we will overflow list */
				     call error (mrds_error_$max_and_terms);
				and_group.num_terms = and_group.num_terms + 1; /* increment number of terms */
				and_group.term_ptr (and_group.num_terms) = pn_ptr; /* add this term to and group */
			     end;			/* if this is term */

			else do;			/* is another and node */

				if and_top + 2 > mrds_data_$max_pred_depth then /* if we will overflow the and stack */
				     call error (mrds_error_$node_stack_ovfl);
				and_top = and_top + 2;
				and_stack (and_top - 1) = pred_node.rbr; /* add branches to and stack */
				and_stack (and_top) = pred_node.lbr;
			     end;			/* if internsl and node */
		     end;				/*  converting and group to list form */
		end;				/* loop for and group */
	end;					/* loop for tree */
     end canonize_pred;
%page;
create_search_lists: proc;

/* Procedure to create the "program" for mrds_dsl_search */

	dcl     (i, j, k)		 fixed bin;

	allocate path_var_flags in (select_area);

	search_array.num_and_groups = pred_array.num_ands;

	do i = 1 to pred_array.num_ands;		/* process each and group */

	     var_count = 0;				/* so far there are no tuple variables in the search path */
	     ag_ptr = pred_array.and_ptr (i);
	     done = "0"b;

/*           Call the permutatuions program. */


	     call mrds_dsl_permute (dbcb_ptr, ag_ptr, search_array (i).path_ptr, search_array (i).cost, icode);
	     if icode ^= 0 then call error (icode);

	     pvp = search_array (i).path_ptr;
	     unspec (path_var_flags) = "0"b;

	     call count_path_len_and_set_flags (pvp, var_count, last_el_ptr, path_var_flags);

	     min_path_first_el_ptr = pvp;
						/* save pointer to fist element in mim cost partial path */
	     min_path_last_el_ptr = last_el_ptr;	/* last element in path also */


	     if display_search_paths then do;
		     call ioa_ ("^/^/The minimum cost search path^/^/");
		     call mdb_display_path_$path (min_path_first_el_ptr, dbcb_ptr);
		     call ioa_ ("^/^/End minimum costr search path^/^/");
		end;
	     if dbcb.print_search_order then do;

/* -print_search_order specified in selection expression,
   output info for each and_group search path */

		     if i = 1 then /* first and_group */
			call ioa_ ("^/Tuple variables listed in search order");
		     else call ioa_ ("^/***** New and group.");

/* put the path variable pointers into an array, so they can be
   printed out in reverse of the list linking for search order */

		     x = 1;			/* CHANGE 81-09-19 */
		     do temp_pvp = pvp repeat temp_pvp -> path_var.fwd_thd
			while (temp_pvp ^= null ());

			path_var_pointer_array (x) = temp_pvp;
			x = x + 1;

		     end;

/* now print out the array using the reverse order
   that is actually the search path order */

		     x = x - 1;			/* last increment not needed */
		     do z = x by -1 to 1;		/* CHANGE 81-09-19 */

			temp_pvp = path_var_pointer_array (z);

			if temp_pvp -> path_var.in_and_group | temp_pvp -> path_var.in_select_clause then do;

/* only do tuple variables that hve an effect on the select set */

				y = temp_pvp -> path_var.var_index;
				temp_rmri_ptr = range.tup_var.ri_ptr (y);

				if range.tup_var.temp_rel (y) then
				     rel_name = ltrim (before (after (range.tup_var.ri_ptr (i) -> rm_rel_info.model_name, "."), "."), "0")
					|| " (temp rel index)";
				else rel_name = temp_rmri_ptr -> rm_rel_info.name;

/* on a secure database, a non-DBA will only see indexed attr,
   never any type of key access method */

				saved_access_method = 0;
				if rm_db_info.mdbm_secured & ^rm_db_info.administrator then do;
					if temp_pvp -> path_var.access_method < INDEXED_ATTR then do;
						saved_access_method =
						     temp_pvp -> path_var.access_method; /* remember real access method */
						temp_pvp -> path_var.access_method =
						     INDEXED_ATTR; /* make the peon see index, rather than key */
					     end;
				     end;

				call ioa_ ("^/Order: ^d  Tuple variable: ""^a""     Relation: ""^a""",
				     x - z + 1, range.tup_var.name (y), rel_name);

				call ioa_ ("^11xAccess method: ""^a""",
				     access_method_name (temp_pvp -> path_var.access_method));

/* addition detail depends on access method used,
   they can't be show to a peon on a secure db,
   because he can infer key info from them. */

				if rm_db_info.administrator | ^rm_db_info.mdbm_secured then do;

					call ioa_ ("^11xEstimate of tuples selected: ^d",
					     temp_pvp -> path_var.number_tuples_selected);

					if temp_pvp -> path_var.access_method = LONG_KEY_HEAD |
					     temp_pvp -> path_var.access_method = TOTAL_PRIMARY_KEY then

					     call ioa_ ("^11xNumber of key attributes involved: ^d",
						temp_pvp -> path_var.attr_index);

					else if temp_pvp -> path_var.access_method = SHORT_KEY_HEAD |
					     temp_pvp -> path_var.access_method = INDEXED_ATTR then do;

						attr_name = temp_rmri_ptr ->
						     rm_rel_info.attr_ptrs (temp_pvp -> path_var.attr_index) ->
						     rm_attr_info.name;

						if temp_pvp -> path_var.second_cond_ptr = null () then
						     call ioa_ ("^15xCondition: ""^a""     Attribute: ""^a""",
							condition_name (temp_pvp -> path_var.cond_ptr -> cond.op_code), attr_name);
						else call ioa_ ("^14xConditions:  ""^a"" & ""^a""    Attribute:  ""^a""",
							condition_name (temp_pvp -> path_var.cond_ptr -> cond.op_code),
							condition_name (temp_pvp -> path_var.second_cond_ptr -> cond.op_code),
							attr_name);
					     end;
				     end;

				if saved_access_method ^= 0 then
				     temp_pvp -> path_var.access_method =
					saved_access_method; /* put back real access method for peon */
			     end;
		     end;
		end;
	     call mrds_dsl_gen_srch_prog (dbcb_ptr, min_path_first_el_ptr, search_array.sv_ptr (i),
		search_array.so_ptr (i), icode);
	     if icode ^= 0 then call error (icode);

	end;					/* creating search lists for each and group */

	if dbcb.print_search_order then
	     call ioa_ ("^/");			/* addition line feed for formating */
	call check_no_tuple_effect ();
	if ^dbcb.no_optimize then do;

/* sort the and groups to get lowest cost and group first,
   so that the first tuple in a series of "or"'s is found faster. */

		sorted = "0"b;
		i = search_array.num_and_groups;
		spare_element = mrds_data_$max_and_groups + 1;
		do while (^sorted);			/* bubble sort */

		     exchanged = "0"b;

		     do j = 2 to i;			/* bubble highest cost element to position "i" */

			if search_array.cost (j) < search_array.cost (j - 1) then do;

				search_array.and_group (spare_element) = search_array.and_group (j);
				search_array.and_group (j) = search_array.and_group (j - 1);
				search_array.and_group (j - 1) = search_array.and_group (spare_element);

				exchanged = "1"b;
			     end;
		     end;

		     if ^exchanged then
			sorted = "1"b;
		     else if i > 2 then
			i = i - 1;
		     else sorted = "1"b;
		end;
	     end;


/* skip over and groups that have 0 cost, and thus can not
   possiblly return any tuples. (they got 0 cost from permute
   by one of the involved relations being empty)
   This will reduce the search program to just those non-null and groups.
   In the extreme, will no non-null and groups, the search program
   degenerates to just a simple reutnr_null action */

	non_null_and_groups = 0;
	so_nops_init = 0;				/* combine all search op tables into onetable */
	do i = 1 to pred_array.num_ands;
	     if search_array.cost (i) ^= 0.0 then do;
		     so_nops_init = so_nops_init + search_array.so_ptr (i) -> search_ops.nops - 1;
		     non_null_and_groups = non_null_and_groups + 1;
		end;
	end;
	so_nops_init = so_nops_init + 1;		/* for RETNUL */
	allocate search_ops in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	search_ops.ic = 1;
	k = 0;
	do i = 1 to pred_array.num_ands;
	     if search_array.cost (i) ^= 0.0 then do;
		     begin_and_group = k;
		     do j = 1 to search_array.so_ptr (i) -> search_ops.nops - 1;
			k = k + 1;
			unspec (search_ops.op (k)) =
			     unspec (search_array.so_ptr (i) -> search_ops.op (j));
		     end;
		     search_ops.op.err_xfer (begin_and_group + 3) = k - begin_and_group - 2;
						/* special case first init and select in each and_group */
		     search_ops.op.err_xfer (begin_and_group + 4) = k - begin_and_group - 3;
		end;
	end;
	k = k + 1;
	unspec (search_ops.op (k)) = unspec (search_array.so_ptr (pred_array.num_ands) ->
	     search_ops.op (search_array.so_ptr (pred_array.num_ands) ->
	     search_ops.nops));			/* Pick up last RETNUL */

	return;
%page;
count_path_len_and_set_flags: proc (top_of_path, var_count, last_el_ptr, path_var_flags);

/* This routine counts the number  of  tuple  variables  used  in  a
   section  of  the  minimum  cost path and sets a bit flag for each
   variable used. It also returns a pointer to the last  element  in
   the path.
*/

/* PARAMETERS */

	dcl     top_of_path		 ptr;		/* (input) first element in path */
	dcl     last_el_ptr		 ptr;		/* (output) pointer to last element in path */
	dcl     var_count		 fixed bin;
						/* (input/output) total number of tuple variables
						   used in all path segments */
	dcl     path_var_flags	 (*) bit (1) unaligned;
						/* (input/output) true is tuple variable used in minimum path */

/* AUTOMATIC */

	dcl     path_var_ptr	 ptr;		/* pointer to an element in path_var list */

	path_var_ptr = top_of_path;

	do while (path_var_ptr ^= null ());		/* loop through path list */
	     var_count = var_count + 1;
	     path_var_flags (path_var_ptr -> path_var.var_index) = "1"b;

	     last_el_ptr = path_var_ptr;		/* save incase this is the last element */
	     path_var_ptr = path_var_ptr -> path_var.fwd_thd;
	end;


	return;

     end /* count_path_len_and_set_flags */;





     end create_search_lists;
%page;
check_no_tuple_effect: procedure ();

/* this routine decides if the tuple variables given
   in the range clause are usefull in this selection expression.
   If a tuple variable appears in the select clause it is OK,
   because it either also appears in the where clause,
   or it will be used to form a cross product with the results
   of the where clause. If a tuple variable does not appear in the select clause
   it must appear in some and group in the where clause. */

	message = "";
	do i = 1 to range.num_vars;

	     if ^range.tup_var (i).used then do;

/* this tuple variable does not appear in the select clause,
   see if it is some and group in the where clause */

		     good_use_found = "0"b;
		     do j = 1 to search_array.num_and_groups while (^good_use_found);

			do pvp = search_array.and_group (j).path_ptr
			     repeat path_var.fwd_thd
			     while (pvp ^= null () & ^good_use_found);

			     if i = path_var.var_index & path_var.in_and_group then

/* we found an instance of the use of this tuple variable in an and group */

				good_use_found = "1"b;

			end;

		     end;

/* see if the tuple variable was used properly
   add it to the error list if not */

		     if ^good_use_found then do;

			     if message = "" then
				message = "Useless tuple variables are: ";

			     message = message || rtrim (range.tup_var (i).name) || " ";

			end;

		end;

	end;

/* see if any bad T.V.'s were found */

	if message ^= "" then do;

		call sub_err_ (mrds_error_$no_tuple_effect, "mrds_dsl_optimize", "c", null (), return_value, message);
		call error (mrds_error_$no_tuple_effect);

	     end;




	dcl     (i, j)		 fixed bin;	/* loop indexes */
	dcl     good_use_found	 bit (1);		/* on => this T.V. OK */
	dcl     message		 char (100) varying;/* error message being built */
	dcl     sub_err_		 entry options (variable);
	dcl     return_value	 fixed bin (35) init (0); /* dummy arg */

     end;
%page;
move_subtree: proc (s_ptr, t_ptr, p_ptr);

/* procedure to relocate a subtree */

	dcl     (s_ptr,				/* pointer to source location */
	        t_ptr,				/* pointer to target location */
	        p_ptr)		 ptr;		/* new parent pointer */

	t_ptr = s_ptr;
	if s_ptr -> pred_node.type = NODE then
	     s_ptr -> pred_node.parent = p_ptr;
	else s_ptr -> pred_leaf.parent = p_ptr;

     end move_subtree;
%page;
copy_subtree: proc (s_ptr, c_ptr, p_ptr);

/* Internal procedure to copy a portion of the pred tree */

	dcl     (s_ptr,				/* ptr to source subtree */
	        c_ptr,				/* ptr to copy subtree */
	        sr_ptr,				/* ptr to current source node */
	        cp_ptr,				/* ptr to current copy node */
	        p_ptr,				/* ptr to parent of copy */
	        p_hold)		 ptr;		/* temp parent pointer holder */

	dcl     1 node_stack	 (mrds_data_$max_pred_depth), /* copy node stack */
		2 s_ptr		 ptr,		/* source node */
		2 c_ptr		 ptr;		/* copy node */

	dcl     top		 fixed bin;	/* index to node stack */

	top = 1;					/* initialize */
	allocate pred_node in (select_area) set (c_ptr);	/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	c_ptr -> pred_node.parent = p_ptr;		/* preset parent */
	node_stack.s_ptr (top) = s_ptr;
	node_stack.c_ptr (top) = c_ptr;

	do while (top > 0);				/* while there are nodes to copy */

	     sr_ptr = node_stack.s_ptr (top);		/* pick off node to be copied */
	     cp_ptr = node_stack.c_ptr (top);
	     top = top - 1;

	     if sr_ptr -> pred_node.type = NODE then do;	/* if copying a node */
		     p_hold = cp_ptr -> pred_node.parent; /* save parent ptr which has been set */
		     cp_ptr -> pred_node = sr_ptr -> pred_node; /* copy the node */
		     cp_ptr -> pred_node.parent = p_hold; /* reinsert parent pointer */

		     if cp_ptr -> pred_node.term then do; /* if this is a term */
			     allocate pred_leaf in (select_area) set (cp_ptr -> pred_node.lbr);
						/* alloc. left leaf */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     cp_ptr -> pred_node.lbr -> pred_leaf.parent = cp_ptr; /* set parent */
			     allocate pred_leaf in (select_area) set (cp_ptr -> pred_node.rbr);
						/* same for right lf */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     cp_ptr -> pred_node.rbr -> pred_leaf.parent = cp_ptr;
			end;			/* if was term */

		     else do;			/* if children are nodes */

			     allocate pred_node in (select_area) set (cp_ptr -> pred_node.lbr);
						/* alloc. left node */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     cp_ptr -> pred_node.lbr -> pred_node.parent = cp_ptr; /* set parent */
			     allocate pred_node in (select_area) set (cp_ptr -> pred_node.rbr);
						/* same for right */ /* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
			     cp_ptr -> pred_node.rbr -> pred_node.parent = cp_ptr;

			end;			/* if children are nodes */

		     top = top + 2;
		     if top > mrds_data_$max_pred_depth then /* if we will overflow the stack */
			call error (mrds_error_$node_stack_ovfl);
		     node_stack.s_ptr (top - 1) = sr_ptr -> pred_node.rbr; /* add branches to stack */
		     node_stack.c_ptr (top - 1) = cp_ptr -> pred_node.rbr;
		     node_stack.s_ptr (top) = sr_ptr -> pred_node.lbr;
		     node_stack.c_ptr (top) = cp_ptr -> pred_node.lbr;

		end;				/* if we had a node */

	     else do;				/* we have a leaf */

		     p_hold = cp_ptr -> pred_leaf.parent; /* save parent pointer */
		     cp_ptr -> pred_leaf = sr_ptr -> pred_leaf; /* copy the leaf */
		     if cp_ptr -> pred_leaf.expr_ptr ^= null then /* if expr leaf */
			call copy_expr (cp_ptr -> pred_leaf.expr_ptr); /* then must copy expr tables */
		     cp_ptr -> pred_leaf.parent = p_hold; /* sestore parent pointer */

		end;				/* if leaf */

	end;					/* copy loop */

     end copy_subtree;

copy_expr: proc (e_ptr);

/* Procedure to copy and expr and modify e_ptr to point to the new tables */

	dcl     e_ptr		 ptr;
	dcl     i			 fixed bin;

	nexp_items_init = e_ptr -> expr.nitems;		/* copy expr struct. */
	allocate expr in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	expr = e_ptr -> expr;
	e_ptr = expr_ptr;

	do i = 1 to e_ptr -> expr.nitems;		/* copy all contained functions */
	     if e_ptr -> expr.item.type (i) = SCAL_FUN then
		call copy_fun (e_ptr -> expr.item.fn_ptr (i));
	end;

     end copy_expr;

copy_fun: proc (f_ptr);

/* Procedure to copy a function */

	dcl     f_ptr		 ptr;
	dcl     i			 fixed bin;

	nsf_args_init = f_ptr -> scalfn.nargs;		/* copy scafn struct. */
	allocate scalfn in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression. */
	scalfn = f_ptr -> scalfn;
	f_ptr = sfn_ptr;

	do i = 1 to f_ptr -> scalfn.nargs;
	     if f_ptr -> scalfn.arg.type (i) = EXPR then
		call copy_expr (f_ptr -> scalfn.arg.ef_ptr (i));
	     else if f_ptr -> scalfn.arg.type (i) = SCAL_FUN then
		call copy_fun (f_ptr -> scalfn.arg.ef_ptr (i));
	end;

     end copy_fun;
%page; build_vectors: proc;

/* Here is where we build the 'shortened' simple_typed_vector for each tuple variable.
   If the whole tuple has been selected, the 'whole' one in the resultant is used. */

	do i = 1 to range.num_vars;
	     bv_stv_ptr = tuple_info.tuple (i).tuple_ptr; /* simple_typed_veector for whole 'view' */
	     bv_ri_ptr = range.tup_var (i).ri_ptr;	/* rm_rel_info ptr */
	     bv_idl_ptr = bv_ri_ptr -> rm_rel_info.id_list_ptr; /* id_list for whole 'view' */
	     if range.tup_var (i).whole_tuple_selected
	     then do;				/* just grab what's already available */
		     range.tup_var (i).stv_ptr = bv_stv_ptr;
		     range.tup_var (i).idl_ptr = bv_idl_ptr;
		end;
	     else do;				/* Build a simple_typed_vector and an id_list */
		     il_number_of_ids = bv_ri_ptr -> rm_rel_info.num_attr; /* Build it oversize */
		     allocate id_list in (select_area) set (id_list_ptr);
		     id_list.version = ID_LIST_VERSION_1;
		     range.tup_var (i).idl_ptr = id_list_ptr;

		     id_list.number_of_ids = 0;
		     do k = 1 to il_number_of_ids;
			if range.tup_var (i).needed_bits.attr (k)
			then do;			/* get the proper id for relation */
				id_list.number_of_ids = id_list.number_of_ids + 1;
				id_list.id (id_list.number_of_ids) = bv_idl_ptr -> id_list.id (k);
			     end;
		     end;
		     if id_list.number_of_ids ^= 0
		     then do;
			     stv_number_of_dimensions = id_list.number_of_ids;
			     allocate simple_typed_vector in (select_area) set (simple_typed_vector_ptr);
			     simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
			     range.tup_var (i).stv_ptr = simple_typed_vector_ptr;

			     stv_number_of_dimensions = 0; /* use for walking through the vector */
			     do k = 1 to il_number_of_ids; /* walk the WHOLE relation */
				if range.tup_var (i).needed_bits.attr (k)
				then do;
					stv_number_of_dimensions = stv_number_of_dimensions + 1;
					simple_typed_vector.dimension (stv_number_of_dimensions).value_ptr =
					     bv_stv_ptr -> simple_typed_vector.dimension (k).value_ptr;
				     end;
			     end;
			end;			/* ids to move */
		     else do;			/* no ids to move */
			     range.tup_var (i).stv_ptr = null ();
			end;
		end;				/* build simple_typec_vector */
	end;					/* walk through tuple vars */


	dcl     bv_idl_ptr		 ptr;
	dcl     bv_stv_ptr		 ptr;
	dcl     bv_ri_ptr		 ptr;
	dcl     i			 fixed bin;
	dcl     k			 fixed bin;

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

/* Internal error procedure */

	dcl     cd		 fixed bin (35);	/* statuc code */

	code = cd;
	go to exit;

     end error;
%page;
	dcl     code		 fixed bin (35);	/* Output -- return code */
	dcl     icode		 fixed bin (35);	/* internal status code */

	dcl     (top,				/* index to top of node stack */
	        or_top,				/* index to top of or node stack */
	        and_top,				/* index to top of and node stack */
	        sa_nvars,				/* no. of vars for size_array. */
	        nxchng,				/* no. of exchanges for bubble sort */
	        begin_and_group)	 fixed bin;	/* index just before the beginning of the
						   current and_group in the combined search ops list. */


	dcl     (c_ptr,				/* pointer to child node */
	        notl_ptr,				/* ptr to temp not node */
	        notr_ptr,				/* ptr to temp not node */
	        p_ptr,				/* pointer to parent node */
	        and_ptr,				/* ptr to new and node */
	        copy_ptr,				/* ptr to top of copied subtree */
	        sa_ptr,				/* to size_array */
	        sap)		 ptr;

	dcl     (done,				/* internal flag */
	        display_predicate_tree,
	        display_search_paths,
	        sa_alloc)		 bit (1) unal;	/* internal flag */

	dcl     node_stack		 (mrds_data_$max_pred_depth) ptr; /* stack of tree nodes */
	dcl     or_stack		 (mrds_data_$max_pred_depth) ptr; /* stack of or nodes */
	dcl     and_stack		 (mrds_data_$max_pred_depth) ptr; /* stack of and nodes */
	dcl     1 size_array	 (sa_nvars) based (sa_ptr),
		2 var_index	 fixed bin,
		2 size		 fixed bin (35);
	dcl     wkspc1		 (4) fixed bin (71);
	dcl     1 search_array	 aligned,		/* to hold search info from each and group */
		2 num_and_groups	 fixed bin,	/* number of and groups used */
		2 and_group	 (mrds_data_$max_and_groups + 1),
		  3 cost		 float bin (63),	/* cost of this and group */
		  3 path_ptr	 ptr,		/* to low cost path for this and group */
		  3 sv_ptr	 ptr,		/* to search_vars for and group */
		  3 so_ptr	 ptr;		/* to search_ops for and group */

	dcl     sorted		 bit (1);		/* on => search array has been sorted by cost */
	dcl     exchanged		 bit (1);		/* on => no more bubbling needed, since none done last pass */
	dcl     spare_element	 fixed bin;	/* address of last unused element in array */
	dcl     neg_op		 (10) bit (6) int static options (constant) init (/* table of negating operators */
				 "0"b, "0"b, "0"b, "0"b, /* first four are not applic. */
				 "000110"b,	/* EQ -> NE */
				 "000101"b,	/* NE -> EQ */
				 "001010"b,	/* LT -> GE */
				 "001001"b,	/* GT -> LE */
				 "001000"b,	/* LE -> GT */
				 "000111"b);	/* GE -> LT */

	dcl     (mrds_error_$node_stack_ovfl,
	        mrds_error_$no_tuple_effect,
	        mrds_error_$max_and_groups,
	        mrds_error_$max_and_terms,
	        mrds_data_$max_attributes,
	        mrds_data_$max_id_len,
	        mrds_data_$max_pred_depth,
	        mrds_data_$max_and_groups,
	        mrds_data_$max_and_terms,
	        mrds_data_$max_safe_tids_returned_per_call,
	        mrds_data_$max_tids_returned_per_call,
	        mrds_data_$max_tup_var) fixed bin (35) ext;

	dcl     var_count		 fixed bin;	/* number of tuple variables used in search path */
	dcl     min_path_first_el_ptr	 ptr;		/* pointrer to first element in minimum cost search path */
	dcl     min_path_last_el_ptr	 ptr;		/* ditto last element */
	dcl     last_el_ptr		 ptr;		/* pointer to last element in minimum cost parstial path */
	dcl     path_var_flags	 (range.num_vars) bit (1) based (pvf_ptr); /* if tuple variable has been used in search path */
	dcl     pvf_ptr		 ptr;		/* pointer to the path_var_flags */
						/* corresponding bit is true */
	dcl     ioa_		 entry options (variable);

	dcl     (addr,
                  addrel,
	        after,
	        before,
	        fixed,
	        ltrim,
	        null,
	        rel,
	        rtrim,
	        string,
	        substr,
	        unspec)		 builtin;

	dcl     mdb_display_path_$path entry (ptr, ptr);
	dcl     mdb_display_pred_tree$display_pred_tree_ entry (ptr, bit (1), bit (1), fixed bin, fixed bin, ptr);
	dcl     mrds_dsl_gen_srch_prog entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsl_permute	 entry (ptr, ptr, ptr, float bin (63), 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     info_ptr		 ptr init (null ());/* dummy arg */
	dcl     return_value	 fixed bin (35) init (0); /* dummy arg */
	dcl     mrds_error_$tuple_not_found fixed bin (35) ext; /* no data to be found */
	dcl     temp_pvp		 ptr;		/* temp for displaying path_var structure info */
	dcl     temp_rmri_ptr	 ptr;		/* temp for rm_rel_info pointer for pso display */
	dcl     (x, y, z)		 fixed bin;	/* array/loop indexes */
	dcl     path_var_pointer_array (mrds_data_$max_tup_var) ptr; /* array of pointers to path_var structures for pso display */
	dcl     condition_name	 (1:6) char (2) init ("=", "^=", "<", "<=", ">", ">=")
				 int static options (constant); /* char versions of comparison ops */
	dcl     access_method_name	 (1:6) char (32) int static options (constant) init
				 ("Primary key equality",
				 "Key head equality",
				 "Key or key head range",
				 "Indexed attribute",
				 "Sequential",
				 "Sequential");
	dcl     (rel_name, attr_name)	 char (32);	/* temps for display for -pso */
	dcl     saved_access_method	 fixed bin;	/* for changing peons displayed access method */
	dcl     non_null_and_groups	 fixed bin;	/* and groups without a 0 size rel */
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     current_max_tids_per_call fixed bin (35);
	dcl     1 current_scope_flags	aligned based (current_scope_ptr) like scope_flags;
          dcl     current_scope_ptr      ptr;
%page;
%include mdbm_scope_info;
%page;
%include dm_element_id_list;
%page;
%include dm_range_constants;
%page;
%include dm_relation_spec;
%page;
%include dm_specification_head;
%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_predicate_tree;
%page;
%include mrds_expressions;
%page;
%include mrds_range;
%page;
%include mrds_select_list;
%page;
%include mrds_tuple_info;
%page;
%include mrds_search_vars;
%page;
%include mdbm_rtrv_info;
%page;
%include mrds_search_ops;
%page;
%include mrds_optimize_tables;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_arg_list;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include vu_typed_vector;
%page;
%include dm_id_list;
%page;
%include mrds_debug_names;
%page;
%include mdbm_rm_attr_info;


     end mrds_dsl_optimize;




		    mrds_dsl_parser.pl1             08/01/88  1412.4rew 08/01/88  1300.0      330921



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

mrds_dsl_parser:
    proc (dbcb_ptr, area_ptr, caller, option_list_ptr, se_ptr, se_len, arg_ptr,
         desc_ptr,
         num_args, current_flag, code);

/****^  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):
     Written.
  2) change(88-05-06,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,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 */

/* This module scans and  parses the MRDS selection expression language.
   The language and the skeleton of this code was designed using LALR.
   It was then customized to work with the rest of MRDS. 
   That is why parts of this code may seem mechanical and confusing.
   I did not spend much time to try and optimize it for either performance
   or readability.

   Caveats and disclaimers aside, this code scans and reads the input
   selection expression. It parses it by walking through the parser tables
   that were generated by LALR a token at a time and selectivly calling
   mrds_dsl_semantics to actually do any work that may be required.
   When this module returns to mrds_dsl_translate, the selection
   expression will have been translated into tabular form and optimized,
   or an error will have been detected and reported.
*/

        dbi_pic = dbcb.dbi;
        call mu_define_area$define_temp_dir_area (
	   dbcb.parser_work_area_ptr, dbcb.dbi, (sys_info$max_seg_size),
	   "MRDS" || dbi_pic, "0"b, "1"b, "0"b, "0"b, code);
        if code ^= 0 then call error (code);

        allocate parser_static_info
	   in (dbcb.parser_work_area_ptr -> parser_work_area);
        parser_static_info.pwa_ptr = dbcb.parser_work_area_ptr;
        parser_static_info.ns_ptr = null;

        current_state = 1;
        lookahead_put, lookahead_get = -1;
        parse_stack_top = 0;
        lookahead_count = 0;
        code = 0;

        unspec (parser_se_info) = "0"b;

        parser_se_info.se_ptr = se_ptr;
        parser_se_info.se_length = se_len;
        parser_se_info.se_cursor = 1;

        call mrds_dsl_semantics$init (addr (parser_lex_stack),
	   addr (parser_se_info),
	   dbcb_ptr, psi_ptr, area_ptr, caller, option_list_ptr,
	   arg_ptr, desc_ptr, num_args, current_flag);

/* The parsing loop. */
NEXT:
        if current_state = 0 then goto parse_done;

        current_table = current_state;
        if debug then do;
	  db_item = "";
	  db_data.state = current_state;
	  db_data.top = parse_stack_top;
        end;

        goto CASE (dpda.v1 (current_table));


CASE (3):						/* Multiple lookahead (k > 1) with shared look table. */
        current_table = dpda.v2 (current_table);


CASE (1):						/* Multiple lookahead (k > 1) without default transition. */
        lookahead_use = lookahead_get - lookahead_need;

        if lookahead_use < lbound (lookahead, 1)
        then lookahead_use = lookahead_use - lbound (lookahead, 1);

        lookahead_need = lookahead_need + 1;

        goto read_look;


CASE (10):					/* Obsolete -- Lookahead 1 (sometimes called read without
						   stacking) with shared transition table. */

CASE (2):						/* Read and stack and/or lookahead 1 (sometimes called
						   read without stacking) with shared transition table.
						   (Read transitions to state S are coded as +S while
						   lookahead transitions to state S are coded -S.) */
        current_table = dpda.v2 (current_table);

CASE (0):						/* Read and stack and/or lookahead 1 with neither a
						   default transition nor a marked symbol transition. */
CASE (9):						/* Obsolete -- Lookahead 1 (sometimes called
						   read without stacking). */
        lookahead_need = 1;
        lookahead_use = lookahead_get;


read_look:
        do while (lookahead_count < lookahead_need);	/* Make sure enough symbols are available. */

	  call scanner (lookahead_put);

	  if lookahead_put = lbound (lookahead, 1) then lookahead_put = 0;

	  lookahead_put = lookahead_put - 1;
	  lookahead_count = lookahead_count + 1;
        end;

        test_token = lookahead.token_id (lookahead_use);

/* Look current token_id up in the read list. */
        m = 0;
        do i = current_table + 1 to current_table + dpda.v2 (current_table);
	  n = dpda.v1 (i);

	  if n < 0 then do;
	      n = -n;
	      m = i;				/* Record a marked symbol transition. */
	  end;

	  if n = test_token then do;
	      next_state = dpda.v2 (i);
	      goto got_token;
	  end;

	  if n > test_token then goto not_found;

        end;


not_found:
        if m > 0 then do;				/* If marked symbol was in table, use it. */
	  next_state = dpda.v2 (m);
	  goto got_token;
        end;

        if debug then call ioa_$nnl (" ^4i^/", current_state);

        parser_se_info.loud = "1"b;
        parser_se_info.error_type = SE_TYPE;
        parser_se_info.error_msg =
	   "The unexpected " || get_terminal (lookahead_use)
	   || " was encountered.";
        call error (mrds_error_$sell_syntax);
        goto parse_done;


got_token:
        if debug then db_data.data = get_terminal (lookahead_use);

        if next_state < 0 then do;			/* This is a lookahead transition. */
	  if debug then do;
	      db_data.type = "LK01";
	      db_look = lookahead_need;
	  end;
	  current_state = -next_state;
        end;
        else do;					/* This is a read transition. */
	  if debug then do;
	      db_data.type = "READ";
	      db_data.flag = "*";
	  end;

	  if parse_stack_top >= hbound (parse_stack, 1)
	  then do;
	      parser_se_info.loud = "1"b;
	      parser_se_info.error_type = IL_TYPE;
	      parser_se_info.error_msg =
		 "The current stack top of "
		 || ltrim (char (parse_stack_top))
		 || ", exceeded the limit of "
		 || ltrim (char (hbound (parse_stack, 1)))
		 || ". Contact systems programming staff.";
	      call error (mrds_error_$parser_stack_overflow);
	  end;

	  parse_stack_top = parse_stack_top + 1;
	  parse_stack (parse_stack_top) = current_state;	/* Stack the current state. */
	  unspec (parser_lex_stack (parse_stack_top)) =
	       unspec (lookahead (lookahead_get));

	  if lookahead_get = lbound (lookahead, 1) then lookahead_get = 0;

	  lookahead_get = lookahead_get - 1;
	  lookahead_count = lookahead_count - 1;
	  current_state = next_state;
        end;

        if debug then call ioa_$nnl ("^a^/", db_item);

        goto NEXT;


CASE (14):					/* Multiple lookahead (k > 1) with either (but not both)
						   a default transition or a marked symbol transition. */
CASE (16):					/* Multiple lookahead (k > 1) with the table
						   continued at another state. */
CASE (15):					/* Read and stack and/or lookahead 1 with either (but not both)
						   a default transition or a marked symbol transition. */
CASE (17):					/* Read and stack and/or lookahead 1
						   continued at another state. */
CASE (7):						/* Null state -- presence indicates LALR failure. */
CASE (8):						/* Final state -- should only appear as state zero. */

CASE (4):						/* Apply by rule and alternative with lookback table. */
CASE (5):						/* Apply by rule and alternative without lookback. */
CASE (6):						/* Apply by rule and alternative with shared lookback table. */

CASE (18):					/* Apply by rule with lookback table. */
CASE (19):					/* Apply by rule without lookback. */
CASE (20):					/* Apply by rule with shared lookback table. */

        parser_se_info.loud = "0"b;
        call error (mrds_error_$parser_unrecognized_state);

CASE (13):					/* Apply by production with shared lookback table. */
        current_table = dpda.v2 (current_state + 2);
CASE (11):					/* Apply by production with lookback table. */
CASE (12):					/* Apply by production without lookback. */
        production_number = dpda.v1 (current_state + 2);

        if debug then do;
	  db_data.type = "APLY";
	  if dpda.v1 (current_state + 1) < 0 then db_data.flag = "*";
	  call ioa_$nnl ("^a  (^i", db_item, production_number);
	  call print_production_name (production_number);
	  call ioa_$nnl (")^-sd = ^i ", dpda.v1 (current_state + 1));
	  if dpda.v1 (current_state + 1) > 0 then do;
	      db_separator = "(";
	      do t = parse_stack_top
		 to parse_stack_top - dpda.v1 (current_state + 1) + 1
		 by -1;
		call ioa_$nnl ("^1a^d", db_separator, parse_stack (t));
		db_separator = "";
	      end;
	      call ioa_$nnl (")");
	  end;
	  call ioa_$nnl ("^/");
        end;

        if dpda.v1 (current_state + 2) > 0 then do;
	  call mrds_dsl_semantics (psi_ptr, lex_stack_top, production_number,
	       code);
	  if code ^= 0
	  then if code = mrds_error_$bad_attr |
		  code = mrds_error_$bad_var then do;

/* At this point the semantics routine has rejected the token on the top 
   of the stack (which is an identifier) as "not_found". It is possible
   that there is a hyphen buried in it that is suipposed to be a minus
   sign or the beginning of a keyword. If the hyphen exists in the token
   we will truncate the token just before the hyphen and try again. */

		 i = index (lex_token, "-") - 1;

		 if i > 0 then do;
		     parser_se_info.token_length,
			parser_lex_stack.token_length (lex_stack_top) =
			i;
		     parser_se_info.se_cursor =
			parser_lex_stack.token_start_pos (lex_stack_top)
			+ i;
		     lookahead_count = 0;		/* this should empty lookahead stack */
		     lookahead_get, lookahead_put = -1;

		     call mrds_dsl_semantics (psi_ptr, lex_stack_top,
			production_number, code);
		     if code ^= 0 then call error (code);
		 end;
		 else call error (code);
	       end;
	       else call error (code);
        end;

/* Check for an apply of an empty production.
   In this case the apply state number must be
   pushed onto the parse stack.  (Reference
   LaLonde, W. R.:  An efficient LALR Parser Generator.
   Tech. Report CSRG-2, 1971, pp. 34-35.) */

        if dpda.v1 (current_state + 1) < 0 then do;
	  if parse_stack_top >= hbound (parse_stack, 1) then do;
	      parser_se_info.loud = "1"b;
	      parser_se_info.error_type = IL_TYPE;
	      parser_se_info.error_msg =
		 "The current stack top of "
		 || ltrim (char (parse_stack_top))
		 || ", exceeded the limit of "
		 || ltrim (char (hbound (parse_stack, 1)))
		 || ". Contact systems programming staff.";
	      call error (mrds_error_$parser_stack_overflow);
	  end;
	  parse_stack (parse_stack_top + 1) = current_state;
        end;

/* Delete lexical & parse stack entries. */
        parse_stack_top = parse_stack_top - dpda.v1 (current_state + 1);
        if parse_stack_top <= 0
        then do;
	  parser_se_info.loud = "0"b;
	  call error (mrds_error_$parser_logic_error);
        end;

        test_state = parse_stack (parse_stack_top);
        lb = current_table + 3;
        ub = current_table + dpda.v2 (current_table);

        do while (lb <= ub);

	  i = divide (ub + lb, 2, 17, 0);

	  if dpda.v1 (i) = test_state then do;
	      current_state = dpda.v2 (i);
	      goto NEXT;
	  end;
	  else if dpda.v1 (i) < test_state
	       then lb = i + 1;
	       else ub = i - 1;
        end;

        current_state = dpda.v2 (current_table + 2);
        goto NEXT;

parse_done:

        return;

get_terminal:
    proc (lex_stack_index) returns (char (100) varying);

dcl     lex_stack_index	 fixed bin parameter;
dcl     temp		 char (100) varying;
dcl     (length, min, substr)
			 builtin;

        if parser_lex_stack.token_id (lex_stack_index) = 0
        then return ("end of the selection expression");
        else
	  begin;



dcl     token		 char (
			 min (50,
			 parser_lex_stack.token_length (lex_stack_index))
			 )
			 based (parser_lex_stack
			 .token_ptr (lex_stack_index));

dcl     terminal		 char (terminals_list
			 .
			 length (parser_lex_stack
			 .token_id (lex_stack_index)))
			 defined (terminal_characters)
			 position (terminals_list
			 .
			 position (parser_lex_stack
			 .token_id (lex_stack_index)))
			 ;

	      if length (terminal) > 2 & substr (terminal, 1, 1) = "<"
		 & substr (terminal, length (terminal), 1) = ">" then do;

		temp = substr (terminal, 2, length (terminal) - 2);

		if length (token) > 0
		then
		     temp = temp || " '" || token || "'";

	      end;
	      else if (substr (terminal, 1, 1)) = "-" & length (terminal) > 1
		 then do;
		     temp = "keyword '";

		     if length (token) > 0
		     then temp = temp || token;
		     else temp = temp || terminal;

		     temp = temp || "'";
		 end;
		 else temp = "operator '" || terminal || "'";

	      return (temp);
	  end;
    end get_terminal;

print_production_name:
    proc (production_name_index);
dcl     production_name_index	 fixed bin parameter;
dcl     variables_list_index	 fixed bin;

        if hbound (production_names, 1) > 0 then do;
	  variables_list_index =
	       -production_names (abs (production_name_index));

	  begin;

dcl     production_name	 char (variables_list
			 .length (variables_list_index))
			 defined (variable_characters)
			 position (variables_list
			 .position (variables_list_index));

	      call ioa_$nnl (" ^a", production_name);
	  end;
        end;
        return;
    end print_production_name;

dbn:
    entry ();
        debug = "1"b;
        return;
dbf:
    entry ();
        debug = "0"b;
        return;

dbsn:
    entry ();
        scanner_debug = "1"b;
        return;
dbsf:
    entry ();
        scanner_debug = "0"b;
        return;

error:
    proc (cd);
dcl     cd		 fixed bin (35);

        code, parser_se_info.error_code = cd;
        if parser_se_info.loud & option_list.error
        then call mu_print_error (addr (parser_se_info));

        goto parse_done;

    end;

scanner:
    proc (stack_index);

/*
   DESCRIPTION

   The purpose of this procedure is to return the next token in the
   selection expression to the parser. This is done via alook up table
   to conclude from the first character, what class of token we have.
   After  a token type has been determined, we parse that token and then
   look up its encoding in the keyword table then load the stacks.

   INPUT CONDITIONS:

   stack_index points to place in the lex stack where the info found
   is to be placed.

   OUTPUT DEFINITIONS:

   Blatant syntax errors like strings with no end quote and numbers that
   dont make sense (like 2.3e) are handled here. Other errors are left for
   the parser to find and report.

   se_cursor always points to the end of the token found plus 1

*/

        if scanner_debug then call ioa_$nnl ("Scanner: token key = ");

start:

        parser_se_info.token_start = parser_se_info.se_cursor;

        if parser_se_info.se_cursor > parser_se_info.se_length then do;
						/* check for EOI */
	  token_end = parser_se_info.se_cursor;
	  token_string = "eoi";
	  call load_stack;
	  goto finish;
        end;

        type = /* check first char to get an idea of type of token */
	   token_type_list (
	   char_class_list (rank (se_array (parser_se_info.se_cursor))));

        if scanner_debug then call ioa_$nnl (" ^d", type);

        goto token_type (type);

/* number */
token_type (1):


        state = 1;
number_entry:


        do while ((state > 0)
	   & (parser_se_info.se_length > parser_se_info.se_cursor));
	  parser_se_info.se_cursor = parser_se_info.se_cursor + 1;
						/* get the next char */
	  class =
	       char_class_list (rank (se_array (parser_se_info.se_cursor)));
	  if class > 6 then class = 6;		/* maximum state allowed */
	  state = num_state_table (state, class);
        end;

        if state > 0
        then token_end = parser_se_info.se_length;	/* last token was a number */
        else if state = -3
	   then token_end = parser_se_info.se_cursor;
	   else token_end = parser_se_info.se_cursor - 1;

        token_string = "<integer>";

/* now check to see if we have a bit string */

        if state < 0 then do; /* this is cheaper than checking se length */
	   if se_array (token_end+1) = B /* found a bit string */
	   then do;
	       if token_end+1 = parser_se_info.se_length
						/* end of string reached */
	       then token_end = token_end+1;
	       else if search ("1234",
		       se_array (token_end + 2)) = 0
		  then token_end = token_end+1;
		  else token_end = token_end+2;	/* take base also */

	       token_string = "<bit_string>";
	   end;
        end;

        call load_stack;

        goto finish;

/* decimal --> alone or a number or .v. */
token_type (2):


        if parser_se_info.se_length = parser_se_info.se_cursor
        then token_end = parser_se_info.se_cursor;
        else do;
	  i = verify (se_array (parser_se_info.se_cursor + 1), DIGITS);
						/* see if its a number or just a period */

	  if i ^= 0 then do;			/* period or arg substitution */

	      i = verify (se_array (parser_se_info.se_cursor + 1), "VvXx");
						/* Check for .v. or .x. */

	      if i ^= 0
	      then token_end = parser_se_info.se_cursor;
	      else if se_array (parser_se_info.se_cursor + 2) = "."
		 then token_end = parser_se_info.se_cursor + 2;
						/* found arg substitution */
		 else token_end = parser_se_info.se_cursor;
						/* just a period */
	  end;
	  else do;				/* found a number, go process it */
	      state = 2;
	      goto number_entry;
	  end;
        end;

        token_string = "";
        call load_stack;

        goto finish;

/* +- --> addop or keyword */
token_type (3):


        if parser_se_info.se_length = parser_se_info.se_cursor
        then i = 1;
        else i = verify (substr (se_string, parser_se_info.se_cursor + 1),
	        ALPHA_NUM);

        if i = 1
        then do;					/* just a - or + */
	  token_end = parser_se_info.se_cursor;
	  token_string = "";
	  call load_stack;
        end;
        else do;					/* check for keyword */

	  if i = 0 then do;				/* EOI encountered */
	      if (parser_se_info.se_length - parser_se_info.se_cursor)
		 > mrds_data_$max_id_len
	      then call scanner_error (mrds_error_$long_ident,
		      substr (se_string, parser_se_info.se_cursor));

	      token = substr (se_string, parser_se_info.se_cursor);
						/* take whole thing */
	      i = parser_se_info.se_length - parser_se_info.se_cursor + 1;
	  end;

	  else if i - 1 > mrds_data_$max_id_len		/* check token length */
	       then call scanner_error (mrds_error_$long_ident,
		       substr (se_string, parser_se_info.se_cursor, i));

	       else token = substr (se_string, parser_se_info.se_cursor, i);

	  call lookup_token (token, id);		/* see if token is a keyword */

	  if id = 0 then do;			/* just a - or a + */
	      token = substr (se_string, parser_se_info.se_cursor, 1);
	      call lookup_token (token, id);
	      if id = 0
	      then call scanner_error (mrds_error_$inv_token, token);
	      token_end = parser_se_info.se_cursor;
	  end;
	  else /* token is a keyword */
	       token_end = parser_se_info.se_cursor + i - 1;


	  parser_lex_stack.token_ptr (stack_index) = /* pointer to token */
	       addr (se_array (parser_se_info.token_start));

	  parser_se_info.token_length,		/* length of token */
	       parser_lex_stack.token_length (stack_index) =
	       token_end - parser_se_info.token_start + 1;

	  parser_lex_stack.token_id (stack_index) = id;
	  parser_lex_stack.token_start_pos (stack_index) =
	       parser_se_info.token_start;

	  parser_se_info.se_cursor = token_end + 1;

	  if token = "-no_ot" | token = "-no_optimize" then do;
	      parser_se_info.no_ot_seen = "1"b;
	      goto start;				/* get another token */
	  end;
	  else if token = "-pso" | token = "-print_search_order" then do;
		 parser_se_info.pso_seen = "1"b;
		 goto start;			/* get another token */
	       end;

        end;

        goto finish;

/*  symbol */
token_type (4):


        i = verify (substr (se_string, parser_se_info.se_cursor),
						/* find end */
	   ALPHA_NUM || "-")
	   - 1;

        if i = -1					/* EOI encountered, take whole thing */
        then if (parser_se_info.se_length - parser_se_info.se_cursor + 1)
	        > mrds_data_$max_id_len
	        /* check length */
	   then do;
	       i = index (substr (se_string, parser_se_info.se_cursor), "-");
	       if i = 0
	       then call scanner_error (mrds_error_$long_ident,
		       substr (se_string, parser_se_info.se_cursor));
	       else token_end = parser_se_info.se_cursor + i - 2;
	   end;
	   else token_end = parser_se_info.se_length;

        else if i > mrds_data_$max_id_len /* No EOI */
	   then do;
	       i = index (substr (se_string, parser_se_info.se_cursor, i),
		  "-");
	       if i = 0
	       then call scanner_error (mrds_error_$long_ident,
		       substr (se_string, parser_se_info.se_cursor));
	       else token_end = parser_se_info.se_cursor + i - 2;
	   end;
	   else token_end = parser_se_info.se_cursor + i - 1;

        token_string = "<symbol>";
        call load_stack;

        goto finish;

/* ^ ^= ^< ^> ^=< ^>< ... --> notop or relop */
token_type (5):


        if parser_se_info.se_cursor = parser_se_info.se_length
        then token_end = parser_se_info.se_cursor;	/* EOI: take the "^" */

        else do;
	  i = verify (substr (se_string, parser_se_info.se_cursor + 1, 2),
	       "=><");

	  if i = 0
	  then token_end = parser_se_info.se_cursor + 2;	/* found three char relop */
	  else token_end = parser_se_info.se_cursor + i - 1;
						/* found one or two char relop */
        end;
        token_string = "";
        call load_stack;

        goto finish;

/* = =< => --> relop */
token_type (6):


        if parser_se_info.se_cursor = parser_se_info.se_length
        then token_end = parser_se_info.se_cursor;	/* EOI: take the "=" */

        else do;
	  i = search (se_array (parser_se_info.se_cursor + 1), "><");
	  token_end = parser_se_info.se_cursor + i;
        end;

        token_string = "";
        call load_stack;


        goto finish;

/* < <= <> --> relop */
token_type (7):


        if parser_se_info.se_cursor = parser_se_info.se_length
        then token_end = parser_se_info.se_cursor;	/* EOI: take the "<" */

        else do;
	  i = search (se_array (parser_se_info.se_cursor + 1), "=>");
	  token_end = parser_se_info.se_cursor + i;
        end;

        token_string = "";
        call load_stack;


        goto finish;

/* > >= >< --> relop */
token_type (8):


        if parser_se_info.se_cursor = parser_se_info.se_length
        then token_end = parser_se_info.se_cursor;	/* EOI: take the ">" */
        else do;
	  i = search (se_array (parser_se_info.se_cursor + 1), "=<");
	  token_end = parser_se_info.se_cursor + i;
        end;

        token_string = "";
        call load_stack;


        goto finish;

/* | --> or or concat */
token_type (9):


        if parser_se_info.se_cursor >= parser_se_info.se_length
        then token_end = parser_se_info.se_cursor;	/* EOI; just take | */
        else do;
	  if se_array (parser_se_info.se_cursor + 1) = "|"
	  then token_end = parser_se_info.se_cursor + 1;
	  else token_end = parser_se_info.se_cursor;
        end;

        token_string = "";
        call load_stack;

        goto finish;

/* CR NL SP FF VT --> whitespace */
token_type (10):


        if parser_se_info.se_length = parser_se_info.se_cursor
        then i = 0;
        else i = verify (substr (se_string, parser_se_info.se_cursor + 1),
	        WHITE_SPACE);
						/* find end of white space */

        if i = 0
        then /* EOI encountered */
	   parser_se_info.se_cursor = parser_se_info.se_length + 1;
						/* flag for EOI trap at beginning */
        else parser_se_info.se_cursor = parser_se_info.se_cursor + i;
						/* get rid of white space, try again */

        goto start;

/* " --> string or bit string */
token_type (11):

        if parser_se_info.se_length = parser_se_info.se_cursor
        then call scanner_error (mrds_error_$inv_string,
	        substr (se_string, parser_se_info.token_start));

        done = "0"b;
        do while (^done);				/* find all double quotes */
	  i = index (substr (se_string, parser_se_info.se_cursor + 1), QUOTE)
	       ;
	  if i = 0				/* no end quote */
	  then call scanner_error (mrds_error_$inv_string,
		  substr (se_string, parser_se_info.token_start));

	  parser_se_info.se_cursor = parser_se_info.se_cursor + i + 1;

	  if parser_se_info.se_cursor > parser_se_info.se_length
	  then done = "1"b;
	  else if se_array (parser_se_info.se_cursor) ^= QUOTE
	       then done = "1"b;
        end;

        if parser_se_info.se_cursor <= parser_se_info.se_length
        then
	   if se_array (parser_se_info.se_cursor)
	        = B /* found a bit string */
	   then do;
	       if parser_se_info.se_cursor = parser_se_info.se_length
						/* end of string reached */
	       then token_end = parser_se_info.se_cursor;
	       else if search ("1234",
		       se_array (parser_se_info.se_cursor + 1)) = 0
		  then token_end = parser_se_info.se_cursor;
		  else token_end = parser_se_info.se_cursor + 1;
						/* take base also */

	       token_string = "<bit_string>";
	       call load_stack;
	   end;

	   else do;				/* just a string */
	       token_end = parser_se_info.se_cursor - 1;
	       token_string = "<string>";
	       call load_stack;
	   end;

        else do;					/* just a string */
	  token_end = parser_se_info.se_cursor - 1;
	  token_string = "<string>";
	  call load_stack;
        end;


        goto finish;

/* all other characters */
token_type (12):


        call scanner_error (mrds_error_$inv_token,
	   substr (se_string, parser_se_info.se_cursor, 1));
						/* cant start a token */

        goto finish;

/* :: or : */
token_type (13):

        if parser_se_info.se_cursor >= parser_se_info.se_length
        then goto token_type (12);
						/* EOI. just take : */

        if se_array (parser_se_info.se_cursor + 1) = ":"
        then do;
	  token_end = parser_se_info.se_cursor + 1;
	  token_string = "";
	  call load_stack;
        end;
        else goto token_type (12);			/* cant use a colon */

        goto finish;

/* simple one character tokens */
token_type (14):


        token_end = parser_se_info.se_cursor;
        token_string = "";
        call load_stack;


        goto finish;



finish:

        if scanner_debug
        then call ioa_ (" Token type: ^a; Token: '^a'",
	        token, substr (se_string, parser_se_info.token_start,
	        parser_lex_stack.token_length (stack_index)));
        return;

load_stack:
    proc;

/* procedure to load the lex stack, update the se info structure,
   and look up token ids
*/


        if token_string = "eoi" then do;		/* all done. */
	  parser_lex_stack.token_ptr (stack_index) = null;

	  parser_lex_stack.token_length (stack_index) = 0;

	  parser_lex_stack.token_start_pos (stack_index) =
	       parser_se_info.se_length;

	  token_id = EOI;
        end;
        else do;
	  parser_lex_stack.token_ptr (stack_index) = /* pointer to token */
	       addr (se_array (parser_se_info.token_start));

	  parser_lex_stack.token_length (stack_index) = /* length of token */
	       token_end - parser_se_info.token_start + 1;

	  parser_lex_stack.token_start_pos (stack_index) =
	       parser_se_info.token_start;

	  parser_se_info.se_cursor = token_end + 1;

	  if token_string = ""
	  then token =
		  substr (se_string, parser_se_info.token_start,
		  parser_lex_stack.token_length (stack_index));
	  else token = token_string;

	  call lookup_token (token, token_id);
	  if token_id = 0
	  then call scanner_error (mrds_error_$inv_token, token);
        end;

        parser_lex_stack.token_id (stack_index) = token_id;

        parser_se_info.token_length =
	   parser_lex_stack.token_length (stack_index);

    end load_stack;

lookup_token:
    proc (token, token_id);

/* routine to do binary search of keyword table. This procedure tries
   to do the lookup as fast possible as this is the most performance
   critical part of the scanner, and consequently the whole parser.

   This tries to take advantage of the of the speed of doing character
   comparisons in the AQ registers instead of using EIS instructions.
   Any token that is less than 9 characters can be manipulated this way.
   A token of length less than 9 can be identified in about 2/3 the time
   it takes to idenitify one of greater length.
*/

dcl     token		 char (24);
dcl     token_id		 fixed bin;

dcl     (low, middle, high)	 fixed bin;
dcl     temp_keyword	 char (24);
dcl     (temp_short_keyword, short_token)
			 char (8) aligned;
dcl     done		 bit (1) aligned;

dcl     1 short_keyword	 (hbound (keyword.name, 1)) based (sk_ptr),
						/* this masks over the keyword struct using an 8 char name field */
	2 name		 char (8) aligned,
	2 filler		 char (16);

        low = lbound (keyword.name, 1);
        high = hbound (keyword.name, 1);
        middle = divide (low + high, 2, 17, 0);
        sk_ptr = addr (keyword);
        done = "0"b;

        if index (token, " ") < 10 then do;		/* do it the fast way */
	  short_token = substr (token, 1, 8);
	  do while (^done);

	      if high < low
	      then done = "1"b;			/* something went wrong */
	      else do;

		temp_short_keyword = short_keyword.name (middle);
						/* copy it, so we only look it up once */

		if short_token ^= temp_short_keyword then do;

		    if short_token > temp_short_keyword
		    then low = middle + 1;
		    else high = middle - 1;

		    middle = divide (low + high, 2, 17, 0);

		end;
		else done = "1"b;
	      end;
	  end;

	  if short_token = temp_short_keyword
	  then token_id = keyword.value (middle);
	  else token_id = 0;

        end;

        else do;					/* do it the normal way */

	  do while (^done);
	      if high < low
	      then done = "1"b;			/* something went wrong */
	      else do;

		temp_keyword = keyword.name (middle);	/* copy it, so we only look it up once */

		if token ^= temp_keyword then do;

		    if token > temp_keyword
		    then low = middle + 1;
		    else high = middle - 1;

		    middle = divide (low + high, 2, 17, 0);

		end;
		else done = "1"b;

	      end;
	  end;

/* check to see if the search was successful, if not we're in trouble */

	  if token = temp_keyword
	  then token_id = keyword.value (middle);
	  else token_id = 0;
        end;

    end lookup_token;

scanner_error:
    proc (cd, token);

dcl     cd		 fixed bin (35);
dcl     token		 char (*);

        parser_se_info.error_code, code = cd;
        parser_se_info.loud = "1"b;
        parser_se_info.error_type = SE_TYPE;
        parser_se_info.error_msg = "'" || rtrim (token) || "'";
        call error (code);

    end scanner_error;

dcl     stack_index		 fixed bin parameter;

dcl     done		 aligned bit;
dcl     token_end		 fixed bin;		/* points to where token ends in se */
dcl     token_string	 char (24) aligned;		/* the token, if known. If its not null
						   we use this to look up the token id */
dcl     mrds_data_$max_id_len	 fixed bin (35) ext static;
dcl     mrds_error_$inv_string fixed bin (35) ext static;
dcl     mrds_error_$inv_token	 fixed bin (35) ext static;
dcl     mrds_error_$long_ident fixed bin (35) ext static;
dcl     token_id		 fixed bin;
dcl     token		 char (24);		/* size is size of keyword.name */
dcl     ioa_		 entry () options (variable);
dcl     ioa_$nnl		 entry () options (variable);
dcl     sk_ptr		 ptr internal static init (null);
						/* for binary search */
dcl     (state, class, id, i, type)
			 fixed bin;
dcl     (null, addr, rank)	 builtin;

dcl     QUOTE		 char internal static options (constant)
			 init ("""");
dcl     B			 char internal static options (constant)
			 init ("b");
dcl     DIGITS		 char (10) internal static
			 options (constant) init ("0123456789");

dcl     EOI		 fixed bin internal static
			 options (constant) init (0);
dcl     WHITE_SPACE		 char (6) based (addr (WHITE_SPACE_data));
dcl     WHITE_SPACE_data	 internal static options (constant)
			 dim (6) bit (9) unaligned
			 init ("011"b3, "012"b3, "013"b3, "014"b3,
			 "015"b3, "040"b3);		/* HT LF VT FF CR SP */

    end scanner;

%include mrds_se_info;
%page;
%include mrds_lex_stack;
%page;
%include mrds_dsl_tables;
%page;
%include mrds_se_options;
%page;
%include mrds_scanner_tables;
%page;
%include mrds_dsl_keywords;
%page;
%include mrds_dbcb;

dcl     area_ptr		 pointer parameter;
dcl     caller		 fixed binary (35) parameter;
dcl     se_ptr		 pointer parameter;
dcl     se_len		 fixed binary parameter;
dcl     arg_ptr		 pointer parameter;
dcl     desc_ptr		 pointer parameter;
dcl     num_args		 fixed binary parameter;
dcl     code		 fixed bin (35) parameter;
dcl     mu_print_error	 entry (ptr);
dcl     mrds_dsl_semantics$init
			 entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35),
			 ptr, ptr, ptr, fixed bin, bit (1) aligned);
dcl     mrds_dsl_semantics	 entry (ptr, fixed bin, fixed bin,
			 fixed bin (35));

dcl     1 parser_lex_stack	 (-3:100) aligned like lex_stack;

dcl     1 parser_se_info	 aligned like se_info;

dcl     lex_stack_ptr	 ptr;

dcl     se_info_ptr		 ptr;
dcl     1 lookahead		 (-3:100)
			 defined parser_lex_stack aligned like lex_stack;
dcl     abs		 builtin;
dcl     addr		 builtin;
dcl     char		 builtin;
dcl     current_flag	 bit (1) aligned;
dcl     current_state	 fixed bin;		/* number of current state */
dcl     current_table	 fixed bin;		/* number of current table */
dcl     dbi_pic		 picture "999";
dcl     1 db_data		 unaligned,
	2 flag		 char (1),		/* * means stacked */
	2 state		 picture "zzz9",
	2 top		 picture "zzz9",
	2 filler		 char (2),
	2 type		 char (6),
	2 data		 char (100);
dcl     db_item		 char (117) defined (db_data);
dcl     db_look		 pic "99" defined (db_data.type) pos (3);
dcl     debug		 bit (1) internal static init ("0"b);
dcl     db_separator	 char (1);
dcl     divide		 builtin;
dcl     fixed		 builtin;
dcl     hbound		 builtin;
dcl     i			 fixed bin;
dcl     index		 builtin;
dcl     ioa_$nnl		 entry options (variable);
						/* Parse stack underflow or local recovery encountered
						   impossible conditions.  Both caused by bad DPDA. */
dcl     mrds_error_$sell_syntax
			 fixed bin (35) ext;
dcl     mrds_error_$parser_logic_error
			 fixed bin (35) external static;
						/* Parse, lexical, or lookahead stack overflow. */
dcl     mrds_error_$parser_stack_overflow
			 fixed bin (35) external static;
						/* Recovery failed. */
dcl     mrds_error_$parser_unrecognized_state
			 fixed bin (35) external static;
dcl     mrds_error_$bad_attr	 fixed bin (35) ext static;
dcl     mrds_error_$bad_var	 fixed bin (35) ext static;
dcl     lb		 fixed bin;
dcl     lbound		 builtin;
dcl     lex_stack_top	 fixed bin defined parse_stack_top;
						/* location of the top of the lexical stack */
dcl     lex_token		 char (parser_lex_stack
			 .token_length (lex_stack_top))
			 based (parser_lex_stack
			 .token_ptr (lex_stack_top));
dcl     lookahead_count	 fixed bin;		/* number of terminals in lookahead stack */
dcl     lookahead_get	 fixed bin;		/* location in lookahead stack to get next token */
dcl     lookahead_need	 fixed bin;		/* number of lookahead tokens needed */
dcl     lookahead_put	 fixed bin;		/* location in the lookahead stack to put next token */
dcl     lookahead_use	 fixed bin;		/* location in the lookahead stack to test with */
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     (m, n)		 fixed bin;
dcl     next_state		 fixed bin;		/* number of next state */
dcl     null		 builtin;
dcl     parse_stack		 (100) fixed bin aligned;	/* parse stack */
dcl     parse_stack_top	 fixed bin;		/* location of the top of the parse stack */
dcl     production_number	 fixed bin;		/* APPLY production number */
dcl     scanner_debug	 internal static bit init ("0"b);
dcl     se_string		 char (parser_se_info.se_length)
			 based (parser_se_info.se_ptr);
						/* string view of se */
dcl     se_array		 (parser_se_info.se_length) char
			 based (parser_se_info.se_ptr);
						/* array view of se */
dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
dcl     t			 fixed bin;
dcl     test_state		 fixed bin;		/* top state from parse stack during look back lookups */
dcl     test_token		 fixed bin defined test_state;/* encoding of current token */
dcl     ub		 fixed bin;
dcl     unspec		 builtin;
dcl     ALPHA_NUM		 char (63) internal static options (constant)
			 init (
			 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
			 );

    end mrds_dsl_parser;




		    mrds_dsl_permute.pl1            08/01/88  1347.3rew 08/01/88  1300.0      814338



/****^  ***********************************************************
        *                                                         *
        * 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(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-07,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, modified the way that the range and select list pointers
     are set.
                                                   END HISTORY COMMENTS */



mrds_dsl_permute:
     proc (dbcb_ptr, ag_ptr, pvp, cost, code);
%page;
/*
   BEGIN_DESCRIPTION
   INPUT:

   dbcb_ptr  -  points to a valid dbcb in which dbcb.pred_ptr points to a valid
   predicate  tree.

   ag_ptr - points to an and_group list to be used in finding a search path.



   OUTPUT:

   pvp  -  points  to  a  search  path  with  the last variable being the first
   variable in the list.

   cost - the calculated cost of this search path.

   code - may be 0 or any of the codes returned by mu_get_rel_size.
   END_DESCRIPTION


   MRDS_DEBUG_TOOL SWITCH DEFINITIONS:

   bit 1 = display each new low cost path as it is determinied.

   bit 2 = display each permutation step.

   bit 3 = use the path defined by the order of the range clause.

   bit 4 = display the access method cost calculation details

   bit 5 = display details of final lowest cost path

   bits 6 thru 9 = not used.

   NOTES for mrds_debug_tool

   bit 1 displays paths  starting  with  the  last  variable  to  be
   determined   and  working  back  to  the  first  variable  to  be
   determined.

   bit 2 displays partial paths starting with the first path  to  be
   determined  and  working  forward to the variable currently being
   looked at.

   bit 3 causes the order of the range clause to be use as the order
   of  searching  of  relations  for tuples satisfying the selection
   expression when it is turned on.

   bit 4 causes the results of the calc_sub_path_cost subroutine  to
   be  output.  This includes the cost of doing each type of useable
   access method, plus the low cost access method chosen,  and  it's
   resulting partial path cost.

   bit 5 causes the details of all the conditions, and  details  for
   the  final  path  determined  as  the  lowest  cost  path  to  be
   displayed.




   HISTORY:

   79-10-01 Rickie E.  Brinegar: Initially written using large portions of code
   from mrds_dsl_calc_cost.

   79-12-01  Rickie  E.  Brinegar: Modified to handle the case where the number
   of  variables in the range clause is greater than the number of variables in
   the and group.

   79-12-10  Rickie  E.   Brinegar:  Modified to make the proper transfers when
   using rev_ops.

   79-12-11  Rickie  E.   Brinegar:  Modified to make proper use of the op_code
   variable when adding a condition to a range variable list.

   80-01-14  Rickie  E.  Brinegar: Modified to keep conditions on attributes in
   the same relation.

   80-01-18  Rickie E.  Brinegar: Modified to look at all the conditions on the
   primary key when deciding if short_key may be used.

   80-01-23  Rickie  E.   Brinegar:  Modified  to properly determine sequential
   paths for tuple variables not found in the and group.

   80-01-25  Rickie  E.   Brinegar:  Modified to add the range variables not in
   this and group to the end of the search path as a sequential search.

   80-02-08  Rickie  E.   Brinegar:  Modified  to  properly  determine  when  a
   expression should be evaluated in a search path.

   80-02-09  Jim  Gray:  Modified  to  remove  bad  coding  in  while clause of
   add_to_attr_list,  so  that both a null ptr, and a structure value depending
   on that value on not in the same if statement.

   80-02-11  Rickie E.  Brinegar: Modified to correct the same problem that Jim
   Gray corrected, only through out the rest of the code.

   80-07-08  Rickie  E.  Brinegar: Modified to add the ability to generate only
   the  search  path defined by the order of the attributes in the range clause
   of the selection expresssion.  This is done by setting mrds_debug_switch bit
   3.

   80-08-14  Davids: answered tr7173 fixed as suggested in tr.  problem occured
   when  mrds  reversed  the order of A op B as it appeared in the where clause
   and  B  was  an expression.  Operator sense was reversed ok but it was still
   connected to A rather than B.

   80-10-17   Rickie   E.   Brinegar:  Modified  add_to_expr_list  to  properly
   subscript expr_list.info.op_code.  This was in response to TR7908.

   81-01-13  Rickie  E.   Brinegar: Modified to reuse the structures allocated.
   These include path_var, attr_list, expr_list, cond.  This was in response to
   TR8567.

   81-02-24  Rickie E.  Brinegar: Commented out the calling of code that has to
   do only with blocked file structures.

   81-03-27 Jim Gray : added dbcb_ptr parameter  to  mu_get_rel_size
   as part of getting rid of mus_ptr_man module.

   81-06-01 Jim Gray : changed to use new resultant structure,  thus
   blocked file code deleted.

   81-06-29 Roger Lackey : added the use of dbcb.no_optimize flag q

   81-07-02 Jim Gray : changed getting of relation tuple count  from
   a  call to mu_get_rel_size, to getting it from the statistics now
   kept in the rm_rel_info structure for that relation.

   81-07-07 Jim Gray : made changes to allow correct calculation  of
   path cost, done via multiplying number of times that a particular
   I/O cost will be incurred. These changes  involved:  1)  re-write
   calc_sub_path_cost  to  take into account the currently available
   access methods, compute the expected number of  tuples  retrieved
   for that access method, compute the access cost based on times it
   will be incurred 2) change the  interface  to  what  used  to  be
   unique_index  (now  long_key)  and index_range (now short_key) to
   allow needed info to be passed back, this included  the  addition
   of  recognition  of  long key head access. 3) added the unordered
   sequential type of access method  4)  changed  the  interface  to
   find_attributes   and   permutations   to  include  a  multiplier
   paramater, to be used in properly calculating sub_path  costs  5)
   Changed handling of not_in_and_group tuple variables, so that the
   implied cross  product  is  done  in  the  fastest  manner.  This
   involves  forcing a sequential access method for not in and_group
   tuple variables, and considering them just  as  the  other  tuple
   variables  are.  6)  Also added many comments to help clarify the
   logic and purpose of the major internal procedures. 7) Added  the
   debug   switch   4,   to  display  the  results  of  the  changed
   calc_sub_path_cost routine. 8) added count_conditions subroutine,
   and changes to long_key/short_key to take into account the number
   of conditions, and the condition types, in estimating the  number
   of tuples selected by an access method.

   81-07-14 Jim Gray : made  some  adjustments  to  the  changes  of
   07-07.   1)  expanded  the  long_key  subroutine  to  allow  >  1
   condition, along with the = conditions for primary keys, and  key
   heads,  and  renamed  the routine equal_key. 2) changed short_key
   not to have to consider  the  =  condition,  now  that  equal_key
   handles  1st key attr for this case 3) improved the info returned
   for the condition against a tuple variable, or a particular  key.
   4)  improved  the  formulas  for  conditions  costing, and tuples
   selected 5) changed the key head formula to the exponential  form
   for  better behavior close to a fraction of 1/1. 6) added info to
   path_var structure to  force  gen_srch_prog  to  use  the  access
   method chosen by permute

   81-07-16 Jim Gray : had to modify copy_attr_list to  put  pointer
   to new copy of the cond structure in the path_var, now that it is
   saved there in order to pass info to gen_srch_prog.

   81-07-17 Jim Gray : added a debug switch option  to  display  all
   the  details  for  the final lowest cost path found. Also changed
   logic dealing with attr_list entries, so that array elements  are
   addressed on an attribute definition order basis.

   81-07-18 Jim Gray : removed logic referring to  cost  =  0  as  a
   control  in  the  permutations  program.  This  was  done for two
   reasons. First this control was part of the old not in and  group
   logic  that  was thrown away, and second, the most efficient path
   was not being found for the case of one of  the  tuple  variables
   having a zero population. In the last case the 0 tuple rel should
   go first always, and result in an and  group  cost  of  0.0  Also
   changed  calc_sub_path_cost  to not do un-needed work in the case
   of unpopulated relations.

   81-07-19 Jim Gray : added logic to handle tuple variables with no
   effect   on  the  select  set.  They  are  dropped  from  further
   consideration in the low cost path, but passed back  to  optimize
   for further no tuple effect checks.

   81-07-21 Jim Gray : added the ability to favor a range of  values
   specified  against  a  short  key  head  or  indexed attr, and to
   remember the details for gen srch prog.

   81-08-03 Jim Gray : fixed problem introduced by last change,  the
   =  condition was not being favored over >, <=, etc. conditions if
   it came first in the condition list.

   81-09-21  Rickie  E.   Brinegar:  Changed  the  assignment of two expr_list
   structures  to  each  other  to  be done using an unspec to avoid subscript
   ranged conditions.

   82-06-04 Mike Kubicar : Added fix for TR phx12306.  The problem was
   that permute would sometimes change its mind in the middle of a
   selection's where clause and decide that an equals comparison is better
   than the range one it was working on.  Unfortunately, it would not
   completely change it's internal representation to reflect this fact.

   82-07-20 Ronald B. Harvey: Made fix for TR phx12925. This involved fixing
   an improperly constructed do statement in get_attr_list. A test could not
   be generated, but it was clear that the statement was in error.

   82-09-16 Davids: Modified the way that the best condition for an indexed
                    attribute is choosen, created the find_index_attr internal
                    procedure. This takes into account not only the precedence
                    order of the equal, range, inequality and not-equal
                    operations but the number of duplicates for each index
                    (obtained from rm_attr_info.number_of_dups). The one with
                    the fewest duplicates will be chosen, if two or more have
                    the same number of dups the one defined first within the
                    relation will be chosen. Note that the number of dups for
                    a vfile type database is an estimate and equal for all
                    of the indices.

                    Modified the internal proc calc_sub_path_cost tono longer
                    assume the equal distribution of dups throughout all
                    indices in a relation but to use the number of dups 
                    returned from the call to the internal proc short_key
                    (which ends up calling find_index_attr).

                    Removed references to the constant cost values for the
                    different access methods and replaced them with references
                    to elements in the dbcb structure. Costs will be dependent
                    on the type of database, i.e. vfile or page_file.

82-12-15  Davids:  Modified the copy_expr_list procedure by explicitly setting
the  number  of expressions in the copy_to_ptr -> path_var.elp -> expr_list to
the original number it was allocated with.  The number of expressions recorded
is reduced from the number the structure was allocated with since the original
number is based on a maximum possible number while the number in the structure
is  the  actual number of expressions.  This was needed because it is possible
to  get  a  string  size  condition  when  different and-groups have different
numbers  of  expressions  and  the  expr_list  structures and being copied and
re-used.  Fixes TR 14382

   83-04-04 Mike Kubicar : Removed code to generate an unordered sequential
   search.  vfile_relmgr_ can now handle all searches on a record collection
   cursor correctly.

   83-10-01 Bert Moberg: Added code to the permutations subroutine to not
   try all possible permutations if the number of tuple variables is very
   large (=> ENOUGH_TUPLE_VARIABLES_TO_NOT_TRY_ALL_POSSIBLE_PERMUTATIONS,
   currently = 5).  The current path must be predicted to select <= 1 tuple
   (<= PATH_DOES_NOT_EXPAND) at every level where permutations are skipped.
   If this true, it implies that the exact order is not as important, since
   the levels will be executed the same number of times.  In all cases, all
   permutations will be tried for the first
   NUMBER_OF_LEVELS_THAT_MUST_BE_PERMUTED (currently 2).

83-10-24 Roger Lackey : Changed the dcl for index_attr_number_of_dups from 
                        fixed bin to fixed bin (35).
*/
%page;
%include mrds_dbcb;
%page;
%include mrds_range;
%page;
%include mrds_predicate_tree;
%page;
%include mrds_optimize_tables;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include mrds_debug_names;
%page;
	dcl     (m_d_p_i, level, number_of_variables) fixed bin;

	dcl     (cost, current_path_cost) float bin (63);

	dcl     (display_low_cost_paths, display_path_permutations,
	        display_access_method_costs, use_range_order) bit (1) unal;

	dcl     (
	        attr_list_free_ptr	 init (null),
	        cond_free_ptr	 init (null),
	        current_path_ptr	 init (null),
	        expr_list_free_ptr	 init (null),
	        last_condp		 init (null),
	        low_cost_path_ptr	 init (null),
	        path_ptr		 init (null),
	        path_var_free_ptr	 init (null),
	        range_order_path_ptr	 init (null),
	        work_path_ptr	 init (null),
	        work_ptr		 init (null)
	        )			 ptr;

	dcl     (
	        mrds_data_$max_attributes,
	        mrds_data_$max_id_len,
	        mrds_data_$max_tup_var,
	        sys_info$max_seg_size
	        )			 fixed bin (35) ext;

	dcl     code		 fixed bin (35);

	dcl     variable_array	 (mrds_data_$max_tup_var) fixed bin;

	dcl     (addr, ceil, fixed, max, null, rel, substr, unspec) builtin;

	dcl     ioa_		 entry options (variable);
	dcl     mdb_display_path_$path entry (ptr, ptr);

	dcl     (temp_current_path_multiplier, current_path_multiplier) float bin (63);
						/* number ot times access cost will be incurred */
	dcl     finished		 bit (1);		/* on => end of generating all permutations */
	dcl     CONDITION_COST_FACTOR	 (1:6) float bin (27) init (1.5, 0.2, (4) (0.5));
						/* weighting for "=", "^=", and other comparisons */
	dcl     condition_array	 (1:6) char (2) init ("=", "^=", "<", "<=", ">", ">=")
				 int static options (constant); /* char values for displaying condition operators */
	dcl     access_method_name	 (1:6) char (20) int static options (constant)
				 init ("Total primary key", "Long key head", "Short key head",
				 "Indexed attribute", "Sequential", "Sequential");
	dcl     first_pass		 bit (1);		/* on => still building a path to compare against */
	dcl     no_tuple_effect_number fixed bin;	/* number of tuple variable with no select set effect */
	dcl     no_tuple_effect_ptr	 ptr;		/* to list of no tuple effect T.V.'s */
	dcl     last_no_tuple_effect_ptr ptr;		/* to last no tuple effect T.V. on list */
	dcl     dummy_good_enough	 bit (1);
%page;
	code = 0;

/* set mrds_debug_tool switches */

	display_low_cost_paths = substr (db_mrds_dsl_permute, 1, 1);
	display_path_permutations = substr (db_mrds_dsl_permute, 2, 1);
	display_access_method_costs = substr (db_mrds_dsl_permute, 4, 1);

	if substr (db_mrds_dsl_permute, 3, 1) | dbcb.no_optimize then
	     use_range_order = "1"b;
	else use_range_order = "0"b;
	select_area_ptr = dbcb.select_area_ptr;
	range_ptr = dbcb.range_ptr;
	number_of_variables = range.num_vars;
	no_tuple_effect_number = 0;
	no_tuple_effect_ptr, low_cost_path_ptr, current_path_ptr = null;
	cost = 0.;
	variable_array (1) = 1;
	allocate path_var in (select_area);		/* set up minimum cost path */
	path_var.alp, path_var.elp = null;
	low_cost_path_ptr = pvp;
	do m_d_p_i = 2 to number_of_variables;
	     variable_array (m_d_p_i) = m_d_p_i;
	     work_ptr = pvp;
	     allocate path_var in (select_area);
	     path_var.alp, path_var.elp = null ();
	     work_ptr -> path_var.fwd_thd = pvp;
	end;
	path_var.fwd_thd = null ();
	m_d_p_i = 1;
	finished = "0"b;
	first_pass = "1"b;
	do while (^finished);			/* generate all permutations of the path */
	     current_path_ptr = null;
	     current_path_cost = 0.;


/* NOTE: in all comments, T.V. is short hand for tuple variable */

	     current_path_multiplier = 1;		/* previously selected tuples don't exists for first T.V. */
	     call
		find_attributes (variable_array (m_d_p_i), current_path_multiplier,
		current_path_cost, code);
	     if code ^= 0 then
		return;
	     current_path_ptr = pvp;
	     level = 1;
	     if number_of_variables > 1 then do;
		     if path_var.in_and_group | path_var.in_select_clause then
			temp_current_path_multiplier =
			     current_path_multiplier * path_var.number_tuples_selected;
		     else temp_current_path_multiplier = current_path_multiplier;

		     call
			permutations (temp_current_path_multiplier, current_path_cost,
			level + 1, dummy_good_enough, code);
		end;
	     else do;
		     low_cost_path_ptr = current_path_ptr;
		     current_path_ptr = null;
		     cost = current_path_cost;
		end;
	     if code ^= 0 then
		return;
	     code = 0;
	     if use_range_order then
		finished = "1"b;
	     else m_d_p_i = m_d_p_i + 1;

	     if m_d_p_i > number_of_variables then
		finished = "1"b;

	     if current_path_ptr ^= null then do;
		     work_ptr = current_path_ptr -> path_var.fwd_thd;
		     do while (current_path_ptr ^= null);
			call free_structures (current_path_ptr);
			current_path_ptr = work_ptr;
			if current_path_ptr ^= null then
			     work_ptr = current_path_ptr -> path_var.fwd_thd;
		     end;
		end;
	end;
%page;
/* add the no tuple effect variables to the end of the low cost path,
   they are needed for no_tuple_effect checks in optimize,
   and will be skipped by gen_srch_prog */

	do pvp = low_cost_path_ptr repeat path_var.fwd_thd
	     while (path_var.fwd_thd ^= null ());

	end;

	path_var.fwd_thd = no_tuple_effect_ptr;

/* display the final low cost path found, if the debug switch is set */

	if substr (db_mrds_dsl_permute, 5, 1) then
	     call display_final_path_details ();

/* perpare final search path by putting it in reverse order expected by mrds_dsl_optimize  */

	do pvp = low_cost_path_ptr repeat path_var.fwd_thd
	     while (path_var.fwd_thd ^= null);
	end;
	path_ptr = pvp;				/* reverse list for mrds_dsl_optimize */
	do m_d_p_i = 1 to number_of_variables - 1 + no_tuple_effect_number;
	     do current_path_ptr = low_cost_path_ptr
		repeat current_path_ptr -> path_var.fwd_thd
		while (current_path_ptr -> path_var.fwd_thd ^= path_ptr);
	     end;
	     path_ptr -> path_var.fwd_thd = current_path_ptr;
	     path_ptr = current_path_ptr;
	end;
	path_ptr -> path_var.fwd_thd = null;
	return;
%page;
find_attributes:
     proc (var_index, multiplier, cost, code);


/* DESCRIPTION:

   this routine gets a path_var structure for this tuple variable filled in.
   This includes adding the list of conditions for this tuple variable
   that can be satisfied at this point, depending on what tuple variables
   preceed it in the search path generated so far */

	dcl     multiplier		 float bin (63);	/* times the current access cost will  be incurred */

	dcl     (
	        base_variable_index,			/* index of base var. */
	        current_term,			/* index to current term in and group */
	        f_a_i,				/* internal index */
	        left_sub_tree_variable_index,		/* left leaf var index */
	        op_code,				/* working op code */
	        other_variable_index,			/* index of other var. */
	        right_sub_tree_variable_index,		/* right leaf var index */
	        var_index
	        )			 fixed bin;	/* Input:  index of variable we are working with */

	dcl     code		 fixed bin (35);	/* internal status code */

	dcl     cost		 float bin (63);	/* internal  cost */

	dcl     (
	        done,				/* internal flag */
	        found,				/* internal flag */
	        variable_index_in_and_group
	        )			 bit (1);		/* internal flag */

	dcl     (
	        base_variable_leaf_ptr init (null),	/* to leaf of base var */
	        other_variable_leaf_ptr init (null)
	        )			 ptr;		/* to leaf of other var */

	dcl     sub_path_cost	 float bin (63);	/* cost of the current path */

	dcl     ops_array		 (5:10) fixed bin int static options (constant)
				 init (1, 2, 3, 5, 4, 6);
	dcl     rev_ops_array	 (6) fixed bin int static options (constant)
				 init (1, 2, 5, 6, 3, 4);




	variable_index_in_and_group = "0"b;

	if path_var_free_ptr = null then
	     allocate path_var in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinitd at the beginning of each new S. E.. */
	else do;
		pvp = path_var_free_ptr;
		path_var_free_ptr = path_var_free_ptr -> path_var.fwd_thd;
	     end;

	path_var.alp, path_var.elp, path_var.fwd_thd = null;
	path_var.var_index = var_index;
	rmri_ptr = range.tup_var.ri_ptr (var_index);

	call get_attr_list (rm_rel_info.num_attr, alp);

	path_var.alp = alp;
	do f_a_i = 1 to attr_list.nattr;
	     attr_list.info (f_a_i).cond_ptr = null;
	     attr_list.info.index = 0;
	end;

	current_term = 1;
	done = "0"b;
	do while (^done);				/* look for all terms in var index */

	     found = "0"b;
	     do f_a_i = current_term to and_group.num_terms while (^found);
		pn_ptr = and_group.term_ptr (f_a_i);
		left_sub_tree_variable_index = fixed (pred_node.id.lleaf_id.var_id);
		right_sub_tree_variable_index =
		     fixed (pred_node.id.rleaf_id.var_id);
		if left_sub_tree_variable_index = var_index then do;
						/* if left leaf is in var index */
			base_variable_leaf_ptr = pred_node.lbr;
			base_variable_index = left_sub_tree_variable_index;
			op_code = ops_array (fixed (pred_node.id.op_code));
			other_variable_leaf_ptr = pred_node.rbr;
			other_variable_index = right_sub_tree_variable_index;
			found = "1"b;
		     end;
		else if right_sub_tree_variable_index = var_index then do;
						/* if right leaf in var. */
			base_variable_leaf_ptr = pred_node.rbr;
			base_variable_index = right_sub_tree_variable_index;
			op_code =
			     rev_ops_array (ops_array (fixed (pred_node.id.op_code)));
			other_variable_leaf_ptr = pred_node.lbr;
			other_variable_index = left_sub_tree_variable_index;
			found = "1"b;
		     end;
	     end;
	     current_term = f_a_i;			/* remember where to start again */
	     if ^found then
		done = "1"b;

	     else do;				/* have term with leaf in var. */
		     variable_index_in_and_group = "1"b;
		     if other_variable_index = base_variable_index then do;
						/* ignore terms where both leaves insame var */
			     if base_variable_leaf_ptr -> pred_leaf.expr_ptr ^= null then
				/* if is expr in this var */
				call
				     add_to_expr_list (base_variable_leaf_ptr,
				     other_variable_leaf_ptr, op_code);
			     else if other_variable_leaf_ptr -> pred_leaf.expr_ptr ^= null
			     then do;
				     op_code =
					rev_ops_array (ops_array (fixed (pred_node.id.op_code)));
						/* changes < to >, */
						/*         <= to =>, */
						/*         => to =<, */
						/*         > to < */
				     call
					add_to_expr_list (other_variable_leaf_ptr,
					base_variable_leaf_ptr, op_code);
				end;		/*  expr in right leaf */
			     else call
				     add_to_attr_list (base_variable_leaf_ptr,
				     other_variable_leaf_ptr, op_code); /* if no expr leaves */
			end;
		     else if base_variable_leaf_ptr -> pred_leaf.expr_ptr ^= null then
			/* if expr */
			call
			     add_to_expr_list (base_variable_leaf_ptr,
			     other_variable_leaf_ptr, op_code);
		     else call
			     add_to_attr_list (base_variable_leaf_ptr,
			     other_variable_leaf_ptr, op_code);
		end;				/* if have leaf in prime variable */
	end;					/* looking for all terms in var index */


/* for tuple variables not participating in this and_group
   we use a path_var bit as an indicator. This will force calc_sub_path_cost
   to use sequential access method for cost calcualtion,
   as this is the method needed for the implied cross product */

	sub_path_cost = 0.0;
	code = 0;

	if ^variable_index_in_and_group then
	     path_var.in_and_group = "0"b;
	else path_var.in_and_group = "1"b;

	path_var.in_select_clause = range.tup_var.used (path_var.var_index);

	call calc_sub_path_cost (multiplier, sub_path_cost, code);
	cost = sub_path_cost;

	return;
%page;
add_to_attr_list:
     proc (bp, op, opc);

/* procedure to add term to attr. list */

	dcl     (
	        bp,				/* base_variable_leaf_ptr */
	        op,				/* other_variable_leaf_ptr */
	        savep		 init (null),
	        work_ptr		 init (null)
	        )			 ptr;

	dcl     ptr_templ		 ptr based;

	dcl     (attr_ind, opc)	 fixed bin;	/* op_code */

	dcl     end_of_list		 bit (1);

	work_ptr = current_path_ptr;
	end_of_list = "0"b;
	do while (^end_of_list);
	     if work_ptr = null then
		end_of_list = "1"b;
	     else if work_ptr -> path_var.var_index = fixed (op -> pred_leaf.var_id)
	     then end_of_list = "1"b;
	     else work_ptr = work_ptr -> path_var.fwd_thd;
	end;

	if work_ptr ^= null | op -> pred_leaf.data_type = CONST
	     | bp -> pred_leaf.id.var_id = op -> pred_leaf.id.var_id then do;
		attr_ind = fixed (bp -> pred_leaf.id.attr_id);

		if attr_list.info.cond_ptr (attr_ind) = null then do;
						/* if first cond. */
			savep = addr (attr_list.info.cond_ptr (attr_ind));
			attr_list.info.index (attr_ind) = attr_ind;
		     end;
		else do;				/* else find end of linked list */
			do condp = attr_list.info.cond_ptr (attr_ind)
			     repeat cond.fwd_thd while (cond.fwd_thd ^= null);
			end;
			savep = addr (cond.fwd_thd);
		     end;

		if cond_free_ptr = null then /* get a condition structure */
		     allocate cond in (select_area);	/* Allocations in select_area are never freed.  This area
						   is reinit at the beginning of each new S. E.. */
		else do;
			condp = cond_free_ptr;
			cond_free_ptr = cond_free_ptr -> cond.fwd_thd;
		     end;

		savep -> ptr_templ = condp;		/* set the values of the condition structure */
		cond.op_code = opc;
		cond.pl_ptr = op;
		cond.fwd_thd = null;
	     end;

     end add_to_attr_list;
%page;
add_to_expr_list:
     proc (bp, op, opc);

/* Procedure to add expr to expr list */

	dcl     end_of_list		 bit (1);
	dcl     opc		 fixed bin;
	dcl     (
	        bp,
	        op,
	        work_ptr		 init (null)
	        )			 ptr;

	end_of_list = "0"b;
	work_ptr = current_path_ptr;
	do while (^end_of_list);
	     if work_ptr = null then
		end_of_list = "1"b;
	     else if work_ptr -> path_var.var_index
		     = fixed (op -> pred_leaf.id.var_id) then
		end_of_list = "1"b;
	     else work_ptr = work_ptr -> path_var.fwd_thd;
	end;

	if work_ptr ^= null | op -> pred_leaf.data_type = CONST
	     | bp -> pred_leaf.id.var_id = op -> pred_leaf.id.var_id then do;

		if path_var.elp = null then do;	/* if first */
			el_nexprs_init = and_group.num_terms;

			if expr_list_free_ptr = null then
			     allocate expr_list in (select_area); /* Allocations in select_area are never freed.  It
						   is reinit at the beginning of each new S. E.. */
			else do;
				elp = expr_list_free_ptr;
				expr_list_free_ptr =
				     expr_list_free_ptr -> expr_list.info (1).epl_ptr;
			     end;

			expr_list.nexprs = 0;
			path_var.elp = elp;
		     end;
		expr_list.nexprs = expr_list.nexprs + 1;
		expr_list.info.epl_ptr (expr_list.nexprs) = bp;
		expr_list.info.pl_ptr (expr_list.nexprs) = op;
		expr_list.info.op_code (expr_list.nexprs) = opc;
	     end;

     end add_to_expr_list;

     end find_attributes;
%page;
calc_sub_path_cost:
     proc (multiplier, cost, code);

/* DESCRIPTION:

   this routine computes the cost of accessing the current tuple variable,
   in it's current position in the search path, thus taking into
   account how the previous tuple variables will affect the useable access methods,
   and the number of occurences of the access of this tuple variable
   See the comments on the Cost Calculation Constants */


	var_index = path_var.var_index;
	path_var.lk_key_ind = 0;			/* unused */
	relation_size = rm_rel_info.current_tuple_population;

/* FORMULAS FOR NUMBER OF TUPLES SELECTED:

   L =   T / (T - D) gives the number of tuples selected by a single index value.
   where T = number of tuples in rel, D = is the number (or an estimate) of the
   duplicate values of that index.

   Of course if L is the number selected by "=",
   then (T - L) is the number selected by "^=".

   The number of tuples to bump that selected by an "=" condition
   for the case of "<", ">=", etc conditions uses the formula

   L +    (L / T) * (T - L) where L is the result of the above formula.
   (T - L) is the number of values
   not selected by an "=" condition, and (L/T) is the percentage
   of the tuple selected by the "=" condition, so taking that percent
   of the remaining tuples suffices to insure about twice as many selected for
   a ">" condition etc.
   Note that for L = T, ot L = 0, the result is 0 added tuples.
   If T is 0, we don't have to worry about this formula.


   For key head accesses, rather than indexed attributes,
   we use the formula L = T ** (1 - (number_used_key_attrs / total_key_attrs))
   to approximate the selectivity of a key head search for the "=" condition.

   The other formulas remain the same.

   After computing selected tuples, we have to worry about how
   additional conditions (comparisons) will reduce the tuples select.
   This is done with the formula T / (C + 1),
   where C is the cost of conditions remaining.
*/

/* go through all access methods useable on this tuple variable,
   and compute the expected number of tuples selected and
   the cost of each access method. then choose the access
   method having the lowest cost for this tuple variable */

	if relation_size = 0
	     | (^path_var.in_select_clause & ^path_var.in_and_group) then do;

/* for empty relations avoid un-needed work, since
   they always get a cost of 0.

   For T.V.'s not in the select clause
   and not in this and group,
   that will be dropped from consideration by permutations,
   just fill in the bare essentials. */

		if rm_rel_info.ready_mode = RETRIEVE_ONLY then
		     path_var.access_method = UNORDERED_SEQUENTIAL;
		else path_var.access_method = ORDERED_SEQUENTIAL;
		path_var.second_cond_ptr, path_var.cond_ptr = null ();
		path_var.attr_index = 0;
		path_var.number_tuples_selected = relation_size;
		cost, path_var.cost, access_method_cost = 0.0;
	     end;
	else do;
		do i = 1 to 6;			/* init the costs */
		     access_method (i).cost = INFINITY;
		end;

/* get the number of conditions used against this tuple variable */

		call
		     count_conditions (tv_condition_count, tv_condition_cost,
		     tv_equal_condition, tv_not_equal_condition);

		if path_var.in_and_group then do;	/* force sequential for not in and group T.V. cost */

/* CHECK ON TOTAL PRIMARY KEY OR LONG KEY HEAD POSSIBILITIES */

			call equal_key (total, equal_head, equal_fraction, equal_key_count);

			if total then do;		/* entire primary key useable */

/* this access method needs the entire primary key attrs
   to have at least one = condition specified against each.
   It will uniquely select one tuple using a seek_key */

				access_method (1).code = TOTAL_PRIMARY_KEY;
				access_method (1).condition_count =
				     tv_condition_count - equal_key_count;
				access_method (1).conditions_cost =
				     tv_condition_cost
				     - (equal_key_count * CONDITION_COST_FACTOR (OTT_EQ));
				access_method (1).tuples_selected = 1; /* unique primary key => 1 tuple */
				access_method (1).cost = dbcb.access_costs.total_primary_key_cost;
			     end;

			if equal_head then do;	/* 1 or more key head attr useable */

/* this case considers where a vfile select can be used
   to do a seek_head on the primary key. It only works where
   it needs at least one equal condition
   on each key head attribute in order to work */

/* we can make a bad estimate of the tuples selected
   by a key head, using the linear relatioship:
   rel_size * (1 - (key_head_attr_count / total_key_attr_count))
   An alternative formula that that works better for the fraction close to 1 is
   rel_size ** (1 - key_head_attr_count / total_key_attr_count),
   but both apply only to the case with the condition "=",
   in general more tuples are selected by ">", etc.
   and the tuples selected must be increased for that case. */

				access_method (2).code = LONG_KEY_HEAD;
				access_method (2).condition_count =
				     tv_condition_count - equal_key_count;
				access_method (2).conditions_cost =
				     tv_condition_cost
				     - (equal_key_count * CONDITION_COST_FACTOR (OTT_EQ));
				access_method (2).tuples_selected =
				     relation_size ** (1 - equal_fraction);
				tuples_selected_temp =
				     access_method (2).tuples_selected
				     / (access_method (2).conditions_cost + 1);
				access_method (2).tuples_selected = ceil (tuples_selected_temp);
				access_method (2).cost =
				     (dbcb.access_costs.access_cost * access_method (2).tuples_selected)
				     + dbcb.access_costs.access_overhead;
			     end;

/* CHECK ON SHORT KEY HEAD AND INDEXED ATTR POSSIBILITIES */

			call
			     short_key (short_head, short_fraction, indexed_attr,
			     key_head_condition_cost, key_head_not_equal_condition,
			     key_head_range, key_head_attr_id, key_head_cond_ptr,
			     key_head_2nd_cond_ptr, indexed_attr_condition_cost,
			     index_attr_equal_condition, index_attr_not_equal_condition,
			     index_attr_range, index_attr_id, index_attr_cond_ptr,
			     index_attr_2nd_cond_ptr, index_attr_number_of_dups);

			if short_head then do;	/* the 1st key attr useable as head with other than "=" */

/* for the first attribute of a primary key, we can use
   vfile select, looking for a key head value.
   The previous method already handled "=" conditions,
   so now we look at all the other conditions, >, <, ^=, etc. */

				access_method (3).code = SHORT_KEY_HEAD;
				access_method (3).condition_count =
				     tv_condition_count - 1 - fixed (key_head_range);
						/* only one condition used for access unless range */
				access_method (3).conditions_cost =
				     tv_condition_cost - key_head_condition_cost;
				if key_head_not_equal_condition then do;
					if short_fraction = 1.0 then
					     access_method (3).tuples_selected = relation_size - 1;
					else access_method (3).tuples_selected =
						relation_size
						- (relation_size ** (1 - short_fraction));
						/* "^=" => T - L */
				     end;
				else do;		/* other than "=" or "^=" condition */
					if short_fraction = 1.0 then
					     access_method (3).tuples_selected = 1;
					else access_method (3).tuples_selected =
						relation_size ** (1 - short_fraction);
					access_method (3).tuples_selected =
					     access_method (3).tuples_selected
					     + (access_method (3).tuples_selected / relation_size)
					     * (relation_size - access_method (3).tuples_selected);
						/* ">", etc.
						   => L + ((L/T) * (T - L)) */
				     end;
				tuples_selected_temp =
				     access_method (3).tuples_selected
				     / (access_method (3).conditions_cost + 1);
				access_method (3).tuples_selected = ceil (tuples_selected_temp);
				access_method (3).cost =
				     (dbcb.access_costs.access_cost * access_method (3).tuples_selected)
				     + dbcb.access_costs.access_overhead;
			     end;

			if indexed_attr then do;

/*
   A  secondary  index is available for access.  We can estimate the
   tuples  selected as rel_size / unique_index_values.  for the case
   where  the condition is "=".  The "=" if present is forced as the
   access  indexed  attr  if  more  than  one  index or condition is
   present.   For  other  than  "=",  the  index selectivity must be
   changed, to show more tuples selected than for an = condition.
*/

				relation_index_selectivity =
				     relation_size / (relation_size - index_attr_number_of_dups);
				GT_LT_SELECTED_TUPLES =
				     relation_index_selectivity
				     + ((relation_index_selectivity / relation_size)
				     * (relation_size - relation_index_selectivity));

				NE_SELECTED_TUPLES = relation_size - relation_index_selectivity;

				access_method (4).code = INDEXED_ATTR;
				access_method (4).condition_count =
				     tv_condition_count - 1 - fixed (index_attr_range);
						/* only one condition being used for access unless range */
				access_method (4).conditions_cost =
				     tv_condition_cost - indexed_attr_condition_cost;
				if index_attr_not_equal_condition then
				     access_method (4).tuples_selected = NE_SELECTED_TUPLES;
						/* ^= => T - L */
				else do;
					access_method (4).tuples_selected =
					     relation_index_selectivity; /* "=" => L */
					if ^index_attr_equal_condition then
					     access_method (4).tuples_selected =
						GT_LT_SELECTED_TUPLES; /* ">", etc. => L + (L/T)*(T-L) */
				     end;
				tuples_selected_temp =
				     access_method (4).tuples_selected
				     / (access_method (4).conditions_cost + 1);
				access_method (4).tuples_selected = ceil (tuples_selected_temp);
				access_method (4).cost =
				     (dbcb.access_costs.access_cost * access_method (4).tuples_selected)
				     + dbcb.access_costs.access_overhead;
			     end;
		     end;


/* for sequential retrievals, the number of tuples that actually
   statisfy the query will depend on the number of conditions specified,
   the greater number of conditions usually meaning fewer tuples retrieved.
   The number of conditions is factored in using the formula:
   relation_size / (condition_count + 1)
   an alternative formula considered was:
   (0.9 ** condition_count) * relation_size  */

		access_method (5).code = UNORDERED_SEQUENTIAL;
		access_method (5).condition_count = tv_condition_count;
		access_method (5).conditions_cost = tv_condition_cost;
		tuples_selected_temp = relation_size / (tv_condition_cost + 1);
		access_method (5).tuples_selected = ceil (tuples_selected_temp);
		access_method (5).cost =
		     dbcb.access_costs.us_access_cost * relation_size;

/* now that all access methods have had their relative costs evaluated,
   chose the lowest cost access method for this tuple variable */

		lowest_cost = INFINITY;
		lowest_cost_index = 0;
		do i = 1 to 6;
		     if lowest_cost > access_method (i).cost then do; /* found a lower cost */
			     lowest_cost = access_method (i).cost;
			     lowest_cost_index = i;
			end;
		end;

		if lowest_cost_index = 0 then do;	/* we screwed up */
			code = mrds_error_$rst_logic_error;
			access_method_cost = 1;	/* dummy values for error */
			path_var.access_method = UNORDERED_SEQUENTIAL;
			path_var.number_tuples_selected = 0;
		     end;
		else do;
			code = 0;
			path_var.access_method = access_method (lowest_cost_index).code;
			path_var.number_tuples_selected =
			     access_method (lowest_cost_index).tuples_selected;
			access_method_cost = access_method (lowest_cost_index).cost;
		     end;


/* point to condition and attribute to be used for access method */

		if path_var.access_method ^= TOTAL_PRIMARY_KEY
		     & path_var.access_method ^= LONG_KEY_HEAD then do;

/* reset attrs/conditions selected by equal key */

			do i = 1 to rm_rel_info.nkey_attr;

			     j = rm_rel_info.key_attr_ptrs (i) -> rm_attr_info.defn_order;

			     attr_list.info.attr_selected (j) = "0"b;

			     do condp = attr_list.info.cond_ptr (j) repeat cond.fwd_thd
				while (condp ^= null ());
				cond.condition_selected = "0"b;
			     end;

			end;

		     end;

/* for a long = key head, remember the number of key head attrs used.
   for indexed attr or short key head, remember the condition used
   and the attribute on which that condition appeared.
   Set the appriopriate bits in the condition and attr_list strucutres
   so that gen_srch_prog will know what to do. */

		if path_var.access_method = LONG_KEY_HEAD
		     | path_var.access_method = TOTAL_PRIMARY_KEY then do;
			path_var.second_cond_ptr, path_var.cond_ptr = null ();
			path_var.attr_index = equal_key_count; /* use to save length of key head */
		     end;
		else if path_var.access_method = INDEXED_ATTR then do;
			path_var.cond_ptr = index_attr_cond_ptr;
			path_var.second_cond_ptr = index_attr_2nd_cond_ptr;
			path_var.attr_index = index_attr_id;

			path_var.cond_ptr -> cond.condition_selected = "1"b;
			if path_var.second_cond_ptr ^= null () then
			     path_var.second_cond_ptr -> cond.condition_selected = "1"b;
			path_var.alp -> attr_list.info.attr_selected (path_var.attr_index) =
			     "1"b;
		     end;
		else if path_var.access_method = SHORT_KEY_HEAD then do;
			path_var.cond_ptr = key_head_cond_ptr;
			path_var.second_cond_ptr = key_head_2nd_cond_ptr;
			path_var.attr_index = key_head_attr_id;

			path_var.cond_ptr -> cond.condition_selected = "1"b;
			if path_var.second_cond_ptr ^= null () then
			     path_var.second_cond_ptr -> cond.condition_selected = "1"b;
			path_var.alp -> attr_list.info.attr_selected (path_var.attr_index) =
			     "1"b;
		     end;
		else do;
			path_var.second_cond_ptr, path_var.cond_ptr = null ();
			path_var.attr_index = 0;
		     end;



/* the new cost will be the old cost, plus
   the times this current access method cost will be incurred
   The addition to the cost so far, is done outside this routine
   as is the multiplication of the new number of tuples selected.
   The overall formula is cost = cost + (previously_selected * access_cost) */

		path_var.cost, cost = (multiplier * access_method_cost);

	     end;

/* optional debug display */

	if display_access_method_costs then do;

		call ioa_ ("^3/RELATION STATISTICS");
		call
		     ioa_ ("^-Tuple variable:  ^a^/^-In and group:  ^[yes^;no^]",
		     range.tup_var (path_var.var_index).name, path_var.in_and_group);
		call
		     ioa_ ("^-In select clause:  ^[yes^;no^]", path_var.in_select_clause)
		     ;
		call
		     ioa_ ("^-Relation size:  ^d^/", relation_size);

		if relation_size ^= 0
		     & (path_var.in_select_clause | path_var.in_and_group) then do;

			call ioa_ ("^/ACCESS METHOD COST ARRAY");

			do i = 1 to 6;

			     call ioa_ ("^/^a", access_method_name (i));
			     if access_method (i).cost = INFINITY then
				call ioa_ ("^-This method not useable.");
			     else do;
				     call
					ioa_ (
					"^-Access method cost:  ^f^/^-Tuples selected:  ^d^/^-Conditions:  ^d"
					, access_method (i).cost,
					access_method (i).tuples_selected,
					access_method (i).condition_count);
				     call
					ioa_ ("^-Conditions cost:  ^f",
					access_method (i).conditions_cost);
				end;

			end;
		     end;

		call ioa_ ("^/ACCESS METHOD CHOSEN^/");

		call ioa_ ("^a", access_method_name (path_var.access_method));
		call
		     ioa_ ("^-Computed cost:  ^f^/^-Multiplier:  ^f", path_var.cost,
		     multiplier);
		if path_var.access_method = TOTAL_PRIMARY_KEY
		     | path_var.access_method = LONG_KEY_HEAD then
		     call ioa_ ("^-Equal key attrs used:  ^d", path_var.attr_index);
		else if path_var.access_method = SHORT_KEY_HEAD
			| path_var.access_method = INDEXED_ATTR then do;
			if path_var.second_cond_ptr = null () then
			     call
				ioa_ ("^-Condition used:  ^a",
				condition_array (path_var.cond_ptr -> cond.op_code));
			else call
				ioa_ ("^-Conditions used:  ^a  &  ^a",
				condition_array (path_var.cond_ptr -> cond.op_code),
				condition_array (path_var.second_cond_ptr -> cond.op_code));
			call
			     ioa_ ("^-Attribute used:  ^a",
			     rm_rel_info.attr_ptrs (path_var.attr_index) -> rm_attr_info.name)
			     ;
		     end;

		call ioa_ ("^/SEARCH PATH SO FAR USING THIS TUPLE VARIABLE");
		call
		     ioa_ ("^-Cost of path at this point:  ^f",
		     current_path_cost + path_var.cost);

		do temp_path_ptr = current_path_ptr
		     repeat temp_path_ptr -> path_var.fwd_thd
		     while (temp_path_ptr ^= null ());

		     call
			ioa_ ("^-Tuple variable:  ^a",
			range.tup_var.name (temp_path_ptr -> path_var.var_index));

		end;

		call
		     ioa_ ("^-Tuple variable:  ^a^/",
		     range.tup_var.name (path_var.var_index));

	     end;

	return;



	dcl     var_index		 fixed bin;

	dcl     tuples_selected_temp	 float bin (63);	/* temp to allow ceil operation */
	dcl     index_attr_range	 bit (1);		/* on => range of values available for key access */
	dcl     key_head_range	 bit (1);		/* on => range of values available for key access */
	dcl     key_head_2nd_cond_ptr	 ptr;		/* to second condition in range */
	dcl     index_attr_2nd_cond_ptr ptr;		/* to second condition in range */
	dcl     GT_LT_SELECTED_TUPLES	 float bin (27);	/* number of tuples to bump select$ed for other than "=" */
	dcl     NE_SELECTED_TUPLES	 float bin (27);	/* number of tuples to bump selected for "^=" */
	dcl     key_head_condition_cost float bin (27);	/* cost of condition against short key head */
	dcl     key_head_not_equal_condition bit (1);	/* on => "^=" against short key head used */
	dcl     key_head_cond_ptr	 ptr;		/* pointer to condition used for short key head */
	dcl     key_head_attr_id	 fixed bin;	/* index of attr for short key head usage */
	dcl     indexed_attr_condition_cost float bin (27); /* cost of condition against indexed attr used */
	dcl     index_attr_equal_condition bit (1);	/* on => "=" condition agsint indexed attr */
	dcl     index_attr_not_equal_condition bit (1);	/* on => "^=" condition used against indexed attr */
	dcl     index_attr_number_of_dups fixed bin (35); /* number of duplicates in the selected index */
	dcl     index_attr_id	 fixed bin;	/* index of attribute used by secondary index method */
	dcl     index_attr_cond_ptr	 ptr;		/* to condtion for used index attr */
	dcl     relation_index_selectivity float bin (27);/* number of tuples selected by an "="
						   on an index value, for 1 index attr  */
	dcl     temp_path_ptr	 ptr;		/* used for displaying current search path */
	dcl     equal_key_count	 fixed bin;	/* number of key attributes involved */
	dcl     tv_condition_count	 fixed bin;	/* number of conditions/expressions against this T.V. */
	dcl     tv_condition_cost	 float bin (27);	/* const of conditions against this T.V. */
	dcl     tv_equal_condition	 bit (1);		/* on => = condition appears against T.V. */
	dcl     tv_not_equal_condition bit (1);		/* on => "^=" condition appears agsinst this T.V. */
	dcl     (i, j)		 fixed bin;	/* loop index */
	dcl     lowest_cost		 float bin (63);	/* temp for saving lowest cost seen so far */
	dcl     lowest_cost_index	 fixed bin;	/* access method array index for lowest cost */
	dcl     mrds_error_$rst_logic_error fixed bin (35) ext; /* program in error */
	dcl     total		 bit (1);		/* on => entire primary key useable */
	dcl     equal_head		 bit (1);		/* on => key equal_head useable */
	dcl     short_head		 bit (1);		/* on => key short_head useable */
	dcl     indexed_attr	 bit (1);		/* on => a  indexed attribute can be used for access */
	dcl     (equal_fraction, short_fraction) float bin (27); /* percentage of total key useable in hey head */
	dcl     multiplier		 float bin (63);	/* number of times this access cost will be incurred */
	dcl     access_method_cost	 float bin (27);	/* cost of using this access method */
	dcl     cost		 float bin (63);	/* cost of path so far */

/* the array slots are used as follows:
   1 => total primary key
   2 => long key head
   3 => short key head
   4 => secondary index
   5 => unordered sequential
   6 => ordered sequential */

	dcl     1 access_method	 dimension (1:6),	/* array for saving costs, tuples selected */
		2 code		 fixed bin,	/* encoding for the access method */
		2 tuples_selected	 fixed bin (35),	/* expected number of tuples that this method will return */
		2 cost		 float bin (63),	/* cost of this access method */
		2 condition_count	 fixed bin,	/* number of conditions involved */
		2 conditions_cost	 float bin (27);	/* cost of conditions against this T.V. */

	dcl     RETRIEVE_ONLY	 fixed bin init (5) int static options (constant);
						/* scope retrieve ready mode */

	dcl     INFINITY		 init (10e37) float bin (63) int static options (constant);

	dcl     (code, relation_size)	 fixed bin (35);
%page;
equal_key:
     proc (total_primary_key, equal_key_head, useable_key_fraction,
	useable_key_attrs);


/* Procedure to determine if a unique index is useable */

/* DESCRIPTION:

   the total_primary_key and useable_key_fraction will be set
   if the tuple variable can be accessed by unique primary key value

   the equal_key_head and useable_key_fraction will be set if
   the tuple variable can be accessed by a key head
   using 1 or more key head attributes using = conditions

   To qualify for total key or long key head,
   there must be the total key or long key head in the users view
   of this tuple variables relation.

   The conditions must involved only constants, or references to other
   tuples variables that have already appeared in the search path,
   and thus have thier values available.

   The longest possible key head for an N attr key is N-1. */


	u_i_i = 0;
	total_primary_key, equal_key_head, useable = "0"b;
	useable_key_fraction = 0.0;
	if rm_rel_info.nkey_attr = rm_rel_info.model_nkey_attr then do;
						/* if not a partial key sub_model */
		useable = "1"b;
		u_i_i = 1;
		done = "0"b;
		do while (^done);
		     rai_ptr = rm_rel_info.key_attr_ptrs (u_i_i);
		     if attr_list.info.cond_ptr (rm_attr_info.defn_order) = null then
			useable = "0"b;		/* attr not referenced by a condition */
		     else do;			/* attr referenced */


/* look for a useable "=" condition on this attribute in the primary key */

			     equal_found = "0"b;
			     do condp = attr_list.info.cond_ptr (rm_attr_info.defn_order)
				repeat cond.fwd_thd while (condp ^= null () & ^equal_found);
						/* look for an "=" condpition */
				if cond.op_code = OTT_EQ then do; /* only if equality */
					pl_ptr = cond.pl_ptr;
					if fixed (pred_leaf.id.var_id) = var_index then
					     useable = "0"b;
					if useable then do; /* if good so far, check for problems */
						if pred_leaf.data_type ^= CONST then do;
							end_of_list = "0"b;
							work_ptr = current_path_ptr;
							do while (^end_of_list);
							     if work_ptr = null then
								end_of_list = "1"b;
							     else if work_ptr -> path_var.var_index
								     = fixed (pred_leaf.id.var_id) then
								end_of_list = "1"b;
							     else work_ptr = work_ptr -> path_var.fwd_thd;
							end;
							if work_ptr = null then
							     useable = "0"b;
						     end;
						if useable then do;
							equal_found = "1"b; /* still useable => good "=" condition */
							cond.condition_selected = "1"b; /* remember which condition used */
							attr_list.info
							     .attr_selected (rm_attr_info.defn_order) = "1"b;
						/* remember attr used */
						     end;
					     end;
				     end;
			     end;
			     if ^equal_found then
				useable = "0"b;	/* can only use it if had an "=" condition */
			end;			/* if refer. */
		     if useable then do;
			     if u_i_i < rm_rel_info.nkey_attr then
				u_i_i = u_i_i + 1;
			     else done = "1"b;
			end;
		     else do;
			     done = "1"b;
			     u_i_i = u_i_i - 1;	/* back up to last useable key attr */
			end;
		end;				/* loop thru key attr */

	     end;					/* not partial key sub_model */

	useable_key_attrs = u_i_i;

	if useable then do;
		total_primary_key = "1"b;
		useable_key_fraction = 1.0;
	     end;

	if ^useable & /* not total key available */
	     u_i_i >= 1 & u_i_i < rm_rel_info.nkey_attr then do; /* >= 1 key head attrs useable */
		equal_key_head = "1"b;
		useable_key_fraction = u_i_i / rm_rel_info.nkey_attr;
						/* ranges from 1/N to N-1/N */
	     end;


	dcl     u_i_i		 fixed bin;

	dcl     (end_of_list, useable) bit (1);

	dcl     work_ptr		 ptr init (null);

	dcl     equal_found		 bit (1);		/* on => a good "=" condition found against this key attr */
	dcl     total_primary_key	 bit (1);		/* on => can use entire primary key as unique index */
	dcl     equal_key_head	 bit (1);		/* on => can use 1 or more attrs of key head with "=" */
	dcl     useable_key_fraction	 float bin (27);	/* percent of key attrs useable as key head */
	dcl     done		 bit (1);		/* on => exit key attr loop */
	dcl     useable_key_attrs	 fixed bin;	/* number of key attributes involved */

     end equal_key;
%page;
short_key:
     proc (key_head, useable_key_fraction, secondary_index,
	key_head_condition_cost, key_head_not_equal_condition, key_head_range,
	key_head_attr_id, key_head_cond_ptr, key_head_2nd_cond_ptr,
	index_attr_condition_cost, index_equal_condition,
	index_not_equal_condition, index_attr_range, index_attr_id,
	index_attr_cond_ptr, index_attr_2nd_cond_ptr, index_attr_number_of_dups);


/* Procedure to check to see if secondary indexed or key heads are referenced */

/* DESCRIPTION:

   if the tuple variable can be access by key head, using other than an = condition
   then the key_head bit is set, as well as the useable_key_fraction

   if the tuple variable can be accessed by secondary index,
   then the secondary_index bit is set

   if neither is possible, then neither bit is set */


	key_head_attr_id, index_attr_id = 0;
	key_head_2nd_cond_ptr, key_head_cond_ptr, index_attr_2nd_cond_ptr,
	     index_attr_cond_ptr = null ();
	key_head_not_equal_condition, index_equal_condition,
	     index_not_equal_condition, key_head_range, key_head, index_attr_range,
	     useable = "0"b;			/* init */
						/* Determine if there is a condition
						   on the first attribute of the primary key.  This will make
						   a key head. */

/* a key head on the first key attribute is useable as an access
   method for this tuple variable under the following circumstances:
   1) the first key order attribute has at least one condition on it
   2) the condition involves constants, or a value from a tuple
   variable that has appeared previously in the search path */

	key_head_condition_cost = 0.0;
	i_r_i = 0;
	do i_r_j = 1 to rm_rel_info.nkey_attr;
	     rai_ptr = rm_rel_info.key_attr_ptrs (i_r_j); /* find the key head */
	     if rm_attr_info.key_order = 1 then do;
		     i_r_i = i_r_j;
		     i_r_j = rm_rel_info.nkey_attr + 1;
		end;
	end;
	if i_r_i ^= 0 then do;			/* if key head found */
		rai_ptr = rm_rel_info.key_attr_ptrs (i_r_i);
		if attr_list.info.cond_ptr (rm_attr_info.defn_order) ^= null ()
		then do;


/* look through all conditions on the single key head attr
   until a usable one is found, and remember it.
   Continue looking for usable conditions until the lowest cost one is found */

			do condp = attr_list.info.cond_ptr (rm_attr_info.defn_order)
			     repeat cond.fwd_thd while (condp ^= null);
			     pl_ptr = cond.pl_ptr;
			     condition_used = "0"b;
			     if cond.op_code ^= OTT_EQ then do; /* "=" handled by equal_key */

				     if pred_leaf.data_type = CONST then
					condition_used, useable = "1"b;
				     else do;
					     end_of_list = "0"b;
					     work_ptr = current_path_ptr;
					     do while (^end_of_list);
						if work_ptr = null then
						     end_of_list = "1"b;
						else if work_ptr -> path_var.var_index
							= fixed (pred_leaf.id.var_id) then
						     end_of_list = "1"b;
						else work_ptr = work_ptr -> path_var.fwd_thd;
					     end;
					     if work_ptr ^= null then
						condition_used, useable = "1"b;
					end;
				end;
			     if condition_used then do;
				     key_head_condition_cost =
					max (key_head_condition_cost,
					CONDITION_COST_FACTOR (cond.op_code));
				     if key_head_cond_ptr = null () then do;
					     key_head_attr_id = rm_attr_info.defn_order;
						/* save first condition found */
					     key_head_cond_ptr = condp;
					end;
				     else if key_head_cond_ptr -> cond.op_code ^= OTT_EQ then do;
					     if cond.op_code ^= OTT_NE & ^key_head_range then do;


/* favor a range condition over just a >, >=, etc */

						     if key_head_cond_ptr ^= null () then do;
							     if ((key_head_cond_ptr -> cond.op_code = OTT_LT
								| key_head_cond_ptr -> cond.op_code = OTT_LE)
								& (cond.op_code = OTT_GT | cond.op_code = OTT_GE))
								|
								((key_head_cond_ptr -> cond.op_code = OTT_GT
								| key_head_cond_ptr -> cond.op_code = OTT_GE)
								& (cond.op_code = OTT_LT | cond.op_code = OTT_LE))
							     then do;
								     key_head_range = "1"b;
								     key_head_2nd_cond_ptr = condp;
								end;
							end;
						     if ^key_head_range
							& key_head_cond_ptr -> cond.op_code = OTT_NE then do;
							     key_head_attr_id = rm_attr_info.defn_order;
						/* favor <, >, <=, >=
						   over ^= condition, as = will not occur */
							     key_head_cond_ptr = condp;
							end;
						end;
					end;
				end;
			end;
		     end;
	     end;
	if useable then do;
		key_head = "1"b;
		if key_head_cond_ptr -> cond.op_code = OTT_NE then
		     key_head_not_equal_condition = "1"b;
		useable_key_fraction = 1 / rm_rel_info.nkey_attr; /* ranges from 1.0 to 1/N */
	     end;

/* a secondary index access method can be used under the following circumstances:
   1) for this tuple variable, we have a secondary indexed attr with at least
   one condition specified against it
   2) that condition references either a constant, or a tuple variable
   that precedes this one in the current path */


	secondary_index, useable = "0"b;		/* init */
	index_attr_condition_cost = 0.0;
	if rm_rel_info.indexed then do;		/* if exists sec. ind. */
		do i_r_i = 1 to rm_rel_info.num_attr;
		     rai_ptr = rm_rel_info.attr_ptrs (i_r_i);
		     if rm_attr_info.index_attr then do;/* if indexed */


/* 
   look through all conditions on this attribute, find the one which
   will select the fewest number of tuples. Relational operator
   precedence is equal, range, in-equality, not-equal. Within each
   class the index with the fewest duplicate values will be chosen.
*/

			     do condp = attr_list.cond_ptr (rm_attr_info.defn_order)
				repeat cond.fwd_thd while (condp ^= null);
				pl_ptr = cond.pl_ptr;
				condition_used = "0"b;
				if pred_leaf.data_type = CONST then
				     condition_used, useable = "1"b;
				else do;
					end_of_list = "0"b;
					work_ptr = current_path_ptr;
					do while (^end_of_list);
					     if work_ptr = null then
						end_of_list = "1"b;
					     else if work_ptr -> path_var.var_index
						     = fixed (pred_leaf.id.var_id) then
						end_of_list = "1"b;
					     else work_ptr = work_ptr -> path_var.fwd_thd;
					end;
					if work_ptr ^= null then
					     condition_used, useable = "1"b;
				     end;
				if condition_used then do;
					index_attr_condition_cost =
					     max (index_attr_condition_cost,
					     CONDITION_COST_FACTOR (cond.op_code));
					if index_attr_cond_ptr = null () then do;
						/* save 1st condition seen */
						index_attr_id = rm_attr_info.defn_order;
						index_attr_cond_ptr = condp;
						index_attr_number_of_dups = rm_attr_info.number_of_dups;
						index_attr_range = "0"b;
						index_attr_2nd_cond_ptr = null ();
					     end;
					else do;
						condition_completes_range = "0"b;
						if index_attr_cond_ptr ^= null () &
						     index_attr_id = rm_attr_info.defn_order
						then do;
							if ((index_attr_cond_ptr -> cond.op_code = OTT_LT
							     | index_attr_cond_ptr -> cond.op_code = OTT_LE)
							     & (cond.op_code = OTT_GT |
							     cond.op_code = OTT_GE))
							     |
							     ((index_attr_cond_ptr -> cond.op_code = OTT_GT
							     | index_attr_cond_ptr -> cond.op_code = OTT_GE)
							     & (cond.op_code = OTT_LT |
							     cond.op_code = OTT_LE))
							then condition_completes_range = "1"b;
						     end;
						call find_index_attr;

					     end;
				     end;
			     end;
			end;
		end;				/* loop thru attr */
	     end;					/* if sec. ind. exist */
	if useable then do;
		secondary_index = "1"b;
		if index_attr_cond_ptr -> cond.op_code = OTT_EQ then
		     index_equal_condition = "1"b;
		else if index_attr_cond_ptr -> cond.op_code = OTT_NE then
		     index_not_equal_condition = "1"b;
	     end;


	dcl     (end_of_list, useable) bit (1);

	dcl     (i_r_i, i_r_j)	 fixed bin;

	dcl     work_ptr		 ptr init (null);
	dcl     key_head_range	 bit (1);		/* on => exists range of values on the key head attr */
	dcl     key_head_2nd_cond_ptr	 ptr;		/* to second in range of values for key head range */
	dcl     index_attr_range	 bit (1);		/* on => attr chosen for selection has a range */
	dcl     index_attr_2nd_cond_ptr ptr;		/* to second value in a range condition */
	dcl     condition_used	 bit (1);		/* on => this key_head/index_attr
						   useable for this attr/condtions */
	dcl     condition_completes_range bit (1);	/* on => exists a range of values on an indexed attr */
	dcl     index_attr_id	 fixed bin;	/* index into attr_ptr array for chosen condition */
	dcl     index_attr_cond_ptr	 ptr;		/* pointer to chosen condition for index */
	dcl     index_attr_number_of_dups fixed bin (35); /* number of dups on index chosen for selection */
	dcl     key_head_attr_id	 fixed bin;	/* index into attr_ptr array |for key head attr */
	dcl     key_head_cond_ptr	 ptr;		/* pointer to chosen condition for key head */
	dcl     key_head_not_equal_condition bit (1);	/* on => "^=" appeared as condition on key head */
	dcl     index_equal_condition	 bit (1);		/* on => "=" condition on indexed attr */
	dcl     index_not_equal_condition bit (1);	/* on => "^=" on indexed attr */
	dcl     key_head		 bit (1);		/* on => first key attr useable as head */
	dcl     secondary_index	 bit (1);		/* on => some secondarily indexed attr useable */
	dcl     useable_key_fraction	 float bin (27);	/* percentage of key attrs useable as key head */
	dcl     key_head_condition_cost float bin (27);	/* cost of conditions on key head attr */
	dcl     index_attr_condition_cost float bin (27); /* cost of conditions on indexed attribute */
%page;
find_index_attr: proc;				/* all parameters are global, local vars start with fia_ */

	dcl     fia_current_cond	 fixed bin;	/* code for current condition on attribute */
	dcl     fia_select_cond	 fixed bin;	/* code for condition that will be used to select
                                                               a tuple unless a better condition is found */
	dcl     fia_COMPARE_SELECTION_TO_CURRENT (4, 4) fixed bin internal static init
				 (1, 5, 9, 13, 2, 6, 10, 14, 3, 7, 11, 15, 4, 8, 12, 16);
						/* values of array are used to decide which
                                                               condition should be used to select the relation */

	if condition_completes_range
	then fia_current_cond = 4;
	else do;
		if condp -> cond.op_code > 3
		then fia_current_cond = 3;
		else fia_current_cond = condp -> cond.op_code;
	     end;

	if index_attr_range
	then fia_select_cond = 4;
	else do;
		if index_attr_cond_ptr -> cond.op_code > 3
		then fia_select_cond = 3;
		else fia_select_cond = index_attr_cond_ptr -> cond.op_code;
	     end;

	goto fia_do_something (fia_COMPARE_SELECTION_TO_CURRENT (fia_select_cond, fia_current_cond));


fia_do_something (1):				/* both conditions are = */
fia_do_something (6):				/* both conditions are ^= */
fia_do_something (11):				/* both conditions are an inequality */
	if index_attr_number_of_dups > rm_attr_info.number_of_dups
	then do;
		index_attr_cond_ptr = condp;
		index_attr_number_of_dups = rm_attr_info.number_of_dups;
		index_attr_id = rm_attr_info.defn_order;
		index_attr_range = "0"b;
		index_attr_2nd_cond_ptr = null ();
	     end;
	goto exit_find_index_attr;

fia_do_something (2):				/* select cond ^=, current cond = */
fia_do_something (3):				/* select cond is an inequality, current cond is = */
fia_do_something (4):				/* select cond is a range, current cond is = */
fia_do_something (10):				/* select cond is ^=, current cond is an inequality */
	index_attr_cond_ptr = condp;
	index_attr_number_of_dups = rm_attr_info.number_of_dups;
	index_attr_id = rm_attr_info.defn_order;
	index_attr_range = "0"b;
	index_attr_2nd_cond_ptr = null ();
	goto exit_find_index_attr;

fia_do_something (5):				/* select cond =, current cond ^= */
fia_do_something (7):				/* select cond is an inequality, current cond is a ^= */
fia_do_something (8):				/* select cond is a range, current cond is a ^= */
fia_do_something (9):				/* select cond is =, current cond is an inequality */
fia_do_something (12):				/* select cond is a range, current cond is an inequality */
						/* the following choices are not possible
                                                               because of the way a range is completed */
fia_do_something (13):				/* select cond is =, current cond completes a range */
fia_do_something (14):				/* select cond is ^=, current cond completes a range */
fia_do_something (16):				/* select cond is a range, current cond completes a range */
	goto exit_find_index_attr;

fia_do_something (15):				/* select cond is an inequality,
                                                               current cond completes a range */
	index_attr_2nd_cond_ptr = condp;
	index_attr_range = "1"b;
	goto exit_find_index_attr;

exit_find_index_attr:
	return;

     end find_index_attr;

     end short_key;

     end calc_sub_path_cost;
%page;
count_conditions:
     procedure (condition_count, condition_cost, equal_seen, not_equal_seen);

/* DESCRIPTION:

   If a tuple variable is to be accessed sequentially,
   the number of tuples selected during the search will depend on
   the number of conditions specified against the tuple variable attriubtes.
   This routine determines the count of those conditions.
   This includes the count of expressions.

   The different operators normally will select different numbers of tuples,
   the number increasing from lowest to highest when the operators are
   "=", a range using "<" and ">", a range using only a ">", ">=, "<", or "<=",
   and finally "^=" for the 4 major cases.
   Thus The following weightings for adding
   conditions have been used:

   ">", "<", ">=", or "<=" - - - add 0.5 for each condition

   "=" - - - add 1.5 for each condition

   "^=" - - - add 0.2 for each condition

   These costs for conditions are then factored into the tuples selected count
   as follows:

   For an access of all tuples in the relation = T tuples,
   the final count used is = T / (condition_cost + 1)

   For a case where the tuples are accessed via some key,
   this is modified to only consider the conditions remaining after
   the conditions used by the key search are subtracted
   thus the final count is = T / (TC - KC + 1)
   where TC = total condition cost and KC = key conditions cost

*/

	condition_count = 0;			/* init */
	condition_cost = 0.0;
	equal_seen = "0"b;
	not_equal_seen = "0"b;

	do i = 1 to rm_rel_info.num_attr;		/* look at all attrs in view of rel */

	     path_var.alp -> attr_list.info.attr_selected (i) = "0"b;
						/* reset for this T.V. */

	     do condp = path_var.alp -> attr_list.info.cond_ptr (i)
		repeat condp -> cond.fwd_thd while (condp ^= null ());

		condp -> cond.condition_selected = "0"b;/* reset for this T.V. */

		condition_cost =
		     condition_cost + CONDITION_COST_FACTOR (condp -> cond.op_code);
		condition_count = condition_count + 1;

		if condp -> cond.op_code = OTT_EQ then
		     equal_seen = "1"b;
		else if condp -> cond.op_code = OTT_NE then
		     not_equal_seen = "1"b;

	     end;

	end;

	if path_var.elp ^= null () then do;

		do i = 1 to path_var.elp -> expr_list.nexprs;
		     condition_cost =
			condition_cost
			+
			CONDITION_COST_FACTOR (path_var.elp
			-> expr_list.info (i).op_code);
		     condition_count = condition_count + 1;

		     if path_var.elp -> expr_list.info (i).op_code = 1 then
			equal_seen = "1"b;
		     else if path_var.elp -> expr_list.info (i).op_code = 2 then
			not_equal_seen = "1"b;
		end;

	     end;



	dcl     equal_seen		 bit (1);		/* on => an "=" condition exists against this relation */
	dcl     not_equal_seen	 bit (1);		/* on => a "^=" condition exists against this relation */
	dcl     condition_count	 fixed bin;	/* count of conditions against this relation */
	dcl     i			 fixed bin;	/* loop index */
	dcl     condp		 ptr;		/* local cond structure pointer */
	dcl     condition_cost	 float bin (27);	/* cost of conditions + expressions on this T.V. */

     end;
%page;
permutations:
     proc (multiplier_param, cost_param, level, good_enough_rtn, code);


/* DESCRIPTION:

   this routine will try all ordering of the tuple variables in this and_group,
   in an attempt to see how this ordering will affect possible access methoods,
   and the cost of using those methods, so that an overall lowest cost
   path through the tuple variables may be found
   tuple variables that are not in the and_group are treated equally with
   those in the and_group. the costing algorithm will put them
   in proper order in the final search path of tuple variables.

   Due to the changes on 10/01/83, this routine will no longer always try
   all possible orderings.  If the number of tuple variables is very large
   and the current path looks very good, the search will skip some of the
   permutations.  Currently, this is done by the simple method of checking
   if the sub-path will select only one tuple.  This should be done by looking
   at which tuple variable provide information to determine other tuple
   variable and only trying the permutations that have some chance of having
   different costs.  Unfortunally, this is much harder to do, so for now we
   will settle for the simple approach. 

   This routine now returns the bit good_enough, to indict the all lower levels
   in the sub-path examined meet the conditions required to skip doing all
   permutations.
 */

	dcl     (ENOUGH_TUPLE_VARIABLES_TO_NOT_TRY_ALL_POSSIBLE_PERMUTATIONS init (5),
	        PATH_DOES_NOT_EXPAND	 init (1),
	        NUMBER_OF_LEVELS_THAT_MUST_BE_PERMUTED init (2))
				 internal static options (constant);

	dcl     (current_variable_index, level, p_i, p_k, p_j) fixed bin;

	dcl     code		 fixed bin (35);

	dcl     (cost_param, current_path_cost, multiplier, multiplier_param,
	        temp_multiplier, sub_path_cost) float bin (63);

	dcl     (done, good_enough_rtn, good_enough, in_current_path, current_good_enough) bit (1);

	dcl     (
	        path_ptr		 init (null),
	        temp_fwd_thd	 init (null),
	        work_ptr		 init (null)
	        )			 ptr;

	good_enough_rtn = "0"b;
	multiplier = multiplier_param;
	current_path_cost = cost_param;
	current_variable_index = 1;
	do while (current_variable_index <= number_of_variables);
	     done = "0"b;
	     p_i = current_variable_index;
	     do while (^done & p_i ^> number_of_variables);
		sub_path_cost = 0.;			/* find this variable in the path. */
		do path_ptr = current_path_ptr
		     repeat path_ptr -> path_var.fwd_thd
		     while (path_ptr -> path_var.fwd_thd ^= null
		     & path_ptr -> path_var.var_index ^= variable_array (p_i));
		end;
		if path_ptr -> path_var.var_index ^= variable_array (p_i) then do;
						/* Does this variable already exist in the path? */
			pvp = null ();
			do while (pvp = null () & p_i ^> number_of_variables);
						/* Assume that this path is not good enough to cause skipping permutations */
			     current_good_enough = "0"b;
			     call
				find_attributes (variable_array (p_i), multiplier,
				sub_path_cost, code); /* No.  Create a path_var for it. */
			     if code ^= 0 then
				return;
			     if ^path_var.in_and_group & ^path_var.in_select_clause
			     then do;

/* a tuple variable with no effect on the select set was found,
   remove it from further considerations in the low cost path */

				     if no_tuple_effect_ptr = null () then do;
					     no_tuple_effect_ptr = pvp;
					     last_no_tuple_effect_ptr = pvp;
					end;
				     else do;
					     last_no_tuple_effect_ptr -> path_var.fwd_thd = pvp;
					     last_no_tuple_effect_ptr = pvp;
					end;

				     do p_j = p_i + 1 to number_of_variables;
					p_k = p_j - 1;
					variable_array (p_k) = variable_array (p_j);
				     end;

				     number_of_variables = number_of_variables - 1;
				     pvp = null ();
				     sub_path_cost = 0.0;
				     no_tuple_effect_number = no_tuple_effect_number + 1;

				     in_current_path = "1"b;
				     do while (p_i ^> number_of_variables & in_current_path);
					do path_ptr = current_path_ptr
					     repeat path_ptr -> path_var.fwd_thd
					     while (path_ptr -> path_var.fwd_thd ^= null ()
					     & path_ptr -> path_var.var_index
					     ^= variable_array (p_i));

					end;

					if path_ptr -> path_var.var_index = variable_array (p_i)
					then p_i = p_i + 1;
					else in_current_path = "0"b;

				     end;

				end;

			end;
			if pvp ^= null () then do;
						/* Check to see if the current path meets the "good enough" rule */
				if level > NUMBER_OF_LEVELS_THAT_MUST_BE_PERMUTED &
				     number_of_variables > ENOUGH_TUPLE_VARIABLES_TO_NOT_TRY_ALL_POSSIBLE_PERMUTATIONS
				     & path_var.number_tuples_selected <= PATH_DOES_NOT_EXPAND
				then current_good_enough = "1"b;
				if display_path_permutations then do;
					call
					     ioa_ (
					     "^/Current level: ^i  Current path cost: ^f  Sub path cost: ^f  Total: ^f"
					     , level, current_path_cost, sub_path_cost,
					     (current_path_cost + sub_path_cost));
					call
					     ioa_ ("^/Current variable: ^i   Current cost: ^f", p_i,
					     current_path_cost);
					call mdb_display_path_$path (current_path_ptr, dbcb_ptr);
					call mdb_display_path_$path (pvp, dbcb_ptr);
				     end;

/* check for the current path exceeding the cost of the lowest cost path
   found so far. If it is exceeded
   then we can discard further consideration of the current path
   We must not stop however, if the first reference low cost path
   has not been completely built yet (first_pass true) */

				if current_path_cost + sub_path_cost >= cost & ^first_pass
				then call free_structures (pvp); /* Yes. */
				else do;
					path_ptr -> path_var.fwd_thd = pvp; /* No. */
					current_variable_index = p_i;
					done = "1"b;
				     end;
			     end;
		     end;
		p_i = p_i + 1;
	     end;


/* check to see if this was the last variable that would make a complete
   path, and if so, was the current path a lower cost one than
   the lowest cost one seen so far. (done => lower cost)
   If this is the first path being built as a reference,
   then we must save it for comparison (first_pass true) */

	     if level >= number_of_variables & (done | first_pass) then do;
		     first_pass = "0"b;
		     if pvp ^= null then do;		/* a no_tuple_effect T.V. could have been last */
			     if path_var.in_select_clause | path_var.in_and_group then
				/* don't consider useless T.V.'s */
				multiplier = multiplier * path_var.number_tuples_selected;
			end;
		     cost = current_path_cost + sub_path_cost;
		     path_ptr = low_cost_path_ptr;
		     do work_ptr = current_path_ptr
			repeat work_ptr -> path_var.fwd_thd while (work_ptr ^= null);
						/* Copy the new, lower cost, path so that
						   modifications maybe made to the current path. */
			if path_ptr -> path_var.alp ^= null then
			     call free_attr_list (path_ptr);
			if path_ptr -> path_var.elp ^= null then
			     call free_expr_list (path_ptr);
			temp_fwd_thd = path_ptr -> path_var.fwd_thd;
			path_ptr -> path_var = work_ptr -> path_var;
			path_ptr -> path_var.fwd_thd = temp_fwd_thd;
			if work_ptr -> path_var.alp ^= null then
			     call copy_attr_list (path_ptr, work_ptr);
			if work_ptr -> path_var.elp ^= null then
			     call copy_expr_list (path_ptr, work_ptr);
			if work_ptr -> path_var.fwd_thd ^= null then
			     path_ptr = path_ptr -> path_var.fwd_thd;
			else path_ptr -> path_var.fwd_thd = null;
		     end;

		     if display_low_cost_paths then do; /* patch to display path */
			     do pvp = low_cost_path_ptr repeat path_var.fwd_thd
				while (path_var.fwd_thd ^= null);
			     end;
			     path_ptr = pvp;
			     do p_i = 1 to number_of_variables - 1;
				do work_ptr = low_cost_path_ptr
				     repeat work_ptr -> path_var.fwd_thd
				     while (work_ptr -> path_var.fwd_thd ^= path_ptr);
				end;
				path_ptr -> path_var.fwd_thd = work_ptr;
				path_ptr = work_ptr;
			     end;
			     path_ptr -> path_var.fwd_thd = null;
			     call ioa_ ("^/Cost: ^f", cost);
			     call mdb_display_path_$path (pvp, dbcb_ptr);
			     path_ptr = low_cost_path_ptr;
			     do p_i = 1 to number_of_variables - 1;
				do work_ptr = pvp repeat work_ptr -> path_var.fwd_thd
				     while (work_ptr -> path_var.fwd_thd ^= path_ptr);
				end;
				path_ptr -> path_var.fwd_thd = work_ptr;
				path_ptr = work_ptr;
			     end;
			     path_ptr -> path_var.fwd_thd = null;
			end;			/* end display path patch */

		     if level > 2 then do;		/* delete the last variable index generated so
						   we may look at the next variable index. */
			     do work_ptr = current_path_ptr
				repeat work_ptr -> path_var.fwd_thd
				while (work_ptr -> path_var.fwd_thd -> path_var.fwd_thd
				^= null);
			     end;
			     call free_structures (work_ptr -> path_var.fwd_thd);
			     good_enough_rtn = current_good_enough;
			     return;
			end;
		     else do;
			     call free_structures (current_path_ptr -> path_var.fwd_thd);
			     good_enough_rtn = current_good_enough;
			     return;
			end;
		end;
	     else if done then do;			/* It was not the last variable to look at.
						   Will this variable keep the path cost, so far,
						   beneath that of the existing path? */

		     if pvp = null () then
			temp_multiplier = multiplier;
		     else if ^path_var.in_and_group & ^path_var.in_select_clause then
			temp_multiplier = multiplier;
		     else temp_multiplier = multiplier * path_var.number_tuples_selected;

		     call permutations (temp_multiplier, current_path_cost + sub_path_cost,
			level + 1, good_enough, code);

		     if code ^= 0 then
			return;
		     good_enough_rtn = current_good_enough & good_enough;
		     call free_structures (path_ptr -> path_var.fwd_thd);
		end;
	     else if level >= number_of_variables	/* A variable to keep the cost below that of the
						   existing path was not found.  Back up a level. */
	     then do;
		     good_enough_rtn = current_good_enough;
		     return;
		end;

	     current_variable_index = current_variable_index + 1;
						/* Look for another path. */
	     if use_range_order then /* only one iteration t = 0.0 then */
		return;

	     if good_enough_rtn then /* Do not search more if this path is good enough */
		return;
	end;
	code = 0;
     end permutations;
%page;
free_structures:
     proc (path_var_ptr);

	dcl     work_ptr		 ptr init (null);

	dcl     path_var_ptr	 ptr;		/* Input: ptr to the path_var structure to be freed */

	if path_var_ptr ^= null () then do;

		path_var_ptr -> path_var.fwd_thd = path_var_free_ptr;
						/* Thread path_var structure onto its free list */
		path_var_free_ptr = path_var_ptr;
		path_var_ptr = null;

		if path_var_free_ptr -> path_var.alp ^= null then
		     call free_attr_list (path_var_free_ptr); /* if an attribute list structure exists put it and its
						   condition structures on their respective list */

		if path_var_free_ptr -> path_var.elp ^= null then
		     call free_expr_list (path_var_free_ptr); /* if an expression list structure exists put it on
						   its list */

	     end;

     end free_structures;
%page;
copy_attr_list:
     proc (copy_to_ptr, copy_from_ptr);

	dcl     (
	        copy_from_ptr,
	        copy_to_ptr,
	        from_work_ptr_1	 init (null),
	        from_work_ptr_2	 init (null),
	        to_work_ptr_1	 init (null),
	        to_work_ptr_2	 init (null)
	        )			 ptr;

	dcl     (c_a_l_i, c_a_l_j)	 fixed bin;

	call
	     get_attr_list (copy_from_ptr -> path_var.alp -> attr_list.nattr,
	     copy_to_ptr -> path_var.alp);






	from_work_ptr_1 = copy_from_ptr -> path_var.alp;
	to_work_ptr_1 = copy_to_ptr -> path_var.alp;


	to_work_ptr_1 -> attr_list = from_work_ptr_1 -> attr_list;

	c_a_l_j = from_work_ptr_1 -> attr_list.nattr;

	do c_a_l_i = 1 to c_a_l_j;
	     if from_work_ptr_1 -> attr_list.info (c_a_l_i).cond_ptr ^= null
	     then do;
		     from_work_ptr_2 =
			from_work_ptr_1 -> attr_list.info (c_a_l_i).cond_ptr;
		     if cond_free_ptr = null then
			allocate cond in (select_area)
			     set (to_work_ptr_1 -> attr_list.info (c_a_l_i).cond_ptr);
		     else do;
			     to_work_ptr_1 -> attr_list.info (c_a_l_i).cond_ptr =
				cond_free_ptr;
			     cond_free_ptr = cond_free_ptr -> cond.fwd_thd;
			end;
		     to_work_ptr_2 = to_work_ptr_1 -> attr_list.info (c_a_l_i).cond_ptr;
		     to_work_ptr_2 -> cond = from_work_ptr_2 -> cond;
		     if copy_from_ptr -> path_var.cond_ptr = from_work_ptr_2 then
			copy_to_ptr -> path_var.cond_ptr = to_work_ptr_2;

		     if copy_from_ptr -> path_var.second_cond_ptr = from_work_ptr_2 then
			copy_to_ptr -> path_var.second_cond_ptr = to_work_ptr_2;
		     from_work_ptr_2 = from_work_ptr_2 -> cond.fwd_thd;
		     do while (from_work_ptr_2 ^= null);
			if cond_free_ptr = null then
			     allocate cond in (select_area)
				set (to_work_ptr_2 -> cond.fwd_thd);
			else do;
				to_work_ptr_2 -> cond.fwd_thd = cond_free_ptr;
				cond_free_ptr = cond_free_ptr -> cond.fwd_thd;
			     end;
			to_work_ptr_2 = to_work_ptr_2 -> cond.fwd_thd;
			to_work_ptr_2 -> cond = from_work_ptr_2 -> cond;
			if copy_from_ptr -> path_var.cond_ptr = from_work_ptr_2 then
			     copy_to_ptr -> path_var.cond_ptr = to_work_ptr_2;

			if copy_from_ptr -> path_var.second_cond_ptr = from_work_ptr_2
			then copy_to_ptr -> path_var.second_cond_ptr = to_work_ptr_2;
			from_work_ptr_2 = from_work_ptr_2 -> cond.fwd_thd;
		     end;
		end;
	end;
     end copy_attr_list;
%page;
free_attr_list:
     proc (path_var_ptr);

	dcl     f_a_l_i		 fixed bin;

	dcl     (
	        path_var_ptr,
	        work_ptr		 init (null)
	        )			 ptr;

	condp = path_var_ptr -> path_var.alp -> attr_list.info (1).cond_ptr;
	path_var_ptr -> path_var.alp -> attr_list.info (1).cond_ptr =
	     attr_list_free_ptr;
	attr_list_free_ptr = path_var_ptr -> path_var.alp;
	path_var_ptr -> path_var.alp = null;

	do f_a_l_i = 1 to attr_list_free_ptr -> attr_list.nattr;
						/* put the condition structures on their free lists */
	     if condp ^= null then do;
		     work_ptr = cond.fwd_thd;
		     do while (condp ^= null);
			cond.fwd_thd = cond_free_ptr;
			cond_free_ptr = condp;
			condp = work_ptr;
			if condp ^= null then
			     work_ptr = cond.fwd_thd;
		     end;
		end;
	     if f_a_l_i ^= 1 then
		attr_list_free_ptr -> attr_list.info (f_a_l_i).cond_ptr = null;
	     if f_a_l_i < attr_list_free_ptr -> attr_list.nattr then
		condp =
		     attr_list_free_ptr -> attr_list.info (f_a_l_i + 1).cond_ptr;
	end;

     end free_attr_list;
%page;
get_attr_list:
     proc (num_of_attrs, alp_param);

	dcl     (
	        alp_param,				/* output parameter: ptr to attr_list structure */
	        work_ptr_1		 init (null),
	        work_ptr_2		 init (null)
	        )			 ptr;

	dcl     ptr_skel		 ptr based;

	dcl     num_of_attrs	 fixed bin;	/* input parameter: size of the attr_list.info array */

	dcl     in_attr_list_free_list bit (1) init ("0"b);

	work_ptr_2 = addr (attr_list_free_ptr);
	work_ptr_1 = attr_list_free_ptr;
	do while (^in_attr_list_free_list & work_ptr_1 ^= null);
	     if work_ptr_1 -> attr_list.nattr = num_of_attrs then do;
		     work_ptr_2 -> ptr_skel = work_ptr_1 -> attr_list.info (1).cond_ptr;
		     in_attr_list_free_list = "1"b;
		end;
	     else do;
		     work_ptr_2 = addr (work_ptr_1 -> attr_list.info (1).cond_ptr);
		     work_ptr_1 = work_ptr_1 -> attr_list.info (1).cond_ptr;
		end;
	end;

	if in_attr_list_free_list then
	     alp_param = work_ptr_1;
	else do;
		al_nattr_init = num_of_attrs;
		allocate attr_list in (select_area) set (alp_param);
	     end;
     end get_attr_list;
%page;
copy_expr_list:
     proc (copy_to_ptr, copy_from_ptr);

	dcl     (copy_from_ptr, copy_to_ptr) ptr;

	if expr_list_free_ptr = null then
	     allocate expr_list in (select_area)
		set (copy_to_ptr -> path_var.elp);
	else do;
		copy_to_ptr -> path_var.elp = expr_list_free_ptr;
		expr_list_free_ptr = expr_list_free_ptr -> expr_list.info (1).epl_ptr;
	     end;
	copy_to_ptr -> path_var.elp -> expr_list.nexprs = el_nexprs_init;
	unspec (copy_to_ptr -> path_var.elp -> expr_list) =
	     unspec (copy_from_ptr -> path_var.elp -> expr_list);
     end copy_expr_list;
%page;
free_expr_list:
     proc (path_var_ptr);

	dcl     path_var_ptr	 ptr;

	path_var_ptr -> path_var.elp -> expr_list.info (1).epl_ptr =
	     expr_list_free_ptr;
	expr_list_free_ptr = path_var_ptr -> path_var.elp;
	path_var_ptr -> path_var.elp = null;

     end free_expr_list;
%page;
display_final_path_details:
     procedure ();

/* this routine outputs optional debug information.
   That info includes the final lowest cost path found,
   and all the conditions against that path, the access methods
   used for each tuple variable and so on. */

	call ioa_ ("^/FINAL PATH,  COST = ^f^/", cost);

/* go through the path in the order it will be used for the search */

	order = 0;
	call ioa_ ("No tuple effect count:  ^d", no_tuple_effect_number);

	do pvp = low_cost_path_ptr repeat path_var.fwd_thd while (pvp ^= null ());

	     order = order + 1;
	     if ^path_var.in_select_clause & ^path_var.in_and_group then
		call ioa_ ("^/No tuple effect variables follow.");

/* output details on this tuple variable */

	     rmri_ptr = range.tup_var.ri_ptr (path_var.var_index);
	     call
		ioa_ ("^/Order: ^d      Tuple variable:  ^a", order,
		range.tup_var.name (path_var.var_index));

	     call ioa_ ("^14xIn and group:  ^[yes^;no^]", path_var.in_and_group);
	     call
		ioa_ ("^14xIn select clause:  ^[yes^;no^]",
		path_var.in_select_clause);
	     call
		ioa_ ("^14xAccess method:  ^a",
		access_method_name (path_var.access_method));
	     call
		ioa_ ("^14xTuples selected:  ^d", path_var.number_tuples_selected);

	     if path_var.access_method = TOTAL_PRIMARY_KEY
		| path_var.access_method = LONG_KEY_HEAD then
		call ioa_ ("^14xEqual key attrs used:  ^d", path_var.attr_index);
	     else if path_var.access_method = SHORT_KEY_HEAD
		     | path_var.access_method = INDEXED_ATTR then do;
		     if path_var.second_cond_ptr = null () then
			call
			     ioa_ ("^14xCondition used:  ^a",
			     condition_array (path_var.cond_ptr -> cond.op_code));
		     else call
			     ioa_ ("^14xConditions used:  ^a  &  ^a",
			     condition_array (path_var.cond_ptr -> cond.op_code),
			     condition_array (path_var.second_cond_ptr -> cond.op_code));
		     call
			ioa_ ("^14xAttribute used:  ^a",
			rm_rel_info.attr_ptrs (path_var.attr_index) -> rm_attr_info.name)
			;
		end;

	     if path_var.in_and_group then do;

/* output all conditions against this tuple variable,
   not in and group tuple variables have no conditions */

		     conditions = 0;
		     alp = path_var.alp;
		     if alp ^= null () then do;

			     do i = 1 to rm_rel_info.num_attr;

				rai_ptr = rm_rel_info.attr_ptrs (i);
				j = rm_attr_info.defn_order;
				if attr_list.info (j).cond_ptr ^= null () then do;

/* this attribute referenced by a condition */

					if conditions = 0 then /* first condition seen */
					     call ioa_ ("^/^14xCONDITION LIST");
					call
					     ioa_ ("^14xAttribute:  ^a^/^14xSelected:  ^[yes^;no^]",
					     rm_attr_info.name, attr_list.info (j).attr_selected);


/* output each condition on this attribute */

					do condp = attr_list.info (j).cond_ptr
					     repeat cond.fwd_thd while (condp ^= null ());

					     conditions = conditions + 1;
					     if cond.pl_ptr -> pred_leaf.data_type = CONST then
						call
						     ioa_ (
						     "^18xCompared(^d):  ""^a""  to:  CONSTANT",
						     conditions, condition_array (cond.op_code));
					     else do; /* compared to attribute */

						     call
							ioa_ ("^18xCompared(^d):  ""^a""  to:  ^a.^a",
							conditions, condition_array (cond.op_code),
							range.tup_var
							.
							name (fixed (cond.pl_ptr -> pred_leaf.id.var_id)),
							range.tup_var
							.
							ri_ptr (
							fixed (cond.pl_ptr -> pred_leaf.id.var_id))
							-> rm_rel_info
							.
							attr_ptrs (
							fixed (cond.pl_ptr -> pred_leaf.id.attr_id))
							-> rm_attr_info.name);
						end;
					     call
						ioa_ ("^18xSelected:  ^[yes^;no^]",
						cond.condition_selected);
					end;
				     end;
			     end;
			end;

/* were there any conditions seen */

		     call ioa_ ("^14xConditions: ^d", conditions);

		     expressions = 0;
		     elp = path_var.elp;
		     if elp ^= null () then do;

/* output comparison operators involving expressions */

			     call ioa_ ("^/^14xEXPRESSIONS");
			     do i = 1 to expr_list.nexprs;

				expressions = expressions + 1;
				call
				     ioa_ ("^18xCompared(^d):  ""^a""", expressions,
				     condition_array (expr_list.info.op_code (i)));
			     end;

			end;

		     call ioa_ ("^14xExpressions:  ^d", expressions);
		end;
	end;


	dcl     (i, j)		 fixed bin;	/* loop/array indexes */
	dcl     expressions		 fixed bin;	/* number of expressions seen */
	dcl     (order, conditions)	 fixed bin;	/* count of path order and conditions per T.V. */

     end;

     end mrds_dsl_permute;




		    mrds_dsl_select_clause_.pl1     08/01/88  1413.4rew 08/01/88  1300.0      344628



/****^  ********************************************
        *                                          *
        * 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):
     Written.
                                                   END HISTORY COMMENTS */


mrds_dsl_select_clause_:
    proc ();

/* DESCRIPTION:

   BEGIN_DESCRIPTION
   This  procedure  translates  the  -select  clause  within  a  DSL selection
   expression  into a tabular form which can be efficiently processed when the
   data is being accessed. The various entrypoints are called by
   mrds_dsl_semantics during the parse.


   INPUT CONDITIONS:

   compiled_clause entry:
   This handles a selection expression that consists of a -compiled only.

   all_attributes entry:
   This handles the portion of a select clause that is meant to return
   a dump of the relation. It is of the type "-select a".

   one_attribute entry:
   This handles the portion of a select clause that is meant to return
   a single attribute. It is of the type "-select a.car".

   finish entry:
   This is called after all of the individual select items have been
   dealt with. It wraps up the processing of the select clause.


   END_DESCRIPTION

   HISTORY:

   76-01-01 J. A. Weeldreyer: Initially written.

   76-09-01 J. A. Weeldreyer: Modified to correct assign_ length problem.

   76-09-02 J. A. Weeldreyer: Modified to correct area ptr init problem.

   76-10-01  J.   A.   Weeldreyer:  Modified  to  return error if key attr not
   defined for temp rel.

   76-11-01 J . A. Weeldreyer: Modified  to fix temp rel key problem.

   76-11-02 J. A. Weeldreyer: Modified to incorporate inverted attributes.

   77-04-01  J.   A.   Weeldreyer:  Modified  to  implement -dup and to remove
   complex range code.

   77-12-01 Oris D.  Friesen: Modified to allocate 'store -another' version of
   select_list.

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

   79-03-22 Al Kepner: Modified to add scope checking.

   79-03-25  Al  Kepner:  Modified  by  to  include all range variables in the
   tuple_info  structure  and  to flag those range variables which are used in
   the -select clause.

   79-06-01 Al Kepner: Modified to use select_area.

   79-11-01 Jim Gray: Modified to make hanlding of deletes with se_values work
   correctly,  by considering the caller, and not gobbling up the se_values as
   arg values.

   80-01-01     Jim     Gray     :     Modified     to     add     call     to
   mu_valid_data_type$valid_scalar_data_type, so that packed decimal could be properly
   handled.

   80-01-15  Jim  Paradise:  Updated  to update the move lists on handling the
   -another entry: set_user_vals.

   80-02-01 Jim Gray : Modified to add area_ptr parameter in all entries.

   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-25   Davids:  the  internal  procedure  check_access  was  added  and
   appropriate  calls  placed  in  the  code.   this module will now check the
   access  on  all  attributes specified in the select clause for the retrieve
   and  modify  operations.   if  the  user  does  not  have  access the error
   incorrect  attribute access is returned.  access at the relation level i.e.
   append  and  delete  are  done  elsewhere.  the information needed to check
   these  access  are  not  easily  gotten  at  this level in all cases.  also
   removed  the declared but never referenced variables.

   80-11-05  Jim Gray : Modified to "and" the mdbm_secured bit with the r_perm
   bits in rm_attr_info so that secure_mrds_db turns this check on.

   80-12-10 Jim Gray : changed scope mode checks to agree with change from r-u
   to  r-s-m-d  type  modes, also changed names to read_attr, modify_attr, and
   delete_tuple  to  agree  with  security  compatiple  names.  Documented and
   cleaned  up  the  scope  checking  code.   Added  sub_err_  messages on the
   particulars  of  the  scope  violation.  This was done with the new routine
   scope_error.   The  mrds_data_$caller_xxx  parameters were changed to fixed
   bin(35) to agree with the mrds_data_ declarations.

   81-06-01 Jim Gray : changed to use new resultant structure.

   81-06-23 Jim Gray : added fix to re-use space for select_list structure
   when many -current operations are done, ala TR 10193.

   81-09-09 Davids: modified so that the internal routine set_u_val is not
   called for the case of a define_temp_rel. TR 11447

   81-12-18 Davids: Modified so that the val_del and  val_mod  flags
   are  no  longer set to "0"b if an attribute comes from a temp_rel
   or if the range variable (if no attributes are specified)  refers
   to  a  temp_rel.  This  is so that temp_rels can be updated. Also
   deleted declared but unreferenced variables.

   82-06-16 Mike Kubicar : Added the fix for TR phx12345.  This module
   would take an area condition if many retrieves with a selection expression
   of "-current ..." were done in a row.

   82-08-27 Mike Kubicar : Removed tuple structure and allocation of tuples.

   82-09-22 Davids: removed references to dbcb.transact_ctl_seg, since this
   bit was always "0"b and the if statements testing it always used ^dbcb...
   not much really changed.

   82-11-02 Mike Kubicar : Changed make_tuple_info (and added a bit of code)
   to pre-allocate enough space of any simple vectors needed for a search.

   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 th escope_info array for the correct relation.
   The declaration to the variable j was deleted since it is no longer used.
   Also explicitly declared the mod builtin function.

   83-04-11 Davids: Replaced reference to add_bit_offset_ with a reference to
   addnitno.

   83-04-22 R. Harvey: added code to set bits in the attr_needed_list structure
   so that less data may be copied from the relation manager.

   84-07-19 Hergert: Moved set_user_vals out of here and made it external.
   Also took set_u_vals and update_movelists with it. Changed calls to
   set_u_vals to mrds_dsl_set_user_vals. This was all done as
   a performancce improvement in the processing of -another's

   84-09-05 Hergert: Added check for call from dsl_$compile so we dont
   bother checking scope or setting user vals since we dont know them anyway.
   Also added entry point compiled_clause for handling compiled se.

   84-11-01 Hergert: Added call to mu_print_error for reporting errors.

   84-11-25 Hergert: created procedure check_scope so that we will check scope
   on compiled selection expressions. This was an oversight during the original
   implemantation. Also made struct free_relations to handle this problem.

   84-12-12 Hergert: Added code to initialize the select_list structure. There
   were certain situations where the random data in the pointers caused
   fault_tags.

   85-11-22 Hergert: Removed all references to var_exists_ptr. Moved
   variable var_exists into select_list structure. It needs to be kept
   around for compiling select expresssions, and it doesnt need to be
   kept for normal processing. This seemed to be the best compromise.

   86-05-05 Hergert: Reorganized and modified for new parser.
*/

compiled_clause:
    entry (dbcb_ptr, area_ptr, caller, argp_ptr, descp_ptr, num_args, trl_ptr,
        cur_sw, code);

/* this entry processes a selection expression consisting of only a -compiled
   clause. It sets up the user values and the move lists for the actual use
   of a compiled select expression.
*/

        compiled_sw = "1"b;
        select_area_ptr = dbcb.select_area_ptr;

        if dbcb.ss_ptr = null then do;
	  range_ptr = dbcb.range_ptr;			/* pick up correct ptr to range list */
	  select_list_ptr = dbcb.select_ptr;		/* and select list */
        end;
        else do;					/* if complex select. expr. */
	  ss_ptr = dbcb.ss_ptr;
	  range_ptr = select_sets.items.range_ptr (1);
	  select_list_ptr = select_sets.items.select_ptr (1);
        end;

/* make sure no one has changed a temp rel on us since we first compiled this se */
        if trl_ptr ^= null
        then
	  do i = 1 to temp_rel_list.number_of_temp_rels;
	      if dbcb.rdbi_ptr -> rm_db_info.tra_ptr
		-> rm_rel_array.name.submodel (temp_rel_list.index (i)) ^=
		temp_rel_list.name (i)
	      then call error (mrds_error_$undef_temp_rel, ^LOUD, 0, "", "");
	  end;

        call mrds_dsl_set_user_vals
	  (dbcb_ptr, area_ptr, argp_ptr, descp_ptr, num_args,
	  select_list_ptr, code);
        if code ^= 0 then call error (code, ^LOUD, 0, "", "");

        call check_scope;				/* make sure proper scope has been set */

        if dbcb.ss_ptr ^= null then do;			/* must copy user data */
	  s_ptr = select_sets.items.select_ptr (1);	/* data from 1st block */
	  do k = 2 to select_sets.nitems;
	      if ^select_sets.oper_flag (k) then do;
		select_list_ptr = select_sets.items.select_ptr (k);
		do i = 1 to select_list.num_items;	/* can copy because from same domains */
		    select_list.item.user_ptr (i) =
		        s_ptr -> select_list.item.user_ptr (i);
		    select_list.item.must_convert (i) =
		        s_ptr -> select_list.item.must_convert (i);
		    select_list.item.user_desc_ptr (i) =
		        s_ptr -> select_list.item.user_desc_ptr (i);
		    call make_move_lists;
		end;
	      end;
	  end;
        end;
        else call make_move_lists;

        return;

all_attributes:
    entry (dbcb_ptr, a_range_ptr, a_select_list_ptr, a_rmri_ptr,
        relation_index, cur_sw, caller, code);

/* this entry process a single token appearing in a select clause.
   This is assumed to be either a reference to dump a whole relation
   or a single attribute in a relation that need no other qualification.
*/
        range_ptr = a_range_ptr;
        select_list_ptr = a_select_list_ptr;
        rmri_ptr = a_rmri_ptr;
        dbcb.val_mod = "0"b;				/* whole tuple includes key attr. */
        var_exists (relation_index) = "1"b;		/* remember this var selected */
        range.tup_var.used (relation_index) = "1"b;	/* remember this var used */
        ss_ptr = dbcb.ss_ptr;

        if ss_ptr = null then check_sw = "0"b;
        else check_sw = "1"b;

        compiled_sw = "0"b;

        if caller ^= mrds_data_$caller_delete
        then do;
	  if ^cur_sw
	  then range.tup_var.whole_tuple_selected (relation_index) = "1"b;
						/* remember whole tuple selected */
	  else if ^range.tup_var.whole_tuple_selected (relation_index) &
		 ^range.tup_var.copied_for_current (relation_index)
	       then range.tup_var.copy_for_current (relation_index) = "1"b;
        end;

/* Keep a list of relations associated with free tuple
   variables (scope must be set before use.) */

        if ^range.tup_var.temp_rel (relation_index)
        then call add_free_rel (relation_index);		/* add_assoc. rels. to free list */

        do i = 1 to rm_rel_info.num_attr;		/* for each attribute */

	  if ^rm_rel_info.mdbm_secured
	  then call check_access (caller,
		 rm_rel_info.attr_ptrs (i) -> rm_attr_info.read_perm,
		 rm_rel_info.attr_ptrs (i) -> rm_attr_info.modify_perm);

	  if select_list.num_items >= mrds_data_$max_select_items
	  then do;				/* if no more room */
	      call ioa_$rsnnl ("Only ^d items are allowed.", err_msg,
		err_msg_len, mrds_data_$max_select_items);
	      call error (mrds_error_$max_select_items, LOUD, 0, SC_TYPE,
		err_msg);
	  end;

	  select_list.num_items = select_list.num_items + 1;
						/* we have room, increment count */
	  unspec (select_list.item (select_list.num_items)) = "0"b;

	  if check_sw
	  then					/* if checking union compat */
	       if dbcb.prev_select then do;		/* if have prev block */
		  if rm_rel_info.attr_ptrs (i)
		      -> rm_attr_info.domain_ptr -> rm_domain_info.name ^=
		      select_sets.domains (select_list.num_items)
		  then				/* if not compat */
		       call error (mrds_error_$block_dom_incons, LOUD, 0,
			 SC_TYPE,
			 "");
	       end;

	  select_list.item.key (select_list.num_items) = "0"b;
						/* temp rel keys must
						   be spec. explic. */
	  select_list.item.index (select_list.num_items) = "0"b;
	  select_list.item.var_index (select_list.num_items) =
	      relation_index;
	  select_list.item.ai_ptr (select_list.num_items) =
	      rm_rel_info.attr_ptrs (i);

        end;					/* looping through attrib. */

        return;

one_attribute:
    entry (dbcb_ptr, a_range_ptr, a_select_list_ptr, a_rmri_ptr, attr_index,
        relation_index, temp_rel_key, cur_sw, caller, code);

/* this entry process a uniquely qualified attribute in a select clause.
   This is the case when the realtion and an attribute are specified
   as in -select a.foo
*/

        range_ptr = a_range_ptr;
        select_list_ptr = a_select_list_ptr;
        rmri_ptr = a_rmri_ptr;
        ai_ptr = rm_rel_info.attr_ptrs (attr_index);
        ss_ptr = dbcb.ss_ptr;

        if ss_ptr = null then check_sw = "0"b;
        else check_sw = "1"b;

        compiled_sw = "0"b;

        if select_list.num_items >= mrds_data_$max_select_items
        then do;					/* If we already have max items */
	  call ioa_$rsnnl ("Only ^d items are allowed.", err_msg,
	      err_msg_len, mrds_data_$max_select_items);
	  call error (mrds_error_$max_select_items, LOUD, 0, SC_TYPE,
	      err_msg);
        end;

        if select_list.num_items > 0
	  & select_list.item.var_index (select_list.num_items)
	  ^= relation_index
        then dbcb.val_mod, dbcb.val_del = "0"b;		/* cant update mult. tuples */

        select_list.num_items = select_list.num_items + 1;	/* have more room, so bump up count */
        unspec (select_list.item (select_list.num_items)) = "0"b;

        if check_sw
        then					/* if checking union compat */
	   if dbcb.prev_select then do;		/* if have prev block */
	       if ai_ptr -> rm_attr_info.domain_ptr -> rm_domain_info.name ^=
		 select_sets.domains (select_list.num_items)
	       then
		  call error (mrds_error_$block_dom_incons, LOUD, 0,
		      SC_TYPE,
		      "");
						/* if not compat */
	   end;

        if ai_ptr -> rm_attr_info.mdbm_secured
        then call check_access (caller, ai_ptr -> rm_attr_info.read_perm,
	       ai_ptr -> rm_attr_info.modify_perm);

        if ai_ptr -> rm_attr_info.key_attr
        then					/* cant modify key attr. */
	   dbcb.val_mod = "0"b;

        if dbcb.prev_select
        then
	   select_list.item.key (select_list.num_items) =
	       select_sets.items.select_ptr (1)
	       -> select_list.item.key (select_list.num_items);
        else
	   select_list.item.key (select_list.num_items) = temp_rel_key;

        select_list.item.var_index (select_list.num_items) = relation_index;
        select_list.item.ai_ptr (select_list.num_items) = ai_ptr;
        var_exists (relation_index) = "1"b;		/* remember this var. selected */
        range.tup_var.used (relation_index) = "1"b;
						/* remember this var used */

        if caller ^= mrds_data_$caller_modify
        then
	   if ^cur_sw
	   then range.tup_var (relation_index).needed_bits
		  .attr (ai_ptr -> rm_attr_info.defn_order) = "1"b;
						/* Mark this attribute as selected */
	   else if ^range.tup_var (relation_index).needed_bits
		  .attr (ai_ptr -> rm_attr_info.defn_order)
		  & ^range.tup_var.whole_tuple_selected (relation_index)
		  & ^range.tup_var.copied_for_current (relation_index)
	        then range.tup_var.copy_for_current (relation_index) = "1"b;


/* Keep a list of relations associated with free tuple
   variables if the db does not have a transaction control file (implies
   scope must be set before use.) */

        if ^range.tup_var.temp_rel (relation_index)
        then call add_free_rel (relation_index);		/* add_assoc. rels. to free list */

        return;

finish:
    entry (dbcb_ptr, a_range_ptr, a_select_list_ptr, ti_ptr, caller, area_ptr,
        argp_ptr, descp_ptr, num_args, cur_sw, code);
						/* this entry finishes up a select clause */

        range_ptr = a_range_ptr;
        select_list_ptr = a_select_list_ptr;
        select_area_ptr = dbcb.select_area_ptr;
        compiled_sw = "0"b;

        if ^cur_sw & dbcb.prev_select then do;		/* must copy user data */
	  s_ptr = dbcb.ss_ptr -> select_sets.items.select_ptr (1);
						/* dtat from 1st block */

	  if s_ptr -> select_list.num_items ^= select_list.num_items
	  then do;				/* must match */
	      call ioa_$rsnnl (
		"^d items were selected in the previous select clause and ^d items were selected in the current one."
		, err_msg, err_msg_len, s_ptr -> select_list.num_items,
		select_list.num_items);
	      call error (mrds_error_$block_sel_incons, LOUD, 1, SC_TYPE,
		err_msg);
	  end;

	  do i = 1 to select_list.num_items;		/* can copy because from same domains */
	      select_list.item.user_ptr (i) =
		s_ptr -> select_list.item.user_ptr (i);
	      select_list.item.must_convert (i) =
		s_ptr -> select_list.item.must_convert (i);
	      select_list.item.user_desc_ptr (i) =
		s_ptr -> select_list.item.user_desc_ptr (i);
	      call make_move_lists;
	  end;					/* user data copy */
        end;					/* if previous select block */

/* there are four cases of existance of selection_expression values, and argument values:
   1) neither are present
   2) both are present
   3) only argument values are present
   4) only selection expression values are present

   1 and 4 are legal for delete, compile and define_temp_rel, 2 and 3 are
   legal for retrieve/modify/store
   if the user leaves out any values for retrieve/modify/store, he gets
   an insufficient_args error
   case 4 with delete must not gobble up se_values mistaken for arg values
   NOTE: se_values are legal in two cases
   a) for temp rels in the range clause
   b) for all selection expressions, for substitutions in the where clause
*/
        else if caller = mrds_data_$caller_compile
	   then call make_tuple_info;
	   else if num_args <= 0 | caller = mrds_data_$caller_delete
		  | caller = mrds_data_$caller_define_temp_rel
	        then do;				/* if no user args, can only delete or dtrel */
		  dbcb.val_mod, dbcb.val_rtrv = "0"b;
		  call make_tuple_info;
	        end;
	        else do;
		  call mrds_dsl_set_user_vals
		      (dbcb_ptr, area_ptr, argp_ptr, descp_ptr, num_args,
		      select_list_ptr, code);
		  call make_move_lists;
	        end;

        if caller ^= mrds_data_$caller_compile then call check_scope;
						/* we dont care about scope if compiling */

        if cur_sw
        then dbcb.current_ptr = select_list_ptr;		/* put select list pointer in correct slot */
        else dbcb.prev_select = "1"b;			/* remember we have procesed a select list */

        return;

check_scope:
    proc;
						/* We must check for proper scope setting on each relation referenced.
						   If a relation appears in the where clause but not in the select clause,
						   then it must have at least read_attr scope permission.
						   A relation appearing in the select clause will require
						   read_attr permission for a retrieve or define_temp_rel oepration
						   modify_attr permission for a modify operation
						   delete_tuple permission for a delete oepration.
						   NOTE: store requires append_tuple, but is handled in mrds_dsl_store
						*/

        do i = 1 to range.num_vars;			/* verify scope for each variable */
	  if ^range.tup_var.temp_rel (i) then do;	/*  for data base rels. only */
	      rmri_ptr = range.tup_var.ri_ptr (i);
	      free_rel = "0"b;			/* assume is bound */
	      do k = 1 to num_free_rels while (^free_rel);/* search free relation list */
		if range.tup_var.rel_index (i) = free_rels (k)
		then free_rel = "1"b;		/* found it */
	      end;

	      if free_rel then do;			/* tuple variable appears in select clause */
		go to free_scope_check (caller);	/* if free, check scope for function */
free_scope_check (1):				/* delete */
		if rm_rel_info.scope_flags_ptr
		    -> scope_flags.permits.delete_tuple /* if scope not set for delete_tuple */
		then goto end_free_scope_check;
		else call scope_error (caller, mrds_error_$scope_viol);

free_scope_check (2):				/* modify */
		if rm_rel_info.scope_flags_ptr
		    -> scope_flags.permits.modify_attr	/* if scope not set for modify_attr */
		then goto end_free_scope_check;
		else call scope_error (caller, mrds_error_$scope_viol);

free_scope_check (3):				/* retrieve */
free_scope_check (4):				/* define_temp_rel */
		if rm_rel_info.scope_flags_ptr
		    -> scope_flags.permits.read_attr	/* if scope not set for retrieve */
		then goto end_free_scope_check;
		else call scope_error (caller, mrds_error_$scope_viol);
end_free_scope_check:
	      end;
	      else				/* tuple variable does not appear in select clause,
						   just where clause */
		 if ^rm_rel_info.scope_flags_ptr
		     -> scope_flags.permits.read_attr	/* if scope not set for retrieve */
		 then call scope_error (mrds_data_$caller_retrieve,
			mrds_error_$scope_viol);	/* insist on retrieve for bound rels. */
	  end;					/* checking this relation */
        end;

    end check_scope;

scope_error:
    procedure (calling_routine, code);

/* routine to issue error message with specifics of scope violation */

        if calling_routine = mrds_data_$caller_delete
        then
	   scope_type = "delete_tuple";
        else if calling_routine = mrds_data_$caller_modify
	   then
	        scope_type = "modify_attr";
	   else scope_type = "read_attr";		/* retrieve, define_temp_rel operations,
						   or tuple variable not in select clause */

        call sub_err_ (code, caller_name, continue, info_ptr, return_value,
	  "^/^a^a^a^a^a",
	  "The relation """, rm_rel_info.name,
	  """ needs a scope permission of """,
	  scope_type, """ in order to perform this operation.");

        call error (code, ^LOUD, 0, "", "");		/* now we can do the normal error exit */

declare code		 fixed bin (35);		/* local copy */
declare calling_routine	 fixed bin (35);		/* type of calling routine, or application of tuple variable */
declare scope_type		 char (20) varying;		/* type of requried scope permission */

    end;

check_access:
    proc (calling_module, r_bit, m_bit);

/* this module is chechs the access of the attribute via the r_bit
   and m_bit and depending on the operation to be performed either returns or
   calls error with the incorrect attribute access code */

dcl     calling_module	 fixed bin (35);		/* special code indicating the calling module */
dcl     r_bit		 bit (1) unal;		/* "1" => user has read permission on attribute */
dcl     m_bit		 bit (1) unal;		/* "1" => user has modify permission on attribute */


dcl     mdbm_error_$inc_attr_acc
			 fixed bin (35) external static;



        if caller = mrds_data_$caller_retrieve then do;
	  if ^(r_bit)
	  then call error (mdbm_error_$inc_attr_acc, LOUD, 0, AV_TYPE,
		 "You must have read permission on this attribute to retrieve from it."
		 );
        end;
        else
	   if caller = mrds_data_$caller_modify
	   then do;
	       if ^(m_bit)
	       then call error (mdbm_error_$inc_attr_acc, LOUD, 0, AV_TYPE,
		      "You must have modify permission on this attribute to modify it."
		      );
	   end;

        return;

    end;

add_free_rel:
    proc (var_index);

/* Procedure to add all those relation indices assoc. with a free tup. var. to the free list */

dcl     (var_index,
        rel_index,
        j)		 fixed bin;

        rel_index = range.tup_var.rel_index (var_index);	/* pick up relation index */

        free_rel = "0"b;				/* assume not on free list */
        do j = 1 to num_free_rels while (^free_rel);	/* search for it on free list */
	  if free_rels (j) = rel_index then free_rel = "1"b;
						/* if found */
        end;
        if ^free_rel then do;				/* if not there, must add it */
	  num_free_rels = num_free_rels + 1;
	  free_rels (num_free_rels) = rel_index;
        end;
    end add_free_rel;

make_move_lists:
    proc;

/* Procedure to make a move list for every selected vauiable */

dcl     (i,
        k,
        var_init,
        mli)		 fixed bin;

        if select_list.mla_ptr = null () then do;
	  select_list.num_vars = range.num_vars;	/* Max size */
	  allocate move_list_array in (select_area);
	  do i = 1 to select_list.num_vars;
	      move_list_array.ml_ptr (i) = null ();
	  end;
        end;
        select_list.num_vars = 0;

        do i = 1 to range.num_vars;			/* count the number of selected vars */
	  if var_exists (i)
	  then select_list.num_vars = select_list.num_vars + 1;
        end;

        var_init = 1;				/* initiallize */
        do k = 1 to select_list.num_vars;		/* make move list for each var. */
	  do move_list_array.var_index (k) = var_init to range.num_vars
	      while (^var_exists (move_list_array.var_index (k)));
	  end;					/* pick a var index */
	  var_init = move_list_array.var_index (k) + 1;

	  if move_list_array.ml_ptr (k) = null () then do;
	      ml_nitems_init = mrds_data_$max_select_items;
	      allocate move_list in (select_area);
	      move_list_array.ml_ptr (k) = ml_ptr;
	  end;
	  else do;
	      ml_ptr = move_list_array.ml_ptr (k);
	      move_list.nitems = mrds_data_$max_select_items;
	  end;
	  mli = 0;
	  do i = 1 to select_list.num_items;		/* find and add all selected items of this var. */
	      if select_list.item.var_index (i)
		= move_list_array.var_index (k) then do;/* if attr of this var. */
		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;					/* adding selected items */

	  move_list.nitems = mli;
        end;					/* making move lists */

        call make_tuple_info;

    end make_move_lists;

make_tuple_info:
    proc;

/* Procedure to make the tuple info structure and allocate each tuple */

dcl     (i, tii)		 fixed bin;

        if cur_sw | compiled_sw			/* If -current or -compiled, don't bother */
        then return;
        ti_ntuples_init = range.num_vars;
        allocate tuple_info in (select_area);		/* Allocations in select_area are never freed.  This area
						   is reinitialized at the beginning
						   of each new selection expression */

        tii = 0;					/* init */
        do i = 1 to range.num_vars;			/* set up for each variable */
	  rmri_ptr = range.tup_var.ri_ptr (i);
	  tii = tii + 1;
	  tuple_info.tuple.var_index (tii) = i;
	  tuple_info.tuple.tuple_ptr (tii) =
	      create_simple_vector (rmri_ptr, select_area_ptr);
	  tuple_info.tuple.tuple_id (tii) = "0"b;
        end;					/* loop through range vars */

    end make_tuple_info;

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;

create_simple_vector:
    proc (rmri_ptr, area_ptr) returns (ptr);


/*

   BEGIN_DESCRIPTION

   This routine will allocate a simple vector for a given relation.  It
   takes a pointer to an rm_rel_info structure as input.  It will examine
   that structure and allocate enough storage to completely contain all
   attributes in it.  Then it will set up pointers to appropriate places in
   that storage for the attributes.

   END_DESCRIPTION

   Parameters:

   rm_ri_ptr (input)  -  A pointer to the rm_rel_info structure for the relation
   of interest.
   area_ptr  (input)  -  The area to allocate the vector in.

   Output:

   A Pointer to a simple vector structure that can be used to do gets from the
   relation.

*/


/* Parameters */

dcl     rmri_ptr		 ptr;
dcl     area_ptr		 ptr;


/* Local */

dcl     attr_offset		 (256) fixed bin (24);
						/* Offsets of attributes from start of allocated block */
dcl     block_size		 fixed bin (24);		/* Size of the block to alloate */
dcl     data_string		 bit (block_size) based (data_string_ptr);
						/* The block */
dcl     data_string_ptr	 ptr;			/* Pointer to above */
dcl     i			 fixed bin;		/* Loop index */
dcl     total_attr		 fixed bin;		/* Total number of attributes */
dcl     vector_area		 area based (area_ptr);	/* Where to allocate vectors */
dcl     vector_ptr		 ptr;			/* Newly created vector */



        total_attr = rm_rel_info.num_attr;
        stv_number_of_dimensions = total_attr;
        allocate simple_typed_vector in (vector_area) set (vector_ptr);
        vector_ptr -> simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
        vector_ptr -> simple_typed_vector.number_of_dimensions = total_attr;
        block_size = 0;
        do i = 1 to total_attr;
	  attr_offset (i) = block_size +
	      align_data_item (
	      addr (rm_rel_info.attr_ptrs (i) -> rm_attr_info.domain_ptr
	      -> rm_domain_info.db_desc),
	      (block_size));
	  block_size =
	      attr_offset (i)
	      + rm_rel_info.attr_ptrs (i) -> rm_attr_info.bit_length;
        end;
        allocate data_string in (vector_area) set (data_string_ptr);
        do i = 1 to total_attr;
	  vector_ptr -> simple_typed_vector.dimension (i).value_ptr =
	      addbitno (data_string_ptr, attr_offset (i));
        end;

        return (vector_ptr);

    end create_simple_vector;

align_data_item:
    procedure (d_ptr, base_to_pad) returns (fixed bin);

/* HISTORY:

   Originally written by Jim Gray - - December 1979

*/



/* 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:

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


dcl     d_ptr		 ptr;			/* Pointer to a standard Multics descriptor */
dcl     needed_bits		 fixed bin;		/* number of bits needed to get the alignment */
dcl     base_to_pad		 fixed bin (24) parameter;	/* original value to be padded out */

        needed_bits = 0;				/* initialize */

        if d_ptr = null ()
        then ;
        else if d_ptr -> descriptor.packed
	   then do;				/* unaligned */

	       if ^(d_ptr -> descriptor.type = 21
		 | (d_ptr -> descriptor.type >= 9
		 & d_ptr -> descriptor.type <= 12)	/* char or decimal */
		 | (d_ptr -> descriptor.type >= 43
		 & d_ptr -> descriptor.type <= 46))
	       then ;				/* packed decimal */
	       else needed_bits = pad (BYTE, base_to_pad);

	   end;
	   else do;				/* aligned */

	       if (d_ptr -> descriptor.type >= 9
		 & d_ptr -> descriptor.type <= 12)
		 |
		 /* decimal */ (d_ptr -> descriptor.type >= 43
		 & d_ptr -> descriptor.type <= 46)
		 |
		 /* packed decimal */ (d_ptr -> descriptor.type >= 19
		 & d_ptr -> descriptor.type <= 22)
		 | /* bit or char */ d_ptr -> descriptor.type = 1
		 | d_ptr -> descriptor.type = 3
		 | d_ptr -> descriptor.type = 33
	       then				/* binary short */
		  needed_bits = pad (WORD, base_to_pad);

	       else if d_ptr -> descriptor.type = 2
		      | d_ptr -> descriptor.type = 34
		      |
		      /* binary long */ (d_ptr -> descriptor.type >= 4
		      & d_ptr -> descriptor.type <= 8)
		  then				/* binary complex */
		       needed_bits = pad (DOUBLE_WORD, base_to_pad);
		  else ;				/* none needed otherwise */

	   end;

        return (needed_bits);

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);


dcl     pad_size		 fixed bin;		/* either 9 or 36 or 72 */
dcl     pad_base		 fixed bin (24);		/* current bit length to be padded */
dcl     number_of_bits	 fixed bin;		/* what has to be added to get to the desired boundary */

    end pad;

dcl     BYTE		 fixed bin init (9) internal static
			 options (constant);
						/* byte boundary = 9 bits */
dcl     WORD		 fixed bin init (36) int static
			 options (constant);
						/* word boundary = 36 bits */
dcl     DOUBLE_WORD		 fixed bin init (72) int static
			 options (constant);
						/* double word boundary = 72 bits */

    end align_data_item;

%include mrds_dbcb;
%page;
%include mrds_select_list;
%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_tuple_info;
%page;
%include mdbm_move_list;
%page;
%include mdbm_rm_domain_info;
%page;
%include mrds_se_info;
%page;
%include mrds_range;
%page;
%include mdbm_descriptor;
%page;
%include mrds_select_sets;
%page;
%include mrds_compiled_se_info;
%page;
%include mdbm_scope_info;
%page;
%include mdbm_seg_area;
%page;
%include mrds_select_area;
%page;
%include vu_typed_vector;


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     LOUD		 bit init ("1"b) aligned internal static
			 options (constant);
dcl     a_range_ptr		 ptr;
dcl     a_rmri_ptr  	 ptr;
dcl     a_select_list_ptr	 ptr;
dcl     addbitno		 builtin;
dcl     addr		 builtin;
dcl     ai_ptr		 ptr;
dcl     area_ptr		 ptr;
dcl     argp_ptr		 ptr;
dcl     attr_index		 fixed bin;
dcl     caller		 fixed bin (35) parm;
dcl     caller_name		 char (32) init ("mrds_dsl_select_clause");
dcl     check_sw		 bit (1) aligned;		/* on if checking union comp. */
dcl     code		 fixed bin (35);
dcl     compiled_sw		 bit (1) aligned;		/* switch indicating if -compiled entry */
dcl     continue		 char (1) init ("c");	/* dont stop after printing error mesg */
dcl     cur_sw		 bit (1) aligned;		/* switch indicating if -current or -select entry */
dcl     descp_ptr		 ptr;
dcl     err_msg		 char (256);
dcl     err_msg_len		 fixed bin;
dcl     fixed		 builtin;
dcl     free_rel		 bit (1) unal;		/* on if relat.is assoc. with free var. */
dcl     i			 fixed bin;
dcl     icode		 fixed bin (35);
dcl     info_ptr		 ptr init (null ());	/* unused */
dcl     ioa_$rsnnl		 entry () options (variable);
dcl     k			 fixed bin;
dcl     mod		 builtin;
dcl     mrds_data_$caller_compile
			 fixed bin (35) ext;	/* dsl_$compile called */
dcl     mrds_data_$caller_define_temp_rel
			 fixed bin (35) external static;
dcl     mrds_data_$caller_delete
			 fixed bin (35) ext;	/* dsl_$delete called */
dcl     mrds_data_$caller_modify
			 fixed bin (35) external static;
dcl     mrds_data_$caller_retrieve
			 fixed bin (35) external static;
dcl     mrds_data_$max_attributes
			 fixed bin (35) ext static;
dcl     mrds_data_$max_id_len	 fixed bin (35) external;
dcl     mrds_data_$max_relations
			 fixed bin (35) external;
dcl     mrds_data_$max_select_items
			 fixed bin (35) external;
dcl     mrds_data_$max_temp_rels
			 fixed bin (35) external;
dcl     mrds_dsl_set_user_vals entry (ptr, ptr, ptr, ptr, fixed bin, ptr,
			 fixed bin (35));
dcl     mrds_error_$block_dom_incons
			 fixed bin (35) external;
dcl     mrds_error_$block_sel_incons
			 fixed bin (35) external;
dcl     mrds_error_$max_select_items
			 fixed bin (35) external;
dcl     mrds_error_$scope_viol fixed bin (35) external;
dcl     mrds_error_$undef_temp_rel
			 fixed bin (35) external;
dcl     null		 builtin;
dcl     num_args		 fixed bin;
dcl     rel		 builtin;
dcl     relation_index	 fixed bin;
dcl     return_value	 fixed bin (35) init (0);	/* unused */
dcl     s_ptr		 ptr;
dcl     se_info_ptr		 ptr;
dcl     sub_err_		 entry options (variable);	/* reports error details */
dcl     sys_info$max_seg_size	 fixed bin (35) external;
dcl     temp_rel_key           bit (1) aligned parameter;

exit:
    end mrds_dsl_select_clause_;

*/
                                          -----------------------------------------------------------


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

*/
