<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">



		    PNOTICE_mrds.alm                10/27/88  1531.2r w 10/27/88  1531.2        3555



	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1988"
          acc       "Copyright (c) 1988 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1RDSM0E0000"
	aci	"C2RDSM0E0000"
	aci	"C3RDSM0E0000"
	end
�



		    create_mrds_db.pl1              10/16/86  1551.9rew 10/16/86  1142.8      270567



/****^  ***********************************************************
        *                                                         *
        * 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-07-21,Blair), approve(86-07-21,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     When this module is called from command level with -list the xref file
     from rmdb will be built and needs to be deleted.
                                                   END HISTORY COMMENTS */

create_mrds_db: cmdb: mrds_rst_cmdb: procedure;		/* CMDB procedure point */

	entry_name = "cmdb";
	goto common;
%page;
/* HISTORY

   Initially written by R. D. Lackey June, 1978

   Modified by Jim Gray 3/79, to put working  storage  in  it's  own
   directory, using extensible areas

   Modified by Jim Gray - - Sept. 1979, to add  suffix  entries  for
   regression test compatibility

   Modified by Jim Gray - - Jan. 1980, to disallow  use  of  blocked
   files, foreign keys, and restructuring.

   Modified by Jim Gray - - Feb. 1980, to remove use of system_free_

   Modified by Jim Gray - - Feb. 1980, to add entries to set up  for
   being called as subroutine.

   Modified by Jim Gray - - April 1980, to  correct  recursion  flag
   problem.

   Modified by Jim Gray - - 80-11-06, to add  "-secure"  option  for
   cmdb, and have mrds_rst_create_db always create a "submodel_dir",
   under the database  directory.  The  -secure  option  causes  the
   mdbm_secured   bit   to   be   set  in  the  db_model.  Also  the
   version_status structure in the db_model had  it's  major  number
   changed  from  7  to 8. The CMDB/RMDB "running" message output at
   the start of an invocation was altered  to  include  the  version
   number of the model being worked on.

   Modified by Jim Gray - -  80-11-10,  to  change  delete_$path  to
   hcs_$del_dir_tree   and   hcs_$delentry_file   calls  to  improve
   performance.

   81-04-28 Jim Gray :  added  logic  for  the  new  -force  control
   argument.

   82-05-12 Roger Lackey : changed the way temp_rsc_dir_name was determined to
   use expand_pathname_ to correct a stringsize condition.

   82-06-09 Davids: removed code that was supposed to handle rmdb
   .                and rmdb metering and tracing. rmdb has  been
   .                moved to a separate subsystem.

   82-06-24 Roger Lackey : change display of model for listing to use
   .                       mrds_dm_display

   82-07-02 Roger Lackey : changed call to mrds_dm_display to 
                           mdbm_util_$mrds_display 
		       and mu_quiesce$* to mdbm_util_$ for binding

   82-07-06 Roger Lackey : changed mu_define_area to be mdbm_util_$mu_define_area

   82-08-19 Davids: added code to set rsc.db_type from arg_info.db_type after the
                    call to mrds_rst_proc_ctl_args.

   82-11-23 Davids: added entries set_vfile_db_type and set_page_file_db_type
   which set the internal static variable default_db_type which was also
   added and inited to "vf". Modified the parameter list of the module
   mrds_rst_proc_ctl_args to include default_db_type.

   12-02-82  R. Harvey: changed calls to release_area_ to release_temp_segment_
   so that the temporary segment really gets freed.

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

   83-02-18  Mike Kubicar : Added recognition of mode string for dm files
   and creation of models that reflect these strings.

   83-05-18 Davids: Added the call to dsl_$create_res_copy to create the 
   copy of the model opening resultant. Also moved the position of where the
   db_model.consistant bit is set to ON from the finish_cmdb internal procedure
   procedure (if rsc.severity_high = 0) to just before the call to
   create_res_copy. This was needed so that create_res_copy can open the db.

   83-10-04 Benjamin: Replaced call to hcs_$initiate with initiate_file_.

   83-10-05 Benjamin: Reverted change of 80-11-10.

   84-07-19 Nguyen: Make cleanup handler more reliable and to diagnose non-
   existent cmdb source segment more quickly.
*/
%page;
/* entries for debug and regression test purposes */


suffix: entry ();					/* USE ".db" SUFFIX ON DATABASE PATH */

	suffix_flag = ON;

	return;



no_suffix: entry ();				/* DON'T USE ".db" SUFFIX ON DATABASE PATH */

	suffix_flag = OFF;

	return;

set_vfile_db_type:
vf:  entry ();					/* Default datatype will be vfile */

	unspec (default_db_relation_modes) = "0"b;
	return;


set_dm_file_db_type:
dmf: entry ();					/* Default datatype will be dm file */

	dcl     set_modes_err_code	 fixed bin (35);	/* Error code, Possibly returned from $parse_mode_string */
	dcl     set_modes_err_msg	 char (500);	/* Possibly returned from $parse_mode_string */
	dcl     mrds_rst_proc_ctl_args$parse_mode_string entry (char (*), 1, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal,
				 2 bit (1) unal, fixed bin (35), char (*));


	entry_name = "cmdb$set_dm_file_db_type";
	mstxn_txn_id = "0"b;			/* Just in case we have to call error */
	rsc_ptr = null ();				/* Ditto */
	default_db_relation_modes.dm_file_type = "1"b;
	default_db_relation_modes.protection_on = "1"b;
	default_db_relation_modes.concurrency_on = "1"b;
	default_db_relation_modes.rollback_on = "1"b;
	call cu_$arg_count (arg_num, code);
	if code ^= 0
	then call error (code,
		"While trying to determine the argument count.");
	if arg_num &gt; 1
	then call error (error_table_$too_many_args,
		"Usage: create_mrds_db$set_dm_file_db_type {mode_string}");
	if arg_num &gt; 0 then do;
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);
		if code ^= 0
		then call error (code,
			"While getting the first argument.");
		call mrds_rst_proc_ctl_args$parse_mode_string (arg, default_db_relation_modes, set_modes_err_code, set_modes_err_msg);
		if set_modes_err_code ^= 0
		then call error (set_modes_err_code, set_modes_err_msg);
	     end;

	return;
%page;
/* entries for new features allowing/disallowing */

new_on: entry ();

	allow_new_features = ON;

	return;

/* turn off new features */

new_off: entry ();

	allow_new_features = OFF;

	return;

/* entries to set up as a command or being called as subroutine */

set_command_level: entry ();

	command_level_call = ON;

	return;


set_subroutine_level: entry ();

	command_level_call = OFF;

	return;
%page;
common:
	if recurse_flag then do;			/* If recursively invoked */
		call com_err_ (mrds_error_$no_recursion, entry_name);
		return;
	     end;
	else do;

		mstxn_txn_id = "0"b;		/* No transaction started yet */
		rsc_ptr = null;			/* Init restructure control segment pointer */
		ai_ptr = null;			/* Arg_info str pointer */
		wa_ptr = null ();

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

		recurse_flag = ON;			/* remember we have been invoked */

	     end;

	call mdbm_util_$mu_define_area (wa_ptr, (sys_info$max_seg_size), "MRDS.cmdb",
	     "0"b /* not extensible */, "1"b /* no freeing */, "0"b, "0"b /* no zeroing */, code);
	if code ^= 0 then call error (code, "defining temp area");

	mrds_dm_display_info_ptr = null;

	if ^command_level_call then ;
	else call ioa_$ioa_switch (iox_$user_output, "CMDB Version ^d models.",
		mdbm_data_$current_version);

	call cu_$arg_list_ptr (arg_list_ptr);		/* Get pointer to commandlevel arguments */

	allocate arg_info in (wk_area);

	call mrds_rst_proc_ctl_args (arg_list_ptr, ai_ptr, suffix_flag, default_db_relation_modes, fatal_sw);
	if fatal_sw then do;			/* Fatal error was encountered during arg processing */
		call tidy_up;
		goto exit;
	     end;

	call initiate_file_ (arg_info.source_dir, arg_info.source_entry, R_ACCESS,
	     temp_seg_ptr, source_seg_bcnt, code);
	if code ^= 0 then do;
		temp_msg = "Source segment: " || rtrim (arg_info.source_dir);
		temp_msg = temp_msg || "&gt;";
		temp_msg = temp_msg || arg_info.source_entry;
		err_msg = temp_msg;
		call error (code, err_msg);
	     end;

/* Create rsc (temporary) segment and directory */
	call mrds_rst_create_rsc (arg_info.temp_work_dir, rsc_ptr, code); /* Create and init rsc */
	if code ^= 0 then call error (code, "Creating rsc segment ");

	rsc.source_seg_ptr = temp_seg_ptr;
	rsc.db_relation_mode_flags = arg_info.relation_mode_flags; /* Set up relation modes */
	rsc.secure = arg_info.secure;			/* set up cmdb -secure option */

	if ^allow_new_features then ;
	else do;
		rsc.allow_foreign_keys = ON;
		rsc.allow_blocked_files = ON;
		rsc.allow_restructuring = ON;
	     end;


	if command_level_call then
	     rsc.command_level = ON;
	else rsc.command_level = OFF;
	rsc.dbp = arg_info.db_dir_path;
	rsc.cmdb_option = ON;

	if arg_info.list then call init_listing_seg;	/* Attach open and init listing segent */
%page;
	rsc.temp_dir = rsc.dbp;			/* For cmdb these are the same */
	db_model_path = rtrim (rsc.temp_dir) || "&gt;db_model";

	call mrds_rst_create_db (rsc_ptr, dbm_ptr, code); /* Create the database skeleton including db_model */
	if code ^= 0 then do;
		if code ^= error_table_$namedup then
		     call error (code, "Creating data base " || rsc.dbp);
		else do;
			if ^arg_info.force then do;
				call expand_pathname_ (rsc.dbp, db_dir, db_entry, cd);
				call error (code, "
      The entry '" || rtrim (db_entry) || "' already exists under the directory " || db_dir);
			     end;
			else do;			/* user gave -force argument */

/* check for a database, since we will not delete
   plain directories, segments, links, or msf's */

				call dmd_$check_path (rtrim (rsc.dbp), db_dir, db_entry, new_found, code);
				if code = error_table_$incorrect_access then
				     code = 0;	/* ignore access problems to the data model */
				if code ^= 0 then
				     call error (code, "Trying to delete existing database: " || rsc.dbp);
				else do;

/* force the user to be a DBA, if possible, so we can give all needed access */

					dir_acl (1).access_name = get_group_id_$tag_star (); /* get person.project.tag */
					call hcs_$add_dir_acl_entries (db_dir, db_entry, addr (dir_acl), 1, code);
					if code ^= 0 then do;
						if code = error_table_$argerr then
						     code = dir_acl (1).status_code; /* get real error for this acl setting */
						call error (code, "Could not set needed access: " || rsc.dbp);
					     end;
					else do;

						call dmd_$set_needed_access (rtrim (rsc.dbp), code);
						if code ^= 0 then
						     call error (code, "Unable to give DBA needed access: " || rsc.dbp);
						else do;

							call delete_directory ();
							if code ^= 0 then
							     call error (code, "Deleting existing database.");
							else do;
								call mrds_rst_create_db (rsc_ptr, dbm_ptr, code); /* try again */
								if code ^= 0 then
								     call error (code, "Creating data base after deletion " || rsc.dbp);
							     end;
						     end;
					     end;
				     end;
			     end;
		     end;
	     end;

	rsc.delete_db_sw = ON;			/* Set for tidy_up */

	call mrds_rst_get_seg_ptr (rsc_ptr, rsc.h_n_seg_info_ls_ptr, DB_MODEL_SEG_NAME, /* Add the new db_model to */
	     INITIATE, dbm_ptr, code);		/*          seg_info list */
	if dbm_ptr = null then call error (code, "DB MODEL");

	rsc.n_dm_ptr = dbm_ptr;			/* For cmdb New is used */
%page;
	rsc.phase = 200;				/* going into parse phase */

	call mrds_rst_parse (rsc_ptr, rsc.source_seg_ptr, source_seg_bcnt / 9);

	if rsc.severity_high &gt;= 3 then ;
	else call mrds_rst_consistancy_check (rsc_ptr);	/* make sure there are no loose ends */


/* Now we might be ready to create relations, set up for transactions */

	mstxn_transactions_needed = rsc.db_relation_mode_flags.protection_on;
	if rsc.db_relation_mode_flags.dm_file_type then do;
		no_dms_err_code = mrds_error_$no_dms;	/* If we're going to get an error, do it now */
		on linkage_error
		     call error (no_dms_err_code,
			"The Data Management System could not be found by the process search rules.");
		dms_test = transaction_manager_$begin_txn;
		revert linkage_error;
	     end;

	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, "Starting a transaction");

	if rsc.severity_high = 0 then do;		/* Logical completed OK */
		call model_adjust_bit_count;		/* Adjust bit count for all models */

		call format_files;
		rsc.n_dm_ptr -&gt; db_model.consistant = ON; /* OK to open db */
		call dsl_$create_res_copy (rsc.dbp, code);
		if code ^= 0
		then do;
			if rsc.listing_seg_sw
			then call ioa_$ioa_switch (rsc.listing_iocb_ptr,
				"2^/Could not create the model resultant copies");
			call ioa_$ioa_switch (iox_$error_output,
			     "2^/Could not create the model resultant copies");
			rsc.severity_high = 4;
			rsc.n_dm_ptr -&gt; db_model.consistant = OFF;
		     end;
	     end;

	call finish_cmdb;


exit:
	if rsc_ptr = null ()
	then mftxn_code = code;			/* Nothing happened */
	else if rsc.severity_high = 0 &amp; code = 0	/* No errors occurred */
	then mftxn_code = 0;			/* Everthings cool */
	else if code = 0
	then mftxn_code = error_table_$action_not_performed; /* Rollback! */
	else mftxn_code = code;
%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then call com_err_ (mftxn_code, entry_name);
	if entry_name ^= "cmdb$set_dm_file_db_type"
	then call tidy_up;
	return;					/* This is the only return from this program */
%page;
model_adjust_bit_count: proc;

/* This procedure adjusts the bit count on the data model and all file models */

	success = ON;				/* Init loop */

	if rsc.h_n_seg_info_ls_ptr ^= null then
	     do loop_ptr = rsc.h_n_seg_info_ls_ptr /* Do all segment in new seg_info list */
		repeat node_ptr
		while (success = ON);

		call mrds_rst_tree_successor (rsc.h_n_seg_info_ls_ptr,
		     loop_ptr, node_ptr, dummy_ptr, success);

		if success then do;			/* IF entry in list was found */

			seg_info_ptr = node.data;	/* Set pointer to seg_info */

			call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, (seg_info.bcnt), code);
			if code ^= 0 then call error (code, "model_adjust_bit_count");

		     end;
	     end;

     end model_adjust_bit_count;
%page;
finish_cmdb: proc;

	if rsc.listing_seg_sw then do;
		if rsc.severity_high &gt; 0 then call ioa_$ioa_switch (rsc.listing_iocb_ptr,
			"^2/An error of severity ^d occured.^/database not created.^/", rsc.severity_high);

		else call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^/NO ERRORS^/");
	     end;
	if rsc.severity_high &gt; 0 &amp; rsc.command_level then
	     call ioa_$ioa_switch (iox_$error_output,
		"^/cmdb: An error of severity ^d occured.^/^6xData base not created.^/", rsc.severity_high);


	if rsc.severity_high = 0 then do;
		rsc.delete_db_sw = OFF;		/* We have a good data base */
		if rsc.listing_seg_sw then do;	/* display db in listing */
			call init_display_info;	/* Internal proc */
			call mdbm_util_$mrds_dm_display (mrds_dm_display_info_ptr, err_msg, code);
			if code ^= 0 then call error (code, err_msg);
		     end;
	     end;

     end finish_cmdb;
%page;
format_files: proc;

/* this procedure walks the global file list and formats the newly created files */

	dcl     error_code		 fixed bin (35);

	node_ptr = rsc.h_gfile_ptr;

	success = ON;

	do while (success);				/* all the files in list */
	     call mrds_rst_tree_successor (rsc.h_gfile_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);

	     if success then do;			/* Found a file info */
		     node_ptr = successor_ptr;
		     gl_ptr = node.data;
		     if ^gl.complete then do;		/* To complete it format the file */
			     call mrds_rst_format_file (rsc_ptr, (gl.name), error_code);
			     if error_code ^= 0
			     then call error (error_code, "Creating relation " || rtrim (gl.name));
			     gl.complete = ON;	/* It is now complete */
			end;
		end;
	end;

     end format_files;
%page;
error: proc (cd, msg);

	dcl     cd		 fixed bin (35);	/* (INPUT) Error code */
	dcl     msg		 char (*);	/* (INPUT) error message input with code */

	code = cd;				/* Code is a global parameter */
	call com_err_ (cd, entry_name, "^/^a", msg);
	goto exit;

     end error;
%page;
init_listing_seg: proc;				/* Initialize listing segment */

	call cu_$decode_entry_value (create_mrds_db, ref_ptr, dummy_ptr); /* Get pointer to ref procedure */

	attach_desc = "vfile_ " || rtrim (get_wdir_ ()) || "&gt;" ||
	     before (arg_info.source_entry, "." || rtrim (entry_name)) || ".list";

	call iox_$attach_name (unique_chars_ ("0"b) || rtrim (entry_name) || ".listing",
	     rsc.listing_iocb_ptr, attach_desc, ref_ptr, code);
	if code = 0 then call iox_$open (rsc.listing_iocb_ptr, STREAM_OUTPUT, "0"b, code);
	if code ^= 0 then call error (code, "listing segment");

	value = "CREATE_MRDS_DB";

	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-^a LISTING FOR ^a",
	     value, rtrim (arg_info.source_dir) || "&gt;" || arg_info.source_entry);

	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Created by:^-^a",
	     get_group_id_ ());

	call date_time_ (clock (), long_date);
	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Created on:^-^a", long_date);

	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-Data base path:^-^a", rsc.dbp);

	value = "";

	if arg_info.list then value = value || " list";

	if value = "" then value = " None";

	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^-^7xOptions:^4x^a", value);

	call ioa_$ioa_switch (rsc.listing_iocb_ptr, "^/");/* A couple of spaces */

	rsc.listing_seg_sw = ON;
	return;

     end init_listing_seg;
%page;
init_display_info: proc;

	allocate mrds_dm_display_info in (wa) set (mrds_dm_display_info_ptr);

	mrds_dm_display_info.version = MRDS_DM_DISPLAY_INFO_VERSION_1;
	mrds_dm_display_info.output_iocb_ptr = rsc.listing_iocb_ptr;
	mrds_dm_display_info.db_path = rsc.dbp;
	mrds_dm_display_info.temp_dir_path = arg_info.temp_work_dir;
	mrds_dm_display_info.work_area_ptr = wa_ptr;
	mrds_dm_display_info.dbm_ptr = dbm_ptr;
	mrds_dm_display_info.sw.default = "0"b;
	mrds_dm_display_info.sw.long = "1"b;		/* This is what we are after */
	mrds_dm_display_info.sw.cmdb = "0"b;
	mrds_dm_display_info.sw.names_only = "0"b;

	mrds_dm_display_info.sw.attribute = "0"b;
	mrds_dm_display_info.sw.relation = "1"b;	/* This is what we are after */
	mrds_dm_display_info.sw.index = "0"b;
	mrds_dm_display_info.sw.history = "0"b;
	mrds_dm_display_info.sw.header = "1"b;		/* This is what we are after */
	mrds_dm_display_info.sw.mbz = "0"b;
	mrds_dm_display_info.dom_name_list_ptr = null;
	mrds_dm_display_info.attr_name_list_ptr = null;
	mrds_dm_display_info.rel_name_list_ptr = null;
	mrds_dm_display_info.index_name_list_ptr = null;
	mrds_dm_display_info.xref_iocb_ptr = null;
	mrds_dm_display_info.xref_name = "";

     end init_display_info;
%page;
tidy_up: proc;

	if rsc_ptr ^= null then do;

		if rsc.db_quiesced_sw then /* If database has been quiesced then  un-quiesce it */
		     call mdbm_util_$quiesce_free (rsc.dbp, code);

		if mrds_dm_display_info_ptr ^= null
		then if mrds_dm_display_info.xref_iocb_ptr ^= null
		     then do;
		               call mdbm_util_$xref_destroy (mrds_dm_display_info.xref_iocb_ptr,
			     mrds_dm_display_info.temp_dir_path, (mrds_dm_display_info.xref_name), err_msg, code);
			     if code ^= 0 then call error (code, err_msg);
			     mrds_dm_display_info.xref_iocb_ptr = null;
			     end;

		if rsc.delete_db_sw then /* If the data base had been created but an error  */
		     call delete_directory;		/*   occured then delete the data base */


		else if rsc.temp_dir_sw then /* Entry point was rmdb and a temp dir was created */
		     call delete_directory;

		if rsc.listing_seg_sw then do;	/* Close and detach the listing segment */
			call iox_$close (rsc.listing_iocb_ptr, code);
			if code = 0 then call iox_$detach_iocb (rsc.listing_iocb_ptr, code);
			if code = 0 then call iox_$destroy_iocb (rsc.listing_iocb_ptr, code);
		     end;

		call expand_pathname_ (rsc.rsc_dir, dir, temp_rsc_dir_name, code);
		if code = 0 then do;
			delete_options.force = ON;
			delete_options.question = OFF;
			delete_options.directory = ON;
			delete_options.segment = ON;
			delete_options.link = ON;
			delete_options.chase = ON;
			delete_options.library = OFF;
			delete_options.raw = OFF;
			delete_options.mbz = OFF;

			quit_sw = "0"b;
			on quit quit_sw = "1"b;
						/* Because the delete_$path takes a lot of cpu time, so let handle the quit
   condition and let it finishes then we give the quit. */
			call delete_$path (arg_info.temp_work_dir, temp_rsc_dir_name, string (delete_options), MODULE_NAME, code);
			if code = 0 then do;
				rsc_ptr = null;
			     end;
			if quit_sw then do;
				quit_sw = "0"b;
				revert quit;
				signal quit;
			     end;
		     end;
		if code ^= 0
		then call com_err_ (code, entry_name, "^a", "deleting rsc_dir");
	     end;

	if wa_ptr ^= null () then do;
		call release_temp_segment_ ("MRDS.cmdb", wa_ptr, code);
		wa_ptr = null ();
	     end;

	recurse_flag = OFF;				/* Reset so we can be called again */
	return;

     end tidy_up;
%page;
delete_directory: proc;

	temp_dir_name = reverse (before (reverse (before (rsc.temp_dir, BLANK)), "&gt;"));
	temp_dir_directory = before (rsc.temp_dir, "&gt;" || temp_dir_name);

	delete_options.force = ON;
	delete_options.question = OFF;
	delete_options.directory = ON;
	delete_options.segment = ON;
	delete_options.link = ON;
	delete_options.chase = ON;
	delete_options.library = OFF;
	delete_options.raw = OFF;
	delete_options.mbz = OFF;

	call delete_$path (temp_dir_directory, temp_dir_name, string (delete_options), MODULE_NAME, code);

     end delete_directory;
%page;
/*
*
*  These routines are dummy routines required for the transaction processing
*  include files.  They do nothing.
*
*/

should_rollback:
     proc returns (bit (1));
	return ("0"b);
     end should_rollback;


restore_significant_data:
     proc;
     end restore_significant_data;
%page;
	dcl     recurse_flag	 bit (1) internal static init ("0"b); /* On = cmdb/rmdb has been invoked */






	dcl     adjust_bit_count_	 entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     cleanup		 condition;
	dcl     quit		 condition;
	dcl     any_other		 condition;
	dcl     linkage_error	 condition;
	dcl     clock		 builtin;
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$decode_entry_value entry (entry, ptr, ptr);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     delete_$path	 entry (char (*), char (*), bit (36) aligned, char (*),
				 fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_group_id_	 entry returns (char (32));
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_wdir_		 entry returns (char (168));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24),
				 fixed bin (35));
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$error_output	 ext ptr;
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$user_output	 ext ptr;
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unspec		 builtin;
	dcl     wa_ptr		 ptr;
	dcl     wk_area		 area (sys_info$max_seg_size) based (wa_ptr);
	dcl     (iox_$detach_iocb, iox_$destroy_iocb) entry (ptr, fixed bin (35));
	dcl     mrds_rst_consistancy_check entry (ptr);	/* valid model checker */
%page;
	dcl     BLANK		 char (1) int static options (constant) init (" ");
	dcl     DB_MODEL_SEG_NAME	 char (32) aligned int static options (constant) init ("db_model");
	dcl     INITIATE		 bit (1) int static options (constant) init ("0"b);
	dcl     MODULE_NAME		 char (14) int static options (constant) init ("create_mrds_db");
	dcl     OFF		 bit (1) int static options (constant) init ("0"b);
	dcl     ON		 bit (1) int static options (constant) init ("1"b);
	dcl     quit_sw		 bit (1) aligned;
	dcl     RINGS		 (3) fixed bin (3) init static options (constant) init (7, 7, 7); /* Ring brackets */
	dcl     STREAM_OUTPUT	 fixed bin internal static options (constant) init (2);

	dcl     mdbm_util_$mrds_dm_display entry (ptr, char (*), fixed bin (35));
          dcl     mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
	dcl     mrds_rst_create_db	 entry (ptr, ptr, fixed bin (35));
	dcl     mrds_rst_create_rsc	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_rst_format_file	 entry (ptr, char (*), fixed bin (35));
	dcl     mrds_rst_get_seg_ptr	 entry (ptr, ptr, char (32) aligned, bit (1), ptr, fixed bin (35));
	dcl     mdbm_util_$quiesce_free entry (char (168), fixed bin (35));
	dcl     mrds_rst_parse	 entry (ptr, ptr, fixed bin (24));
	dcl     mrds_rst_proc_ctl_args entry (ptr, ptr, bit (1), 1, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal,
				 2 bit (1) unal, bit (1));
	declare suffix_flag		 bit (1) init ("1"b) int static; /* on =&gt; use ".db" suffix on db path */
	declare allow_new_features	 bit (1) init ("0"b) int static; /* on =&gt; allow foreign keys, blocked files, restructuring */
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	declare mdbm_util_$mu_define_area entry (ptr, fixed bin (18), char (11), /* calls mu_define_area_ to get temp seg */
				 bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
	declare command_level_call	 bit (1) internal static init ("1"b); /* on =&gt; set up as command, not subroutine */
	declare mdbm_data_$current_version fixed bin (35) ext; /* curent model version numberr */
	declare error_table_$incorrect_access fixed bin (35) ext; /* no acl to existing data model */
	declare new_found		 bit (1);		/* on =&gt; new version db arch found */
	declare dmd_$check_path	 entry (char (*), char (168), char (32), bit (1), fixed bin (35)); /* determines if path is to db */
	declare dmd_$set_needed_access entry (char (*), fixed bin (35)); /* gives a DBA all acls */
	declare dsl_$create_res_copy	 entry (char (168), fixed bin (35));
	declare hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); /* set acl on a dir */
	declare 1 dir_acl		 (1:1) aligned,	/* structure for setting sma on db dir */
		2 access_name	 char (32),	/* person.project.tag */
		2 dir_modes	 bit (36) init ("111000000000000000000000000000000000"b), /* sma acl */
		2 status_code	 fixed bin (35) init (0); /* error code for this acl setting */
	declare error_table_$argerr	 fixed bin (35) ext;/* from hcs_$add_dir_acl_entries */

	dcl     mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1));
	dcl     sys_info$max_seg_size	 ext fixed bin (35);

/*	ERROR CODES	*/

	dcl     error_table_$action_not_performed fixed bin (35) ext static; /* Could not create db */
	dcl     error_table_$namedup	 ext fixed bin (35);
	dcl     error_table_$too_many_args fixed bin (35) ext static;
	dcl     mrds_error_$no_recursion ext fixed bin (35);
	dcl     mrds_error_$no_dms	 ext fixed bin (35);
%page;
	dcl     arg		 char (arg_len) based (arg_ptr);
						/* To get args for set_dm_file_db_type entry point */
	dcl     arg_len		 fixed bin (21);	/* To get args for set_dm_file_db_type entry point */
	dcl     arg_list_ptr	 ptr;		/* Pointer to commmand level argument list */
	dcl     arg_num		 fixed bin;	/* Number of args for set_dm_file_db_type entry point */
	dcl     arg_ptr		 ptr;		/* To get arguments for set_dm_file_db_type entry point */
	dcl     source_seg_bcnt	 fixed bin (24);	/* Bit count of source segment */
	dcl     temp_seg_ptr	 ptr;
	dcl     err_msg		 char (256);
	dcl     fatal_sw		 bit (1);		/* ON =&gt; Fatal error occured while processing control arguments */

	dcl     (addr, null, fixed, rtrim, before, reverse, string) builtin;

	dcl     cd		 fixed bin (35);
	dcl     db_dir		 char (168);
	dcl     db_entry		 char (32);
	dcl     dir		 char (168);
	dcl     dms_test		 entry options (variable) variable; /* See if dms software is there */
	dcl     code		 fixed bin (35);	/* Error code */
	dcl     (dummy_ptr, loop_ptr)	 ptr;		/* Dummy pointer */
	dcl     ref_ptr		 ptr;		/* procedure reference pointer */
	dcl     attach_desc		 char (200);	/* Attach descriptor */
	dcl     entry_name		 char (32);
	dcl     db_model_path	 char (168);	/* path name down to db_model */
	dcl     long_date		 char (24);
	dcl     no_dms_err_code	 fixed bin (35);	/* To avoid recursive linkage_error conditions */
	dcl     temp_dir_name	 char (32);	/* Name of temp directory entry */
	dcl     temp_dir_directory	 char (168);
	dcl     temp_rsc_dir_name	 char (32);	/* temp for holding rsc dir name */
	dcl     temp_msg		 char (256) varying;
	dcl     value		 char (64) varying;

	dcl     1 default_db_relation_modes int static,	/* Relation modes, set by set_(vfile dm_file)_db_type entry points */
		2 dm_file_type	 bit (1) init ("0"b), /* Default vfile */
		2 protection_on	 bit (1) init ("0"b), /* No transactions */
		2 concurrency_on	 bit (1) init ("0"b), /* No concurrency */
		2 rollback_on	 bit (1) init ("0"b); /* No journalling */
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_arg_info;
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_global_lists;
%page;
%include mrds_dm_display_info;
%page;
%include mdbm_db_model;
%page;
%include access_mode_values;
%page;
%include delete_options;

     end;
�



		    mrds_rst_.alm                   10/23/86  1025.2rew 10/23/86  1008.1       13059



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

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"  2) change(86-10-21,Blair), approve(86-10-21,PBF7311),
"     audit(86-10-23,Dupuis), install(86-10-23,MR12.0-1199):
"     Add the name execute_undo so that rmdb_execute_undo can be called from
"     display_mrds_dm which is outside of the rmdb subsystem.
"                                                      END HISTORY COMMENTS

"
"81-05-27 Jim Gray : created to support the bound_mrds_create_ segment
"since display_mrds_dm needs access to some mrds_rst_ modules, but is in bound_mrds_
"
"82-07-07 Roger Lackey : added add_rmdb_history for rmdb_add_rmdb_history
"
"83-02-15 Ron Harvey : deleted $create_rsc, $global_list_build, $build_seg_info_ls
"	    as they were no longer called.


	name	mrds_rst_

	entry	add_rmdb_history
add_rmdb_history:
	tra	&lt;rmdb_add_rmdb_history&gt;|[add_rmdb_history]

	entry     execute_undo
execute_undo: 
	tra	&lt;rmdb_execute_undo&gt;|[execute_undo]	      	

	end
�



		    mrds_rst_attribute_cleanup.pl1  04/18/85  1454.7r w 04/18/85  0909.0       56007



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - october 1978

*/


mrds_rst_attribute_cleanup: procedure (rsc_ptr);

/* DESCRIPTION:

   this routine is invoked to supply default attributes for domains
   that currently have no attribute of the same name as the domain(for RMDB), or
   which have had no attributes specified for them.  it produces dummy attribute
   list structures identical to the input to mrds_rst_attribute_handler
   that have a attribute name equal to the domain name, and then calls the
   attribute handler to put the attribute models in place.

*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   global lists - - (input) searched for domains without attributes
   since they contain all database entities during RMDB/CMDB

   parse info structures - - (output) via calls to mrds_rst_attribute_handler
   to build the attribute model as default for the given domain

*/

/* get the semantic structure pointers */

	directive_ptr = rsc.directive_ptr;

/* if trace is on call metering */

	if ^rsc.trace_sw then ;
	else do;
		if directive.type = DEFINE then
		     directive_mesg = "DEFINE";
		else if directive.type = REDEFINE then
		     directive_mesg = "REDEFINE";
		else directive_mesg = "CMDB";
		call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_cleanup",
		     "1"b /* in */, directive_mesg);
	     end;

/* check for domains with no referencing attributes,
   any found get default attributes of the same name
   as that of the given domain */

	if directive.type = REDEFINE then do;
		call ioa_$rs ("^a ^a", message, message_length,
		     "The attribute cleanup handler will not implement the ""redefine""",
		     "directive until a later release.");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message));
	     end;
	else do;

/* initialize the successor function to get the first domain on the
   global list of domains in the database */

		root_ptr = rsc.h_gdom_ptr;
		node_ptr = root_ptr;		/* convention for first on list */
		success = "1"b;			/* do at least one loop */

		do while (success);

		     call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);

		     if ^success then ;		/* success off =&gt; no more in list */
		     else do;			/* next domain found */

			     node_ptr = successor_ptr;/* get pointer to next on list after last one */
			     gl_ptr = node_ptr -&gt; node.data; /* get element portion from tree head */

			     if default_attribute_present () then ; /* already default attr present */
			     else do;		/* none found, set default attribute */

/* make believe we are the parser, and that we
   just found an attribute definition of domain-name domain-name */

				     call mrds_rst_rsc_alloc (rsc_ptr, ATTRIBUTE_DOMAIN, attdom_ptr);
				     attribute_domain.attr = gl.name; /* set domain name as attribute's */
				     attribute_domain.dom = gl.name;
				     attribute_domain.default = "1"b; /* not defined in source */
				     attribute_domain.unused = "0"b;
				     attribute_domain.line_num = 0;

/* define the attribute just prepared */

				     call mrds_rst_attribute_handler (rsc_ptr, attdom_ptr);

				end;

			end;

		end;

	     end;

/* call trace if metering is on */

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_cleanup",
		"0"b /* out */, directive_mesg);

default_attribute_present: procedure () returns (bit (1));

/* routine to return true if an attribute of the same
   name as the domain has been defined as referencing this domain.
   (this will only happen with default attributes, not source ones)
   else it returns false, say if no attributes are present */

	call mrds_rst_tree_search (gl.name, gl.item_sub_list_ptr, node_ptr, parent_ptr, success);

	return (success);


	declare node_ptr		 ptr;		/* local version for search */
	declare parent_ptr		 ptr;		/* unused */
	declare success		 bit (1);		/* on =&gt; default attribute of domain name found */



     end;

	declare directive_mesg	 char (8);	/* meter call message */
	declare mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* find routine */
	declare mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* working area manager */
	declare ioa_$rs		 entry options (variable); /* string manipulation routine */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */
	declare message		 char (96) varying; /* specifics of error message */
	declare message_length	 fixed (21);	/* length of specifics message */
	declare mrds_error_$rst_undone_option fixed bin (35) external; /* unimplemented feature */
	declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next on list routine */
	declare mrds_rst_attribute_handler entry (ptr, ptr); /* attribute semantic routine */
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* trace/meter routine */
	declare sys_info$max_seg_size	 fixed bin (35) external; /* system largest segment allowed */
	declare (fixed, addr, rel)	 builtin;		/* functions known to pl1 */

%include mrds_rst_rsc;
%include mrds_rst_struct_types;
%include mrds_rst_global_lists;
%include mrds_rst_tree;
%include mrds_rst_parse_info;
%include mrds_rst_semantics;

     end;
�



		    mrds_rst_attribute_handler.pl1  04/18/85  1454.7r w 04/18/85  0909.0       89091



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - october 1978

*/


mrds_rst_attribute_handler: procedure (rsc_ptr, list_ptr);


/* DESCRIPTION:

   this routine builds/alters the mrds database model attribute information
   and the global list of database entities maintained during CMDB/RMDB
   based upon the attribute data and directive that is active when
   it is called from the RMDB/CMDB parser.
   the directive may be undefine, define, redefine, or cmdb and the
   data is either an attribute name or a structure holding an
   attribute-domain name pair.

*/


/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   list_ptr - - (input) pointer to the single attribute name(undefine only),
   or to the attribute-domain name pair structure

   database model - - (output) updated model with altered attribute information

   global lists - - (output) the lists of database entities, updated
   according to the directive and data

   error_output - - (output) via calls to mrds_rst_error for error messages

*/

/* REMAINING ERRORS:

   undefine:

   the attribute name may be the &lt;error_symbol&gt;(this may be ignored)
   the attribute may not be defined in the model

   define, cmdb:

   the attribute name may be the &lt;error_symbol&gt;(this may be ignored)
   the domain name may be the &lt;error_symbol&gt;(this may be ignored)
   the attribute may already be defined in the model
   the domain may not be defined in the model

   redefine:

   same as under define, except the attribute may not be defined

   note: "(this may be ignored)" means a previous error will prevent
   a database model with erroneous data fom being built

*/

/* call trace if metering is on */

	directive_ptr = rsc_ptr -&gt; rsc.directive_ptr;
	stmt_ptr = rsc_ptr -&gt; rsc.stmt_ptr;

	if directive.type = UNDEFINE then do;		/* input structure depends on directive */
		delete_name_ptr = list_ptr;
		attribute_name = delete_name.overlay;
	     end;
	else do;
		attdom_ptr = list_ptr;
		attribute_name = attribute_domain.attr;
	     end;

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_handler",
		IN, (attribute_name));

/* check on which directive called us */

	if directive.type = UNDEFINE | directive.type = REDEFINE then do;
		if stmt (directive.type).attribute.number &gt; 0 then ; /* not first time */
		else do;				/* issue error first time only */
			call ioa_$rs ("^a ^a", message, message_length,
			     "The attribute handler will not implement ""undefine"" or ""redefine""",
			     "directives until a later release.");
			call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message));
		     end;
	     end;
	else do;

/* define or cmdb directive was caller, process newly defined attribute-domain correspondence */

		call define_attribute_domain ();

	     end;

/* call the trace routine if metering is turned on */

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_attribute_handler",
		OUT, (attribute_name));

define_attribute_domain: procedure ();

/* routine to make the definition correspondence of an attribute to a domain */


/* make sure the attribute is not already in the database or previously defined */

	call mrds_rst_list_element$add (attribute_domain.attr, MAIN_LIST, rsc_ptr,
	     rsc.h_gattr_ptr, gl_ptr, error_code);
	if error_code = 0 then ;
	else do;
		call ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The attribute """, attribute_domain.attr,
		     """ given on line", attribute_domain.line_num,
		     "is already defined in the database, the duplicate will be ignored!!");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$attr_already_exists, (message));
		call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy global element not in list */
	     end;

/* attribute was not found in list so it was added,   link list element to list head and fill in the blanks */

	gl.type = MAIN_LIST;
	gl.name = attribute_domain.attr;
	gl.item_info_ptr = null ();			/* no domain sublist element yet */
	gl.parse_info_ptr = attdom_ptr;
	gl.other_info_ptr = null ();			/* no domain_info yet */
	gl.item_sub_list_ptr = null ();		/* no containing relations yet */
	gl.file_info_ptr = null ();			/* unused, this and fm_ptr obtained from corresponding */
	gl.file_model_ptr = null ();			/* relation's attr sublist ai_ptr via the pointer function */
	gl.affected = ON;
	gl.undefine = OFF;
	gl.redefine = OFF;
	if directive.type = DEFINE then do;
		gl.define = ON;
		gl.cmdb = OFF;
	     end;
	else do;					/* CMDB directive */
		gl.define = OFF;
		gl.cmdb = ON;
	     end;
	gl.superior_assigned = OFF;			/* no relation for this attribute yet */
	gl.inferior_assigned = OFF;			/* no domain for this attribute yet */
	gl.complete = OFF;				/* no attribute info yet */
	gl.consistant = ON;				/* assume good til errors found */
	gl.reserved = OFF;

/* make sure that the given domain is defined in the database */

	call mrds_rst_tree_search (attribute_domain.dom, rsc.h_gdom_ptr, node_ptr, parent_ptr, success);
	if ^success then do;			/* not found */
		gl.consistant = OFF;		/* no domain for this attribute */
		call ioa_$rs ("^a^a^a^a^a ^d ^a", message, message_length,
		     "The domain """, attribute_domain.dom, """ given for attribute """,
		     attribute_domain.attr, """ on line",
		     attribute_domain.line_num, "has not been defined in the database.");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undefined_domain, (message));
	     end;
	else if error_code ^= 0 then ;		/* previous error =&gt; attr not found, don't add to sublist */
	else do;
		dom_gl_ptr = node_ptr -&gt; node.data;	/* get domain global element pointer */

/* domain found, add this attribute to it's referencing sublist */

		call mrds_rst_list_element$add (attribute_domain.attr, SUB_LIST, rsc_ptr,
		     dom_gl_ptr -&gt; gl.item_sub_list_ptr, sl_ptr, error_code);
		if error_code ^= 0 then do;		/* sub/main list disagreement */
			call ioa_$rs ("^a^a^a^a^a", message, message_length,
			     "LOGIC ERROR in mrds_rst_attribute_handler, the attribute """, attribute_domain.attr,
			     """ was found in the sublist of domain """, attribute_domain.dom,
			     """ but wasn't found in the global attribute list.");
			call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message));
		     end;
		else do;

/* fill in the sub list element info */

			sl.type = SUB_LIST;
			sl.name = attribute_domain.attr;
			sl.item_info_ptr = null ();	/* no attribute_info yet */
			sl.parse_info_ptr = attdom_ptr;
			sl.old_other_info_ptr = null ();
			sl.new_other_info_ptr = dom_gl_ptr;
			sl.global_list_ptr = gl_ptr;
			sl.reserved = OFF;

/* set domain present for this attribute, and get the domain info and sublist pointers */

			gl.item_info_ptr = sl_ptr;
			gl.other_info_ptr = dom_gl_ptr -&gt; gl.item_info_ptr; /* set domain_info ptr for attr */
			gl.inferior_assigned = ON;
			dom_gl_ptr -&gt; gl.inferior_assigned = ON; /* attr references domain now */
		     end;
	     end;

     end;

	declare sys_info$max_seg_size	 fixed bin (35) external; /* system constant */
	declare (fixed, rel, addr, null) builtin;	/* functions known to pl1 */
	declare ON		 bit (1) internal static options (constant) init ("1"b); /* true state */
	declare OFF		 bit (1) internal static options (constant) init ("0"b); /* false */
	declare error_code		 fixed binary (35); /* mrds_error_ table index */
	declare message		 char (256) varying;/* specifics of error message */
	declare message_length	 fixed bin (21);	/* length of specifics message */
	declare mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */
	declare mrds_error_$undefined_domain fixed bin (35) external; /* item not in database */
	declare mrds_error_$attr_already_exists fixed bin (35) external; /* duplicate attr definition */
	declare mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */
	declare mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* work area manager */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */
	declare ioa_$rs		 entry options (variable); /* string manipulator */
	declare mrds_rst_list_element$add entry (char (32) aligned, fixed binary, ptr, ptr, ptr, fixed bin (35));
	declare list_ptr		 ptr;		/* pointer to parse info list */
	declare IN		 bit (1) internal static options (constant) init ("1"b); /* input meter flag */
	declare OUT		 bit (1) internal static options (constant) init ("0"b); /* output meter flag */
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */
	declare dom_gl_ptr		 ptr;		/* temp storage for domain global element pointer */
	declare attribute_name	 char (32);	/* input name for metering */

%include mrds_rst_rsc;
%include mrds_rst_struct_types;
%include mrds_rst_semantics;
%include mrds_rst_parse_info;
%include mrds_rst_tree;
%include mrds_rst_global_lists;


     end;
�



		    mrds_rst_consistancy_check.pl1  10/16/86  1551.9r w 10/16/86  1145.0       64674



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

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

/*
   Known Problems:
	1) RMDB code should be removed since its now done by the rmdb subsystem
*/

mrds_rst_consistancy_check: procedure (rsc_ptr);

/*
   .                        BEGIN_DESCRIPTION
   This routine makes sure that creation(CMDB) or restructuring(RMDB)
   of a database model has resulted in a model that is guarenteed
   to be consistant, complete, and error free.

   For CMDB this means checking that some attributes or domains
   might never have been used or referenced, a possible oversight
   by the database builder.

   RMDB is more complicated, because an "undefine" directive
   can cause an inconsistancy that was later rectified by a
   "define" or "redefine" directive. Thus many more checks
   are made to ensure that attributes have domains, and are contained
   in some relation, all domains are referenced, and so on.
   .                        END_DESCRIPTION
*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the restructure control segment
   that holds error, directives seen, and other common information

   (output) warning messages about detected inconsistancies in
   the database, and the setting of severity high in the rsc segment

*/

/* get the semantic structure pointers */

	stmt_ptr = rsc.stmt_ptr;
	directive_ptr = rsc.directive_ptr;

/* call metering if trace is on */

	if ^rsc.trace_sw then ;
	else do;
		if directive.cmdb.seen then
		     meter_mesg = "CMDB";
		else meter_mesg = "RMDB";
		call mrds_rst_meter (rsc_ptr, "mrds_rst_consistancy_check", "1"b /* input call */, meter_mesg);
	     end;
						/* take action based on which command invoked us,
						   CMDB only can have used attributes and domains */

	if directive.cmdb.seen then do;

/* CMDB directive */

		call check_for_referencing_relation ("0"b /* for domains */);

		call check_for_referencing_relation ("1"b /* for attributes */);


	     end;

	else do;

/* RMDB directive */

/* quick and dirty version for RMDB with only "define" directive */

		call check_for_referencing_relation ("0"b /* for domains */);

		call check_for_referencing_relation ("1"b /* for attributes */);
						/* 	     call ioa_$ioa_switch (iox_$error_output,
						   "RMDB consistancy check not implemented yet.^/") ; */

	     end;

/* call metering if trace is on */

	if ^trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_consistancy_check", "0"b /* output call */, meter_mesg);

check_for_referencing_relation: procedure (attribute_check);

/* routine to check the global list elements of domains and attributes,
   to see whether they have been made ude of in some relation or not */

	if attribute_check then
	     root_ptr = rsc.h_gattr_ptr;
	else root_ptr = rsc.h_gdom_ptr;
	node_ptr = root_ptr;			/* convention for first on list */
	success = "1"b;				/* to init loop */

/* go through all attributes/domains, checking that they are used in some relation */

	do while (success);

	     call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);

	     if ^success then ;
	     else do;
		     node_ptr = successor_ptr;
		     gl_ptr = node_ptr -&gt; node.data;

/* issue a warning if this attribute/domain is unused */

		     if gl.superior_assigned then ;
		     else do;

/* error message depends on which list was checked */

			     if attribute_check then
				if gl.parse_info_ptr -&gt; attribute_domain.default then ;
				else call unused_attribute_error (); /* only if not default attribute */
			     else do;
				     call unused_domain_error ();
						/* 			     call delete_domain_info () ; */
				end;

			end;

		end;

	end;


	declare attribute_check	 bit (1);		/* ON =&gt; this is for the attribute list elements, else domains */

     end;

unused_attribute_error: procedure ();

/* output error message warning of an attribute without a relation */

	attdom_ptr = gl.parse_info_ptr;
	if attribute_domain.default then do;
		line_mesg = "h";
		default_mesg = "default_";
	     end;
	else do;
		default_mesg = "";
		line_mesg = "given on line " || ltrim (char (attribute_domain.line_num)) || " h";
	     end;

	call ioa_$rs ("^a ^a^a^a^a ^a^a", message, message_length,
	     "The", default_mesg, "attribute """, gl.name, """", line_mesg,
	     "as never been assigned to a relation.");
	call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_unused_attr, (message));

     end;

unused_domain_error: procedure ();

/* output error message warning of a domain unreferenced by a relation */

	call ioa_$rs ("^a^a^a ^d ^a", message, message_length,
	     "The domain """, gl_ptr -&gt; gl.name, """ given on line",
	     gl_ptr -&gt; gl.parse_info_ptr -&gt; domain.line_num,
	     "has only been referenced by attributes that have no assigned relation.");
	call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_unused_attr_dom, (message));

     end;

	declare meter_mesg		 char (4);	/* name of directive being checked */
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* restructuring metering routine */
	declare default_mesg	 char (8) varying;
	declare line_mesg		 char (24) varying;
	declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1)); /* get next on list routine */
	declare ioa_$rs		 entry options (variable); /* string manipulator routine */
	declare message		 char (256);	/* specifics of error */
	declare message_length	 fixed bin (21);	/* length of specifics message */
	declare mrds_rst_error	 entry (ptr, fixed bin (2), fixed bin (35), char (*)); /* error handler */
	declare mrds_error_$rst_unused_attr fixed bin (35) ext; /* unreferenced attr error */
	declare mrds_error_$rst_unused_attr_dom fixed bin (35) ext; /* unreferenced attrs dom unused elsewhere */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment size */
	declare (addr, rel, fixed,
	        char, ltrim)	 builtin;		/* functions known to pl1 */

%include mrds_rst_rsc;
%include mrds_rst_parse_info;
%include mrds_rst_tree;
%include mrds_rst_global_lists;
%include mrds_rst_semantics;
%include mdbm_db_model;

     end;
��



		    mrds_rst_create_db.pl1          10/16/86  1551.9rew 10/16/86  1142.8      104049



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

mrds_rst_create_db: proc (rsc_ptr, dbm_ptr, code);


/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     initialize unreferenced_attribute_ptr offset.
                                                   END HISTORY COMMENTS */


/*
                            BEGIN_DESCRIPTION
   This procedure creates the skeleton of a database, including:
   db_model (data base model segment)
   dbc (database control segment)

   These segments are initialized before returning.
   If an error occures the data base is not created (it is deleted).
 		        END_DESCRIPTION
*/


/* HISTORY

   Written by Roger D. Lackey    December  1978

   Modified by Jim Gray - 3/20/79 - - to handle new versions of model and working storage (rsc)

   Modified by Jim Gray - - 80-11-06, to
   1) add initialization of mdbm_secured bit in db_model
   2) always create a submodel_dir under the database dir
   3) change the version_status major number from 7 to 8
   4) put the version_status number in a mrds_data_ entry

   Modified by Jim Gray - - 80-11-07, to put the name of the submodel dir
   in a standard mrds_data_ entry fors users and mrds to refer to.

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

   80-12-09 Jim Gray : mdbm_util_$init_dbc changed to call to mdbm_util_$create_control_segment
   as part of r-u to r-s-m-d scope mode and dbc version change.
   CMDB now always creates version 5 dbc structures in a segment "db.control".

   82-04-09 Davids: modified the init_db_model procedure so that it uses
   .                the new names for elements in the db_model, specifically
   .                unused_offsets and restructuring_history_offset.

   82-04-15 Davids: changed unused_offset (13) to inconsistent_message_offset

   82-05-04 Davids: changed unused_offset (12) to last_restructuring_history_offset
   .                and added the prefix first_ to restructuring_history_offset

   82-08-19 Davids: changed code to set the value of db_model.db_type to either
                    1 (vfile db) or 2 (page_file db) based on the value of
                    rsc.db_type instead of just always setting it to 1.

   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-10-04 Benjamin: reverted change of 80-11-10.
*/

/* PARAMETERS

   rsc_ptr (INPUT) pointer to control segment (contains rsc.temp_dir (database path))
   dbm_ptr (OUTPUT) pointer to db_model
   code (OUTPUT) error code

   */
%page;
	db_created_sw = OFF;

	on cleanup call tidy_up;			/* Set a cleanup handler */

	if rsc.meter_sw | rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, MODULE_NAME, ON, "");

	call expand_pathname_ (rsc.temp_dir, dir, db_ent, code);
	if code ^= 0 then call error (code);

	call hcs_$append_branchx (dir, db_ent, 11, RINGS, /* Create the data base directory */
	     get_group_id_$tag_star (), 1, 0, 0, code);
	if code ^= 0 then call error (code);

	db_created_sw = ON;				/* Remember database directory was created */

	call hcs_$append_branchx (rtrim (dir) || "&gt;" || rtrim (db_ent), /* create the submodel_dir */
	     mrds_data_$submodel_dir_name, 11, RINGS, get_group_id_$tag_star (), 1, 0, 0, code);
	if code ^= 0 then call error (code);

	call hcs_$make_seg (rsc.temp_dir, "db_model", "", 10, dbm_ptr, code); /* Create the db_model */
	if dbm_ptr = null then call error (code);

	else call init_db_model;

	call mdbm_util_$create_control_segment (rsc.temp_dir, dbc_ptr, dbc_bit_count, code);
	if code ^= 0 then call error (code);


exit:	if rsc.meter_sw | rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, MODULE_NAME, OFF, "");

	return;					/* Only exit from this procedure */
%page;
error: proc (cd);

	dcl     cd		 fixed bin (35);

	call tidy_up;
	code = cd;				/* Set return error code */
	goto exit;

     end error;





tidy_up: proc;					/* Clean up procedure */

	if db_created_sw				/* If database created then delete it */
	then do;
		delete_options.force = ON;
		delete_options.question = OFF;
		delete_options.directory = ON;
		delete_options.segment = ON;
		delete_options.link = ON;
		delete_options.chase = ON;
		delete_options.raw = OFF;
		delete_options.library = OFF;
		delete_options.mbz = OFF;

		call delete_$path (dir, db_ent, string (delete_options), MODULE_NAME, code);

	     end;

     end tidy_up;
%page;
init_db_model: procedure;

/* This procedure initializes the db_model */

	db_model_path = rtrim (rsc.temp_dir) || "&gt;db_model";

	db_model.version = mdbm_data_$current_version;
	db_model.dbm_area = empty;
	db_model.version_ptr = set_version ();
	db_model.changer_ptr = set_change_time ();
	db_model.uniq_sw_name = unique_chars_ ("0"b) || ".mrds" || copy (" ", 32 - 15 - 5); /* unique switch name */
	db_model.db_type_flags.vfile_type =
	     ^rsc.db_relation_mode_flags.dm_file_type;
	db_model.db_type_flags.concurrency_on =
	     rsc.db_relation_mode_flags.concurrency_on;
	db_model.db_type_flags.transactions_needed =
	     rsc.db_relation_mode_flags.protection_on;
	db_model.db_type_flags.rollback_on =
	     rsc.db_relation_mode_flags.rollback_on;
	db_model.consistant = "0"b;
	db_model.mdbm_secured = rsc.secure;		/* on if cmdb -secure option */
	db_model.copy_good = "0"b;
	db_model.reserved = "0"b;
	db_model.num_rels = 0;
	db_model.blk_file_id_len = 0;
	db_model.unblk_file_id_len = 0;
	db_model.num_blk_files = 0;
	db_model.num_unblk_files = 0;
	db_model.num_domains = 0;
	db_model.num_dyn_links = 0;
	db_model.max_max_tuples = 0;
	db_model.pad_1 = 0;
	db_model.pad_2 = 0;
	db_model.file_ptr = NULL_OFFSET;
	db_model.domain_ptr = NULL_OFFSET;
	db_model.unreferenced_attribute_ptr = NULL_OFFSET;
	db_model.unused_offsets (*) = NULL_OFFSET;
	db_model.last_restructuring_history_offset = NULL_OFFSET;
	db_model.inconsistent_message_offset = NULL_OFFSET;
	db_model.first_restructuring_history_offset = NULL_OFFSET;

	return;
     end init_db_model;
%page;
set_version: procedure () returns (bit (18));

/* fill in the version structure */
/* this major number was 7 for the MR8 mrds release,
   it was changed to 8 on 80-11-06, to signify the addition of the submodel_dir to the architecture */

	call mrds_rst_model_alloc (rsc_ptr, db_model_path, VERSION_STATUS, version_status_ptr);

	if version_status_ptr = null () then
	     call model_overflow ("version_status");
	else do;


/* CMDB/RMDB source code version */

		version_status.cmdb_rmdb.major = mrds_data_$current_version_status; /* MR8.0 */
		version_status.cmdb_rmdb.minor = 0;
		version_status.cmdb_rmdb.modification = " ";

/* database model version */

		version_status.model.major = mrds_data_$current_version_status;
		version_status.model.minor = 0;
		version_status.model.modification = " ";

/* resultant model version */

		version_status.resultant.major = mrds_data_$current_version_status;
		version_status.resultant.minor = 0;
		version_status.resultant.modification = " ";

	     end;


	return (rel (version_status_ptr));

     end;
%page;
set_change_time: procedure () returns (bit (18));

/* fill in the user_id and time for the database creator */

	call mrds_rst_model_alloc (rsc_ptr, db_model_path, CHANGER, changer_ptr);

	if changer_ptr = null () then
	     call model_overflow ("changer");

	else do;

		changer.id = get_group_id_ ();
		changer.time = clock ();
		changer.next = NULL_OFFSET;		/* creator = last on list */

	     end;

	return (rel (changer_ptr));

     end;
%page;
model_overflow: procedure (struct_cause);

/* report mdb_model overflow, first time only */

	if rsc.model_overflow then ;
	else do;
		rsc.model_overflow = ON;

		call ioa_$rs ("^a^a^a^a", message, message_length,
		     "LOGIC ERROR in mrds_rst_create_db, the db_model area overflowed",
		     "while processing the structure """, struct_cause, """.");

		call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message));

	     end;



	declare struct_cause	 char (*);	/* either "changer", or "version_status" */

     end;
%page;
/* External entries */

	declare ioa_$rs		 entry options (variable); /* string manipulator */
	declare mrds_error_$rst_logic_error fixed bin (35) ext; /* program error */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error routine */
	declare mrds_rst_model_alloc	 entry (ptr, char (*), fixed bin, ptr); /* model allocation routine */
	declare unique_chars_	 entry (bit (*)) returns (char (15)); /* unique char string routine */
	dcl     mdbm_util_$create_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35));
	declare dbc_bit_count	 fixed bin (24);
	dcl     mdbm_data_$current_version ext fixed bin (35);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_group_id_	 entry returns (char (32));
	dcl     clock		 builtin;
	dcl     addr		 builtin;
	dcl     copy		 builtin;
	dcl     fixed		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;
	dcl     string		 builtin;
	dcl     delete_$path	 entry (char (*), char (*), bit (36) aligned, char (*),
				 fixed bin (35));
	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_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*));
	dcl     MODULE_NAME		 char (18) int static options (constant) init ("mrds_rst_create_db");
	dcl     OFF		 bit (1) int static options (constant) init ("0"b);
	dcl     ON		 bit (1) int static options (constant) init ("1"b);
	dcl     RINGS		 (3) fixed bin (3) init static options (constant) init (7, 7, 7); /* Ring brackets */


	declare message		 char (120) varying;/* specifics of error message */
	declare message_length	 fixed bin (21);	/* length of specifics string */
	dcl     dir		 char (168);	/* Directory superior to data base */
	declare db_model_path	 char (168);	/* path down to db_model segment */
	declare mrds_data_$current_version_status fixed bin (35) ext; /* display_mrds_dm needs to know about this */
	declare mrds_data_$submodel_dir_name char (16) ext; /* common place to get name of submodel dir */
	dcl     db_ent		 char (32);	/* Data base directory name */
	dcl     code		 fixed bin (35);	/* error code */
	dcl     db_created_sw	 bit (1);		/* ON =&gt; Db_directory was created */
	dcl     (empty, null)	 builtin;
	dcl     NULL_OFFSET		 bit (18) unal int static options (constant) init ("111111111111111111"b);
	dcl     cleanup		 condition;
	dcl     sys_info$max_seg_size	 ext fixed bin (35);
%page;
%include mrds_rst_struct_types;
%page;
%include mdbm_db_model;
%page;
%include mdbm_dbc;
%page;
%include mrds_rst_rsc;
%page;
%include delete_options;

     end mrds_rst_create_db;

���



		    mrds_rst_create_rsc.pl1         04/18/85  1454.7r w 04/18/85  0909.0       61362



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

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

mrds_rst_create_rsc: create_rsc: proc (input_dir, rsc_ptr, code);


/* This procedure creates and initializes the temporary rsc working storage
   under the given directory, as a directory containing segments allocated
   according to a storage classification of data functional use */



/* Initially written by R. D. Lackey August 1978 */
/* modified by Jim Gray 2/19/79, to change structure of rsc to directory with extensible area segments */
/* MODIFIED by Jim Gray - - Jan. 1980, to add initialization of foreign_key, blocked file, and restructuring allow flags. */
/* Modified by Jim Gray - - Feb. 1980, to add init of command level bit */
/* Modified by Jim Gray - - 80-11-06, to add inititalization of rsc.secure bit */

/* 81-05-18 Jim Gray : added initialization of rsc.max_attrs bit */
/* 82-07--6 Roger Lackey : changed call to mu_define_area to 
   mdbm_util_$mu_define_area for binding*/





/* input_dir (INPUT PARAMETER) pathname where rsc directory is to be appended */
/* rsc_ptr    (OUTPUT PARAMETER) pointer to rsc segment */
/* code	(OUTPUT PARAMETER) error code from append_branchx or make_seg or define_area_ */
%page;
/* get a new directory under the given pathname in which to put
   the working storage segments, 1 common, and several extensible areas */

	dir_name = unique_chars_ ("0"b) || ".rsc_dir";
	call hcs_$append_branchx (input_dir, dir_name,
	     01011b /* sma acl's */, rings, get_group_id_$tag_star (),
	     1 /* directory */, 0 /* copy_sw */, 0 /* bit_count */, code);
	if code ^= 0 then goto exit;


/* Create rsc common storage data segment */

	rsc_dir_name = rtrim (input_dir) || "&gt;" || dir_name;
	call hcs_$make_seg (rsc_dir_name, unique_chars_ ("0"b) || ".MRDS.rsc.rst", "", 10 /* rw acl's */, rsc_ptr, code);
	if code ^= 0 then goto exit;			/* Return with bad error code */


/* Initiallize all  the elements of the rsc structure */

	rsc.rsc_dir = rsc_dir_name;
	rsc.dbp = BLANK;
	rsc.temp_dir = BLANK;
	rsc.temp_dir_sw = OFF;
	rsc.db_quiesced_sw = OFF;
	rsc.o_db_open_sw = OFF;
	rsc.n_db_open_sw = OFF;
	rsc.listing_seg_sw = OFF;
	rsc.skip_scanner_conversion = OFF;
	rsc.cmdb_option = OFF;
	rsc.trace_sw = OFF;
	rsc.debug_sw = OFF;
	rsc.meter_sw = OFF;
	rsc.delete_db_sw = OFF;
	rsc.model_consistent_sw = OFF;
	rsc.physical_started_sw = OFF;
	rsc.physical_complete_sw = OFF;
	rsc.model_overflow = OFF;
	rsc.max_files = OFF;
	rsc.allow_foreign_keys = OFF;
	rsc.foreign_key_seen = OFF;
	rsc.allow_blocked_files = OFF;
	rsc.blocked_file_seen = OFF;
	rsc.allow_restructuring = OFF;
	rsc.command_level = ON;
	rsc.secure = OFF;
	rsc.max_attrs = OFF;
	rsc.severity_high = 0;
	rsc.phase = 0;
	rsc.h_o_seg_info_ls_ptr = null;
	rsc.h_n_seg_info_ls_ptr = null;
	rsc.h_gfile_ptr = null;
	rsc.h_gdom_ptr = null;
	rsc.h_gattr_ptr = null;
	rsc.h_grel_ptr = null;
	rsc.h_glink_ptr = null;
	rsc.o_dm_ptr = null;
	rsc.n_dm_ptr = null;
	rsc.o_fn_hdr_ptr = null;
	rsc.source_seg_ptr = null;
	rsc.listing_iocb_ptr = null;
	rsc.directive_ptr = null;
	rsc.stmt_ptr = null;
	rsc.trace_metering_iocb_ptr = null;
	rsc.wa = empty ();				/* non-extensible common area for static storage */



/* get segments and initialize them as extensible areas */

	rsc.tree_node_area_ptr = area_init ("tnode");
	rsc.tree_data.seg_info_area_ptr = area_init ("seg_in");
	rsc.tree_data.gl_area_ptr = area_init ("gl");
	rsc.tree_data.sl_area_ptr = area_init ("sl");
	rsc.parse_info_area_ptr = area_init ("parse");
	rsc.static_info_area_ptr = area_init ("static");
	rsc.variable_length_area_ptr = area_init ("variab");
	rsc.other_area_ptr = area_init ("other");


exit:	return;
%page;
area_init: procedure (class_word) returns (ptr);

/* first get a segment to use as an area */

	call hcs_$make_seg (rsc.rsc_dir, unique_chars_ ("0"b) || ".MRDS." || class_word,
	     "", 10 /* rw acl's */, model_seg_ptr, code);
	if code ^= 0 then goto exit;

/* set up the segment header, get the area pointer */

	model_seg_ptr -&gt; model_seg.struct_offset = NULL_OFFSET;
	model_seg_ptr -&gt; model_seg.padding = 0;
	model_area_ptr = pointer (model_seg_ptr, size (model_seg));

/* routine to initialize the area_info for the define area call */

	call mdbm_util_$mu_define_area (model_area_ptr, sys_info$max_seg_size - size (model_seg),
	     "MRDS." || class_word,
	     "1"b /* extensible */, "0"b /* freeing */, "0"b, "0"b /* no zeroing */, code);
	if code ^= 0 then goto exit;

	return (model_area_ptr);


	dcl     class_word		 char (6) varying;	/* name for class type of storage in segment */

     end;
%page;
	dcl     (addr, empty, fixed, pointer, rel, rtrim) builtin;
	dcl     rsc_dir_name	 char (168);	/* pathname of rsc directory */
	dcl     dir_name		 char (32);	/* name of rsc directory entry */
	dcl     input_dir		 char (*);
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     rings		 (3) fixed bin (3) init ((3) 7);
	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_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     NULL_OFFSET		 bit (18) init ((18)"1"b);
	dcl     mdbm_util_$mu_define_area entry (ptr, fixed bin (18), char (11), /* does call to define_area_ */
				 bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     BLANK		 char (1) int static options (constant) init (" ");
	dcl     OFF		 bit (1) int static options (constant) init ("0"b);
	dcl     ON		 bit (1) int static options (constant) init ("1"b);
	dcl     code		 fixed bin (35);	/* (INPUT PARAMETER) eror code */
	dcl     null		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;
%page;
%include mdbm_seg_area;
%page;
%include mrds_rst_rsc;
%page;
%include area_info;
%page;
%include area_structures;



     end mrds_rst_create_rsc;
��



		    mrds_rst_domain_handler.pl1     10/16/86  1551.9r w 10/16/86  1145.0      123399



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - october 1978
   Modified by RDL	October 1978 	to add define and cmdb code
   Modified by Jim Gray 3/20/79 - to handle to versions of model and working storage (rsc)

*/


mrds_rst_domain_handler: procedure (rsc_ptr, list_ptr);


/* DESCRIPTION:

   this routine is called by the RMDB/CMDB parser to build/alter
   the mrds database model based on the parse information passed
   to it, and which directive called it.(undefine, define, redefine, cmdb)
   it will be passed only domain information of one of two forms,
   either a single name to delete, or a structure for defining
   a new domain, or redefining an existing domain.

*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   list_ptr - - (input) pointer to either a 32 character domain name,
   or to a parse_info domain structure describing the domain.
   the first only occurs with the undefine directive.

   mdbm_db_model - - (output) the updated model with it's domain information altered

   gloabl lists - - (output) the database entity list reflecting the changes
   to the model(used for ease of reference during RMDB/CMDB)

   error_output - - (output) via calls to mrds_rst_error for error messages

*/

/* REMAINING ERRORS:

   undefine:

   the domain name may be the &lt;error_symbol&gt;(this may be ignored)
   the domain may not be defined in the model

   define, cmdb:

   the domain name may be the &lt;error_symbol&gt;(this can be ignored)
   the domain may be already defined in the model.
   the check option stack may have bad(unconverted) constants(this can be ignored)
   the encode_proc, decode_proc, check_proc pathnames may be invalid
   (i.e. may not be able to initiate them)

   redefine:

   the domain name may be the &lt;error_symbol&gt;(this can be ignored).
   the domain may not be defined in the model.
   same check and procedure errors as under define.

   note: where it is stated "(this may be ignored)", this is because
   a previous error has been issued that will prevent the bad information
   from ever being built into and used in a valid db_model.

*/

Start:

	directive_ptr = rsc.directive_ptr;		/* So we can use directive str */
	stmt_ptr = rsc.stmt_ptr;

	if directive.type = UNDEFINE then do;
		delete_name_ptr = list_ptr;
		domain_name = delete_name.overlay;
	     end;
	else do;
		domain_ptr = list_ptr;
		domain_name = domain.name;
	     end;

	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_domain_handler", ON /* entrance */, (domain_name));

	if directive.type = UNDEFINE then do;		/* Undefine the domain */

/* This is not implemented yet so issue an error */

		if stmt (directive.type).domain.number &gt; 0 then ;
		else call error (2, mrds_error_$rst_undone_option,
			"The domain handler will not implement the ""undefine"" directive" ||
			" until a later release.");

	     end;					/* END of undefine */

	if directive.type = DEFINE | directive.type = CMDB then do; /* Define or cmdb section */

		dbm_ptr = rsc.n_dm_ptr;		/* db_model pointer */

		call mrds_rst_list_element$add /* Add to global domain list */
		     (domain.name, MAIN_LIST, rsc_ptr, rsc.h_gdom_ptr, gl_ptr, code);
		if code ^= 0 then do;		/* Something wrong happened */
			if code = mrds_error_$rst_list_duplicate then
			     call error (2, mrds_error_$domain_already_defined,
				"The domain """ || rtrim (domain.name) ||
				""" given on line " || ltrim (char (domain.line_num)) ||
				" is already defined" || ", the duplicate will be ignored!!");
			else call error (3, code, "Adding " || rtrim (domain.name) || " to gdom_list");
		     end;

/* Domain was not found in gdom list so it was added to the gdom list */



/* Fill in list elements in gdom list entry for this domain */

		gl.type = MAIN_LIST;
		gl.name = domain.name;
		gl.item_info_ptr = null ();		/* no domain_info pointer yet */
		gl.parse_info_ptr = domain_ptr;
		gl.other_info_ptr = dbm_ptr;
		gl.item_sub_list_ptr = null;		/* No attributes attached to this domain yet */
		gl.file_info_ptr = null;
		gl.file_model_ptr = null;
		gl.affected = ON;
		gl.undefine = OFF;
		gl.redefine = OFF;
		if directive.type = DEFINE then do;
			gl.define = ON;
			gl.cmdb = OFF;
		     end;
		else do;
			gl.define = OFF;
			gl.cmdb = ON;
		     end;
		gl.superior_assigned = OFF;		/* no referencing relations yet */
		gl.inferior_assigned = OFF;		/* No attributes assigned to this domain yet */
		gl.complete = ON;			/* domain info assigned */
		gl.consistant = ON;			/* assume innocent until proven guilty */
		gl.reserved = OFF;

/* allocate a domain info for this domain */

		db_model_path = rtrim (rsc.temp_dir) || "&gt;db_model";
		call mrds_rst_model_alloc (rsc_ptr, db_model_path, DOMAIN_INFO, di_ptr);

		if di_ptr = null () then
		     call model_overflow ("domain_info");
		else do;


			call init_domain_info;	/* Set all default values */
			gl.item_info_ptr = di_ptr;
			call assign_domain_info;	/* Fill in domain_info with info from domain structure */

/* link the domain info into to the list in definition order */

			if db_model.domain_ptr = NULL_OFFSET then
			     db_model.domain_ptr = rel (di_ptr);
			else do;
				if stmt (directive.type).domain.number &gt; 0 then ; /* not first time */
				else do;		/* first time, get end of current list */
					last_di_ptr = pointer (dbm_ptr, db_model.domain_ptr);
					do while (last_di_ptr -&gt; domain_info.fwd_thread ^= NULL_OFFSET);
					     last_di_ptr = pointer (dbm_ptr, last_di_ptr -&gt; domain_info.fwd_thread);
					end;
				     end;
				last_di_ptr -&gt; domain_info.fwd_thread = rel (di_ptr); /* set old last pointing to new last */
			     end;
			last_di_ptr = di_ptr;	/* remember new last place on list */


/* count up the number of domains */

			db_model.num_domains = db_model.num_domains + 1;

		     end;

	     end;					/* define or cmdb section */

	if directive.type = REDEFINE then do;		/* Redefine section */

/* THis directive is not implemented yet -- so issue error msg */

		if stmt (directive.type).domain.number &gt; 0 then ;
		else call error (2, mrds_error_$rst_undone_option,
			"The domain handler will not implement the ""redefine"" directive" ||
			" until a later release.");

	     end;					/* END   of redefine section */

exit:						/* Only exit from procedure */
	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_domain_handler", OFF /* exit */, (domain_name));
	return;

assign_domain_info: proc;

/* This procedure assignes the information supplied in domain (from parser)
   to the domain_info elements */

	domain_info.name = domain.name;
	domain_info.changer_ptr = db_model.changer_ptr;
	domain_info.db_desc = domain.descriptor;
	domain_info.user_desc = domain.descriptor;
	domain_info.ave_len = domain.varying_avg_length;

	if domain.options then do;			/* Some options were supplied */

		if domain.check.flag then do;		/* check option */
			if domain.check.stack_ptr = null then domain_info.ck_stack_ptr = NULL_OFFSET;
			else domain_info.ck_stack_ptr = rel (domain.check.stack_ptr);
			domain_info.nck_items = domain.check.stack_size;

			call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option,
			     "The ""-check"" option given for domain """ || rtrim (domain.name) ||
			     """ on line " || ltrim (char (domain.line_num)) ||
			     " will not be implemented until a later release.");
		     end;


		if domain.check_proc.flag then do;	/* check_proc option */
			domain_info.check_path_ptr = set_path_entry ((domain.check_proc.path),
			     (domain.check_proc.entry));
		     end;

		if domain.encode_proc.flag then do;	/* encode_proc option */
			domain_info.encd_path_ptr = set_path_entry ((domain.encode_proc.path),
			     (domain.encode_proc.entry));
		     end;

		if domain.decode_proc.flag then do;	/* decode_proc option */
			domain_info.decd_path_ptr = set_path_entry ((domain.decode_proc.path),
			     (domain.decode_proc.entry));
		     end;

		if domain.decode_dcl.flag then do;	/* decode_dcl option */
			domain_info.user_desc = domain.decode_dcl.descriptor;
		     end;

	     end;					/* END   if domain.options then do    */


     end assign_domain_info;

error: proc (sev, cd, msg);

	dcl     sev		 fixed bin;	/* (INPUT) Severity level */
	dcl     cd		 fixed bin (35);	/* (INPUT) error code */
	dcl     msg		 char (*);	/* (INPUT)  specific error information */

	call mrds_rst_error (rsc_ptr, sev, cd, msg);
	goto exit;

     end error;

init_domain_info: proc;

	domain_info.name = " ";
	domain_info.db_desc_is_ptr = OFF;
	domain_info.user_desc_is_ptr = OFF;
	domain_info.db_desc = OFF;
	domain_info.user_desc = OFF;
	domain_info.no_conversion = OFF;
	domain_info.procedures_present = OFF;
	domain_info.reserved = OFF;
	domain_info.nck_items = 0;
	domain_info.ave_len = 0;
	domain_info.fwd_thread = NULL_OFFSET;
	domain_info.ck_stack_ptr = NULL_OFFSET;
	domain_info.check_path_ptr = NULL_OFFSET;
	domain_info.encd_path_ptr = NULL_OFFSET;
	domain_info.decd_path_ptr = NULL_OFFSET;
	domain_info.str_before_path_ptr = NULL_OFFSET;
	domain_info.str_err_path_ptr = NULL_OFFSET;
	domain_info.str_after_path_ptr = NULL_OFFSET;
	domain_info.get_before_path_ptr = NULL_OFFSET;
	domain_info.get_err_path_ptr = NULL_OFFSET;
	domain_info.get_after_path_ptr = NULL_OFFSET;
	domain_info.mod_before_path_ptr = NULL_OFFSET;
	domain_info.mod_err_path_ptr = NULL_OFFSET;
	domain_info.mod_after_path_ptr = NULL_OFFSET;
	domain_info.unused_1 = NULL_OFFSET;
	domain_info.unused_2 = NULL_OFFSET;
	domain_info.changer_ptr = NULL_OFFSET;


     end init_domain_info;

set_path_entry: procedure (path, entry) returns (bit (18));

/* routine to allocate and fill in the path_entry structure, and return the offset to it */

	call mrds_rst_model_alloc (rsc_ptr, db_model_path, PATH_ENTRY, path_entry_ptr);

	if path_entry_ptr = null () then do;
		path_entry_ptr = pointer (null (), NULL_OFFSET);
		call model_overflow ("path_entry");
	     end;

	else do;

/* fill in the supplied path and entry names */

		path_entry_ptr -&gt; path_entry.path = path;
		path_entry_ptr -&gt; path_entry.entry = entry;

	     end;

	return (rel (path_entry_ptr));



	declare path		 char (168);	/* input pathname */
	declare entry		 char (32);	/* input entryname */

     end;

model_overflow: procedure (struct_cause);

/* report model capacity exceeded, first time only */

	if rsc.model_overflow then ;
	else do;
		rsc.model_overflow = ON;

		call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length,
		     "The domain """, domain.name, """ on line", domain.line_num,
		     "caused an overflow of the db_model while processing the structure """,
		     struct_cause, """.");

		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message));

	     end;


	declare struct_cause	 char (*);	/* either "domain_info", or "path_entry" */

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

	dcl     NULL_OFFSET		 bit (18) unal int static options (constant) init ("111111111111111111"b);
	dcl     ON		 bit (1) internal static options (constant) init ("1"b); /* true state */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b); /* false */
	dcl     list_ptr		 ptr;		/* (INPUT PARAMETER)  */
	declare last_di_ptr		 ptr internal static; /* pointer to last domain_info in list */

	declare db_model_path	 char (168);	/* path name down to db_model */
	declare message_length	 fixed bin (21);	/* length of error specifics message */
	dcl     code		 fixed bin (35);	/* Error code */
	dcl     sys_info$max_seg_size	 ext fixed bin (35);/* System constant */
	declare mrds_rst_model_alloc	 entry (ptr, char (*), fixed bin, ptr); /* model alloc routine */
	dcl     char		 builtin;
	dcl     ltrim		 builtin;
	dcl     pointer		 builtin;

	declare message		 char (256) varying;/* specifics of error occurence */
	declare domain_name		 char (32);	/* input name for metering */

	declare mrds_error_$rst_model_limit fixed bin (35) ext; /* model capacity exceededd */
	dcl     mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */
	dcl     mrds_error_$rst_list_duplicate ext fixed bin (35); /* Duplicate found in attemp to add to list */
	dcl     mrds_error_$domain_already_defined ext fixed bin (35);
	declare ioa_$rs		 entry options (variable); /* string manipulator */
	dcl     mrds_rst_list_element$add entry (char (32) aligned, fixed binary, ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */

%include mrds_rst_rsc;
%include mrds_rst_struct_types;
%include mrds_rst_semantics;
%include mrds_rst_global_lists;
%include mrds_rst_parse_info;
%include mdbm_db_model;

     end;
�



		    mrds_rst_error.pl1              04/18/85  1454.7r w 04/18/85  0908.8       62010



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

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

/* HISTORY:

   Originally written by roger lackey
   Modified by Jim Gray - - Feb. 1980, to add signaling of th condition
   mrds_rst_error, when rsc.command_level is off, indicating that CMDB
   was called from a subroutine level, and thus not to output
   errors to error_output.
   Modified by Jim Gray - - Mar. 1980, to fix formatting of specifics message,
   so that no blanks in a 79 char length of text are handled better.

*/

mrds_rst_error: proc (rsc_ptr, severity, err_code, specifics_text);

/*	PARAMETERS	*/

/* rsc_ptr ptr;				/ Pointer to rst (restructuring ) control segment */
	dcl     severity		 fixed bin;	/* (INPUT)
						   1 = Warning level  error detected
						   2 = syntax error detected
						   3 =
						   4 = Fatal error during logical phase of restructuring
						   5 = fatal error during physical restructuring */

	dcl     err_code		 fixed bin (35);	/* (INPUT) error code for com_err_ */
	dcl     specifics_text	 char (*);	/* (INPUT) associated specific message */

/*
   .                        BEGIN_DESCRIPTION
   this routine is a common error reporting routine for create/restructure_mrds_db
   it's primary purpose is to format error messages for output on the users console.
   The error messages include a severity level, the error table message,
   plus one or more lines of length &lt;= 80, with specifics about this error.
   It also can return simple a condition info with the status code,
   instead of doing an user error output(except for the listing segment)
   if the call was from a subroutine level.
   .                        END_DESCRIPTION
*/
%page;
	call convert_status_code_ (err_code, shortinfo, longinfo);

	if severity &lt; 2 then err_msg.type = "WARNING ";
	else err_msg.type = "*ERROR*";

	err_msg.severity_level = severity;

	err_msg.msg1 = longinfo;
	specifics = specifics_text || NL;

	call format_specifics_message ();

	code = 0;					/* init */

	if rsc.command_level then do;			/* called as a command, not from subroutine level */
		call iox_$put_chars (iox_$error_output, addr (err_msg), length (string (err_msg)), code);
		call iox_$put_chars (iox_$error_output, addrel (addr (specifics), 1), length (specifics), code);
	     end;
	else do;

/* fill in the condition information for find_condition_info_,
   then signal the condition mrds_rst_error for mrds_dm_create_db to handle,
   since this was a call from a subroutine interface */

		mrds_error_cond_info.length = size (mrds_error_cond_info);
		mrds_error_cond_info.version = 1;
		mrds_error_cond_info.cant_restart = "0"b;
		mrds_error_cond_info.default_restart = "1"b;
		mrds_error_cond_info.pad = "0"b;
		mrds_error_cond_info.info_string = substr (specifics, 1, min (256, length (specifics)));
		mrds_error_cond_info.status_code = err_code;
		mrds_error_cond_info.severity = severity;
		mrds_error_cond_info.severity_high = rsc.severity_high;

		call signal_ ("mrds_rst_error", null (), addr (mrds_error_cond_info));

	     end;

	if code = 0 then
	     if rsc.listing_seg_sw then do;
		     call iox_$put_chars (rsc.listing_iocb_ptr, addr (err_msg), length (string (err_msg)), code);
		     call iox_$put_chars (rsc.listing_iocb_ptr, addrel (addr (specifics), 1), length (specifics), code);
		end;

	if code ^= 0 then do;
		if rsc.command_level then
		     call com_err_ (code, "mrds_rst_error");
		else call sub_err_ (code, "mrds_rst_error", "c", null (), 0, "Unable to output listing.");
	     end;

	rsc.severity_high = max (rsc.severity_high, severity);
%page;
format_specifics_message: procedure ();

/* routine to break long lines down to shorter ones by inserting
   new_lines where blanks appear, so that error messages will not be
   folded by the printing device. */

	i, pos = 1;

	do while (pos + 79 &lt; length (specifics));	/* Break into 79 char lines or less at a blank char */
	     i = index (reverse (substr (specifics, pos, 79)), BLANK);
	     if i ^= 0 then do;
		     substr (specifics, pos + 79 - i, 1) = NL;
		     pos = pos + 79 - i;
		end;
	     else do;				/* no blank in 79 chars, find first blank following */
		     pos = pos + 79;
		     i = index (substr (specifics, pos), BLANK);
		     if i ^= 0 then do;
			     substr (specifics, pos + i - 1, 1) = NL;
			     pos = pos + i;
			end;
		     else pos = length (specifics);	/* no blanks left, get out */
		end;

	end;

     end;
%page;

	dcl     code		 fixed bin (35);
	dcl     com_err_		 entry options (variable);
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     iox_$error_output	 ext ptr;
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     longinfo		 char (100) aligned;/* Long msg from convert status code */
	dcl     shortinfo		 char (8) aligned;	/* Short msg from convert status code */
	dcl     sys_info$max_seg_size	 ext fixed bin (35);
	declare signal_		 entry options (variable); /* passes cond_info structure upon signaling condition */

	declare 1 mrds_error_cond_info aligned,
%include cond_info_structure;

	2 severity fixed bin,
	     2 severity_high fixed bin;

	declare sub_err_		 entry options (variable);
	dcl     (addr, fixed, length, max, rel, size, string) builtin;
	dcl     (addrel, index, min, null, reverse, substr) builtin;

	dcl     BLANK		 char (1) int static options (constant) init (" ");
	dcl     NL		 char (1) int static options (constant) init ("
");
	dcl     (i, pos)		 fixed bin;



	dcl     1 err_msg		 aligned,
		2 lf0		 char (1) unal init ("
"),						/* Start with a line feed */
		2 type		 char (8) unal,	/* Type = WARNING or *ERROR*      */
		2 constant	 char (12) unal init ("OF SEVERITY "),
		2 severity_level	 pic "9" unal,	/* Severity numeric 1 to 5 see input parameter */
		2 lf1		 char (1) unal init ("
"),
		2 msg1		 char (100) unal,	/* Error message from error table */
		2 lf2		 char (1) unal init ("
");

	dcl     specifics		 char (256) varying unal; /* Additional err info */
%page;
%include mrds_rst_rsc;

     end mrds_rst_error;
��



		    mrds_rst_file_cleanup.pl1       04/18/85  1454.7r w 04/18/85  0909.1       55773



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

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

mrds_rst_file_cleanup:
     procedure (rsc_ptr);

/* DESCRIPTION:

   This  routine  is  invoked  to supply default unblocked files for relations
   which  have  had  no files specified for them.  it produces dummy file list
   structures identical to the input to mrds_rst_file_handler that have a file
   name equal to the relation name, and then calls the file handler to put the
   file models in place.



   PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   global  lists  -  - (input) searched for relations without files since they
   contain all database entities during RMDB/CMDB

   parse  info  structures  - - (output) via calls to mrds_rst_file_handler to
   build the file model as default for the given relation



   HISTORY:

   78-10-01 Jim Gray : Originally written.
   
   81-09-16  Rickie  E.   Brinegar:  changed  the  assignment  of  gl.name  to
   file.name  to  be  done via a rtrim to remove the substring range condition
   from compile.

*/
%page;
/* get semantic structure pointers */

	directive_ptr = rsc.directive_ptr;

/* if trace is on call metering */

	if ^rsc.trace_sw then
	     ;
	else do;
		if directive.type = DEFINE then
		     directive_mesg = "DEFINE";
		else if directive.type = REDEFINE then
		     directive_mesg = "REDEFINE";
		else directive_mesg = "CMDB";
		call
		     mrds_rst_meter (rsc_ptr, "mrds_rst_file_cleanup", "1"b /* in */,
		     directive_mesg);
	     end;

/* check for relations with no referencing files,
   any found get default files of the same name
   as that of the given relation, using unblocked file attributes */

	if directive.type = REDEFINE then do;
		call
		     ioa_$rs ("^a ^a", message, message_length,
		     "The file cleanup handler will not implement the ""redefine""",
		     "directive until a later release.");
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */,
		     mrds_error_$rst_undone_option, (message));
	     end;
	else do;

/* initialize the successor function to get the first relation on the
   global list of relations in the database */

		root_ptr = rsc.h_grel_ptr;
		node_ptr = root_ptr;		/* convention for first on list */
		success = "1"b;			/* do at least one loop */

		do while (success);

		     call
			mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr,
			successor_parent_ptr, success);

		     if ^success then
			;			/* success off =&gt; no more in list */
		     else do;			/* next relation found */

			     node_ptr = successor_ptr;/* get pointer to next on list after last one */
			     gl_ptr = node_ptr -&gt; node.data; /* get element portion from tree head */

			     if gl.superior_assigned then
				;		/* file present for this relation */
			     else do;		/* none found, set default file */

/* make believe we are the parser, and that we
   just found an file definition of "rel_name(rel_name) -unblocked" */

				     call mrds_rst_rsc_alloc (rsc_ptr, FILE, file_ptr);
				     file.name = rtrim (gl.name); /* set relation name as file's */
				     file.type = 1; /* default file type = unblocked */
				     file.ppb = 0;	/* zero out blocked file parameters */
				     file.hbh = 0;
				     file.block = 0;
				     file.num_items = 1; /* one relation in file */
				     file.default = "1"b; /* not from source definition */
				     file.unused = "0"b;
				     file.line_num = 0;

/* set file relation list to one relation with this relation name */

				     call mrds_rst_rsc_alloc (rsc_ptr, ITEM, item_ptr);
				     file.i_ptr = item_ptr; /* link to file header */
				     item.name = gl.name; /* set relation name */
				     item.next = null (); /* no more in list */
				     item.unused = "0"b;
				     item.line_num = 0; /* dummy number */


/* define the file just prepared */

				     call mrds_rst_file_handler (rsc_ptr, file_ptr);

				end;

			end;

		end;

	     end;

/* call trace if metering is on */

	if ^rsc.trace_sw then
	     ;
	else call
		mrds_rst_meter (rsc_ptr, "mrds_rst_file_cleanup", "0"b /* out */,
		directive_mesg);
%page;
	declare ioa_$rs		 entry options (variable); /* string manipulation routine */
	declare mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* work area manager */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*));
						/* general error handler */
	declare message		 char (96) varying; /* specifics of error message */
	declare message_length	 fixed (21);	/* length of specifics message */
	declare mrds_error_$rst_undone_option fixed bin (35) external;
						/* unimplemented feature */
	declare directive_mesg	 char (8);	/* meter call message */
	declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1));
						/* get next on list routine */
	declare mrds_rst_file_handler	 entry (ptr, ptr);	/* file semantic routine */
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*));
						/* trace/meter routine */
	declare sys_info$max_seg_size	 fixed bin (35) external; /* system largest segment allowed */
	declare (fixed, addr, null, rel, rtrim) builtin;	/* functions known to pl1 */
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_global_lists;
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_parse_info;
%page;
%include mrds_rst_semantics;

     end;
���



		    mrds_rst_file_handler.pl1       10/16/86  1551.9r w 10/16/86  1143.7      376353



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - october 1978
   modified by Jim Gray - - July 1979 to add pl1 version of data alignment in tuple
   Modified by Jim Gray - - Dec. 1979, to  add consideration of packed decimal
   data types to pad_to_alignment_boundary routine.
   Modified by Jim Gray - - Dec. 1979, to make pad_to_alignment_boundary external
   procedure mdbm_util_$align_data_item, so other routines could use it.
   Modified by Jim Gray - - Jan. 1980, to disallow file statement, only default files are now allowed.
   Modified by Jim Gray - - April 1980, to remove abs. path in attach desc, so databsaes can be copied.
   Modified by Jim Gray - - Sept. 1980, to capture the use of reserved segment names
   "dbc" and "db_model" for this new architecture.

   81-04-30 Jim Gray : changed max number of relations creatable
   tobe dependent on mrds_data_$max_relations, rather than on a file_id_len
   that is constrained by the mdbm_tuple_id include file structure.

   81-05-01 Jim Gray : changed db_model.file_id_len to be taken from mrds_data_$max_relations

   81-05-18 Jim Gray : added check for max attrs per relation

   81-09-16 Davids: added the rtrim so that the code would compile with
   .        the prefix option stringsize.

   81-11-25 Davids: changed rel_info.id to  be  "000000000001"b  and
   file_info.file_id  to be "000000000000000000000000000000000001"b,
   For all relations and files. This was to prepare the way for easy
   restructuring,  i.e.  adding  and  deleteing relations and making
   temp_rels permanent.

   82-05-19 Davids: changed rel_info.nsec_inds to  rel_info.unused_3
   because  it  really wasn't the number of secondary indices in the
   relation it was always zero - it is still 0 but now it has a more
   descriptive name.

   82-06-25  R.  Harvey: changed to use mdbm_file_model_init.incl to
   speed up creation of databases.

   82-07-02 Roger Lackey: deleted
   file_model.num_rels = file_model.num_rels + 1;
   because it is now initialized in structured and only one relation per file
   is allowed now.

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


mrds_rst_file_handler:
     procedure (rsc_ptr, list_ptr);

/*
   .                       BEGIN_DESCRIPTION:
   this routine builds/alters the mrds database model file information
   and the global entity lists maintained by RMDB/CMDB,
   based upon the file data and directive that is active when
   called by the RMDB/CMDB parser.
   the directive may be undefine, define, redefine, or cmdb and the data is
   either a file name to be deleted, or a linked list of linked list of
   structures holding the file information and it's relation list
   .                       END_DESCRIPTION
*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   list_ptr - - (input) pointer to the single file name to be deleted(undefine only) or to the
   file structure headed list of relation structures

   database model - - (output) updated model with altered file information

   global lists - - (output) the list of database entities, updated
   according to directive and data

   error_output - - (output) via mrds_rst_error calls, of error messages
*/

/* REMAINING ERRORS:


   undefine:

   the file name may be the &lt;error_symbol&gt;(this may be ignored)
   the file may not be defined in the database

   define, cmdb:

   the file name may be the &lt;error_symbol&gt;(this may be ignored)
   one of the relation names may be the &lt;error_symbol&gt;(this may be ignored)
   the file may already be defined in the database
   a relation may not be defined in the database
   a relation may reside in a file already
   the file/relation max_tuples may not be set
   the file type may conflict with the max_tuples option values given

   redefine:

   same as define, except file name may not be defined in the database
   or the relation(s) may reside in other than the given file

   note: "(this may be ignored)" means a previous error will prevent
   a database model with erroneous information from being built

*/

/* set semantic structure pointers */

	stmt_ptr = rsc_ptr -&gt; rsc.stmt_ptr;
	directive_ptr = rsc_ptr -&gt; rsc.directive_ptr;

	if directive.type = UNDEFINE then do;		/* input structure depends on direcitve */
		delete_name_ptr = list_ptr;
		file_name = rtrim (delete_name.overlay);/* CHANGE 81-09-16 */
	     end;
	else do;
		file_ptr = list_ptr;
		file_name = file.name;
	     end;

/* call trace if metering is on */

	if ^rsc.trace_sw then
	     ;
	else call
		mrds_rst_meter (rsc_ptr, "mrds_rst_file_handler", IN, file_name);

/* check on which directive called us */

	if directive.type = UNDEFINE | directive.type = REDEFINE then do;
		if stmt (directive.type).file.number &gt; 0 then
		     ;				/* not first time */
		else do;				/* first time only, issue error */
			call
			     ioa_$rs ("^a ^a", message, message_length,
			     "The file handler will not implement ""undefine"" or ""redefine"""
			     , "directives until a later release.");
			call
			     mrds_rst_error (rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_undone_option, (message));
		     end;
	     end;
	else do;

/* define or cmdb directive was caller, process newly defined file */

		if file.default then
		     ;				/* called from file cleanup to give default file for rels */
		else if rsc.allow_blocked_files then
		     ;
		else if rsc.blocked_file_seen then
		     ;
		else do;
			rsc.blocked_file_seen = ON;
			call
			     ioa_$rs ("^a", message, message_length,
			     "The file statment will not be implemented until a later release."
			     );
			call
			     mrds_rst_error (rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_undone_option, (message));
		     end;


		call define_file ();

	     end;

/* call the trace routine if metering is turned on */

	if ^rsc.trace_sw then
	     ;
	else call
		mrds_rst_meter (rsc_ptr, "mrds_rst_file_handler", OUT, file_name);

define_file:
     procedure ();

/* routine to build the model for this file according to it's definition */

	error_mode = OFF;

/* check that files defined in the source do not use relation names */

	if file.default then
	     ;					/* file from cleanup handler */
	else do;					/* from source */

		call
		     mrds_rst_tree_search ((file.name), rsc.h_grel_ptr, node_ptr,
		     parent_ptr, success);

		if ^success then
		     ;				/* not a relation name */
		else do;				/* bad name, do a fixup */
			error_mode = ON;		/* set special provisions for detecting all errors */
			call
			     ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The file """,
			     file.name, """ on line", file.line_num,
			     "has the same name as a relation, only default files may have relation names!!"
			     );
			call
			     mrds_rst_error (rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_dup_file, (message));
			call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* get dummy version not in list */
		     end;
	     end;

/* make sure the file is not already in the database or previously defined(if above error did'nt occur) */

	if error_mode then
	     error_code = 0;
	else call
		mrds_rst_list_element$add ((file.name), MAIN_LIST, rsc_ptr,
		rsc.h_gfile_ptr, gl_ptr, error_code);

	if error_code = 0 then
	     ;					/* normal processing of good file */
	else do;
		error_mode = ON;			/* make special provisions so all errors are detected */
		call
		     ioa_$rs ("^a^a^a ^d ^a", message, message_length, "The file """,
		     file.name, """ on line", file.line_num,
		     "is already defined in the database, duplicate names are not allowed!!"
		     );
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_dup_file,
		     (message));
		call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy version not in list */
	     end;

/* check for reserved segment names (due to db architecture) being used for file name */

	if file.name ^= "dbc" &amp; file.name ^= "db_model" then
	     ;
	else do;
		error_mode = ON;			/* use unique name instead of reserved name */
		if file.default then
		     call
			ioa_$rs ("^a^a^a", message, message_length,
			"The relation name """, file.name,
			""" is a reserved name in this database architecture.");
		else call
			ioa_$rs ("^a^a^a ^d ^a", message, message_length,
			"The file name """, file.name, """ given on line",
			file.line_num,
			"is a reserved name in this database architecture.");
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */,
		     mrds_error_$rst_reserved_name, (message));
	     end;

/* file was not found in list so it was added,
   link list element to list head and fill in the blanks */

	gl.type = MAIN_LIST;
	gl.name = file.name;
	gl.item_info_ptr = null ();			/* no file_info yet */
	gl.parse_info_ptr = file_ptr;
	gl.other_info_ptr = gl_ptr;
	gl.item_sub_list_ptr = null ();		/* no relations yet */
	gl.file_info_ptr = null ();			/* no file model defined to hold file yet */
	gl.file_model_ptr = null ();
	gl.affected = ON;
	gl.undefine = OFF;
	gl.redefine = OFF;
	if directive.type = DEFINE then do;
		gl.define = ON;
		gl.cmdb = OFF;
	     end;
	else do;					/* CMDB directive */
		gl.define = OFF;
		gl.cmdb = ON;
	     end;
	gl.superior_assigned = OFF;			/* no file model for this file yet */
	gl.inferior_assigned = OFF;			/* no relations for this file yet */
	gl.complete = OFF;				/* file is not formatted yet */
	gl.consistant = ON;				/* assume innocent until proven guilty */
	gl.reserved = OFF;

/* build the file model and file_info for this file */

	call load_file_model ();

/* process the list of relations for this file */

	if ^gl.superior_assigned then
	     ;
	else do;

		call file_relation_handler ();

/* compute parameters for blocked files, now that max_tuples and tuple sizes are known */

		if ^gl.inferior_assigned then
		     gl.consistant = OFF;

/* check for too many files or too many tuples */

		call check_file_size_and_number ();

	     end;

     end;

file_relation_handler:
     procedure ();

/* check each relation in the list for this file */

	max_tuples = 0;
	item_ptr = file.i_ptr;			/* get first on list of this file's relations */
	do while (item_ptr ^= null ());

/* make sure that the given relation is defined in the database */

	     call
		mrds_rst_tree_search (item.name, rsc.h_grel_ptr, node_ptr,
		parent_ptr, success);

	     if ^success then do;			/* not found */
		     call
			ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length,
			"The relation """, item.name, """ on line", item.line_num,
			"given for file """, file.name,
			""" has not been defined in the database.");
		     call
			mrds_rst_error (rsc_ptr, 2 /* severity */,
			mrds_error_$rst_undef_rel, (message));
		end;
	     else do;
		     rel_gl_ptr = node_ptr -&gt; node.data;/* get relation global element pointer */
		     relation_ptr = rel_gl_ptr -&gt; gl.parse_info_ptr; /* get relation declaration */

/* check that this relation is not already in some file */

		     if ^rel_gl_ptr -&gt; gl.superior_assigned then
			;
		     else do;
			     call
				ioa_$rs ("^a^a^a ^d ^a^a^a^a^a", message, message_length,
				"The relation """, relation.name, """ on line",
				relation.line_num, "given in file """, file.name,
				""" is already defined as belonging to file """,
				rel_gl_ptr -&gt; gl.other_info_ptr -&gt; gl.name,
				""",  moving relations is not allowed!!");
			     call
				mrds_rst_error (rsc_ptr, 2 /* severity */,
				mrds_error_$rst_rel_has_file, (message));
			end;
		     rel_gl_ptr -&gt; gl.superior_assigned = ON; /* file present for this relation */
		     rel_gl_ptr -&gt; gl.file_info_ptr = fi_ptr; /* set file info/model in relation global element */
		     rel_gl_ptr -&gt; gl.file_model_ptr = fm_ptr;
		     rel_gl_ptr -&gt; gl.other_info_ptr = gl_ptr; /* file global list element for relation */

/* add this relation to the file's relation sublist */

		     call
			mrds_rst_list_element$add (relation.name, SUB_LIST, rsc_ptr,
			gl.item_sub_list_ptr, sl_ptr, error_code);

		     if error_code ^= 0 then do;
			     call
				ioa_$rs ("^a^a^a^a", message, message_length,
				"LOGIC ERROR in  mrds_rst_file_handler, a duplicate relation """
				, relation.name, """ was found in sublist of file """,
				file.name, """.");
			     call
				mrds_rst_error (rsc_ptr, 4 /* severity */, error_code,
				(message));
			     num_dims = 0;		/* unused variable */
			end;
		     else do;

/* fill in the sublist element */

			     sl.type = SUB_LIST;
			     sl.name = relation.name;
			     sl.item_info_ptr = null (); /* no relation info yet */
			     sl.parse_info_ptr = relation_ptr; /* relation parse structure */
			     sl.old_other_info_ptr = null ();
			     sl.new_other_info_ptr = gl_ptr;
			     sl.global_list_ptr = rel_gl_ptr;
			     sl.reserved = OFF;

/* build the relation info for this "good" relation in this file */

			     call load_rel_info ();
			     gl.inferior_assigned = ON; /* relation present for file */

/* build all the attribute infos contained in this relation, if attributes present, and rel_info obtained */

			     if ^rel_gl_ptr -&gt; gl.inferior_assigned
				| ^rel_gl_ptr -&gt; gl.complete then
				;
			     else do;

				     call load_attr_infos ();

				     call check_relation_key_length ();

				     call align_varying_tuple_data ();
				end;
			end;
		end;

/* go to next relation in list */

	     item_ptr = item.next;
	end;

     end;

load_file_model:
     procedure ();

/* routine to initialize and fill in the file model/info */

	db_model_path = rtrim (rsc.temp_dir) || "&gt;db_model";

/* update the db_model file statistics */

	dbm_ptr = rsc.n_dm_ptr;
	db_model.num_unblk_files = db_model.num_unblk_files + 1;
	db_model.unblk_file_id_len =
	     max (db_model.unblk_file_id_len,
	     fixed (ceil (log2 (db_model.num_unblk_files)), 17));
	bit_36_temp = db_model.num_unblk_files;

/* add a file_info to the db_model for this file */

	call mrds_rst_model_alloc (rsc_ptr, db_model_path, FILE_INFO, fi_ptr);

	if fi_ptr ^= null () then
	     ;
	else if rsc.model_overflow then
	     ;					/* reported first time only */
	else do;
		rsc.model_overflow = ON;
		call
		     ioa_$rs ("^a^a^a^a ^a", message, message_length, "File """,
		     file.name, """", line_number (),
		     "caused an overflow of the db_model while processing the file_info.")
		     ;
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */,
		     mrds_error_$rst_model_limit, (message));
	     end;

	gl.file_info_ptr = fi_ptr;
	gl.item_info_ptr = fi_ptr;

	if error_mode then
	     name_of_file = unique_chars_ ("0"b);	/* use dummy name if previous error */
	else name_of_file = rtrim (file.name);
	file_model_path = rtrim (rsc.temp_dir) || "&gt;" || name_of_file || ".m";

	if fi_ptr = null () then
	     ;					/* due to model overflow */
	else do;

		file_info.file_name = name_of_file;
		file_info.file_id = "000000000000000000000000000000000001"b;

/* link into file_info list in order */

		file_info.fwd_ptr, file_info.unused = NULL_OFFSET;

		if db_model.file_ptr = NULL_OFFSET then
		     db_model.file_ptr = rel (fi_ptr);
		else do;
			if stmt (directive.type).file.number &gt; 0 then
			     ;			/* not first time */
			else do;			/* first time, get list end */
				last_fi_ptr = pointer (dbm_ptr, db_model.file_ptr);
				do while (last_fi_ptr -&gt; file_info.fwd_ptr ^= NULL_OFFSET);
				     last_fi_ptr =
					pointer (dbm_ptr, last_fi_ptr -&gt; file_info.fwd_ptr);
				end;
			     end;
			last_fi_ptr -&gt; file_info.fwd_ptr = rel (fi_ptr); /* set list end as new file_info */
		     end;
		last_fi_ptr = fi_ptr;

	     end;

/* get a segment for a file_model for this file */

	call
	     mrds_rst_get_seg_ptr (rsc_ptr,
	     rsc.h_n_seg_info_ls_ptr /* put in new model list */,
	     name_of_file || ".m" /* file_model name */, ON /* create seg */,
	     fm_ptr, error_code);

	if error_code ^= 0 then do;
		call
		     ioa_$rs ("^a^a^a", message, message_length,
		     "Unable to make segment for file model of file """, name_of_file,
		     """.");
		call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message));
	     end;
	else do;

/* initialize the file model */

		call file_model_init ();
		gl.superior_assigned = ON;		/* file model for file present */
		gl.file_model_ptr = fm_ptr;

	     end;

     end;

file_model_init:
     procedure ();
						/* fill in file parameters with initial values */

	like_file_model = init_file_model;		/* init model */
	file_model.fi_ptr = rel (fi_ptr);		/* offset in db_model of file_info */
	file_model.changer_ptr = db_model.changer_ptr;	/* get person.project and system time */
	file_model.fm_area = empty ();		/* initailize file_model area */

     end;

load_rel_info:
     procedure ();

/* routine to allocate and initialize the rel_info structure for
   the current relation in this file, using the file model area,
   and updating the file_model and global file element as necessary */

	call mrds_rst_model_alloc (rsc_ptr, file_model_path, REL_INFO, ri_ptr);

	if ri_ptr ^= null then
	     rel_gl_ptr -&gt; gl.complete = ON;		/* rel_info present now */
	else if rsc.model_overflow then
	     ;					/* reported only first time */
	else do;
		rsc.model_overflow = ON;
		call
		     ioa_$rs ("^a^a^a^a ^a^a^a", message, message_length, "File """,
		     file.name, """", line_number (),
		     "caused an overflow of the file_model while processing the relation """
		     , relation.name, """.");
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */,
		     mrds_error_$rst_model_limit, (message));
	     end;

	rel_gl_ptr -&gt; gl.item_info_ptr = ri_ptr;	/* set rel_info in rel global element */
	sl.item_info_ptr = ri_ptr;			/* set rel_info in file's rel sublist element */

/* update the relation count */

	if ri_ptr = null () then
	     ;
	else do;

		db_model.num_rels = db_model.num_rels + 1;

/* initialize relation detailed information */

		rel_info = init_rel_info;		/* copy template */
		rel_info.name = relation.name;
		rel_info.changer_ptr = file_model.changer_ptr;
		bit_36_temp = db_model.num_rels;

		file_model.rel_ptr = rel (ri_ptr);

	     end;

     end;

load_attr_infos:
     procedure ();

/* routine to allocate and initialize the attr_info structures for
   the attributes in the current relation, using the file model area,
   updating the file_model and rel_info and global list elements as necessary to reflect the additions */

	root_ptr = rel_gl_ptr -&gt; gl.item_sub_list_ptr;	/* start of attr list for this relation */
	all_attributes_used = OFF;			/* not all attrs added to rel yet */
	current_definition_order = 1;

/* run through all attributes in this relation */

	do while (^all_attributes_used);

	     if ^definition_order_found () then
		all_attributes_used = ON;
	     else do;

/* get needed pointers */

		     di_ptr = attr_gl_ptr -&gt; gl.other_info_ptr; /* get attribute's domain info pointer */
		     dom_sl_ptr = attr_gl_ptr -&gt; gl.item_info_ptr; /* corres domain sublist for attr */

/* now get space for a new attr_info for this attribute for this relation */

		     call
			mrds_rst_model_alloc (rsc_ptr, file_model_path, ATTR_INFO,
			ai_ptr);
		     if ai_ptr ^= null then
			attr_gl_ptr -&gt; gl.complete = ON; /* attr_info present */
		     else if ^rsc.model_overflow then do;
			     rsc.model_overflow = ON; /* so only first overflow reported */
			     call
				ioa_$rs ("^a^a^a^a ^a^a^a^a^a", message, message_length,
				"File """, file.name, """", line_number (),
				"caused an overflow of the file_model while processing attribute """
				, attr_gl_ptr -&gt; gl.name, """ in relation """,
				rel_gl_ptr -&gt; gl.name, """.");
			     call
				mrds_rst_error (rsc_ptr, 2 /* severity */,
				mrds_error_$rst_model_limit, (message));
			end;

/* update global list entries */

		     rel_sl_ptr -&gt; sl.item_info_ptr = ai_ptr; /* set attr_info in rel's attr sublist element
						   this can be used now to get the fm_ptr via pointer(ai_ptr,0)
						   and the fi_ptr via pointer(fm_ptr, file_model.fi_ptr) */
		     if attr_sl_ptr ^= null () then do;
			     attr_sl_ptr -&gt; sl.item_info_ptr = ri_ptr; /* set rel_info in attr's rel sublist element */
			     attr_sl_ptr -&gt; sl.old_other_info_ptr = ai_ptr;
						/* set attr_info ptr for this rel */
			end;
		     if dom_sl_ptr = null () then
			;
		     else dom_sl_ptr -&gt; sl.item_info_ptr = ai_ptr; /* set attr_info in domain's attr sublist */

/* fill in the attr_info structure for this attribute */

		     call set_attr_info ();

		end;

/* go to the next attribute in user defined order */

	     current_definition_order = current_definition_order + 1;
	end;
     end;

set_attr_info:
     procedure ();

/* routine to fill in the attr_info structure details */

/* count up number of attributes */

	if ai_ptr = null () then
	     ;
	else do;
		rel_info.num_attr = rel_info.num_attr + 1;
		if ^attribute.pr_key then
		     ;
		else rel_info.num_key_attrs = rel_info.num_key_attrs + 1;

		if rel_info.num_attr &gt; mrds_data_$max_attributes &amp; ^rsc.max_attrs
		then do;
			rsc.max_attrs = ON;
			call
			     ioa_$rs ("^a^a^a^a^a ^d^a", message, message_length,
			     "Attribute """, attr_gl_ptr -&gt; gl.name, """ in relation """,
			     rel_gl_ptr -&gt; gl.name,
			     """ exceeded the maxmimum number of attributes allowed per relation of"
			     , mrds_data_$max_attributes, ".");
			call
			     mrds_rst_error (rsc_ptr, 2 /* severity */,
			     mrds_error_$max_attributes, (message));
		     end;



/* initialize attr_info structure */

		attr_info.name = attribute.name;
		attr_info.changer_ptr = file_model.changer_ptr;
		attr_info.key_attr = attribute.pr_key;	/* ON =&gt; primary key */
		attr_info.index_attr = OFF;		/* not involved in indexes or links yet */
		attr_info.link_attr = OFF;
		attr_info.reserved = OFF;
		attr_info.index_id = OFF;
		attr_info.defn_order = attribute.defn_order;
		attr_info.key_order = attribute.key_order;
		attr_info.link_par_cnt, attr_info.link_child_cnt = 0;
		attr_info.rslt_ptr = NULL_OFFSET;	/* off for  mrds */

/* compute attribute bit offset and length, update rel_info max data length,
   and number/offset of varying attributes, and the average tuple size,
   also set the attribute and global list domain info pointers */

		call compute_bit_offset_and_length ();	/* sets average_tuple_length */

/* link the attr_info into the list in definition order */

		current_ai_ptr = pointer (fm_ptr, rel_info.attr_ptr);
		last_ai_ptr = null ();
		place_not_found = ON;

/* find the right list position according to definition order */

		do while (place_not_found);
		     if rel (current_ai_ptr) = NULL_OFFSET then
			place_not_found = OFF;
		     else if current_ai_ptr -&gt; attr_info.defn_order
			     &gt;= attr_info.defn_order then
			place_not_found = OFF;
		     else do;
			     last_ai_ptr = current_ai_ptr;
			     current_ai_ptr =
				pointer (fm_ptr, current_ai_ptr -&gt; attr_info.fwd_thread);
			end;
		end;

/* set this attr_info's forward pointer */

		if current_ai_ptr = null () then
		     attr_info.fwd_thread = NULL_OFFSET;
		else attr_info.fwd_thread = rel (current_ai_ptr);

/* set previous pointer to this attr_info */

		if last_ai_ptr = null () then
		     rel_info.attr_ptr = rel (ai_ptr);
		else last_ai_ptr -&gt; attr_info.fwd_thread = rel (ai_ptr);
	     end;

     end;

definition_order_found:
     procedure () returns (bit (1));

/* this routine determines if the current definition order
   correspondes to any in the sublist of attrs for this relation */

	node_ptr = root_ptr;			/* convention for first on list */
	found = OFF;
	required_order_found = OFF;
	do while (^found);

	     call get_definition_order (order_was_obtained, order_obtained);
	     if ^order_was_obtained then do;
		     found = ON;
		     required_order_found = OFF;
		end;
	     else if current_definition_order ^= order_obtained then
		;
	     else do;
		     found = ON;
		     required_order_found = ON;
		end;

	end;

	return (required_order_found);


	declare required_order_found	 bit (1);		/* on =&gt; current order is in list */
	declare found		 bit (1);		/* on =&gt; exit loop, else keep looking */
	declare order_was_obtained	 bit (1);		/* on =&gt; given order was in list */
	declare order_obtained	 fixed bin;	/* order found during get next order */

     end;

get_definition_order:
     procedure (found, order_found);

/* get the definition order of the next attribute in the relation's attr sublist */

	call
	     mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr,
	     successor_parent_ptr, found);
	if ^found then
	     order_found = 0;
	else do;

		node_ptr = successor_ptr;		/* make it the current one */
		rel_sl_ptr = node_ptr -&gt; node.data;	/* get rel sublist pointer */
		attr_gl_ptr = rel_sl_ptr -&gt; sl.global_list_ptr; /* get global attr pointer */
		call
		     list_search (relation.name, attr_gl_ptr -&gt; gl.item_sub_list_ptr,
		     attr_sl_ptr, ATTR_SL);
		attribute_ptr = rel_sl_ptr -&gt; sl.parse_info_ptr; /* get parse information */
		order_found = attribute.defn_order;

	     end;


	declare order_found		 fixed bin;	/* definition order of next attribute */
	declare found		 bit (1);		/* on =&gt; attr found, else none left */

     end;

list_search:
     procedure (key, root_ptr, data_ptr, success);

/* routine to get an element pointer from the global lists */

	call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success);

	if success then
	     data_ptr = node_ptr -&gt; node.data;
	else do;
		call
		     ioa_$rs ("^a^a^a", message, message_length,
		     "LOGIC ERROR in mrds_rst_file_handler, the name """, key,
		     """ was found in a global list, but not in the corresponding sublist"
		     );
		call
		     mrds_rst_error (rsc_ptr, 4 /* severity */,
		     mrds_error_$rst_logic_error, (message));
		data_ptr = null ();
	     end;

	declare key		 char (32) aligned; /* name to look for in list */
	declare root_ptr		 ptr;		/* head of desired list */
	declare node_ptr		 ptr;		/* pointer to head portion of list element */
	declare parent_ptr		 ptr;		/* pointer to tree parent of found node */
	declare data_ptr		 ptr;		/* pointer to data portion of list element */
	declare success		 bit (1);		/* ON =&gt; element found */

     end;

compute_bit_offset_and_length:
     procedure ();

/* routine to convert the attribute's domain descriptor into
   the required tuple offset and space required and update the
   corresponding statistics for the relation information
   NOTE: the padding routines were introduced to make the data stored
   in the tuple(via bit offset/length) relect the pl1 definition
   of storage locations needed for unaligned and aligned data types */

	attr_info.bit_length = get_domain_bit_size ();	/* also sets domain_info ptr in attr_info */

/* fixed length attribute/domain handling */

	if ^varying_string then do;			/* fixed attributes */
		padding =
		     mdbm_util_$align_data_item (desc_ptr, rel_info.var_offset - 1);
		attr_info.bit_offset = rel_info.var_offset + padding;
						/* set to end of fixed data */
		rel_info.var_offset =
		     rel_info.var_offset + attr_info.bit_length + padding;
						/* set new fixed data end */
		rel_info.avg_data_len =
		     rel_info.avg_data_len + attr_info.bit_length + padding;
						/* average = max for fixed */
	     end;

/* varying string handling */

	else do;					/* varying strings */
		rel_info.nvar_atts = rel_info.nvar_atts + 1; /* count up varying attributes */
		attr_info.bit_offset = rel_info.nvar_atts; /* varying array index, not offset */
		rel_info.avg_data_len =
		     rel_info.avg_data_len + average_varying_length
		     + pad (WORD, average_varying_length); /* use average for varying */
		padding = pad (WORD, attr_info.bit_length); /* varying must start/stop on word boundary */
	     end;

/* set the maximum tuple and key bit lengths */

	rel_info.max_data_len =
	     rel_info.max_data_len + attr_info.bit_length + padding;
	if ^attribute.pr_key then
	     ;
	else rel_info.max_key_len = rel_info.max_key_len + attr_info.bit_length;


     end;

get_domain_bit_size:
     procedure () returns (fixed binary (35));

/* calculate the amount of storage that needs to be allocated(in bits)
   to hold a converted value that has the same type as the domain */

	varying_string = OFF;

/* set attributes domain info pointer */

	if di_ptr = null () then do;
		attr_info.domain_ptr = NULL_OFFSET;
		domain_bit_length = 1;		/* set dummy domain size */
		attr_gl_ptr -&gt; gl.consistant = OFF;	/* no domain info present for attribute */
		desc_ptr = null ();
	     end;
	else do;					/* good domain present */

		attr_info.domain_ptr = rel (di_ptr);
		attr_gl_ptr -&gt; gl.other_info_ptr = di_ptr; /* set domain_info in attr global element */
		rel_sl_ptr -&gt; sl.new_other_info_ptr = di_ptr; /* set domain_info in rel sublist for attr */
		desc_ptr = addr (domain_info.db_desc);	/* get descriptor for this attribute */

/* set bit length according to this domain's data type, and average length of varying strings */

		domain_bit_length =
		     mdbm_util_$get_data_bit_length (desc_ptr -&gt; descriptor_bit_36_ovrly)
		     ;

/* set varying strings average bit length */

		if descriptor.type = 20 then do;	/* bit varying */
			varying_string = ON;
			average_varying_length = domain_info.ave_len + 36;
		     end;
		else if descriptor.type = 22 then do;	/* char varying */
			varying_string = ON;
			average_varying_length = (domain_info.ave_len * 9) + 36;
		     end;
		else ;				/* not varying string */

	     end;

	return (domain_bit_length);


	declare domain_bit_length	 fixed binary (35); /* required bit length to store domain's data */

     end;

pad:
     procedure (pad_size, pad_base) returns (fixed bin);

/* routine to return the number of bits necessary to pad a bit count
   out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits
   as determined by the pad size input */

	if mod (pad_base, pad_size) = 0 then
	     number_of_bits = 0;
	else do;

		number_of_bits = pad_size - mod (pad_base, pad_size);

	     end;

	return (number_of_bits);


	declare pad_size		 fixed bin;	/* either 9 or 36 or 72 */
	declare pad_base		 fixed bin (35);	/* current bit length to be padded */
	declare number_of_bits	 fixed bin;	/* what has to be added to get to the desired boundary */

     end;

align_varying_tuple_data:
     procedure ();

/* varying attributes in the tuple must start on a word boundary,
   this routine makes sure that the end of the fixed data portion of the
   tuple, which is where the varying attributes start, is on that boundary */

	if rel_info.nvar_atts = 0 then
	     ;
	else do;

		amount_to_pad = pad (WORD, rel_info.var_offset - 1);
		rel_info.var_offset = rel_info.var_offset + amount_to_pad;
		rel_info.max_data_len = rel_info.max_data_len + amount_to_pad;
		rel_info.avg_data_len = rel_info.avg_data_len + amount_to_pad;

	     end;


	declare amount_to_pad	 fixed bin;	/* bits needed for word alignment */

     end;

check_file_size_and_number:
     procedure ();

/* routine to check that the number of files and/or
   the maximum number of file tuples don't
   exceed implementation limits based on the mdbm_tuple_id.incl.pl1 constants */

	file_id_space = db_model.unblk_file_id_len;	/* already set to max(file_id_len, ceil(log2(num_files))) */
	db_model.max_max_tuples = max (db_model.max_max_tuples, max_tuples);
						/* get max across all files so far */
	if db_model.max_max_tuples = 0 then
	     tuple_id_space = 0;
	else tuple_id_space = ceil (log2 (db_model.max_max_tuples));
	vfile_component_space = ceil (log2 (max_vfile_components));

/* try to pad the file_id_space out to mrds_data_$file_id_len_pad
   to make room for restructuring to add files wihtout causing the
   reformatting of all files in the database due to an overflow of the
   existing db_model.file_id_len space allotted */

/*	     if file_type = BLOCKED then
   blocked_check = ON ;
   else blocked_check = OFF ;
   first_time = ON ;
   space_left_to_pad = ON ;
   do while (space_left_to_pad) ;

   if (blocked_check &amp; (file_id_space + tuple_id_space &lt;= 34)) |
   (^blocked_check &amp; (file_id_space + vfile_component_space &lt;= 17)) then do ;

   /* last space usage within limits, try to get another
   bit for the file_id_space to occupy * /

   if file_id_space &lt; mrds_data_$file_id_len_pad then
   file_id_space = file_id_space + 1 ; /* can add bit since within needed space guess * /
   else space_left_to_pad = OFF ;
   end ;

   else if ^first_time then do ;

   /* we padded too much, back off one bit and use that * /

   file_id_space = file_id_space - 1 ;
   space_left_to_pad = OFF ;
   end ;

   else do ;

   /* not enough space on the first try with minimrdsm sizes * /

   space_left_to_pad = OFF ; */

	file_id_space = ceil (log2 (mrds_data_$max_relations)) + 1;

	if db_model.num_blk_files + db_model.num_unblk_files
	     &gt; mrds_data_$max_relations then do;


		if rsc.max_files then
		     ;				/* only give error first time */
		else do;
			rsc.max_files = ON;
			call
			     ioa_$rs ("^a^a^a^a ^a ^d ^a", message, message_length,
			     "The file """, file.name, """", line_number (),
			     "was unblocked file number", db_model.num_unblk_files,
			     "and exceeded the maximum number of unblocked files allowed."
			     );
			call
			     mrds_rst_error (rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_option_limit, (message));
		     end;
	     end;


/* save the possibly bigger file_id_space calculated */

	db_model.unblk_file_id_len = file_id_space;



	declare file_id_space	 fixed binary;	/* bit length of file id */
	declare tuple_id_space	 fixed binary;	/* bit length of tuple maximum */
	declare vfile_component_space	 fixed binary;	/* bit length of max vfile components */
	declare max_vfile_components	 fixed binary init (900); /* max no of comps */

     end;

check_relation_key_length:
     procedure ();

/* make sure that the data length of the attributes
   that make up the primary key for this relation do not
   exceed the implementation restriction maximum */

	key_length_in_chars = ceil (rel_info.max_key_len / 9);

	if key_length_in_chars &lt;= mrds_data_$max_key_len then
	     ;
	else do;

		call
		     ioa_$rs ("^a^a^a ^d ^a^a^a ^d ^a ^d ^a", message, message_length,
		     "The relation """, relation.name, """ on line", relation.line_num,
		     "given in file """, file.name,
		     """ has a primary key data length of", key_length_in_chars,
		     "characters, which is greater than the allowed maximum length of",
		     mrds_data_$max_key_len, "characters.");
		call
		     mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$long_key,
		     (message));

	     end;


     end;

line_number:
     procedure () returns (char (20) varying);

/* return null string for default files,
   or the line occurence for files from the source */

	if file.default then
	     returned_line = "";
	else returned_line = ", on line " || ltrim (char (file.line_num)) || ",";

	return (returned_line);


	declare returned_line	 char (20) varying;

     end;

	declare name_of_file	 char (30) varying; /* name to add .m to for model seg */
	declare db_model_path	 char (168);	/* path name to db_model */
	declare file_model_path	 char (200);	/* path name down to file_model */
	declare mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* work area manager */
	declare mrds_rst_model_alloc	 entry (ptr, char (*), fixed bin, ptr);
						/* model allocation routine */

	declare unique_chars_	 entry (bit (*)) returns (char (15)); /* unique character generator */
	declare error_mode		 bit (1);		/* ON =&gt; duplicate file name processing fixup */
	declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1));
						/* get next routine */
	declare attr_gl_ptr		 ptr;		/* pointer to attribute global element */
	declare dom_sl_ptr		 ptr;		/* pointer to corres attribute domain sublist element */
	declare rel_sl_ptr		 ptr;		/* pointer to relation sublist element */
	declare attr_sl_ptr		 ptr;		/* pointer to attribute sublist element */
	declare ATTR_SL		 bit (1);		/* ON =&gt; pointer found for attr_sl_ptr */
						/* init path/entry value */
	declare file_name		 char (30);	/* file name for this call */
	declare (addr, ceil, char, log2, empty, fixed, ltrim, max, mod, null, pointer, rel, rtrim)
				 builtin;		/* functions known to pl1 */
	declare ON		 bit (1) internal static options (constant) init ("1"b);
						/* true value */
	declare OFF		 bit (1) internal static options (constant) init ("0"b);
						/* false value */
	declare NULL_OFFSET		 bit (18) internal static options (constant)
				 init ((18)"1"b);	/* db version of null offset */
	declare sys_info$max_seg_size	 fixed bin (35) external; /* system constant */
	declare mrds_rst_get_seg_ptr
				 entry (ptr, ptr, char (32) aligned, bit (1), ptr, fixed bin (35));
						/* ON =&gt; get new segment */
	declare error_code		 fixed binary (35); /* mrds_error_ table index */
	declare message		 char (320) varying;/* specifics of error message */
	declare message_length	 fixed bin (21);	/* length of specifics message */
	declare last_fi_ptr		 ptr internal static; /* saved file_info pointer */
	declare last_ai_ptr		 ptr;		/* saved attr_info pointer */
	declare current_ai_ptr	 ptr;		/* pointer to present attr_info in list */
	declare place_not_found	 bit (1);		/* definition order insertion place flag */
	declare mrds_error_$rst_model_limit fixed bin (35) external;
						/* model capacity exceeded */
	declare mrds_error_$long_key	 fixed bin (35) external; /* max key length exceeded */
	declare mrds_error_$rst_option_limit fixed bin (35) external;
						/* exceeded allowable for option */
	declare mrds_error_$rst_undone_option fixed bin (35) external;
						/* option not coded yet */
	declare mrds_error_$rst_undef_rel fixed bin (35) external; /* item not in database */
	declare mrds_error_$rst_dup_file fixed bin (35) external; /* duplicate attr definition */
	declare mrds_error_$rst_rel_has_file fixed bin (35) external;
						/* file assigned to relation */
	declare mrds_error_$rst_logic_error fixed bin (35) ext; /* program failure */
	declare max_tuples		 fixed binary (71); /* file's accumulated max tuples */
	declare mrds_data_$max_key_len fixed bin (35) ext;/* implementation restriction on key size */
	declare key_length_in_chars	 fixed bin (35);	/* computed character length of relation key */
	declare mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1));
						/* list searcher */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*));
						/* general error handler */
	declare ioa_$rs		 entry options (variable); /* string manipulator */
	declare mrds_rst_list_element$add
				 entry (char (32) aligned, fixed binary, ptr, ptr, ptr,
				 fixed bin (35));
	declare list_ptr		 ptr;		/* pointer to parse info list */
	declare IN		 bit (1) internal static options (constant) init ("1"b);
						/* input meter flag */
	declare OUT		 bit (1) internal static options (constant) init ("0"b);
						/* output meter flag */
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*));
						/* metering/tracing routine */
	declare rel_gl_ptr		 ptr;		/* temp storage for relation global element pointer */
	declare average_varying_length fixed bin (35);	/* average varying string bit length */
	declare varying_string	 bit (1);		/* ON =&gt; varying string type attribute */
	declare bit_36_temp		 fixed bin (35) aligned; /* 36 bit word to overlay */
	declare BYTE		 fixed bin init (9);/* byte boundary = 9 bits */
	declare WORD		 fixed bin init (36); /* word boundary = 36 bits */
	declare DOUBLE_WORD		 fixed bin init (72); /* double word boundary = 72 bits */
	declare padding		 fixed bin;	/* amount needed to pad to a given boundary */
	declare current_definition_order fixed bin;	/* definition order for current attr */
	declare all_attributes_used	 bit (1);		/* on =&gt; all rel attrs processed */
	declare mdbm_util_$get_data_bit_length entry (bit (36))
				 returns (fixed bin (35)); /* gets storage bits from descriptor */
	declare descriptor_bit_36_ovrly bit (36) based;	/* overlay for descriptor */
	declare mdbm_util_$align_data_item entry (ptr, fixed bin (35))
				 returns (fixed bin); /* aligns to data type boundary,
						   given current offset */
	declare mrds_error_$rst_reserved_name fixed bin (35) ext; /* reserved name used */
	declare mrds_data_$max_relations fixed bin (35) ext; /* most relations can create */
	declare mrds_data_$max_attributes fixed bin (35) ext; /* max attrs allowed per rel */
	declare mrds_error_$max_attributes fixed bin (35) ext; /* &gt; mrds_data_$max_attrs seen */

%include mrds_rst_struct_types;
%include mdbm_descriptor;
%include mrds_rst_rsc;
%include mrds_rst_semantics;
%include mrds_rst_parse_info;
%include mrds_rst_tree;
%include mrds_rst_global_lists;
%include mdbm_file_model;
%include mdbm_file_model_init;
%include mdbm_db_model;

     end;
���



		    mrds_rst_format_file.pl1        08/01/88  1435.5r w 08/01/88  1315.0      115758



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




/****^  HISTORY COMMENTS:
  1) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-01,Dupuis),
     install(86-12-09,MR12.0-1237):
     Change to use mrds_data_$relation_blocking_factor when creating new
     relations.
                                                   END HISTORY COMMENTS */


/* HISTORY
   Originally coded by Oris Friesen -- June 1978
   Modified by Jim Gray - - October 1978, to correct calculate_size
   Modified by Jim Gray - - November 1978, to correct handling of &gt; 255 pages/blocked file
   Modified by Jim Gray - - December 1978, to put module and error handling in mrds_rst format
   Modified by Jim Gray - - March 1979, to correct bucket headers from 0 to 1 when bucket_density &lt; 0

   81-05-28 Jim Gray : removed blocked file code

   82-09-07 D. Woodka : changed for DMS conversion to call relation_manager
   create relation and create index.

   82-12-07 R. Harvey : fixed bug with secondary index creation - too many
   calls were previously being made. Also set protected bit in
   file_create_info.

   83-01-10 Mike Kubicar : added a common error handling routine, "error"
   and returned on the first error.  Also added "code" parameter for returning
   the error encountered.

   83-02-17 R. Harvey : changed to support attribute naming in relation_manager
   interface.

   83-10-04 Paul Benjamin : changed hcs_$initiate calls to initiate_file_.
   Changed "1"b to ON and "0"b to OFF.

   84-08-21 Matthew Pierret : changed file_create_info to use version
   FILE_CREATE_INFO_VERSION_2, added initialization of ring_brackets in
   file_create_info to 0.
*/


mrds_rst_format_file: procedure (rsc_ptr, input_file_name, code);
%page;
/*
                            BEGIN_DESCRIPTION
   Given a single file name, this routine  creates a relation
   for the database and the corresponding  indices  according
   to the  file_model of the name file_name.m already defined
   in the database.

                            END_DESCRIPTION
*/

/* PARAMETERS

   rsc_ptr - - (input) pointer to the restructure control segment.

   input_file_name - - (input) equivalent to file_info.file_name,
   char(30) aligned, is the name of the data file. 

   code - - (output) returned error code.

*/
%page;
/* call metering if trace is on */

	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_file_format",
		"1"b /* input call */, input_file_name);


	code = 0;

/* initialize for calls to create_relation and create_index */

	file_segment_name = rtrim (input_file_name);

	call initiate_file_ (rsc.dbp, "db_model", RW_ACCESS, dbm_ptr, bit_count, error_code);
	if error_code = error_table_$no_r_permission | error_code = error_table_$no_w_permission then do;
		call mrds_dm_authorization$set_needed_access (rtrim (rsc.dbp),
		     error_code);			/* fails if user is not a DBA */
		if error_code ^= 0 then error_code = mrds_error_$no_model_access;
		else call initiate_file_ (dbp, "db_model", RW_ACCESS, dbm_ptr, bit_count, error_code);
	     end;

	if dbm_ptr = null then call error (rsc_ptr, 4 /* severity */,
		mrds_error_$no_database, " The database model could not be initiated.");

	file_model_name = rtrim (file_segment_name) || ".m";
	call initiate_file_ (rsc.dbp, file_model_name, RW_ACCESS, fm_ptr, bit_count, error_code);
	if fm_ptr = null then call error (rsc_ptr, 4 /* severity */,
		error_code, " The file model," || file_model_name || "could not be initiated.");

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

	tva_number_of_vector_slots = 0;
	tva_number_of_dimensions = rel_info.num_attr;
	tva_maximum_dimension_name_length = 32;
	allocate typed_vector_array in (rsc.wa);

	il_number_of_ids = rel_info.num_attr;
	allocate id_list in (rsc.wa);
	id_list.number_of_ids = 0;
	id_list.version = ID_LIST_VERSION_1;

	typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
	ai_ptr = ptr (fm_ptr, rel_info.attr_ptr);	/* get attribute info  */
	do i = 1 to tva_number_of_dimensions;

	     if attr_info.key_attr then do;		/* set up the primary key index */
		     id_list.number_of_ids = id_list.number_of_ids + 1;
		     id_list.id (id_list.number_of_ids) = attr_info.defn_order;
		end;

	     di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);/* set up descriptor list for create relation */
	     typed_vector_array.dimension_table (i).name = attr_info.name;
	     typed_vector_array.dimension_table (i).descriptor_ptr = addr (domain_info.db_desc);
	     ai_ptr = ptr (fm_ptr, attr_info.fwd_thread);

	end;

	allocate rel_creation_info in (rsc.wa);
	allocate file_create_info in (rsc.wa);

/* initialize values for create_relation */

	rel_creation_info.version = REL_CREATION_INFO_VERSION_2;
	rel_creation_info.file_create_info_ptr = addr (file_create_info);
	esm_info_ptr = null;
	cism_info_ptr = null;
	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 = rsc.db_relation_mode_flags.protection_on;
	file_create_info.flags.no_concurrency = ^rsc.db_relation_mode_flags.concurrency_on;
	file_create_info.flags.no_rollback = ^rsc.db_relation_mode_flags.rollback_on;
	file_create_info.flags.mbz_1 = OFF;
          file_create_info.ring_brackets (*) = 0;
	file_create_info.mbz_2 = 0;
          file_create_info.mbz_3 = OFF;

/* initialize values for create_index */
	style = 1;
	relation_index_flags_ptr = addr (flag_list);
	relation_index_flags.relation_must_be_empty = OFF;
	relation_index_flags.index_is_clustering = OFF;
	relation_index_flags.index_is_unique = ON;	/* for primary key */




/* make call to relation manager */

	if rsc.db_relation_mode_flags.dm_file_type then do; /* if this is a page_file database */

		call relation_manager_$create_relation (rsc.dbp, file_segment_name,
		     rel_creation_info_ptr, typed_vector_array_ptr,
		     rel_opening_id, rel_info.id, error_code);
		if error_code ^= 0 then
		     call error (rsc_ptr, 4 /* severity */, error_code,
			"while creating relation" || file_segment_name);

/* create the primary index for the relation */

		call relation_manager_$create_index (rel_opening_id,
		     id_list_ptr, flag_list, style, rel_info.primary_key_index_id, error_code);

		if error_code ^= 0 then
		     call error (rsc_ptr, 4 /* severity */, error_code,
			"while creating the primary index for" || file_segment_name);

	     end;

	else do;					/* if this is a vfile_ database */

		call vfile_relmgr_$create_MRDS_relation (rsc.dbp, file_segment_name,
		     rel_creation_info_ptr, typed_vector_array_ptr,
		     rel_opening_id, rel_info.id, error_code);
		if error_code ^= 0 then
		     call error (rsc_ptr, 4 /* severity */, error_code,
			"while creating relation" || file_segment_name);

/* create the primary index for the relation */

		call vfile_relmgr_$create_index (rel_opening_id,
		     id_list_ptr, flag_list, style, rel_info.primary_key_index_id, error_code);
		if error_code ^= 0 then
		     call error (rsc_ptr, 4 /* severity */, error_code,
			"while creating the primary index for" || file_segment_name);

	     end;


/* create the secondary indexes for the relation */

	relation_index_flags.index_is_unique = OFF;	/* index need not be unique for secondary index */

	id_list.number_of_ids = 1;			/* secondary indices involve only one attribute */

	do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
	     repeat ptr (fm_ptr, attr_info.fwd_thread)
	     while (rel (ai_ptr) ^= NULL_OFFSET);

	     if attr_info.index_attr then do;
		     id_list.id (1) = attr_info.defn_order;

		     if rsc.db_relation_mode_flags.dm_file_type then do; /* if this is a page_file database */

			     call relation_manager_$create_index (rel_opening_id,
				id_list_ptr, flag_list, style, attr_info.index_id, error_code);

			     if error_code ^= 0 then
				call error (rsc_ptr, 4 /* severity */, error_code,
				     " while creating secondary indices for " || file_segment_name);

			end;

		     else do;			/* if this is a vfile_ database */

			     call vfile_relmgr_$create_index (rel_opening_id,
				id_list_ptr, flag_list, style, attr_info.index_id, error_code);
			     if error_code ^= 0 then
				call error (rsc_ptr, 4 /* severity */, error_code,
				     " while creating secondary indices for " || file_segment_name);

			end;

		end;				/* index_attr */

	end;					/* do ai_ptr */

/* close the relation */

	if rsc.db_relation_mode_flags.dm_file_type
	then call relation_manager_$close (rel_opening_id, error_code);
	else call vfile_relmgr_$close (rel_opening_id, error_code);
	if error_code ^= 0 then
	     call error (rsc_ptr, 4 /* severity */, error_code,
		" while closing relation " || file_segment_name);


/* call metering if trace is on */

EXIT:
	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_file_format",
		"0"b /* output call */, input_file_name);

	return;
%page;
/**********
*
*  This error routine provides a common action on error.  It will call
*  mrds_rst_error to display the error and then return.
*
**********/

error:
     proc (err_rsc_ptr, err_severity, err_code, err_text);

	dcl     err_rsc_ptr		 ptr;		/* Pointer to rsc common structure */
	dcl     err_severity	 fixed bin;	/* Cmdb severity */
	dcl     err_code		 fixed bin (35);	/* Standard error code */
	dcl     err_text		 char (*);	/* Expanitory text for error */

	code = err_code;				/* Set error code for return. Note, global parameter (Yuck) */
	call mrds_rst_error (err_rsc_ptr, err_severity, err_code, err_text);
	goto EXIT;
     end error;
%page;
	dcl     bit_count		 fixed bin (24);	/* Required in calls to initiate_file_ */
	dcl     code		 fixed bin (35);	/* Returned error code */
	dcl     error_code		 fixed bin (35);	/* internal status return code */
	dcl     error_table_$no_r_permission
				 fixed bin (35) ext static;
	dcl     error_table_$no_w_permission
				 fixed bin (35) ext static;
	dcl     file_model_name	 char (32);
	dcl     flag_list		 bit (36) aligned;
	dcl     i			 fixed bin;	/* index variable */
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24),
				 fixed bin (35));
	dcl     (addr, null, fixed, rel, rtrim, ptr) builtin;
	dcl     rel_opening_id	 bit (36) aligned;
	dcl     style		 fixed bin (17);
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering routine */
	dcl     input_file_name	 char (*);	/* file name to be formatted */
	dcl     file_segment_name	 char (32);	/* rtrim of input_file_name */
          dcl     mrds_data_$relation_blocking_factor fixed bin (17) external static;
	dcl     mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35));
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_access fixed bin (35) ext static;
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* error output routine */
	dcl     NULL_OFFSET		 int static bit (18) unal init ((18)"1"b) options (constant);
	dcl     OFF		 bit (1) aligned internal static options (constant) init ("0"b);
	dcl     ON		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     relation_manager_$close entry (bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$create_index entry (bit (36) aligned, ptr, bit (36) aligned, fixed bin (17), bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$create_relation entry (char (*), char (*), ptr, ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$close	 entry (bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$create_MRDS_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 (17), bit (36) aligned, fixed bin (35));
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;
%page;
%include mdbm_file_model;
%page;
%include mdbm_rs_info;
%page;
%include mrds_dbcb;
%page;
%include mdbm_db_model;
%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 access_mode_values;
     end mrds_rst_format_file;
��



		    mrds_rst_get_seg_ptr.pl1        04/18/85  1454.7r w 04/18/85  0909.1       47151



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

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

mrds_rst_get_seg_ptr: proc (rsc_ptr, head_of_list_ptr, seg_name, create_sw, seg_ptr, code);

/* This procedure searches the specified list in rsc for for the segment name
   If the create_sw is ON and the
   segment name was not found in the specified list the segment name is
   added to the list and the segment created.
   If the create_sw is ON and the segment name was found in the list the seg_ptr returned
   is null and code = mrds_error_$rst_list_duplicate.

   if create_sw = OFF then the bit count is adjusted on the segment and the segment is inititated if possible.

   The segment pointer and code are returned by this procedure.
*/


/*  	HISTORY
   Initially written by Roger D.Lackey Sept, 78
   Modified by R. D. Lackey January 16, 1979 to add adjust_bit_count

   81-01-31 Jim Gray : added call to set needed access for DBA types,
   if access violation occurred. also changed to only make call
   to adjust_bit_count and/or initiate, if the seg ptr or bit count unknown
   in order to improve performance.

   82-07-02 R. Harvey : changed reference of dmd$set_needed_access to
   dmd_$set_needed_access
*/



/*	PARAMETERS	*/

/* dcl rsc_ptr  pointer; 				/* (INPUT) Pointer to rsc (restructuring control) segment */
	dcl     head_of_list_ptr	 ptr;		/* (INPUT) Pointer to head of list to be searched */
	dcl     seg_name		 char (32) aligned; /* (INPUT) Name of segment we are searching for */
	dcl     create_sw		 bit (1);		/* (INPUT) On =&gt; create segment */
	dcl     seg_ptr		 ptr;		/* (OUTPUT) Pointer to segment (may be null) */
	dcl     code		 fixed bin (35);	/* (OUTPUT) Error code */

Start:

	call mrds_rst_list_element$add (seg_name, SEG_INFO, rsc_ptr, head_of_list_ptr, seg_info_ptr, code);

	if code = 0 | code = mrds_error_$rst_list_duplicate then do;

		if code = 0 then do;		/* Entry was added to list */

			seg_info.name = seg_name;	/* Init seg info stuff */
			if head_of_list_ptr = rsc.h_n_seg_info_ls_ptr then
			     seg_info.dir = rsc.temp_dir;
			else seg_info.dir = rsc.dbp;
			seg_info.seg_ptr = null;
			seg_info.bcnt = 0;

		     end;

		if create_sw then do;		/* create_sw = ON the want to create a seg */

			if code = 0 then do;	/* Entry was added to the list */

				call hcs_$make_seg (seg_info.dir, seg_info.name, "", 10, seg_info.seg_ptr, code);
				seg_ptr = seg_info.seg_ptr;

			     end;
		     end;

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

		else do;				/* Create_sw = OFF */

			if ^(seg_info.seg_ptr = null () | seg_info.bcnt = 0) then do; /* already set */
				code = 0;
				seg_ptr = seg_info.seg_ptr;
			     end;
			else do;

				call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, bit_count, code);
				if code = error_table_$moderr then do;
					call dmd_$set_needed_access
					     (seg_info.dir, code); /* fails if caller not DBA */
					if code ^= 0 then
					     code = error_table_$moderr;
					else call adjust_bit_count_ (seg_info.dir, seg_info.name, "1"b, bit_count, code);

				     end;

				if code = 0 then
				     call hcs_$initiate_count (seg_info.dir, seg_info.name, "",
					seg_info.bcnt, 0, seg_info.seg_ptr, code);
				seg_ptr = seg_info.seg_ptr;
			     end;

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

		     end;


	     end;

	else seg_ptr = null;			/* Something was wrong */


exit:	return;

/*	OTHERS	*/

	dcl     bit_count		 fixed bin (35);	/* For adjust bit count */
	dcl     adjust_bit_count_	 entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     mrds_rst_list_element$add entry (char (32) aligned, fixed bin, ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_error_$rst_list_duplicate ext fixed bin (35);
	dcl     sys_info$max_seg_size	 ext fixed bin (35);
	dcl     (addr, fixed, null, rel) builtin;
	declare error_table_$moderr	 fixed bin (35) ext;/* incorrect access */
	declare dmd_$set_needed_access entry (char (*), fixed bin (35)); /* sets access for DBA types */

%include mrds_rst_rsc;

%include mrds_rst_global_lists;

%include mrds_rst_tree;


     end mrds_rst_get_seg_ptr;
�



		    mrds_rst_index_handler.pl1      10/16/86  1551.9rew 10/16/86  1142.6      103959



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


/****^  HISTORY COMMENTS:
  1) change(86-04-03,Spitzer), approve(86-04-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     remove unused dcls.
                                                   END HISTORY COMMENTS */


/* HISTORY:

   originally written by jim gray - - october 1978
   Modified November 1978, by Roger Lackey to  add define &amp; cmdb section.

   81-05-18 Jim Gray : added check for number of indexed attributes
   exceeding the capabilities of the rel_id field used in the vfile
   key for secondary indexes.

   83-01-11 Ron Harvey : changed to zero out the index_id field and to set
   set max_attr_index_id field to beyond the maximum.

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


mrds_rst_index_handler: procedure (rsc_ptr, list_ptr);

/* DESCRIPTION:

   this routine builds/alters the mrds database model index information
   and the global entity lists maintained by RMDB/CMDB,
   based upon the index data and directive that is active when
   called by the RMDB/CMDB parser.
   the directive may be undefine, define, redefine, or cmdb and the data is a linked list of
   structures holding the index information and its attribute list

*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   list_ptr - - (input) pointer to the relation structure headed list of attribute structures

   database model - - (output) updated model with altered index information

   global lists - - (output) the list of database entities, updated
   according to directive and data

   error_output - - (output) via mrds_rst_error calls, of error messages

*/

/* REMAINING ERRORS:


   define, cmdb:

   the index name may be the &lt;error_symbol&gt;(this may be ignored)
   one of the attribute names may be the &lt;error_symbol&gt;(this may be ignored)
   the index may already be defined in the database
   one of the given attributes may not be defined as part of the given index

   undefine,    redefine:

   same as define, except index name may not be defined in the database

   note: "(this may be ignored)" means a previous error will prevent
   a database model with erroneous information from being built

*/

Start:
	directive_ptr = rsc.directive_ptr;		/* So we can use directive str */
	stmt_ptr = rsc.stmt_ptr;

	index_ptr = list_ptr;
	index_relation_name = rel_index.rel_name;	/* same for all directives */
	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_index_handler", ON,
		(index_relation_name));

	if directive.type = UNDEFINE then do;		/* Undefine the index */

/* THIS IS NOT IMPLEMENTED YET SO ISSUE AN ERROR MSG */

		if stmt (directive.type).index.number &gt; 0 then ;
		else call error (2, mrds_error_$rst_undone_option,
			"The index handler will not implement the ""undefine"" directive" ||
			" until a later release.");

	     end;					/* END of undefine */

	if directive.type = DEFINE | directive.type = CMDB then do; /* Define or cmdb section */


		item_ptr = rel_index.i_ptr;		/* rel_index.i_ptr points to list of indexed
						   attributes for this relation */
						/* Make sure relation is defined for data base */

		call mrds_rst_tree_search (rel_index.rel_name, rsc.h_grel_ptr, node_ptr, parent_ptr, success);

		if ^success then do;		/* Relation name was not found in db */

			call mrds_rst_error (rsc_ptr, 2, mrds_error_$rst_undef_rel,
			     "The indexed relation """ || rtrim (rel_index.rel_name) ||
			     """ on line " || ltrim (char (rel_index.line_num)) ||
			     " specified for the indexed attribute """
			     || rtrim (item.name) || """ has not been defined in the database.");

/* check that the given attributes are at least defined in the database */

			do while (item_ptr ^= null ());

			     call mrds_rst_tree_search (item.name, rsc.h_gattr_ptr, node_ptr, parent_ptr, success);

			     if ^success then do;


				     call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undef_attr,
					"The attribute """ || rtrim (item.name) || """ given on line " ||
					ltrim (char (item.line_num)) || " is not defined in the database.");

				end;

			     item_ptr = item.next;

			end;


		     end;

		else do;				/* Relation exists for this attribute */

			rel_gl_ptr = node_ptr -&gt; node.data; /* Set the relation global element pointer */
			ri_ptr = rel_gl_ptr -&gt; gl.item_info_ptr; /* So we can reference rel_info */

/* check for attempt to set index in a non-new file during the current release */

			file_gl_ptr = rel_gl_ptr -&gt; gl.other_info_ptr; /* get rel's file gl ptr */
			if file_gl_ptr -&gt; gl.parse_info_ptr = null () then do; /* not from source =&gt; existing file */
				call ioa_$rs ("^a^a^a ^d ^a ^a", message, message_length,
				     "The relation """, rel_index.rel_name, """ on line", rel_index.line_num,
				     "has a secondary index statement given for it, but does not belong to a newly created file,",
				     "this option will not be implemented until a later release.");
				call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message));
			     end;
			else do;			/* new file */
				file_gl_ptr -&gt; gl.affected = ON; /* file where relation resides is affected */
				rel_gl_ptr -&gt; gl.affected = ON; /* This relation is affected */

/* Find attribute in sublist of relation */

				do while (item_ptr ^= null); /* Do all attributes to indexed */

				     call mrds_rst_tree_search (item.name, rel_gl_ptr -&gt; gl.item_sub_list_ptr,
					node_ptr, parent_ptr, success);

				     if ^success then do; /* Attribute was not found in this relation */

					     call mrds_rst_error (rsc_ptr, 2, mrds_error_$rst_not_rel_attr,
						"The attribute """ || rtrim (item.name) ||
						""" given on line " || ltrim (char (item.line_num)) ||
						" was not defined for the relation """ ||
						rtrim (rel_index.rel_name) || """.");

					end;
				     else do;	/* Attribute was found in this relation */

					     attr_sl_ptr = node_ptr -&gt; node.data; /* Attribute sub_list entry pointer */
					     ai_ptr = attr_sl_ptr -&gt; sl.item_info_ptr; /* So we can reference attr_info */
					     fm_ptr = pointer (ai_ptr, 0); /* rel's file ptr */

					     if ai_ptr = null () | ri_ptr = null () | fm_ptr = null () then ;
					     else do;


						     if attr_info.index_attr then /* Attribute was already indexed */
							call mrds_rst_error (rsc_ptr, 1, mrds_error_$previously_defined_index,
							     "The attribute """ || rtrim (item.name) ||
							     """ on line " || ltrim (char (item.line_num)) ||
							     " in relation """ || rtrim (rel_index.rel_name) ||
							     """ was already defined as a secondary index.");

						     else do; /* Make this attribute indexed */

/* check for the indexed attribute being within maximum key length */

							     if attr_info.bit_length &gt; 9 * mrds_data_$max_key_len then
								call mrds_rst_error (rsc_ptr, 2, mrds_error_$long_key,
								     "The attribute """ || rtrim (item.name) ||
								     """ on line " || ltrim (char (item.line_num)) ||
								     " in relation """ || rtrim (rel_index.rel_name) ||
								     """ has a secondary key data length of " ||
								     ltrim (char (ceil (attr_info.bit_length / 9))) ||
								     " characters, which is longer than the allowed maximum length of "
								     || ltrim (char (mrds_data_$max_key_len)) || " characters.");
							     else do;

								     attr_info.index_attr = ON; /* Mark the attribute as a secondary index */
								     rel_info.indexed = ON; /* relation now has secondary indexes */

								     attr_info.index_id = OFF; /* This needs to be cleared */
								     attr_gl_ptr = attr_sl_ptr -&gt; sl.global_list_ptr;
								     attr_gl_ptr -&gt; gl.affected = ON; /* Mark attr as affected */
								end;
							end;
						end;
					end;

				     item_ptr = item.next; /* Continue to next attribute to be indexed (if any) */
				end;		/* End of DO WHILE (item_ptr ^= null) */

			     end;
		     end;				/* END of relation exists do */
	     end;					/* END of DEFINE | CMDB  section */

	if directive.type = REDEFINE then do;		/* REDEFINE section */

/* THIS DIRECTIVE IS NOT IMPLEMENTED YET -- SO ISSUE AN ERROR MSG */


		if stmt (directive.type).index.number &gt; 0 then ;
		else call error (2, mrds_error_$rst_undone_option,
			"The index handler will not implement the ""redefine"" directive" ||
			" until a later release.");


	     end;					/* END of REDEFINE section */


exit:
	if rsc.trace_sw then
	     call mrds_rst_meter (rsc_ptr, "mrds_rst_index_handler", OFF /* EXIT */,
		(index_relation_name));
	return;

error: proc (sev, cd, msg);

	dcl     sev		 fixed bin;	/* (INPUT) Severity level */
	dcl     cd		 fixed bin (35);	/* (INPUT) error code */
	dcl     msg		 char (*);	/* (INPUT)  specific error information */

	call mrds_rst_error (rsc_ptr, sev, cd, msg);
	goto exit;

     end error;

	declare (fixed, addr, rel, null, ceil, char, ltrim, pointer, rtrim) builtin;
	declare list_ptr		 ptr;		/*  pointer to parse info list */

	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */
	dcl     mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */
	declare ioa_$rs		 entry options (variable); /* string manipulator */

	dcl     mrds_error_$previously_defined_index fixed bin (35) external;
	dcl     mrds_error_$rst_undef_rel fixed bin (35) external;
	dcl     mrds_error_$rst_not_rel_attr fixed bin (35) external;
	declare mrds_error_$undef_attr fixed bin (35) ext;
	dcl     mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */

	declare attr_gl_ptr		 ptr;		/* pointer to global attr element */
	declare file_gl_ptr		 ptr;		/* pointer to file global list element */
	dcl     rel_gl_ptr		 pointer;		/* Pointer to global list structure (gl) for relation */
	dcl     attr_sl_ptr		 pointer;		/* Pointer to relation sublist
						   (list of attr's for this relation ) */

	dcl     ON		 bit (1) internal static options (constant) init ("1"b); /* true state */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b); /* false */

	declare message		 char (256) varying;/* specifics of error message */
	declare message_length	 fixed bin (21);	/* length of specifics message */
	declare index_relation_name	 char (32);	/* input name for metering */
	declare mrds_data_$max_key_len fixed bin (35) ext;/* longest key allowed, in chars */
	declare mrds_error_$long_key	 fixed bin (35) ext;/* key too long error */
          declare sys_info$max_seg_size  fixed bin(35) ext static;

%include mrds_rst_rsc;
%include mrds_rst_semantics;
%include mrds_rst_parse_info;
%include mdbm_file_model;

%include mdbm_db_model;

%include mrds_rst_global_lists;

%include mrds_rst_tree;
     end mrds_rst_index_handler;
�



		    mrds_rst_list_element.pl1       04/18/85  1454.7r w 04/18/85  0909.2       53379



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

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

mrds_rst_list_element: procedure (key, structure_type, rsc_ptr, root_ptr, structure_ptr, error_code);


/* HISTORY:

   originally written by jim gray - - july 1978
   modified by Jim Gray 2/19/79, to allocate structures in areas according to type,
   this changed the area_ptr input to an rsc_ptr input parameter

*/

/* DESCRIPTION:

   add or delete global list header and data space
   the global restructuring lists are made up of elements
   that have two parts.  the head portion is a node
   in a binary tree with a link to a data portion that
   may be one of several pl1 structures.

   there are two entries:
   entry add - inserts the head portion into the
   tree and links it newly allocated data space.
   entry delete - deletes the head portion and
   frees the allocated data space.     */


/* PARAMETERS:

   key - - (input) data key used for location of head portion in search tree

   structure_type - - (input) the type of pl1 structure in the include file
   that is to be allocated or freed (see include file)

   rsc_ptr - - (input) pointer to the common rsc segment, that contains pointers to the areas where
   the different structure types are to be allocated, or freed from

   root_ptr - - (input/output) pointer to desired list to be manipulated,
   additions to empty lists, or deletions of root nodes change it

   error_code - - (output) value indicating either failure reason or success

   structure_ptr - - (output) when adding, the resultant pointer to the
   newly allocated structure(or to the existing structure when duplicate add attempted)

*/
%page;

add: entry (key, structure_type, rsc_ptr, root_ptr, structure_ptr, error_code);

/* entry to add element to global list
   first, get head portion for list element into
   it's proper place in the list */

	call mrds_rst_tree_insert (key, rsc_ptr, root_ptr, node_ptr, success);

/* no success means attempt to add duplicate to list,
   return error code and pointer to existing structure */

	if ^success then do;
		error_code = mrds_error_$rst_list_duplicate;
		structure_ptr = node_ptr -&gt; node.data;
	     end;

	else do;

/* get new data portion for list element using
   the given area and structure parameters */

		if structure_type = MAIN_LIST then do;
			error_code = 0;
			call mrds_rst_rsc_alloc (rsc_ptr, GL, structure_ptr);
		     end;
		else if structure_type = SUB_LIST then do;
			error_code = 0;
			call mrds_rst_rsc_alloc (rsc_ptr, SL, structure_ptr);
		     end;
		else if structure_type = SEG_INFO then do;
			error_code = 0;
			call mrds_rst_rsc_alloc (rsc_ptr, SEGINFO, structure_ptr);
		     end;
		else do;
			error_code = mrds_error_$rst_invalid_structure_type;
			structure_ptr = null ();
		     end;

/* link data portion of element to it's head part
   that is in the global list */

		node_ptr -&gt; node.data = structure_ptr;

	     end;

	return;





delete: entry (key, structure_type, rsc_ptr, root_ptr, error_code);

/* entry to delete global element
   first delete the head portion from list,
   saving pointer to the data portion */

	call mrds_rst_tree_delete (key, rsc_ptr, root_ptr, structure_ptr, success);

/* no success means key node was not found */

	if ^success then
	     error_code = mrds_error_$rst_list_delete_fail;

	else

/* free the data portion space with size according to structure type */

	     if structure_type = MAIN_LIST then do;
		error_code = 0;
		call mrds_rst_rsc_alloc$free (rsc_ptr, GL, structure_ptr);
	     end;
	else if structure_type = SUB_LIST then do;
		error_code = 0;
		call mrds_rst_rsc_alloc$free (rsc_ptr, SL, structure_ptr);
	     end;
	else if structure_type = SEG_INFO then do;
		error_code = 0;
		call mrds_rst_rsc_alloc$free (rsc_ptr, SEGINFO, structure_ptr);
	     end;
	else error_code = mrds_error_$rst_invalid_structure_type;
%page;


	dcl     null		 builtin;
	dcl     mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* work area manager */
	dcl     mrds_rst_rsc_alloc$free entry (ptr, fixed bin, ptr); /* freeing entry in work area manager */
	dcl     mrds_rst_tree_delete	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* tree node delete routine */
	dcl     mrds_rst_tree_insert	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* tree node insertion routine */

	dcl     structure_ptr	 ptr;		/* pointer to data space just added or to be deleted */

	dcl     structure_type	 fixed binary;	/* number 0f structure desired, see include file */
	dcl     error_code		 fixed binary (35); /* zero or failure reason code */

	dcl     mrds_error_$rst_list_duplicate fixed binary (35) external; /* attempt to add duplicate error */
	dcl     mrds_error_$rst_invalid_structure_type fixed binary (35) external; /* undefined structure type error */
	dcl     mrds_error_$rst_list_delete_fail fixed binary (35) external; /* attempt to delete missing key */
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_rsc;
%page;
%include mdbm_seg_area;
%page;
%include mrds_rst_global_lists;


     end;


�



		    mrds_rst_meter.pl1              04/18/85  1454.7r w 04/18/85  0909.2       21303



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

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

mrds_rst_meter: proc (rsc_ptr, module_name, in_out, msg);

/*  PARAMETERS */

/* rsc_ptr     	pointer		pointer to rsc control segment
   module_name	char (*)		name of module making call
   in_out		bit (1)		On = entering module  OFF = exiting module
   msg 		char (*)		message to be associated with metering entry.

*/

/* HISTORY:  Initially written by R. D. Lackey October, 1978 */

	dcl     (addr, fixed, rel)	 builtin;
	dcl     module_name		 char (*);	/* (INPUT) Name of module making metering call */
	dcl     in_out		 bit (1);		/* (INPUT) On = entering   OFF = exiting */
	dcl     msg		 char (*);	/* (INPUT) Message to be associated with metering entry */

	dcl     cpu_time_and_paging_	 entry (fixed bin, fixed bin (71), fixed bin);
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     vtime		 fixed bin (71);
	dcl     pf		 fixed bin;
	dcl     pd_pf		 fixed bin;
	dcl     enter_exit		 char (5);
	dcl     sys_info$max_seg_size	 ext fixed bin (35);


	if in_out = "1"b then enter_exit = "IN:";
	else enter_exit = " OUT:";

	if rsc.meter_sw then do;			/* Meter */
		call cpu_time_and_paging_ (pf, vtime, pd_pf);

		call ioa_$ioa_switch (rsc.trace_metering_iocb_ptr,
		     "^5a^2x^32a^1x^12d^2x^8d^2x^8d^2x^a",
		     enter_exit, module_name, vtime, pf, pd_pf, msg);
	     end;

	else call ioa_$ioa_switch (rsc.trace_metering_iocb_ptr,
		"^5a^2x^a;", enter_exit, module_name);

	return;
%page;
%include mrds_rst_rsc;

     end mrds_rst_meter;
�



		    mrds_rst_model_alloc.pl1        10/16/86  1551.9r w 10/16/86  1143.7      118575



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

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

/* HISTORY:

   originally written by jim gray - - February 1979

   82-05-11 Roger Lackey : Changed the way model_seg_path_dir and
   model_seg_path_entry were deterimded form model_seg_path by replacing
   old  code (which could get a stringsize condition)
   with a call to expand_pathname_

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

mrds_rst_model_alloc: procedure (rsc_ptr, model_seg_path, struct_type, struct_ptr);

/*
   .                        BEGIN_DESCRIPTION
   this routine handles all allocations and freeing of structures to be
   placed in the database model for a MRDS database, this includes either
   the db_model segment, or one of the file_model segments.
   there are a total of three entries, the normal entry is for allocation
   of fixed length structures, the $variable entry is for allocation of
   structures that are of variable length, based on one paramater,
   and the $free entry is used to free a given allocation of a particular
   structure type.
   .                        END_DESCRIPTION
*/

/* PARAMETERS:

   normal entry ===
   rsc_ptr - - (input) pointer to the common control segment "rsc"

   model_seg_path - - (input) the absolute pathname of the segment in which
   the allocation is to take place, thus the pathname of either
   the db_model, or one of the file_models

   struct_type - - (input) fixed binary number that indicates which structure
   is to be allocated. the include file mrds_rst_struct_types
   gives the constants that are used for that purpose.

   struct_ptr - - (output) pointer to the newly allocated structure of the type given by struct_type.
   it will be null, if the model area overflowed - the user must check for this.

   $variable entry ===
   struct_size - - (input) a fixed binary (35) number, in addition to those above,
   that gives the length for the current allocation of this structure type,
   that has a variable length based on one parameter.

   $free entry ===
   same as the normal entry, except struct_ptr is an input parameter,
   and it points to the allocation instance to be freed.
*/

/* establish on unit to capture model overflow */

	on area
	     begin;
		struct_ptr = null ();		/* to tell caller we failed */
		goto return_label;
	     end;

/* normal allocation entry point */

	FREE = OFF;
	goto common;


/* freeing entry point */

mrds_rst_model_alloc$free: entry (rsc_ptr, model_seg_path, struct_type, struct_ptr);

	FREE = ON;

/* determine if we are freeing a variable length allocation */

	if struct_type &lt;= hbound (case, 1) then
	     goto common;
	else goto var_common;


common:

	if ^rsc.trace_sw then ;
	else call trace (ON);			/* input call */

	call decode_model_seg_path ();

/* check that the encoding for structure type is within the legal range */

	if struct_type &lt; lbound (case, 1) | struct_type &gt; hbound (case, 1) then
	     call bad_struct_type ();

	else do;

/* good structure type code, go to the allocate that it indicates for the
   given structure to be allocated, and the area in which it will reside */

		goto case (struct_type);


/* db_model area structures */

case (0):

		if FREE then ;			/* can't free till not head of segment */
		else do;
			call hcs_$make_seg (model_seg_path_dir, model_seg_path_entry, "",
			     01010b /* rw mode */, struct_ptr, error_code);
			if error_code = 0 then ;
			else call unable_to_make_segment ();
		     end;
		goto return_label;

case (1):

		if FREE then
		     free struct_ptr -&gt; file_info in (db_model_area);
		else allocate file_info set (struct_ptr) in (db_model_area);
		goto return_label;

case (2):

		if FREE then
		     free struct_ptr -&gt; domain_info in (db_model_area);
		else allocate domain_info set (struct_ptr) in (db_model_area);
		goto return_label;

case (3):

		if FREE then
		     free struct_ptr -&gt; path_entry in (db_model_area);
		else allocate path_entry set (struct_ptr) in (db_model_area);
		goto return_label;

case (4):

		if FREE then
		     free struct_ptr -&gt; stack_item in (db_model_area);
		else allocate stack_item set (struct_ptr) in (db_model_area);
		goto return_label;

case (5):

		if FREE then
		     free struct_ptr -&gt; version_status in (db_model_area);
		else allocate version_status set (struct_ptr) in (db_model_area);
		goto return_label;

case (6):

		if FREE then
		     free struct_ptr -&gt; changer in (db_model_area);
		else allocate changer set (struct_ptr) in (db_model_area);
		goto return_label;

/* file_model  area structures */

case (7):

		if FREE then ;			/* can't free til not segment head */
		else do;
			call hcs_$make_seg (model_seg_path_dir, model_seg_path_entry, "", 01010b /* rw mode */,
			     struct_ptr, error_code);
			if error_code = 0 then ;
			else call unable_to_make_segment ();
		     end;
		goto return_label;

case (8):

		if FREE then
		     free struct_ptr -&gt; rel_info in (file_model_area);
		else allocate rel_info set (struct_ptr) in (file_model_area);
		goto return_label;

case (9):

		if FREE then
		     free struct_ptr -&gt; attr_info in (file_model_area);
		else allocate attr_info set (struct_ptr) in (file_model_area);
		goto return_label;

case (10):

		if FREE then
		     free struct_ptr -&gt; parent_link_info in (file_model_area);
		else allocate parent_link_info set (struct_ptr) in (file_model_area);
		goto return_label;

case (11):

		if FREE then
		     free struct_ptr -&gt; child_link_info in (file_model_area);
		else allocate child_link_info set (struct_ptr) in (file_model_area);
		goto return_label;

case (12):

		if FREE then
		     free struct_ptr -&gt; attr_list in (file_model_area);
		else allocate attr_list set (struct_ptr) in (file_model_area);
		goto return_label;

case (13):

		if FREE then
		     free struct_ptr -&gt; sort_key in (file_model_area);
		else allocate sort_key set (struct_ptr) in (file_model_area);
		goto return_label;

case (14):

		if FREE then
		     free struct_ptr -&gt; dup_prev in (file_model_area);
		else allocate dup_prev set (struct_ptr) in (file_model_area);
		goto return_label;

case (15):

		if FREE then
		     free struct_ptr -&gt; select_chain in (file_model_area);
		else allocate select_chain set (struct_ptr) in (file_model_area);
		goto return_label;


	     end;

mrds_rst_model_alloc$variable: entry (rsc_ptr, model_seg_path, struct_type, struct_size, struct_ptr);

/* entry to handle structures whose length is variable */

	FREE = OFF;

var_common:

	if ^rsc.trace_sw then ;
	else call trace (ON);			/* input call */

/* establish on unit to capture model overflow */

	on area
	     begin;
		struct_ptr = null ();		/* to tell caller we failed */
		goto return_label;
	     end;

	call decode_model_seg_path ();

	if struct_type &lt; lbound (var_case, 1) | struct_type &gt; hbound (var_case, 1) then
	     call bad_struct_type ();
	else if struct_size &lt; 1 then
	     call bad_struct_size ();

	else do;

/* good encoding and size given, go allocate the given structure
   with the specified size, and place it according to the area policy */

		goto var_case (struct_type);

var_case (30):

		if FREE then
		     free struct_ptr -&gt; constant in (db_model_area);
		else do;
			alloc_length = struct_size;
			allocate constant set (struct_ptr) in (db_model_area);
		     end;
		goto return_label;

var_case (31):

		if FREE then
		     free struct_ptr -&gt; atd in (file_model_area);
		else do;
			atd_len = struct_size;
			allocate atd set (struct_ptr) in (file_model_area);
		     end;
		goto return_label;

var_case (32):

		if FREE then
		     free struct_ptr -&gt; comp_no_array in (file_model_area);
		else do;
			ncomp_init = struct_size;
			allocate comp_no_array set (struct_ptr) in (file_model_area);
		     end;
		goto return_label;

	     end;

return_label:

	if ^rsc.trace_sw then ;
	else call trace (OFF);			/* output call */


	return;

decode_model_seg_path: procedure ();

/* get the pointer, directory, and entry for either the
   file_model or db_model, depending on the model segment path input */

	call expand_pathname_ (model_seg_path, model_seg_path_dir, model_seg_path_entry, error_code);
	if error_code ^= 0 then
	     call mrds_rst_error (rsc_ptr, 4, error_code,
		"Bad pathname: " || model_seg_path);


	else do;
		seg_ptr = cv_ptr_ (model_seg_path, error_code);

/* code ^= 0, if seg not created yet for db or file_model */

		if error_code ^= 0 then do;
			dbm_ptr = null ();
			fm_ptr = null ();
		     end;
		else do;
			if model_seg_path_entry = "db_model" then do;
				dbm_ptr = seg_ptr;
				fm_ptr = null ();
			     end;
			else do;
				fm_ptr = seg_ptr;
				dbm_ptr = null ();
			     end;
		     end;


	     end;

     end;

bad_struct_type: procedure ();

/* error routine for bad structure encoding value */

	call ioa_$rs ("^a ^d ^a", message, message_length,
	     "LOGIC ERROR in mrds_rst_model_alloc,", struct_type,
	     "is an invalid code for structure type.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message));

     end;

bad_struct_size: procedure ();

/* report bad strructure allocation length */

	call ioa_$rs ("^a ^d ^a", message, message_length,
	     "LOGIC ERROR in mrds_rst_model_alloc,", struct_size,
	     "is an illegal structure allocation size.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message));

     end;

unable_to_make_segment: procedure ();

/* report trouble in making a model segment */

	call ioa_$rs ("^a^a^a^a^a", message, message_length,
	     "Unable to make the model segment with directory """,
	     model_seg_path_dir, """ and entry portion """,
	     model_seg_path_entry, """ in the database model.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message));

     end;

trace: procedure (in_out);

/* common to metering routine */

	struct_type_picture = struct_type;
	call mrds_rst_meter (rsc_ptr, "mrds_rst_model_alloc", in_out, (struct_type_picture));


	declare in_out		 bit (1);		/* on =&gt; input, off =&gt; output call */
	declare struct_type_picture	 picture "99";	/* character version of encoding */

     end;

	declare cv_ptr_		 entry (char (*), fixed bin (35)) returns (ptr); /* gets segments pointer from path */
	declare seg_ptr		 ptr;		/* temp store for segment pointer */
	declare mrds_error_$rst_logic_error fixed bin (35) external; /* program error */
	declare error_code		 fixed bin (35);	/* 0 =&gt; no error, else coded error */
	declare model_seg_path_dir	 char (168);	/* directory portion of pathname */
	declare model_seg_path_entry	 char (32);	/* entry portion of pathname */
	declare sys_info$max_seg_size	 fixed bin (35) external; /* system segment length */
	declare (lbound, hbound, addr, fixed, rel, null) builtin;
	declare mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* trace routine */
	declare ioa_$rs		 entry options (variable); /* string manipulator */
	declare message		 char (96) varying; /* specifics of error */
	declare message_length	 fixed bin (21);	/* length of returned message */
	declare area		 condition;	/* will occur if model space used up */
	declare mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* common error routine */
	declare FREE		 bit (1);		/* on =&gt; free, off =&gt; allocate */
	declare struct_ptr		 ptr;		/* pointer to allocated structure, or instance tobe freed */
	declare struct_type		 fixed bin;	/* encoding value for this structure to allocate or free */
	declare struct_size		 fixed bin (35);	/* length to allocate for variable size struc tures */
	declare model_seg_path	 char (*);	/* pathname of segment to allocate in */
	declare ON		 bit (1) internal static options (constant) init ("1"b); /* true value */
	declare OFF		 bit (1) internal static options (constant) init ("0"b); /* false value */
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); /* creates segments */
	declare file_model_area	 area based (addr (file_model.fm_area));
	declare db_model_area	 area based (addr (db_model.dbm_area));

%include mrds_rst_struct_types;
%include mdbm_file_model;
%include mdbm_db_model;
%include mrds_rst_rsc;

     end;
�



		    mrds_rst_parse.pl1              04/18/85  1454.7r w 04/18/85  0909.2      306567



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 1978

*/

mrds_rst_parse: procedure (rsc_ptr, source_seg_ptr, source_length);

/*
   .                        BEGIN_DESCRIPTION
   table driven lrk parsing algorithm
   method is that of a no backtrack bottom up shift reduce parser
   the tables are built using the automated lrk tool of d. ward
   (see the Multics lrk MTB)

   an additional entry - debug_set - may be call without parameters to set
   a debug switch for debug output
   .                        END_DESCRIPTION
*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to restructure control segment

   source_seg_ptr - - (input) pointer to restructuring source segment

   source_length - - (input) character length of source segment

   (output) will come from the semantic action routines that the parser calls
   as well as from the scanner listing segment output which includes error messages
   ( the listing is in source_seg.list )

*/
%page;
/* normal entry */

	goto PARSE;











/* debug switch set entry */

debug_set: entry ();

/* switch state of debug switch to regulate
   debug output from parser */

	debug_sw = ^debug_sw;
	return;












PARSE:

/* if trace is on, call metering */

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_parse", "1"b /* in */, "");


/* initialize the lexical analyzer, and semantic routines */

	call mrds_rst_scanner$init (rsc_ptr, source_seg_ptr, source_length);
	call mrds_rst_semantics$init (rsc_ptr);




/* go forth and parse the source */
%page;
/*

   ________________________________________________________________________________

   _____________________________________________________________
   | initialize                                                  |
   | do while (^EOI);                                            |
   |      if READ_state then do;                                 |
   |           enter state number into parse stack               |
   |           if look-ahead stack empty                         |
   |           then call scanner; /* puts to look-ahead stack * /|
   |           look in read-table for 1st look-ahead symbol      |
   |           if not found then ERROR                           |
   |           set next state from read-table                    |
   |           if look-ahead transition                          |
   |           then delete 1 state from parse stack              |
   |           else move symbol from look-ahead stack            |
   |                            to lex stack                     |
   |      end;                                                   |
   |      else if LOOK_state then do; /* look ahead n * /        |
   |           do until n symbols in look-ahead stack;           |
   |                call scanner; /* put to look-ahead stack * / |
   |           end;                                              |
   |           look in look-table for n'th look-ahead symbol     |
   |           if not found then ERROR                           |
   |           set next state from look-table                    |
   |      end;                                                   |
   |      else if APPLY_state then do;                           |
   |           call semantics                                    |
   |           delete necessary symbols from lex stack           |
   |           delete necessary states from parse stack          |
   |           look in apply-table for top stacked state         |
   |           set next state from apply-table                   |
   |      end;                                                   |
   | end;                                                        |
   |_____________________________________________________________|
   Generalized parse procedure.

*/

/* get space for lexical stack */

	call mrds_rst_rsc_alloc (rsc_ptr, LEX_STACK, lex_stack_ptr);
	call mrds_rst_rsc_alloc (rsc_ptr, P_STRUCT, p_struct_ptr);
	call mrds_rst_rsc_alloc (rsc_ptr, CUR_LEX_TOP, cur_lex_top_ptr);


/* Parser for tables created by LRK. */


	current_state = 1;
	nil_sym = -1;				/* set nil_sym non-existant */
	nil_flag = "0"b;				/* Initially not in skip error recovery */
	ls_top, ps_top = 0;
	la_put, la_get = 1;
	la_ct = 0;
	token_cnt = 0;
	error_mark = -1;

/* The parsing loop. */
NEXT:
	if (current_state = 0) then goto done_parse;
	current_table = current_state;
	string (db_data) = "";
	db_data.state = current_state;
	goto CASE (DPDA.v1 (current_table));

CASE (3):						/* Shared look */
	current_table = DPDA.v2 (current_table);
CASE (1):						/* Look. */
	la_use = mod (la_get + la_need - 1, -lbound (lex_stack, 1)) + 1;
	if (la_need &gt;= -lbound (lex_stack, 1) - 1) then call too_many (-lbound (lex_stack, 1), "lookahead");
	la_need = la_need + 1;
	goto read_look;

CASE (10):					/* Shared read */
	current_table = DPDA.v2 (current_table);

CASE (9):						/* Read. */
	db_data.type = "READ";
	la_need = 1;
	la_use = la_get;
	goto read_look;

CASE (2):						/* Stack and Shared read */
	current_table = DPDA.v2 (current_table);

CASE (0):						/* Stack and Read. */
	db_data.type = "READ";
	db_data.flag = "*";
	la_need = 1;
	la_use = la_get;
	if (ps_top &gt;= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse");
	ps_top = ps_top + 1;			/* Top of  parsing stack. */
	parse_stack (ps_top) = current_state;		/* Stack the current state. */
	cur_lex_top (ps_top) = ls_top;		/* save current lex top (for recovery) */
read_look:
	do while (la_ct &lt; la_need);			/* make sure enough symbols are available */
	     call mrds_rst_scanner (addr (lex_stack), -la_put);
	     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct + 1;
	end;
	test_symbol = lex_stack.symbol (-la_use);
	m = 0;
	nil = 0;
						/*	Look current symbol up in read list. */
	do i = current_table + 1 to current_table + DPDA.v2 (current_table);
	     n = DPDA.v1 (i);
	     dcl	   an		      fixed bin (24);
	     if n &lt; 0 then an = -n;
	     else an = +n;
	     if (an = test_symbol) then do;
		     next_state = DPDA.v2 (i);
		     goto got_symbol;
		end;
	     if (an &gt; test_symbol) then do;
		     do i = i to current_table + DPDA.v2 (current_table);
			if abs (DPDA.v1 (i)) = nil_sym then nil = i;
		     end;
		     go to not_found;
		end;
	     if n &lt; 0 then m = i;			/* Record a default transition. */
	     else if n = nil_sym then nil = i;		/* Record a nil symbol transition
						   (for skip error recovery) */
	end;
not_found:
	if (m &gt; 0) then do;				/* if marked symbol was in table, use it */
		next_state = DPDA.v2 (m);
		goto got_symbol;
	     end;

	if nil_flag &amp; nil &gt; 0 then do;		/* If skip recovery has just occurred
						   and there is a nil symbol
						   transition take the transition
						   and back up to the nil
						   symbol in the lookahead
						   stack. */
		next_state = DPDA.v2 (nil);
		la_get = mod (la_get - 2, -lbound (lex_stack, 1)) + 1;
		la_ct = la_ct + 1;
		test_symbol = nil_sym;
		go to got_symbol;
	     end;
	line_number = lex_stack (-la_use).line;
	if token_cnt &gt; error_mark then
	     if local_recovered () then goto read_look;

	if skip_recovered () then do;
		call mrds_rst_error (rsc_ptr, 3 /* severity */, mrds_error_$rst_parse_err_recover, (recov_msg));
		goto NEXT;
	     end;
	if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, " ^4i  ", current_state);
	call ioa_$rs ("^a ^d ^a ^a", message, message_length,
	     "Line", lex_stack (-la_get).line, "symbol", getermc (test_symbol, la_get));
	call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_parse_err_no_recover, (message));
	goto done_parse;

got_symbol:
	nil_flag = "0"b;				/* If skip error recovery was
						   in progress, it is now
						   complete. */
	if debug_sw then do;
		if (next_state &lt; 0) then do;		/* is this a look-ahead state? */
			db_data.type = "LK01";
			db_look = la_need;
			db_data.data = geterm (test_symbol, 0); /* display only terminal "name" on look-ahead */
			db_data.flag = " ";
		     end;
		else do;
			db_data.data = getermc (test_symbol, la_get); /* display terminal "name" and data, if available */
		     end;
		call ioa_$ioa_switch_nnl (iox_$user_output, "^a^/", string (db_data));
	     end;
	current_state = next_state;
	if (current_state &lt; 0) then do;		/* Transition is a look-ahead state. */
		current_state = -current_state;
	     end;
	else do;
		if (ls_top &gt;= hbound (lex_stack, 1)) then call too_many (hbound (lex_stack, 1), "lexical");
		ls_top = ls_top + 1;
		lex_stack (ls_top) = lex_stack (-la_get);
		la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
		la_ct = la_ct - 1;
		token_cnt = token_cnt + 1;
	     end;
	goto NEXT;

CASE (6):						/* Apply Shared */
	current_table = DPDA.v2 (current_state + 3);
CASE (4):						/* Apply state. */
CASE (5):						/* Apply single */
	la_need = 1;
	rulen = DPDA.v1 (current_state + 2);
	altn = DPDA.v2 (current_state + 2);
	if debug_sw then do;
		db_data.type = "APLY";
		db_data.data = "(";
		call ioa_$ioa_switch_nnl (iox_$user_output, "^a^i ^i)", string (db_data), rulen, altn);
	     end;
	if (rulen &gt; 0) then do;
		if rsc_ptr -&gt; rsc.severity_high &gt;= 3 then ; /* forget semantics if skip recovery has occured */
		else call mrds_rst_semantics (rulen, altn, lex_stack_ptr, ls_top);
	     end;
	if debug_sw then do;
		call ioa_$ioa_switch_nnl (iox_$user_output, "^-pd=^i ld=^i("
		     , DPDA.v1 (current_state + 1), DPDA.v2 (current_state + 1));
		do t = ps_top to ps_top - DPDA.v1 (current_state + 1) + 1 by -1;
		     call ioa_$ioa_switch_nnl (iox_$user_output, " ^d", parse_stack (t));
		end;
		call ioa_$ioa_switch_nnl (iox_$user_output, ")^/");
	     end;
						/* *	Check for an apply of an empty production.
						   In this case the apply state number must be
						   pushed on 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) = -1 then do;
		if (ps_top &gt;= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse");
		parse_stack (ps_top + 1) = current_state;
	     end;
	ps_top = ps_top - DPDA.v1 (current_state + 1);	/* Delete parse stack states. */
	ls_top = ls_top - DPDA.v2 (current_state + 1);	/* delete lex stack states */
	if ps_top &lt;= 0 then do;
		call ioa_$rs ("^a", message, message_length, "Parse stack empty");
		call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_parse_fail, (message));
		goto done_parse;
	     end;
	do i = current_table + 4 to current_table + DPDA.v2 (current_table);
	     if (DPDA.v1 (i) = parse_stack (ps_top)) then do;
		     current_state = DPDA.v2 (i);
		     goto NEXT;
		end;
	end;
	current_state = DPDA.v2 (current_table + 3);
	goto NEXT;
done_parse:
	if rsc.trace_sw then call mrds_rst_meter (rsc_ptr, "mrds_rst_parse", "0"b /* out */, "");
	return;
						/* %page; */
skip_recovered: proc returns (bit (1));

/* *
   Skip recovery requires that the user difine one or more  recovery
   terminal symbols by means of the

   -recover &lt;nil&gt; st1 st2 ...

   control  included  in  the  lrk  source.   st1  st2 etc. are skip
   terminals.  They are terminals which can  end  statements.   They
   cause  a  table  to  be built for skip recovery.  This table is a
   list of read or lookahead states which can follow the reading  of
   a skip terminal. These states correspond to the beginnings of new
   statements.

   Skip  recovery  is  done  when  an  error  has occurred and local
   recovery (if used) was not successful.  Basically what it does is
   to skip forward in the source by calling  the  scanner  until  it
   encounters  one  of  the skip terminals.  It then tries to find a
   state which followed a previous occurrence of the found terminal.
   If one is found it adjusts the lexical and parse stacks and  then
   procedes.

   Effectively  a  bad "statement" has been discarded.  In this case
   "statement" means an input string bounded by two  identical  skip
   terminals  (such  as  ";"  for  example)  including  the boundary
   terminal on  the  right.   If  the  language  is  such  that  the
   discarded  statement  is optional (syntactically) the rest of the
   input can be checked for syntax errors.

   When a bad "statement" is discarded the parser  is  restarted  in
   the  state  in  which it began to process that statement.  If the
   next input symbol encountered is not acceptable  to  this  state,
   the  parser  makes  a last attempt at error recovery by replacing
   the bad "statement" with the &lt;nil&gt; symbol defined by the -recover
   control if used.

   The &lt;nil&gt; symbol is one which the scanner must NEvER  return.  It
   is  needed  because some languages do not allow all statements to
   occur at every point.  This means that when you back  up  to  the
   last  statement  beginning  point, you may not be allowed to have
   the statement you find next.  As an example, take  this  grammar:
   &lt;g&gt;  ::= &lt;i&gt; | &lt;g&gt; &lt;i&gt; !
   &lt;i&gt;  ::= &lt;a&gt; | &lt;b&gt; !
   &lt;a&gt;  ::= a ; &lt;rd&gt; !
   &lt;rd&gt; ::= r ; | &lt;rd&gt; r ; !
   &lt;b&gt;  ::= b ; &lt;sd&gt; !
   &lt;sd&gt; ::= s ; | &lt;sd&gt; s ; !
   %page;
   Then  suppose  that  you  intended to have an input like line (1)
   below, but instead you got (2):

   (1)  a ; r ; r ; b ; s ; s ; s ; a ; r ; r ; r ;
   (2)  a ; r ; r ; b ; s ; s ; s   a ; r ; r ; r ;

   Suppose that the grammar had specified
   -recover &lt;nil&gt; ;
   and local recovery  is  not  used.   When  the  "s"  "a"  ";"  is
   encountered,  skip  recovery  will discard it as a bad statement.
   But this then means that it will miss the fact that it should  be
   entering  the  &lt;a&gt;  rule.   It  will  then get to the "r" but the
   parser will have restarted in a state which can  read  either  an
   "a",  "b",  or  "s".   So  it  will  have to skip again.  In this
   example, skipping will occur, one statement at a time, until  EOI
   is reached.  This means that no syntax checking is done in all of
   the "r" s which are skipped.  This is not highly desireable.

   However, if you add a rule like this:

   &lt;a&gt;  ::= &lt;nil&gt; &lt;rd&gt; !
   then  the  generated &lt;nil&gt; from skip recovery will allow the &lt;rd&gt;
   to be correctly parsed, reducing  the  number  of  useless  error
   messages by quite a bit, usually.

   These &lt;nil&gt; rules can help parse thru misplaced statements during
   error  recovery,  but  will  never  accept these statements under
   normal circumstances.  The semantics on these &lt;nil&gt; rules  should then report an error.
   */


	dcl     (i, ii)		 fixed bin (24);
	dcl     (j, jj)		 fixed bin (24);
	dcl     c			 fixed bin (24);
	dcl     dec4		 pic "zzz9";

/* * %page; */
%page;

	if (hbound (skip_v1, 1) &lt;= 0) then return ("0"b); /* no skip table */
	error_mark = 0;
	current_table = 1;
	recov_msg = "Unuseable ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	recov_msg = recov_msg || " on line ";
	dec4 = lex_stack (-la_get).line;
	recov_msg = recov_msg || ltrim (dec4);
	recov_msg = recov_msg || ",  Skipped to ";

	nil_sym = skip_v1 (2);			/* SKIP table */
	c = 1;
	do while (c ^= 0);
	     if (la_ct &lt; 1) then do;			/* if look-ahead stack is empty, get a symbol */
		     call mrds_rst_scanner (addr (lex_stack), -la_put);
		     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
		     la_ct = 1;
		end;
	     c = lex_stack.symbol (-la_get);
	     do i = current_table + 2 to current_table + skip_v2 (current_table); /* SKIP table */
		if (skip_v1 (i) = c) then do;		/* SKIP table */
			jj = skip_v2 (i);		/* SKIP table */
			do j = ps_top to 1 by -1;
			     do ii = jj + 1 to jj + skip_v2 (jj); /* SKIP table */
				if (skip_v1 (ii) = parse_stack (j)) then do; /* SKIP table */
					ps_top = j - 1;
					ls_top = cur_lex_top (j);
					current_state = skip_v2 (ii); /* SKIP table */
					recov_msg = recov_msg || geterm (c, 0);
					recov_msg = recov_msg || " on line ";
					dec4 = lex_stack (-la_get).line;
					recov_msg = recov_msg || ltrim (dec4)
					     || " " || copy ("!*!", 26);
					lex_stack (-la_get).symlen = 0;
						/* generate a nil symbol into the look-ahead stack */
					lex_stack (-la_get).symbol = nil_sym;
					la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
						/* Advance past nil symbol.
						   It will not be used unless
						   the next symbol cannot be read. */
					la_ct = la_ct - 1;
					nil_flag = "1"b;
					return ("1"b);
				     end;
			     end;
			end;
		     end;
	     end;
	     la_get = mod (la_get, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct - 1;
	end;
	recov_msg = recov_msg || end_of_input_msg || copy ("!*!", 26);
	current_state = 0;
	return ("1"b);
     end;
%page;
	dcl     (addr, mod, fixed)	 builtin;
	dcl     db_look		 pic "99" defined (db_data.type) pos (3);
	dcl     1 db_data,
		2 flag		 char (1),	/* * means stacked */
		2 state		 pic "zzz9",
		2 fil1		 char (2),
		2 type		 char (6),
		2 data		 char (100);
	dcl     DDop		 (-1:2) char (4) int static init ("LOOK", "FINI", "READ", "ERR");
	dcl     ioa_$ioa_switch_nnl	 entry options (variable);
	dcl     iox_$user_output	 ptr ext static;


	;
	dcl     ls_top		 fixed bin (24);	/* location of top of lexical stack */
	dcl     altn		 fixed bin (24);	/* APPLY alternative number */
	dcl     current_state	 fixed bin (24);	/* number of current state */
	dcl     test_symbol		 fixed bin (24);	/* encoding of current symbol */
	dcl     current_table	 fixed bin (24);	/* number of current table */
	dcl     i			 fixed bin (24);	/* temp */
	dcl     la_ct		 fixed bin (24);	/* number of terminals in look-ahead stack */
	dcl     la_get		 fixed bin (24);	/* location in look_ahead stack to get next symbol */
	dcl     la_need		 fixed bin (24);	/* number of look-ahead symbols needed */
	dcl     la_put		 fixed bin (24);	/* location in look_ahead stack to put next symbol */
	dcl     la_use		 fixed bin (24);	/* location in look-ahead stack to test with */
	dcl     (m, n)		 fixed bin (24);
	dcl     next_state		 fixed bin (24);	/* number of next state */
	dcl     nil_sym		 fixed bin (24);
	dcl     nil		 fixed bin (24);
	dcl     nil_flag		 bit (1);
	dcl     ps_top		 fixed bin (24);	/* location of top of parse stack */
	dcl     recov_msg		 char (150) var;
	dcl     rulen		 fixed bin (24);	/* APPLY rule number */
	dcl     t			 fixed bin (24);
	dcl     sys_info$max_seg_size	 fixed binary (35) external; /* largest segment size */
	dcl     token_cnt		 fixed binary (24); /* number of tokens used */
	dcl     error_mark		 fixed binary (24); /* point to get past before another local correction allowed */
	dcl     line_number		 fixed binary (24); /* line where error detected */
						/* %page; */
geterm: proc (idx, ids) returns (char (100) var);

	dcl     (idx, ids)		 fixed bin (24);
	dcl     temp		 char (100) var;
	dcl     c_str		 char (20000) based;

	temp = "";
get_rest:
	if (ids &gt; 0) then
	     if (lex_stack (-ids).symlen &gt; 0) then do;
		     temp = temp || """";
		     temp = temp || substr (lex_stack (-ids).symptr -&gt; c_str, 1, min (50, lex_stack (-ids).symlen));
		     temp = temp || """";
		     return (temp);
		end;
	if (idx = 0) then temp = end_of_input_msg;
	else temp = substr (string (TC), TL.fc (idx), TL.ln (idx));
	return (temp);
getermc: entry (idx, ids) returns (char (100) var);

	if (idx = 0) then temp = end_of_input_msg;
	else temp = substr (string (TC), TL.fc (idx), TL.ln (idx));
	temp = temp || " ";
	goto get_rest;
     end;
%page;
local_recovered: proc returns (bit (1));

/*
   "    this procedure implements the LRK local error recovery (using
   "    the  DPDA  table).  This  is  done by using the current (bad)
   "    symbol and the next input symbol. All  possible  parses  from
   "    this state are examined. These trial parses proceed until the
   "    next read or lookahead state is encountered. The trial parses
   "    are true simulations of what  can  happen,  apply  states are
   "    chosen according to the simulated top of parse stack.

   "    Given:
   "         B is the current symbol (bad)
   "         N is the next input symbol
   "         C is the current state
   "         R is a "next" read state
   "    These are the conditions which can exist.
   "         C( N )    R( B N )    -kind-
   "            0         1 0    symbol leading to R is missing
   "            0         0 1    B is a wrong symbol
   "            1         1 0    B and N reversed in input
   "            1         0 x    B is an extra symbol in the input
   "            0         0 0    recovery fails

   "    The recovery tries to find  a  useable  combination.  If  one
   "    exists,  the  search  does  not  stop.  If  a  second  one is
   "    encountered, the search stops, a message is  generated  which
   "    says the choice is not unique, and then the first combination
   "    is used.

   "    The local recovery shcheme was altered in  Sept  1977  by  Al
   "    Kepner  to  allow  local  recovery from errors encountered by
   "    look-ahead states.  Preveously  only  errors  encountered  by
   "    read states could be handled.  The error correction scheme is
   "    still the same heuristic described above.
   "
   "    Some  complexity has been added to procedure next_term.  Note
   "    the new variables la_get2 and la_use2.  These  are  necessary
   "    to  handle  the  case  where  an  error  is  encountered by a
   "    look-ahead state and the next state found is not a look-ahead
   "    state.  In this case the next  read  state  encountered  will
   "    correspond  to the "bad" symbol or a symbol to the left of it
   "    (depending on how many look-ahead states preceded the error).
   "    The goal is to  find  the  read  or  look-ahead  state  which
   "    corresponds  to  the  input  symbol to the right of the "bad"
   "    symbol.  The goal is recognized by the condition  "la_use2  =
   "    la_next".   Until  this  goal  is reached look-ahead and read
   "    states are simply passed through using the  look-ahead  stack
   "    to find the appropriate next state.
   */
%page;







	if (test_symbol &lt; 0) then do;
		call ioa_$rs ("^a ^d ^a", message, message_length,
		     "Line", lex_stack (-la_get).line, "Negative terminal; cannot recover");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_parse_err_no_correct, (message));
		return ("0"b);
	     end;
	error_mark = token_cnt + la_need;
	do while (la_ct &lt; la_need + 1);
	     call mrds_rst_scanner (addr (lex_stack), -la_put);
	     la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
	     la_ct = la_ct + 1;
	end;
	if hbound (skip_v1, 1) &gt; 0 then nil_sym = skip_v1 (2); /* SKIP table */
	else nil_sym = -1;
	la_next = mod (la_use, -lbound (lex_stack, 1)) + 1;
	next_symbol = lex_stack (-la_next).symbol;
	dcl     string		 builtin;
	string (sws) = "0"b;
	transit = -1;
	combinations = 0;
	depth = 0;
	if debug_sw then call dump_la;
	do i = current_table + 1 to current_table + DPDA.v2 (current_table) while (combinations &lt; 2);
	     alt_symbol = abs (DPDA.v1 (i));
	     if alt_symbol = nil_sym then go to try_again;
	     if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^4i ^4a ^i ^a^/",
		     current_state, DDop (sign (DPDA.v2 (i))), alt_symbol, geterm (alt_symbol, 0));
	     string (cycle) = "0"b;
	     if combinations &lt; 2 then
		call next_term ((ps_top), (DPDA.v2 (i)));
try_again:
	end;
	recov_msg = "";
	if (transit = -1) then return ("0"b);
	goto case (fixed (string (sws)));

case (0):						/* can't resolve it */
	return ("0"b);

case (3):
case (7):						/* cannot occur */
	signal condition (logic_error);
	dcl     logic_error		 condition;

case (1):						/* B is wrong symbol */
	recov_msg = recov_msg || geterm (transit, 0);
	recov_msg = recov_msg || " used in place of erroneous ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	goto set_symbol;

case (2):						/* symbol leading to R is missing */
	recov_msg = recov_msg || "Missing ";
	recov_msg = recov_msg || geterm (transit, 0);
	recov_msg = recov_msg || " is assumed before ";
	recov_msg = recov_msg || geterm (test_symbol, la_get);
	la_ct = la_ct + 1;
	lex_stack (-la_put) = lex_stack (-la_next);
	lex_stack (-la_next) = lex_stack (-la_use);
	la_put = mod (la_put, -lbound (lex_stack, 1)) + 1;
set_symbol:
	lex_stack (-la_use).token_num = 0;		/* flag as phoney token for semantics */
	la_next = la_use;
	lex_stack (-la_next).symptr = addr (default_symbol);
	lex_stack (-la_next).symlen = length (default_symbol);
	lex_stack (-la_next).line = lex_stack (-(mod (la_put - 2, -lbound (lex_stack, 1)) + 1)).line;
	lex_stack (-la_next).symbol = transit;
	goto done;

case (4):
case (5):						/* B is an extra symbol */
	recov_msg = recov_msg || "Extraneous ";
	recov_msg = recov_msg || geterm (test_symbol, la_use);
	recov_msg = recov_msg || " ignored before ";
	recov_msg = recov_msg || geterm (next_symbol, la_next);
	la_ct = la_ct - 1;
	la_put = mod (la_put - 2, -lbound (lex_stack, 1)) + 1; /* Back up one in look-ahead stack. */
	lex_stack (-la_use) = lex_stack (-la_next);
	goto done;

case (6):						/* B and N reversed */
	recov_msg = recov_msg || geterm (test_symbol, la_use);
	recov_msg = recov_msg || " and ";
	recov_msg = recov_msg || geterm (next_symbol, la_next);
	recov_msg = recov_msg || " are reversed.";
	lex_stack (ls_top + 1) = lex_stack (-la_use);
	lex_stack (-la_use) = lex_stack (-la_next);
	lex_stack (-la_next) = lex_stack (ls_top + 1);
done:
	if combinations &lt;= 1 then ;
	else recov_msg = recov_msg || copy (" ", 30) || "(choose first of many possibilities)";
	call ioa_$rs ("^a ^d ^a", message, message_length,
	     "Line", line_number, recov_msg);
	call mrds_rst_error (rsc_ptr, 1 /* severity */, mrds_error_$rst_parse_err_correct, (message));
	if debug_sw then call dump_la;
	return ("1"b);				/* recovery completed */

	dcl     1 sws,
		2 CNf		 bit (1) unal,	/* current state contains next symbol */
		2 RBNf		 bit (2) unal;	/* next read matches bad or next symbol */
	dcl     combinations	 fixed bin (24);	/* useable combinations found so far */
	dcl     transit		 fixed bin (24);	/* found alternate symbol to use from current state */
	dcl     la_next		 fixed bin (24);	/* temporary "next" look-ahead position */
	dcl     alt_symbol		 fixed bin (24);	/* current alternate symbol */
	dcl     cycle		 (4000) bit (1) unal;
	dcl     default_symbol	 char (13) int static init ("ERROR_SYMBOL_");
	dcl     next_symbol		 fixed bin (24);
	dcl     depth		 fixed bin (24);
						/* %page; */
%page;
dump_la: proc;

	dcl     ii		 fixed bin (24);
	if debug_sw then do;
		ii = la_get;
		do while (ii ^= la_put);
		     call ioa_$ioa_switch_nnl (iox_$user_output, "#la(-^i) ^3i""^a""^/",
			ii,
			lex_stack (-ii).symbol,
			geterm (lex_stack (-ii).symbol, 0));
		     ii = mod (ii, -lbound (lex_stack, 1)) + 1;
		end;
	     end;
     end dump_la;
						/* %page; */
next_term: proc (top, ns);

	look_ahead = (ns &lt; 0);
	if look_ahead then do;
		la_use2 = la_use;
		la_get2 = la_get;
	     end;
	else la_use2, la_get2 = mod (la_get, -lbound (lex_stack, 1)) + 1;
	depth = depth + 5;
	do i = 1 to ps_top;
	     parse_stack2 (i) = parse_stack (i);
	end;
NEXT:
	if (ns = 0) then do;
		transit = 0;
		depth = depth - 5;
		go to done;
	     end;
	ns = abs (ns);
	cur_st = ns;
	if DPDA.v1 (cur_st) = 0 | DPDA.v1 (cur_st) = 2 then do; /* Stack state? */
		if top &gt;= hbound (parse_stack, 1) then call too_many (hbound (parse_stack, 1), "parse");
		top = top + 1;
		parse_stack (top) = cur_st;
	     end;
	goto CASE (DPDA.v1 (cur_st));
CASE (2):						/* Stack and Shared read */
CASE (3):						/* Shared look */
CASE (10):					/* Shared read */
	cur_st = DPDA.v2 (cur_st);
CASE (0):						/* Stack and Read. */
CASE (1):						/* Look. */
CASE (9):						/* Read. */
	if DPDA.v1 (cur_st) = 1 then
	     la_use2 = mod (la_use2, -lbound (lex_stack, 1)) + 1;
	else la_use2 = la_get2;
	if la_use2 = la_next then do;
		if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i READ^/", depth, ns);
		rep = 0;
		do s = test_symbol, next_symbol while (next_symbol ^= alt_symbol);
		     rep = rep + 1;
		     do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (combinations &lt; 2);
			if ((DPDA.v1 (i) &lt; 0) &amp; (-DPDA.v1 (i) &lt;= s))
			     | (DPDA.v1 (i) = s) then do;
				if debug_sw then
				     call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx(^i)^i^/", depth, rep, s);
				if (combinations = 0) then do;
					combinations = 1;
					transit = alt_symbol;
					if (rep = 1) then RBNf = "10"b;
					else RBNf = "01"b;
				     end;
				else combinations = 2;
			     end;
		     end;
		end;
		if (next_symbol = alt_symbol) then do;
			if (combinations = 0) then do;
				CNf = "1"b;
				do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st);
				     if ((DPDA.v1 (i) &lt; 0) &amp; (-DPDA.v1 (i) &lt;= test_symbol))
					| DPDA.v1 (i) = test_symbol then
					RBNf = "10"b;
				end;
				transit = alt_symbol;
				combinations = 1;
			     end;
			else combinations = 2;
		     end;
done:
		depth = depth - 5;
		do i = 1 to ps_top;
		     parse_stack (i) = parse_stack2 (i);
		end;
		return;
	     end;
	else do;
		if la_use2 = la_use			/* la_use points to the bad input symbol. */
		then s = alt_symbol;		/* We are considering an alternate symbol. */
		else
		     s = lex_stack (-la_use2).symbol;
		marked = 0;
		do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st)
		     while (abs (DPDA.v1 (i)) &lt;= s);
		     if abs (DPDA.v1 (i)) = s then
			go to found;
		     else if DPDA.v1 (i) &lt; 0 then
			marked = i;
		end;
		if marked ^= 0 then
		     i = marked;
		else go to done;
found:
		ns = DPDA.v2 (i);
		if ns &gt;= 0 then
		     la_get2 = mod (la_get2, -lbound (lex_stack, 1)) + 1;
		go to NEXT;
	     end;
CASE (4):						/* Apply state. */
CASE (5):						/* Apply single */
CASE (6):						/* Apply Shared */
	if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx^4i APLY^/", depth, ns);
	if DPDA.v1 (cur_st + 1) = -1 then do;
		if (top &gt;= hbound (parse_stack, 1)) then call too_many (hbound (parse_stack, 1), "parse");
		parse_stack (top + 1) = cur_st;
	     end;
	top = top - DPDA.v1 (cur_st + 1);
	if (DPDA.v1 (cur_st) = 6) then
	     cur_st = DPDA.v2 (cur_st + 3);
	if top &gt; 0 then
	     do i = cur_st + 4 to cur_st + DPDA.v2 (cur_st);
		if (DPDA.v1 (i) = parse_stack (top)) then do;
			ns = DPDA.v2 (i);
			goto NEXT;
		     end;
	     end;
	else return;
	ns = DPDA.v2 (cur_st + 3);
	goto NEXT;





	dcl     top		 fixed bin (24),	/* top of parse stack for this invocation */
	        ns		 fixed bin (24);	/* branch to follow */

	dcl     cur_st		 fixed bin (24);	/* current state for this recursion */
	dcl     rep		 fixed bin (24);
	dcl     s			 fixed bin (24);
	dcl     look_ahead		 bit (1);
	dcl     i			 fixed bin (24);
	dcl     la_get2		 fixed bin (24);
	dcl     la_use2		 fixed bin (24);
	dcl     marked		 fixed bin (24);
     end next_term;
     end local_recovered;

/* * %page; */

too_many: proc (x, t);
	p6 = x;
	call ioa_$rs ("^a", message, message_length,
	     "Exceeded " || p6 || " entries of lrk " || t || " stack.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_parse_fail, (message));
	go to stop;

/* *	variables for too_many:	*/
	dcl     p6		 pic "zzzzz9";
	dcl     t			 char (*) parm;
	dcl     x			 fixed bin (24) parm;
     end too_many;
stop:
	;
%page;


	dcl     (abs, copy, hbound, lbound, length, ltrim,
	        min, rel, sign, string, substr) builtin;
	dcl     source_seg_ptr	 ptr;		/* restructuring directives source segment pointer */
	dcl     source_length	 fixed binary (24); /* character length of source segment */
	dcl     mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* working area allocate routine */
	dcl     mrds_rst_scanner$init	 entry (ptr, ptr, fixed binary (24)); /* scanner initialization entry */
	dcl     mrds_rst_scanner	 entry (ptr, fixed bin (24)); /* lexical analyzer routine */
	dcl     mrds_rst_semantics	 entry (fixed bin (24), fixed bin (24), ptr, fixed bin (24)); /* semantic action routines */
	dcl     mrds_rst_semantics$init entry (ptr);	/* semantic initialization entry */
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* error handling routine */
	dcl     ioa_$rs		 entry options (variable); /* routine to return string */
	dcl     message		 char (128) varying;/* message with details of error */
	dcl     message_length	 fixed binary;	/* length of returned error message */
	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering routine */
	dcl     mrds_error_$rst_parse_err_recover fixed bin (35) external; /* skip recovery error */
	dcl     mrds_error_$rst_parse_err_no_recover fixed bin (35) external; /* unable to skip recover  */
	dcl     mrds_error_$rst_parse_err_correct fixed bin (35) external; /* local correction error */
	dcl     mrds_error_$rst_parse_err_no_correct fixed bin (35) external; /* unable to correct locally */
	dcl     mrds_error_$rst_parse_fail fixed bin (35) external; /* parsing cannot proceed error */
	dcl     end_of_input_msg	 char (18) init (" --END_OF_INPUT-- "); /* EOI message */












%include mrds_rst_parse_stack;
%page;
%include mrds_rst_parse_table;
%page;
%include mrds_rst_skip_table;
%page;
%include mrds_rst_terminals;
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;

     end;

�



		    mrds_rst_parse_table.alm        04/18/85  1454.7r w 04/18/85  0909.2      235071



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
	equ	STRD,0
	equ	LOOK,1
	equ	STRDS,2
	equ	LOOKS,3
	equ	APLY,4
	equ	APLY1,5
	equ	APLYS,6
	equ	SKIP,7
	equ	ADJUST,8
	equ	NSRD,9
	equ	NSRDS,10
	equ	T0,0
	equ	ST0,0
"
"
" DPDA table
DPDA:	zero	0,DPDAs
	segdef	DPDA
"
" STATE 1
	equ	ST1,*-DPDA
	zero	STRD,LN1
	zero	13,ST13	"&lt;domain&gt;
	equ	LN1,*-DPDA-ST1-1
"
" STATE 3
	equ	ST3,*-DPDA
	zero	NSRD,LN3
	zero	0,-ST582	"EOI
	zero	14,-ST580	"&lt;attribute&gt;
	zero	15,-ST582	"&lt;relation&gt;
	zero	16,-ST582	"&lt;index&gt;
	equ	LN3,*-DPDA-ST3-1
"
" STATE 8
	equ	ST8,*-DPDA
	zero	STRD,LN8
	zero	4,ST50	"&lt;semicolon&gt;
	zero	-12,ST54	"&lt;identifier&gt;
	equ	LN8,*-DPDA-ST8-1
"
" STATE 11
	equ	ST11,*-DPDA
	zero	STRD,LN11
	zero	0,ST0	"EOI
	equ	LN11,*-DPDA-ST11-1
"
" STATE 13
	equ	ST13,*-DPDA
	zero	STRD,LN13
	zero	5,ST58	"&lt;colon&gt;
	equ	LN13,*-DPDA-ST13-1
"
" STATE 15
	equ	ST15,*-DPDA
	zero	NSRD,LN15
	zero	0,-ST598	"EOI
	zero	15,-ST596	"&lt;relation&gt;
	zero	16,-ST598	"&lt;index&gt;
	equ	LN15,*-DPDA-ST15-1
"
" STATE 19
	equ	ST19,*-DPDA
	zero	STRD,LN19
	zero	4,ST81	"&lt;semicolon&gt;
	zero	-12,ST85	"&lt;identifier&gt;
	equ	LN19,*-DPDA-ST19-1
"
" STATE 22
	equ	ST22,*-DPDA
	zero	APLY1,LN22
	zero	0,0   pd ld
	zero	65,1   rule/alt
	zero	31,ST15 prod/val
	equ	LN22,*-DPDA-ST22-1
"
" STATE 26
	equ	ST26,*-DPDA
	zero	STRD,LN26
	zero	5,ST87	"&lt;colon&gt;
	equ	LN26,*-DPDA-ST26-1
"
" STATE 28
	equ	ST28,*-DPDA
	zero	STRD,LN28
	zero	1,ST135	"&lt;left_parenthesis&gt;
	zero	17,ST137	"&lt;real&gt;
	zero	18,ST141	"&lt;complex&gt;
	zero	19,ST145	"&lt;fixed&gt;
	zero	20,ST149	"&lt;float&gt;
	zero	21,ST153	"&lt;binary&gt;
	zero	22,ST157	"&lt;decimal&gt;
	zero	23,ST161	"&lt;precision&gt;
	zero	24,ST163	"&lt;char&gt;
	zero	25,ST172	"&lt;bit&gt;
	zero	26,ST181	"&lt;varying&gt;
	zero	27,ST184	"&lt;nonvarying&gt;
	zero	28,ST187	"&lt;aligned&gt;
	zero	29,ST194	"&lt;unaligned&gt;
	equ	LN28,*-DPDA-ST28-1
"
" STATE 43
	equ	ST43,*-DPDA
	zero	APLY1,LN43
	zero	0,0   pd ld
	zero	8,1   rule/alt
	zero	8,ST47 prod/val
	equ	LN43,*-DPDA-ST43-1
"
" STATE 47
	equ	ST47,*-DPDA
	zero	STRD,LN47
	zero	3,ST198	"&lt;comma&gt;
	zero	4,ST200	"&lt;semicolon&gt;
	equ	LN47,*-DPDA-ST47-1
"
" STATE 50
	equ	ST50,*-DPDA
	zero	APLY1,LN50
	zero	1,1   pd ld
	zero	7,1   rule/alt
	zero	7,ST3 prod/val
	equ	LN50,*-DPDA-ST50-1
"
" STATE 54
	equ	ST54,*-DPDA
	zero	APLY1,LN54
	zero	0,0   pd ld
	zero	11,1   rule/alt
	zero	10,ST28 prod/val
	equ	LN54,*-DPDA-ST54-1
"
" STATE 58
	equ	ST58,*-DPDA
	zero	APLY1,LN58
	zero	1,1   pd ld
	zero	3,1   rule/alt
	zero	3,ST8 prod/val
	equ	LN58,*-DPDA-ST58-1
"
" STATE 62
	equ	ST62,*-DPDA
	zero	NSRD,LN62
	zero	0,-ST604	"EOI
	zero	16,-ST602	"&lt;index&gt;
	equ	LN62,*-DPDA-ST62-1
"
" STATE 65
	equ	ST65,*-DPDA
	zero	STRD,LN65
	zero	4,ST226	"&lt;semicolon&gt;
	zero	-12,ST230	"&lt;identifier&gt;
	equ	LN65,*-DPDA-ST65-1
"
" STATE 68
	equ	ST68,*-DPDA
	zero	APLY1,LN68
	zero	0,0   pd ld
	zero	70,1   rule/alt
	zero	34,ST62 prod/val
	equ	LN68,*-DPDA-ST68-1
"
" STATE 72
	equ	ST72,*-DPDA
	zero	STRD,LN72
	zero	5,ST234	"&lt;colon&gt;
	equ	LN72,*-DPDA-ST72-1
"
" STATE 74
	equ	ST74,*-DPDA
	zero	APLY1,LN74
	zero	0,0   pd ld
	zero	66,1   rule/alt
	zero	32,ST78 prod/val
	equ	LN74,*-DPDA-ST74-1
"
" STATE 78
	equ	ST78,*-DPDA
	zero	STRD,LN78
	zero	3,ST238	"&lt;comma&gt;
	zero	4,ST240	"&lt;semicolon&gt;
	equ	LN78,*-DPDA-ST78-1
"
" STATE 81
	equ	ST81,*-DPDA
	zero	APLY1,LN81
	zero	1,1   pd ld
	zero	65,2   rule/alt
	zero	31,ST15 prod/val
	equ	LN81,*-DPDA-ST81-1
"
" STATE 85
	equ	ST85,*-DPDA
	zero	STRD,LN85
	zero	-12,ST244	"&lt;identifier&gt;
	equ	LN85,*-DPDA-ST85-1
"
" STATE 87
	equ	ST87,*-DPDA
	zero	APLY1,LN87
	zero	1,1   pd ld
	zero	4,1   rule/alt
	zero	4,ST19 prod/val
	equ	LN87,*-DPDA-ST87-1
"
" STATE 91
	equ	ST91,*-DPDA
	zero	APLY,LN91
	zero	0,0   pd ld
	zero	13,1   rule/alt
	zero	11,ST131 prod/val
	zero	ST266,ST423
	equ	LN91,*-DPDA-ST91-1
"
" STATE 96
	equ	ST96,*-DPDA
	zero	APLYS,LN96
	zero	0,0   pd ld
	zero	14,1   rule/alt
	zero	11,ST91 prod/val
	equ	LN96,*-DPDA-ST96-1
"
" STATE 100
	equ	ST100,*-DPDA
	zero	APLY,LN100
	zero	0,0   pd ld
	zero	31,1   rule/alt
	zero	14,ST109 prod/val
	zero	ST608,ST249
	equ	LN100,*-DPDA-ST100-1
"
" STATE 105
	equ	ST105,*-DPDA
	zero	APLYS,LN105
	zero	0,0   pd ld
	zero	25,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN105,*-DPDA-ST105-1
"
" STATE 109
	equ	ST109,*-DPDA
	zero	APLY1,LN109
	zero	0,0   pd ld
	zero	16,1   rule/alt
	zero	13,ST113 prod/val
	equ	LN109,*-DPDA-ST109-1
"
" STATE 113
	equ	ST113,*-DPDA
	zero	NSRD,LN113
	zero	1,-ST608	"&lt;left_parenthesis&gt;
	zero	3,-ST619	"&lt;comma&gt;
	zero	4,-ST619	"&lt;semicolon&gt;
	zero	6,-ST619	"&lt;hyphen&gt;
	zero	17,-ST608	"&lt;real&gt;
	zero	18,-ST608	"&lt;complex&gt;
	zero	19,-ST608	"&lt;fixed&gt;
	zero	20,-ST608	"&lt;float&gt;
	zero	21,-ST608	"&lt;binary&gt;
	zero	22,-ST608	"&lt;decimal&gt;
	zero	23,-ST608	"&lt;precision&gt;
	zero	28,-ST608	"&lt;aligned&gt;
	zero	29,-ST608	"&lt;unaligned&gt;
	equ	LN113,*-DPDA-ST113-1
"
" STATE 127
	equ	ST127,*-DPDA
	zero	APLYS,LN127
	zero	0,0   pd ld
	zero	12,1   rule/alt
	zero	11,ST91 prod/val
	equ	LN127,*-DPDA-ST127-1
"
" STATE 131
	equ	ST131,*-DPDA
	zero	NSRD,LN131
	zero	3,-ST625	"&lt;comma&gt;
	zero	4,-ST625	"&lt;semicolon&gt;
	zero	6,-ST623	"&lt;hyphen&gt;
	equ	LN131,*-DPDA-ST131-1
"
" STATE 135
	equ	ST135,*-DPDA
	zero	STRD,LN135
	zero	11,ST293	"&lt;positive_integer&gt;
	equ	LN135,*-DPDA-ST135-1
"
" STATE 137
	equ	ST137,*-DPDA
	zero	APLYS,LN137
	zero	0,0   pd ld
	zero	18,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN137,*-DPDA-ST137-1
"
" STATE 141
	equ	ST141,*-DPDA
	zero	APLYS,LN141
	zero	0,0   pd ld
	zero	19,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN141,*-DPDA-ST141-1
"
" STATE 145
	equ	ST145,*-DPDA
	zero	APLYS,LN145
	zero	0,0   pd ld
	zero	20,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN145,*-DPDA-ST145-1
"
" STATE 149
	equ	ST149,*-DPDA
	zero	APLYS,LN149
	zero	0,0   pd ld
	zero	21,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN149,*-DPDA-ST149-1
"
" STATE 153
	equ	ST153,*-DPDA
	zero	APLYS,LN153
	zero	0,0   pd ld
	zero	22,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN153,*-DPDA-ST153-1
"
" STATE 157
	equ	ST157,*-DPDA
	zero	APLYS,LN157
	zero	0,0   pd ld
	zero	23,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN157,*-DPDA-ST157-1
"
" STATE 161
	equ	ST161,*-DPDA
	zero	STRD,LN161
	zero	1,ST135	"&lt;left_parenthesis&gt;
	equ	LN161,*-DPDA-ST161-1
"
" STATE 163
	equ	ST163,*-DPDA
	zero	NSRD,LN163
	zero	1,-ST629	"&lt;left_parenthesis&gt;
	zero	3,-ST635	"&lt;comma&gt;
	zero	4,-ST635	"&lt;semicolon&gt;
	zero	6,-ST635	"&lt;hyphen&gt;
	zero	26,-ST629	"&lt;varying&gt;
	zero	27,-ST629	"&lt;nonvarying&gt;
	zero	28,-ST629	"&lt;aligned&gt;
	zero	29,-ST629	"&lt;unaligned&gt;
	equ	LN163,*-DPDA-ST163-1
"
" STATE 172
	equ	ST172,*-DPDA
	zero	NSRD,LN172
	zero	1,-ST639	"&lt;left_parenthesis&gt;
	zero	3,-ST640	"&lt;comma&gt;
	zero	4,-ST640	"&lt;semicolon&gt;
	zero	6,-ST640	"&lt;hyphen&gt;
	zero	26,-ST639	"&lt;varying&gt;
	zero	27,-ST639	"&lt;nonvarying&gt;
	zero	28,-ST639	"&lt;aligned&gt;
	zero	29,-ST639	"&lt;unaligned&gt;
	equ	LN172,*-DPDA-ST172-1
"
" STATE 181
	equ	ST181,*-DPDA
	zero	STRD,LN181
	zero	24,ST350	"&lt;char&gt;
	zero	25,ST359	"&lt;bit&gt;
	equ	LN181,*-DPDA-ST181-1
"
" STATE 184
	equ	ST184,*-DPDA
	zero	STRD,LN184
	zero	24,ST368	"&lt;char&gt;
	zero	25,ST377	"&lt;bit&gt;
	equ	LN184,*-DPDA-ST184-1
"
" STATE 187
	equ	ST187,*-DPDA
	zero	APLY,LN187
	zero	0,0   pd ld
	zero	32,1   rule/alt
	zero	17,ST317 prod/val
	zero	ST28,ST100
	zero	ST266,ST100
	zero	ST608,ST100
	equ	LN187,*-DPDA-ST187-1
"
" STATE 194
	equ	ST194,*-DPDA
	zero	APLYS,LN194
	zero	0,0   pd ld
	zero	33,1   rule/alt
	zero	17,ST187 prod/val
	equ	LN194,*-DPDA-ST194-1
"
" STATE 198
	equ	ST198,*-DPDA
	zero	STRD,LN198
	zero	-12,ST54	"&lt;identifier&gt;
	equ	LN198,*-DPDA-ST198-1
"
" STATE 200
	equ	ST200,*-DPDA
	zero	APLY1,LN200
	zero	2,2   pd ld
	zero	7,2   rule/alt
	zero	7,ST3 prod/val
	equ	LN200,*-DPDA-ST200-1
"
" STATE 204
	equ	ST204,*-DPDA
	zero	APLY1,LN204
	zero	3,3   pd ld
	zero	1,1   rule/alt
	zero	1,ST11 prod/val
	equ	LN204,*-DPDA-ST204-1
"
" STATE 208
	equ	ST208,*-DPDA
	zero	STRD,LN208
	zero	4,ST399	"&lt;semicolon&gt;
	zero	-12,ST403	"&lt;identifier&gt;
	equ	LN208,*-DPDA-ST208-1
"
" STATE 211
	equ	ST211,*-DPDA
	zero	APLY1,LN211
	zero	0,0   pd ld
	zero	80,1   rule/alt
	zero	40,ST204 prod/val
	equ	LN211,*-DPDA-ST211-1
"
" STATE 215
	equ	ST215,*-DPDA
	zero	STRD,LN215
	zero	5,ST407	"&lt;colon&gt;
	equ	LN215,*-DPDA-ST215-1
"
" STATE 217
	equ	ST217,*-DPDA
	zero	STRD,LN217
	zero	1,ST411	"&lt;left_parenthesis&gt;
	equ	LN217,*-DPDA-ST217-1
"
" STATE 219
	equ	ST219,*-DPDA
	zero	APLY1,LN219
	zero	0,0   pd ld
	zero	71,1   rule/alt
	zero	35,ST223 prod/val
	equ	LN219,*-DPDA-ST219-1
"
" STATE 223
	equ	ST223,*-DPDA
	zero	STRD,LN223
	zero	3,ST413	"&lt;comma&gt;
	zero	4,ST415	"&lt;semicolon&gt;
	equ	LN223,*-DPDA-ST223-1
"
" STATE 226
	equ	ST226,*-DPDA
	zero	APLY1,LN226
	zero	1,1   pd ld
	zero	70,2   rule/alt
	zero	34,ST62 prod/val
	equ	LN226,*-DPDA-ST226-1
"
" STATE 230
	equ	ST230,*-DPDA
	zero	APLY1,LN230
	zero	0,0   pd ld
	zero	74,1   rule/alt
	zero	37,ST217 prod/val
	equ	LN230,*-DPDA-ST230-1
"
" STATE 234
	equ	ST234,*-DPDA
	zero	APLY1,LN234
	zero	1,1   pd ld
	zero	5,1   rule/alt
	zero	5,ST65 prod/val
	equ	LN234,*-DPDA-ST234-1
"
" STATE 238
	equ	ST238,*-DPDA
	zero	STRD,LN238
	zero	-12,ST85	"&lt;identifier&gt;
	equ	LN238,*-DPDA-ST238-1
"
" STATE 240
	equ	ST240,*-DPDA
	zero	APLY1,LN240
	zero	2,2   pd ld
	zero	64,1   rule/alt
	zero	31,ST15 prod/val
	equ	LN240,*-DPDA-ST240-1
"
" STATE 244
	equ	ST244,*-DPDA
	zero	APLY,LN244
	zero	1,1   pd ld
	zero	68,1   rule/alt
	zero	33,ST74 prod/val
	zero	ST238,ST419
	equ	LN244,*-DPDA-ST244-1
"
" STATE 249
	equ	ST249,*-DPDA
	zero	APLY1,LN249
	zero	1,1   pd ld
	zero	17,1   rule/alt
	zero	13,ST113 prod/val
	equ	LN249,*-DPDA-ST249-1
"
" STATE 253
	equ	ST253,*-DPDA
	zero	APLY,LN253
	zero	0,0   pd ld
	zero	54,1   rule/alt
	zero	25,ST271 prod/val
	zero	ST644,ST427
	equ	LN253,*-DPDA-ST253-1
"
" STATE 258
	equ	ST258,*-DPDA
	zero	APLYS,LN258
	zero	0,0   pd ld
	zero	53,1   rule/alt
	zero	25,ST253 prod/val
	equ	LN258,*-DPDA-ST258-1
"
" STATE 262
	equ	ST262,*-DPDA
	zero	APLYS,LN262
	zero	0,0   pd ld
	zero	52,1   rule/alt
	zero	25,ST253 prod/val
	equ	LN262,*-DPDA-ST262-1
"
" STATE 266
	equ	ST266,*-DPDA
	zero	STRDS,ST28

"
" STATE 267
	equ	ST267,*-DPDA
	zero	APLYS,LN267
	zero	0,0   pd ld
	zero	55,1   rule/alt
	zero	25,ST253 prod/val
	equ	LN267,*-DPDA-ST267-1
"
" STATE 271
	equ	ST271,*-DPDA
	zero	APLY1,LN271
	zero	0,0   pd ld
	zero	51,1   rule/alt
	zero	24,ST275 prod/val
	equ	LN271,*-DPDA-ST271-1
"
" STATE 275
	equ	ST275,*-DPDA
	zero	NSRD,LN275
	zero	3,-ST646	"&lt;comma&gt;
	zero	4,-ST646	"&lt;semicolon&gt;
	zero	6,-ST644	"&lt;hyphen&gt;
	equ	LN275,*-DPDA-ST275-1
"
" STATE 279
	equ	ST279,*-DPDA
	zero	APLY,LN279
	zero	2,2   pd ld
	zero	10,1   rule/alt
	zero	9,ST43 prod/val
	zero	ST198,ST386
	equ	LN279,*-DPDA-ST279-1
"
" STATE 284
	equ	ST284,*-DPDA
	zero	APLY1,LN284
	zero	0,0   pd ld
	zero	49,1   rule/alt
	zero	23,ST279 prod/val
	equ	LN284,*-DPDA-ST284-1
"
" STATE 288
	equ	ST288,*-DPDA
	zero	STRD,LN288
	zero	30,ST431	"&lt;check_proc&gt;
	zero	31,ST433	"&lt;encode_proc&gt;
	zero	32,ST435	"&lt;decode_proc&gt;
	zero	33,ST437	"&lt;decode_dcl&gt;
	equ	LN288,*-DPDA-ST288-1
"
" STATE 293
	equ	ST293,*-DPDA
	zero	STRD,LN293
	zero	2,ST441	"&lt;right_parenthesis&gt;
	zero	3,ST446	"&lt;comma&gt;
	equ	LN293,*-DPDA-ST293-1
"
" STATE 296
	equ	ST296,*-DPDA
	zero	APLYS,LN296
	zero	1,1   pd ld
	zero	24,1   rule/alt
	zero	14,ST100 prod/val
	equ	LN296,*-DPDA-ST296-1
"
" STATE 300
	equ	ST300,*-DPDA
	zero	APLY1,LN300
	zero	0,0   pd ld
	zero	39,1   rule/alt
	zero	20,ST304 prod/val
	equ	LN300,*-DPDA-ST300-1
"
" STATE 304
	equ	ST304,*-DPDA
	zero	NSRD,LN304
	zero	1,-ST650	"&lt;left_parenthesis&gt;
	zero	3,-ST651	"&lt;comma&gt;
	zero	4,-ST651	"&lt;semicolon&gt;
	zero	6,-ST651	"&lt;hyphen&gt;
	zero	26,-ST650	"&lt;varying&gt;
	zero	27,-ST650	"&lt;nonvarying&gt;
	zero	28,-ST650	"&lt;aligned&gt;
	zero	29,-ST650	"&lt;unaligned&gt;
	equ	LN304,*-DPDA-ST304-1
"
" STATE 313
	equ	ST313,*-DPDA
	zero	APLY1,LN313
	zero	1,1   pd ld
	zero	45,1   rule/alt
	zero	22,ST91 prod/val
	equ	LN313,*-DPDA-ST313-1
"
" STATE 317
	equ	ST317,*-DPDA
	zero	APLY,LN317
	zero	0,0   pd ld
	zero	42,1   rule/alt
	zero	21,ST300 prod/val
	zero	ST650,ST450
	equ	LN317,*-DPDA-ST317-1
"
" STATE 322
	equ	ST322,*-DPDA
	zero	APLY,LN322
	zero	0,0   pd ld
	zero	38,1   rule/alt
	zero	19,ST313 prod/val
	zero	ST639,ST346
	zero	ST640,ST346
	zero	ST655,ST456
	zero	ST656,ST456
	zero	ST660,ST460
	zero	ST661,ST460
	zero	ST665,ST464
	zero	ST666,ST464
	zero	ST670,ST468
	zero	ST671,ST468
	equ	LN322,*-DPDA-ST322-1
"
" STATE 336
	equ	ST336,*-DPDA
	zero	STRD,LN336
	zero	11,ST454	"&lt;positive_integer&gt;
	equ	LN336,*-DPDA-ST336-1
"
" STATE 338
	equ	ST338,*-DPDA
	zero	APLYS,LN338
	zero	0,0   pd ld
	zero	43,1   rule/alt
	zero	21,ST317 prod/val
	equ	LN338,*-DPDA-ST338-1
"
" STATE 342
	equ	ST342,*-DPDA
	zero	APLYS,LN342
	zero	0,0   pd ld
	zero	44,1   rule/alt
	zero	21,ST317 prod/val
	equ	LN342,*-DPDA-ST342-1
"
" STATE 346
	equ	ST346,*-DPDA
	zero	APLY1,LN346
	zero	1,1   pd ld
	zero	34,1   rule/alt
	zero	18,ST96 prod/val
	equ	LN346,*-DPDA-ST346-1
"
" STATE 350
	equ	ST350,*-DPDA
	zero	NSRD,LN350
	zero	1,-ST655	"&lt;left_parenthesis&gt;
	zero	3,-ST656	"&lt;comma&gt;
	zero	4,-ST656	"&lt;semicolon&gt;
	zero	6,-ST656	"&lt;hyphen&gt;
	zero	26,-ST655	"&lt;varying&gt;
	zero	27,-ST655	"&lt;nonvarying&gt;
	zero	28,-ST655	"&lt;aligned&gt;
	zero	29,-ST655	"&lt;unaligned&gt;
	equ	LN350,*-DPDA-ST350-1
"
" STATE 359
	equ	ST359,*-DPDA
	zero	NSRD,LN359
	zero	1,-ST660	"&lt;left_parenthesis&gt;
	zero	3,-ST661	"&lt;comma&gt;
	zero	4,-ST661	"&lt;semicolon&gt;
	zero	6,-ST661	"&lt;hyphen&gt;
	zero	26,-ST660	"&lt;varying&gt;
	zero	27,-ST660	"&lt;nonvarying&gt;
	zero	28,-ST660	"&lt;aligned&gt;
	zero	29,-ST660	"&lt;unaligned&gt;
	equ	LN359,*-DPDA-ST359-1
"
" STATE 368
	equ	ST368,*-DPDA
	zero	NSRD,LN368
	zero	1,-ST665	"&lt;left_parenthesis&gt;
	zero	3,-ST666	"&lt;comma&gt;
	zero	4,-ST666	"&lt;semicolon&gt;
	zero	6,-ST666	"&lt;hyphen&gt;
	zero	26,-ST665	"&lt;varying&gt;
	zero	27,-ST665	"&lt;nonvarying&gt;
	zero	28,-ST665	"&lt;aligned&gt;
	zero	29,-ST665	"&lt;unaligned&gt;
	equ	LN368,*-DPDA-ST368-1
"
" STATE 377
	equ	ST377,*-DPDA
	zero	NSRD,LN377
	zero	1,-ST670	"&lt;left_parenthesis&gt;
	zero	3,-ST671	"&lt;comma&gt;
	zero	4,-ST671	"&lt;semicolon&gt;
	zero	6,-ST671	"&lt;hyphen&gt;
	zero	26,-ST670	"&lt;varying&gt;
	zero	27,-ST670	"&lt;nonvarying&gt;
	zero	28,-ST670	"&lt;aligned&gt;
	zero	29,-ST670	"&lt;unaligned&gt;
	equ	LN377,*-DPDA-ST377-1
"
" STATE 386
	equ	ST386,*-DPDA
	zero	APLY1,LN386
	zero	2,2   pd ld
	zero	9,1   rule/alt
	zero	8,ST47 prod/val
	equ	LN386,*-DPDA-ST386-1
"
" STATE 390
	equ	ST390,*-DPDA
	zero	STRD,LN390
	zero	1,ST472	"&lt;left_parenthesis&gt;
	equ	LN390,*-DPDA-ST390-1
"
" STATE 392
	equ	ST392,*-DPDA
	zero	APLY1,LN392
	zero	0,0   pd ld
	zero	81,1   rule/alt
	zero	41,ST396 prod/val
	equ	LN392,*-DPDA-ST392-1
"
" STATE 396
	equ	ST396,*-DPDA
	zero	STRD,LN396
	zero	3,ST474	"&lt;comma&gt;
	zero	4,ST476	"&lt;semicolon&gt;
	equ	LN396,*-DPDA-ST396-1
"
" STATE 399
	equ	ST399,*-DPDA
	zero	APLY1,LN399
	zero	1,1   pd ld
	zero	80,2   rule/alt
	zero	40,ST204 prod/val
	equ	LN399,*-DPDA-ST399-1
"
" STATE 403
	equ	ST403,*-DPDA
	zero	APLY1,LN403
	zero	0,0   pd ld
	zero	84,1   rule/alt
	zero	43,ST390 prod/val
	equ	LN403,*-DPDA-ST403-1
"
" STATE 407
	equ	ST407,*-DPDA
	zero	APLY1,LN407
	zero	1,1   pd ld
	zero	6,1   rule/alt
	zero	6,ST208 prod/val
	equ	LN407,*-DPDA-ST407-1
"
" STATE 411
	equ	ST411,*-DPDA
	zero	STRD,LN411
	zero	-12,ST487	"&lt;identifier&gt;
	equ	LN411,*-DPDA-ST411-1
"
" STATE 413
	equ	ST413,*-DPDA
	zero	STRD,LN413
	zero	-12,ST230	"&lt;identifier&gt;
	equ	LN413,*-DPDA-ST413-1
"
" STATE 415
	equ	ST415,*-DPDA
	zero	APLY1,LN415
	zero	2,2   pd ld
	zero	69,1   rule/alt
	zero	34,ST62 prod/val
	equ	LN415,*-DPDA-ST415-1
"
" STATE 419
	equ	ST419,*-DPDA
	zero	APLY1,LN419
	zero	2,2   pd ld
	zero	67,1   rule/alt
	zero	32,ST78 prod/val
	equ	LN419,*-DPDA-ST419-1
"
" STATE 423
	equ	ST423,*-DPDA
	zero	APLY1,LN423
	zero	1,1   pd ld
	zero	56,1   rule/alt
	zero	26,ST267 prod/val
	equ	LN423,*-DPDA-ST423-1
"
" STATE 427
	equ	ST427,*-DPDA
	zero	APLY1,LN427
	zero	1,1   pd ld
	zero	50,1   rule/alt
	zero	24,ST275 prod/val
	equ	LN427,*-DPDA-ST427-1
"
" STATE 431
	equ	ST431,*-DPDA
	zero	STRD,LN431
	zero	9,ST495	"&lt;path_name&gt;
	equ	LN431,*-DPDA-ST431-1
"
" STATE 433
	equ	ST433,*-DPDA
	zero	STRD,LN433
	zero	9,ST500	"&lt;path_name&gt;
	equ	LN433,*-DPDA-ST433-1
"
" STATE 435
	equ	ST435,*-DPDA
	zero	STRD,LN435
	zero	9,ST505	"&lt;path_name&gt;
	equ	LN435,*-DPDA-ST435-1
"
" STATE 437
	equ	ST437,*-DPDA
	zero	APLY1,LN437
	zero	1,1   pd ld
	zero	57,1   rule/alt
	zero	27,ST266 prod/val
	equ	LN437,*-DPDA-ST437-1
"
" STATE 441
	equ	ST441,*-DPDA
	zero	APLY,LN441
	zero	2,2   pd ld
	zero	30,1   rule/alt
	zero	16,ST105 prod/val
	zero	ST161,ST296
	equ	LN441,*-DPDA-ST441-1
"
" STATE 446
	equ	ST446,*-DPDA
	zero	NSRD,LN446
	zero	6,-ST675	"&lt;hyphen&gt;
	zero	8,-ST675	"&lt;plus&gt;
	zero	11,-ST678	"&lt;positive_integer&gt;
	equ	LN446,*-DPDA-ST446-1
"
" STATE 450
	equ	ST450,*-DPDA
	zero	APLY1,LN450
	zero	1,1   pd ld
	zero	40,1   rule/alt
	zero	20,ST304 prod/val
	equ	LN450,*-DPDA-ST450-1
"
" STATE 454
	equ	ST454,*-DPDA
	zero	STRD,LN454
	zero	2,ST524	"&lt;right_parenthesis&gt;
	equ	LN454,*-DPDA-ST454-1
"
" STATE 456
	equ	ST456,*-DPDA
	zero	APLY1,LN456
	zero	2,2   pd ld
	zero	46,1   rule/alt
	zero	22,ST91 prod/val
	equ	LN456,*-DPDA-ST456-1
"
" STATE 460
	equ	ST460,*-DPDA
	zero	APLY1,LN460
	zero	2,2   pd ld
	zero	35,1   rule/alt
	zero	18,ST96 prod/val
	equ	LN460,*-DPDA-ST460-1
"
" STATE 464
	equ	ST464,*-DPDA
	zero	APLY1,LN464
	zero	2,2   pd ld
	zero	47,1   rule/alt
	zero	22,ST91 prod/val
	equ	LN464,*-DPDA-ST464-1
"
" STATE 468
	equ	ST468,*-DPDA
	zero	APLY1,LN468
	zero	2,2   pd ld
	zero	36,1   rule/alt
	zero	18,ST96 prod/val
	equ	LN468,*-DPDA-ST468-1
"
" STATE 472
	equ	ST472,*-DPDA
	zero	STRD,LN472
	zero	-12,ST531	"&lt;identifier&gt;
	equ	LN472,*-DPDA-ST472-1
"
" STATE 474
	equ	ST474,*-DPDA
	zero	STRD,LN474
	zero	-12,ST403	"&lt;identifier&gt;
	equ	LN474,*-DPDA-ST474-1
"
" STATE 476
	equ	ST476,*-DPDA
	zero	APLY1,LN476
	zero	2,2   pd ld
	zero	79,1   rule/alt
	zero	40,ST204 prod/val
	equ	LN476,*-DPDA-ST476-1
"
" STATE 480
	equ	ST480,*-DPDA
	zero	APLY1,LN480
	zero	0,0   pd ld
	zero	75,1   rule/alt
	zero	38,ST484 prod/val
	equ	LN480,*-DPDA-ST480-1
"
" STATE 484
	equ	ST484,*-DPDA
	zero	STRD,LN484
	zero	2,ST543	"&lt;right_parenthesis&gt;
	zero	-12,ST487	"&lt;identifier&gt;
	equ	LN484,*-DPDA-ST484-1
"
" STATE 487
	equ	ST487,*-DPDA
	zero	NSRD,LN487
	zero	2,-ST684	"&lt;right_parenthesis&gt;
	zero	7,-ST682	"&lt;asterisk&gt;
	zero	-12,-ST684	"&lt;identifier&gt;
	equ	LN487,*-DPDA-ST487-1
"
" STATE 491
	equ	ST491,*-DPDA
	zero	APLY1,LN491
	zero	2,2   pd ld
	zero	72,1   rule/alt
	zero	35,ST223 prod/val
	equ	LN491,*-DPDA-ST491-1
"
" STATE 495
	equ	ST495,*-DPDA
	zero	NSRD,LN495
	zero	3,-ST690	"&lt;comma&gt;
	zero	4,-ST690	"&lt;semicolon&gt;
	zero	6,-ST690	"&lt;hyphen&gt;
	zero	10,-ST688	"&lt;entry_name&gt;
	equ	LN495,*-DPDA-ST495-1
"
" STATE 500
	equ	ST500,*-DPDA
	zero	NSRD,LN500
	zero	3,-ST696	"&lt;comma&gt;
	zero	4,-ST696	"&lt;semicolon&gt;
	zero	6,-ST696	"&lt;hyphen&gt;
	zero	10,-ST694	"&lt;entry_name&gt;
	equ	LN500,*-DPDA-ST500-1
"
" STATE 505
	equ	ST505,*-DPDA
	zero	NSRD,LN505
	zero	3,-ST702	"&lt;comma&gt;
	zero	4,-ST702	"&lt;semicolon&gt;
	zero	6,-ST702	"&lt;hyphen&gt;
	zero	10,-ST700	"&lt;entry_name&gt;
	equ	LN505,*-DPDA-ST505-1
"
" STATE 510
	equ	ST510,*-DPDA
	zero	STRD,LN510
	zero	11,ST565	"&lt;positive_integer&gt;
	equ	LN510,*-DPDA-ST510-1
"
" STATE 512
	equ	ST512,*-DPDA
	zero	APLY1,LN512
	zero	0,0   pd ld
	zero	28,1   rule/alt
	zero	15,ST510 prod/val
	equ	LN512,*-DPDA-ST512-1
"
" STATE 516
	equ	ST516,*-DPDA
	zero	APLY1,LN516
	zero	0,0   pd ld
	zero	27,1   rule/alt
	zero	15,ST510 prod/val
	equ	LN516,*-DPDA-ST516-1
"
" STATE 520
	equ	ST520,*-DPDA
	zero	APLY1,LN520
	zero	0,0   pd ld
	zero	26,1   rule/alt
	zero	15,ST510 prod/val
	equ	LN520,*-DPDA-ST520-1
"
" STATE 524
	equ	ST524,*-DPDA
	zero	APLYS,LN524
	zero	2,2   pd ld
	zero	41,1   rule/alt
	zero	21,ST317 prod/val
	equ	LN524,*-DPDA-ST524-1
"
" STATE 528
	equ	ST528,*-DPDA
	zero	STRD,LN528
	zero	2,ST567	"&lt;right_parenthesis&gt;
	zero	-12,ST572	"&lt;identifier&gt;
	equ	LN528,*-DPDA-ST528-1
"
" STATE 531
	equ	ST531,*-DPDA
	zero	APLY1,LN531
	zero	0,0   pd ld
	zero	85,1   rule/alt
	zero	44,ST528 prod/val
	equ	LN531,*-DPDA-ST531-1
"
" STATE 535
	equ	ST535,*-DPDA
	zero	APLY1,LN535
	zero	2,2   pd ld
	zero	82,1   rule/alt
	zero	41,ST396 prod/val
	equ	LN535,*-DPDA-ST535-1
"
" STATE 539
	equ	ST539,*-DPDA
	zero	APLY1,LN539
	zero	1,1   pd ld
	zero	76,1   rule/alt
	zero	38,ST484 prod/val
	equ	LN539,*-DPDA-ST539-1
"
" STATE 543
	equ	ST543,*-DPDA
	zero	APLY,LN543
	zero	3,3   pd ld
	zero	73,1   rule/alt
	zero	36,ST219 prod/val
	zero	ST413,ST491
	equ	LN543,*-DPDA-ST543-1
"
" STATE 548
	equ	ST548,*-DPDA
	zero	APLY,LN548
	zero	1,1   pd ld
	zero	78,1   rule/alt
	zero	39,ST480 prod/val
	zero	ST484,ST539
	equ	LN548,*-DPDA-ST548-1
"
" STATE 553
	equ	ST553,*-DPDA
	zero	APLY1,LN553
	zero	3,3   pd ld
	zero	58,1   rule/alt
	zero	28,ST262 prod/val
	equ	LN553,*-DPDA-ST553-1
"
" STATE 557
	equ	ST557,*-DPDA
	zero	APLY1,LN557
	zero	3,3   pd ld
	zero	60,1   rule/alt
	zero	29,ST258 prod/val
	equ	LN557,*-DPDA-ST557-1
"
" STATE 561
	equ	ST561,*-DPDA
	zero	APLY1,LN561
	zero	3,3   pd ld
	zero	62,1   rule/alt
	zero	30,ST253 prod/val
	equ	LN561,*-DPDA-ST561-1
"
" STATE 565
	equ	ST565,*-DPDA
	zero	STRD,LN565
	zero	2,ST576	"&lt;right_parenthesis&gt;
	equ	LN565,*-DPDA-ST565-1
"
" STATE 567
	equ	ST567,*-DPDA
	zero	APLY,LN567
	zero	3,3   pd ld
	zero	83,1   rule/alt
	zero	42,ST392 prod/val
	zero	ST474,ST535
	equ	LN567,*-DPDA-ST567-1
"
" STATE 572
	equ	ST572,*-DPDA
	zero	APLY1,LN572
	zero	1,1   pd ld
	zero	86,1   rule/alt
	zero	44,ST528 prod/val
	equ	LN572,*-DPDA-ST572-1
"
" STATE 576
	equ	ST576,*-DPDA
	zero	APLYS,LN576
	zero	5,5   pd ld
	zero	29,1   rule/alt
	zero	16,ST441 prod/val
	equ	LN576,*-DPDA-ST576-1
"
" STATE 580
	equ	ST580,*-DPDA
	zero	STRD,LN580
	zero	14,ST26	"&lt;attribute&gt;
	equ	LN580,*-DPDA-ST580-1
"
" STATE 582
	equ	ST582,*-DPDA
	zero	APLY,LN582
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST322 prod/val
	zero	ST580,ST22
	zero	ST582,ST22
	zero	ST596,ST68
	zero	ST598,ST68
	zero	ST602,ST211
	zero	ST604,ST211
	zero	ST623,ST284
	zero	ST625,ST284
	zero	ST675,ST512
	zero	ST678,ST512
	equ	LN582,*-DPDA-ST582-1
"
" STATE 596
	equ	ST596,*-DPDA
	zero	STRD,LN596
	zero	15,ST72	"&lt;relation&gt;
	equ	LN596,*-DPDA-ST596-1
"
" STATE 598
	equ	ST598,*-DPDA
	zero	APLYS,LN598
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN598,*-DPDA-ST598-1
"
" STATE 602
	equ	ST602,*-DPDA
	zero	STRD,LN602
	zero	16,ST215	"&lt;index&gt;
	equ	LN602,*-DPDA-ST602-1
"
" STATE 604
	equ	ST604,*-DPDA
	zero	APLYS,LN604
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN604,*-DPDA-ST604-1
"
" STATE 608
	equ	ST608,*-DPDA
	zero	STRD,LN608
	zero	1,ST135	"&lt;left_parenthesis&gt;
	zero	17,ST137	"&lt;real&gt;
	zero	18,ST141	"&lt;complex&gt;
	zero	19,ST145	"&lt;fixed&gt;
	zero	20,ST149	"&lt;float&gt;
	zero	21,ST153	"&lt;binary&gt;
	zero	22,ST157	"&lt;decimal&gt;
	zero	23,ST161	"&lt;precision&gt;
	zero	28,ST187	"&lt;aligned&gt;
	zero	29,ST194	"&lt;unaligned&gt;
	equ	LN608,*-DPDA-ST608-1
"
" STATE 619
	equ	ST619,*-DPDA
	zero	APLY1,LN619
	zero	0,0   pd ld
	zero	15,1   rule/alt
	zero	12,ST127 prod/val
	equ	LN619,*-DPDA-ST619-1
"
" STATE 623
	equ	ST623,*-DPDA
	zero	STRD,LN623
	zero	6,ST288	"&lt;hyphen&gt;
	equ	LN623,*-DPDA-ST623-1
"
" STATE 625
	equ	ST625,*-DPDA
	zero	APLYS,LN625
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN625,*-DPDA-ST625-1
"
" STATE 629
	equ	ST629,*-DPDA
	zero	STRD,LN629
	zero	1,ST336	"&lt;left_parenthesis&gt;
	zero	26,ST338	"&lt;varying&gt;
	zero	27,ST342	"&lt;nonvarying&gt;
	zero	28,ST187	"&lt;aligned&gt;
	zero	29,ST194	"&lt;unaligned&gt;
	equ	LN629,*-DPDA-ST629-1
"
" STATE 635
	equ	ST635,*-DPDA
	zero	APLYS,LN635
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN635,*-DPDA-ST635-1
"
" STATE 639
	equ	ST639,*-DPDA
	zero	STRDS,ST629

"
" STATE 640
	equ	ST640,*-DPDA
	zero	APLYS,LN640
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN640,*-DPDA-ST640-1
"
" STATE 644
	equ	ST644,*-DPDA
	zero	STRD,LN644
	zero	6,ST288	"&lt;hyphen&gt;
	equ	LN644,*-DPDA-ST644-1
"
" STATE 646
	equ	ST646,*-DPDA
	zero	APLY1,LN646
	zero	0,0   pd ld
	zero	48,1   rule/alt
	zero	23,ST279 prod/val
	equ	LN646,*-DPDA-ST646-1
"
" STATE 650
	equ	ST650,*-DPDA
	zero	STRDS,ST629

"
" STATE 651
	equ	ST651,*-DPDA
	zero	APLYS,LN651
	zero	0,0   pd ld
	zero	37,1   rule/alt
	zero	19,ST322 prod/val
	equ	LN651,*-DPDA-ST651-1
"
" STATE 655
	equ	ST655,*-DPDA
	zero	STRDS,ST629

"
" STATE 656
	equ	ST656,*-DPDA
	zero	APLYS,LN656
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN656,*-DPDA-ST656-1
"
" STATE 660
	equ	ST660,*-DPDA
	zero	STRDS,ST629

"
" STATE 661
	equ	ST661,*-DPDA
	zero	APLYS,LN661
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN661,*-DPDA-ST661-1
"
" STATE 665
	equ	ST665,*-DPDA
	zero	STRDS,ST629

"
" STATE 666
	equ	ST666,*-DPDA
	zero	APLYS,LN666
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN666,*-DPDA-ST666-1
"
" STATE 670
	equ	ST670,*-DPDA
	zero	STRDS,ST629

"
" STATE 671
	equ	ST671,*-DPDA
	zero	APLYS,LN671
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN671,*-DPDA-ST671-1
"
" STATE 675
	equ	ST675,*-DPDA
	zero	STRD,LN675
	zero	6,ST516	"&lt;hyphen&gt;
	zero	8,ST520	"&lt;plus&gt;
	equ	LN675,*-DPDA-ST675-1
"
" STATE 678
	equ	ST678,*-DPDA
	zero	APLYS,LN678
	zero	-1,-1   pd ld
	zero	2,1   rule/alt
	zero	2,ST582 prod/val
	equ	LN678,*-DPDA-ST678-1
"
" STATE 682
	equ	ST682,*-DPDA
	zero	STRD,LN682
	zero	7,ST548	"&lt;asterisk&gt;
	equ	LN682,*-DPDA-ST682-1
"
" STATE 684
	equ	ST684,*-DPDA
	zero	APLYS,LN684
	zero	0,0   pd ld
	zero	77,1   rule/alt
	zero	39,ST548 prod/val
	equ	LN684,*-DPDA-ST684-1
"
" STATE 688
	equ	ST688,*-DPDA
	zero	STRD,LN688
	zero	10,ST553	"&lt;entry_name&gt;
	equ	LN688,*-DPDA-ST688-1
"
" STATE 690
	equ	ST690,*-DPDA
	zero	APLY1,LN690
	zero	2,2   pd ld
	zero	59,1   rule/alt
	zero	28,ST262 prod/val
	equ	LN690,*-DPDA-ST690-1
"
" STATE 694
	equ	ST694,*-DPDA
	zero	STRD,LN694
	zero	10,ST557	"&lt;entry_name&gt;
	equ	LN694,*-DPDA-ST694-1
"
" STATE 696
	equ	ST696,*-DPDA
	zero	APLY1,LN696
	zero	2,2   pd ld
	zero	61,1   rule/alt
	zero	29,ST258 prod/val
	equ	LN696,*-DPDA-ST696-1
"
" STATE 700
	equ	ST700,*-DPDA
	zero	STRD,LN700
	zero	10,ST561	"&lt;entry_name&gt;
	equ	LN700,*-DPDA-ST700-1
"
" STATE 702
	equ	ST702,*-DPDA
	zero	APLY1,LN702
	zero	2,2   pd ld
	zero	63,1   rule/alt
	zero	30,ST253 prod/val
	equ	LN702,*-DPDA-ST702-1
	equ	DPDAs,*-DPDA


	zero	1,12	"SKIP/ADJ

	zero	7,2	"SKIP/ADJ

	zero	34,0	"SKIP/ADJ

	zero	4,710	"SKIP/ADJ

	zero	8,8	"SKIP/ADJ

	zero	11,3	"SKIP/ADJ

	zero	47,3	"SKIP/ADJ

	zero	510,3	"SKIP/ADJ

	zero	580,3	"SKIP/ADJ

	zero	596,3	"SKIP/ADJ

	zero	602,3	"SKIP/ADJ

	zero	623,3	"SKIP/ADJ

	zero	644,3	"SKIP/ADJ
	end
�



		    mrds_rst_proc_ctl_args.pl1      09/26/88  1255.5rew 09/26/88  1247.9      146844



/****^  ***********************************************************
        *                                                         *
        * 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-09-19,Blair), approve(88-09-19,MCR7995), audit(88-09-20,Dupuis),
     install(88-09-26,MR12.2-1119):
     Make sure that arg_info.relation_mode_flags has a null value when we
     process -vf so that if vfile was specified after -dm it will
     successfully override any previously set modes. TR 21051.
                                                   END HISTORY COMMENTS */


mrds_rst_proc_ctl_args: proc (arg_list_ptr, ai_ptr, suffix_flag,
	default_relation_mode_flags, fatal_sw);

/* 
                   BEGIN_DESCRIPTION
   The purpose of this procedure is to process the command level control
   arguments for the rmdb and cmdb commands.

   arg_list_ptr	ptr;		(INPUT)  Pointer to Multics command level argument list
   ai_ptr		ptr;		(INPUT) Pointer to arg_info structure
   suffix_flag	bit(1);		(input) ON =&gt; enforce ".db" suffix in database pathname
   default_relation_mode_flags struct   (input)  Defaults for creating relations
   fatal_sw	bit (1);		(OUTPUT) On = fatal error occured during argument processing
   (do not continue after return).

   All error messages will be reported from this procedure via com_err_
   What to do upon return from this procedure should be decided
   as a result of the fatal_sw (If ON do not continue)

   If the fatal_sw is OFF then arg_info will reflect the argument info supplied
   and any defaults not supplied.
                   END_DESCRIPTION

                   HISTORY
   Written by R. D. Lackey March 1979

   Modified by Jim Gray - - June 1979 to enforce MR7.0 database pathname suffix ".db"

   Modified by Jim Gray - - June 1980, to remove -control from usage
   statment to agree with documentation for this release.

   Modified by Jim Gray - - 80-11-06, to add "-secure" option to cmdb control arg processing.

   81-04-28 Jim Gray : added -no_list, -no_secure, and -force options.

   81-09-25 Davids: changed the internal procedure get_source so that it no longer
   determines if the source arg had a suffix and if not added it instead it just
   calls expand_pathname_$add_suffix. A stringrange error was occuring on source
   names less than 5 characters. Also changed the declaration of entry_name from
   char (32) varying to char (4). It is being used to hold the suffix "cmdb" or "rmdb"

   82-08-19 Davids: added processing for control arguments -page_file (-pf)
   and -vfile (-vf)

   82-11-23 Davids: added the default_db_type parameter and changed so that
   arg_info.db_type is set from default_db_type instead of the constant "vf".

   83-02-18 Mike Kubicar : Ripped out all code relating to the obsolete
   restructure_mrds_db.  Added the -dm_file option and its corresponding
   mode string to describe the properties for creating relations.

   83-10-04 Paul Benjamin: to check whether or not the offending arg is a
   control arg before returning et$badopt and return et$bad_arg instead.

   84-09-06 Paul Benjamin: to  change -dm_file to -data_management_file but
   retain the former as undocumented form.
*/
%page;
/* START */

	fatal_sw = OFF;
	call init_arg_info;				/* Init arg_info structure */

	call cu_$arg_count_rel (nargs, arg_list_ptr);	/* Get the number of arguments in list */

	entry_name = "cmdb";
	dm_file_mode_string = "";
	if nargs &lt; 1 then /* Got to have at least the cmdb source path */
	     call error (error_table_$wrong_no_of_args, "create_mrds_db
Usage:  cmdb source_path {database_path -control_args...}^/");

	else call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then call error (code, "Argument number 1");

	call get_source (arg, entry_name);		/* Stuff absolute path name of source in arg_info */

	rel_db_path = before (arg_info.source_entry, "." || entry_name); /* Init in case no data base path is */
						/*    use source entry name without entry_name component */

	if nargs &gt; 1 then do i = 2 to nargs;		/* Set option flags if any */
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr);
		if code ^= 0 then call error (code, "parameter " || arg);

		opt_ok = OFF;

		if i = 2 then do;			/* See if they supplied a data base path */
			if ^is_ctl_option (arg) then do;
				opt_ok = ON;
				rel_db_path = arg;
			     end;


		     end;

		if arg = "-no_list" | arg = "-nls" then do;
			opt_ok = ON;
			arg_info.list = OFF;
		     end;
		else if arg = "-ls" | arg = "-list" then opt_ok, arg_info.list = ON; /*       -list option */
		else if arg = "-secure" then opt_ok, arg_info.secure = ON; /* set secured bit in model option */
		else if arg = "-no_secure" then do;
			opt_ok = ON;
			arg_info.secure = OFF;
		     end;
		else if arg = "-no_force" | arg = "-nfc" then do;
			opt_ok = ON;
			arg_info.force = OFF;
		     end;
		else if arg = "-force" | arg = "-fc" then do;
			opt_ok = ON;
			arg_info.force = ON;
		     end;
		else if arg = "-td" | arg = "-temp_dir" then do; /* temp directory option */
			arg_info.twd = ON;
			opt_ok = ON;

			i = i + 1;		/* Position to next arg (should be temp_dir path) */
			if i &gt; nargs then call error (mrds_error_$no_temp_dir, "");
			else call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr);
			if code ^= 0 then call error (code, "Temp_directory");

			if is_ctl_option (arg) then
			     call error (mrds_error_$no_temp_dir, "");
			call absolute_pathname_ (arg, arg_info.temp_work_dir, code);
			if code ^= 0 then call error (code, arg);
		     end;
		else if arg = "-vfile" | arg = "-vf"
		then do;
			opt_ok = ON;
			arg_info.relation_mode_flags = "0"b;
                              dm_file_mode_string = "";
		     end;
		else if arg = "-data_management_file" | arg = "-dmf" 
		     | /* undocumented */ arg = "-dm_file" then do;
			opt_ok = ON;
			arg_info.relation_mode_flags.dm_file_type = "1"b;
			arg_info.relation_mode_flags.protection_on = "1"b;
			arg_info.relation_mode_flags.concurrency_on = "1"b;
			arg_info.relation_mode_flags.rollback_on = "1"b;
			call cu_$arg_ptr_rel ((i + 1), arg_ptr, arg_len,
			     code, arg_list_ptr);
			if (code ^= 0) &amp; (code ^= error_table_$noarg)
			then call error (code, "Argument number "
				|| ltrim (char ((i + 1), 20)));
			if code ^= error_table_$noarg
			then if ^is_ctl_option (arg) then do;
				     if length (arg) &gt; length (dm_file_mode_string)
				     then call error (error_table_$bigarg, "Mode string is too long.");
				     dm_file_mode_string = arg;
				     i = i + 1;
				end;
		     end;

		if ^opt_ok
		then do;
			if is_ctl_option (arg)
			then call error (error_table_$badopt, arg);
			else call error (error_table_$bad_arg, arg);
		     end;
	     end;					/* END DO I = 2 TO NARGS */


/* Take care of the mode string */

	call set_modes (dm_file_mode_string, arg_info.relation_mode_flags);


/* make  absolute path of data base directory */

	if ^suffix_flag then
	     call absolute_pathname_ (rel_db_path, arg_info.db_dir_path, code);
	else call absolute_pathname_$add_suffix (rel_db_path, db_suffix, arg_info.db_dir_path, code);

	if code ^= 0 then call error (code, rel_db_path);

exit:	return;					/* Only return from this procedure */
%page;
/**********
*
*   This routine is used to parse the mode string needed by the dm_file
*   argument and check it for consistency.  It calls mode_string_$parse
*   to parse the string and then goes through the mode_string_info
*   structure, setting bits in the "mode_bits" parameter to reflect the
*   state of the mode string.
*
**********/

set_modes:
     proc (mode_string, mode_bits);

/* Parameters */

	dcl     mode_string		 char (*);	/* The mode string in the command line */
	dcl     1 mode_bits		 like db_relation_modes; /* Structure describing the file characteristics */

/* Local definitions */

	dcl     error_table_$bad_mode_value fixed bin (35) ext static;
	dcl     error_table_$undefined_mode fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     mode_string_$parse	 entry (char (*), ptr, ptr, fixed bin (35));

	dcl     code		 fixed bin (35);	/* Error code */
	dcl     i			 fixed bin;	/* Loop variable */
	dcl     local_area		 area;		/* For call to mode_string_$parse */
	dcl     1 mode_defined,			/* The corresponding bit is set if the mode
						   string contains the mode */
		2 protection	 bit (1),
		2 rollback	 bit (1),
		2 concurrency	 bit (1);

/* Include file */

%include mode_string_info;


/* Procedure */

	if mode_string = ""				/* No string given so there's nothing to do */
	then return;
	unspec (mode_defined) = "0"b;
	call mode_string_$parse (mode_string, addr (local_area),
	     mode_string_info_ptr, code);
	if code ^= 0
	then call error (code, "While trying to parse the mode string.");
	if mode_string_info.version ^= mode_string_info_version_2
	then call error (error_table_$unimplemented_version,
		"The mode_string_info structure is not version two.");
	if mode_string_info.modes (1).version ^= mode_value_version_3
	then call error (error_table_$unimplemented_version,
		"The mode_value structure is not version three.");

/* Now walk through the returned structure and examine the modes */

	do i = 1 to mode_string_info.number;
	     if mode_string_info.modes (i).mode_name = "protection" then do;
		     if ^mode_string_info.modes (i).flags.boolean_valuep
		     then call error (error_table_$bad_mode_value,
			     "Protect must be a boolean mode value.");
		     mode_defined.protection = "1"b;
		     mode_bits.protection_on =
			mode_string_info.modes (i).flags.boolean_value;
		end;
	     else if mode_string_info.modes (i).mode_name = "rollback" then do;
		     if ^mode_string_info.modes (i).flags.boolean_valuep
		     then call error (error_table_$bad_mode_value,
			     "rollback must be a boolean mode value.");
		     mode_defined.rollback = "1"b;
		     mode_bits.rollback_on
			= mode_string_info.modes (i).flags.boolean_value;
		end;
	     else if mode_string_info.modes (i).mode_name = "concurrency" then do;
		     if ^mode_string_info.modes (i).flags.boolean_valuep
		     then call error (error_table_$bad_mode_value,
			     "Concurrency must be a boolean mode value.");
		     mode_defined.concurrency = "1"b;
		     mode_bits.concurrency_on
			= mode_string_info.modes (i).flags.boolean_value;
		end;
	     else call error (error_table_$undefined_mode,
		     mode_string_info.modes (i).mode_name);
	end;

/*
*
* Check the file attributes for consistency.  Neither concurrency or
* before journalling can be specified unless the file is protected.
* It is valid however, to specify ^protection and not specify either
* rollback or concurrency.  In that case, the latter two modes
* will default to off.
*
*/

	if mode_bits.dm_file_type			/* All bits are zero for vfile */
	then if mode_defined.protection &amp; ^mode_bits.protection_on then do; /* Force undefined bits to off */
		     if ^mode_defined.concurrency
		     then mode_bits.concurrency_on = "0"b;
		     if ^mode_defined.rollback
		     then mode_bits.rollback_on = "0"b;
		end;
	if mode_bits.rollback_on &amp; ^mode_bits.protection_on
	then call error (error_table_$bad_mode_value,
		"Rollback cannot be specified without protection.");
	if mode_bits.concurrency_on &amp; ^mode_bits.protection_on
	then call error (error_table_$bad_mode_value,
		"Concurrency cannot be specified without protection.");

     end set_modes;
%page;
error: proc (cd, msg);

	dcl     cd		 fixed bin (35);
	dcl     msg		 char (*);	/* Detailed error message (may be null) */

	if entry_name = "cmdb" then do;
		call com_err_ (cd, entry_name, msg);
		fatal_sw = ON;			/* Indicate that an error occured */
	     end;
	else do;
		sm_err_code = cd;
		sm_err_msg = msg;
	     end;
	goto exit;

     end error;
%page;
is_ctl_option: proc (iarg) returns (bit (1));

/* This procedure checks the supplied argument to see if it is a control arg */

	dcl     iarg		 char (*);	/* (INPUT) Input argument */

	if length (iarg) &lt; 1
	then return ("0"b);
	else return (substr (iarg, 1, 1) = "-");
     end is_ctl_option;
%page;
get_source: proc (source, en);

/* This procedure given a source segment path sets the source directory path and
   entry in arg_info with the proper suffix if not supplied. */

	dcl     source		 char (*);	/* (INPUT) source segment name */
	dcl     en		 char (*);	/* (INPUT) entry name (rmdb or cmdb) */

	if is_ctl_option (arg) then /* Did not give a source path */
	     call error (mrds_error_$bad_source_path, arg || "
      First argument must be a source pathname.");

	call expand_pathname_$add_suffix (source, en, arg_info.source_dir, arg_info.source_entry, code);
	if code ^= 0 then call error (code, source);

     end get_source;
%page;
init_arg_info: proc;

	arg_info.list = OFF;
	arg_info.twd = OFF;
	arg_info.secure = OFF;
	arg_info.force = OFF;
	arg_info.source_dir = BLANK;
	arg_info.source_entry = BLANK;
	arg_info.db_dir_path = BLANK;
	arg_info.temp_work_dir = get_pdir_ (); ;	/* This will be changed if a twd arg is supplied */
	arg_info.relation_mode_flags = default_relation_mode_flags;

     end init_arg_info;
%page;
/**********
*
*  Entry point for parsing a dm_file mode string.
*
***********/

parse_mode_string: entry (external_mode_string, external_mode_bits, sm_err_code, sm_err_msg);


/* Parameters */

	dcl     external_mode_string	 char (*) parm;
	dcl     1 external_mode_bits	 like db_relation_modes;
	dcl     sm_err_code		 fixed bin (35);
	dcl     sm_err_msg		 char (*);

	sm_err_code = 0;
	sm_err_msg = "";
	call set_modes (external_mode_string, external_mode_bits);
	return;

%page;
/*	PARAMETERS	*/

	dcl     arg_list_ptr	 ptr;		/* (INPUT) */

/*      ai_ptr ptr;					/* (INPUT) */
	dcl     1 default_relation_mode_flags /* (INPUT) */
				 like db_relation_modes;
	dcl     fatal_sw		 bit (1);		/* (OUTPUT) */

/*	OTHERS		*/

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     dm_file_mode_string	 char (200);
	dcl     entry_name		 char (4);
	dcl     opt_ok		 bit (1);
	dcl     rel_db_path		 char (168);	/* Relative database path */
	dcl     nargs		 fixed bin;
	dcl     i			 fixed bin;

	dcl     (addr, before, char, empty, length, ltrim,
	        substr, unspec)	 builtin;

/*	SUBROUTINES	*/

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	declare absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); /* appends suffix to path */
	declare db_suffix		 char (3) init ("db") int static options (constant); /* MR7.0 database directory pathname suffic */
	declare suffix_flag		 bit (1);		/* on =&gt; use ".db" suffix in database path */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* incorrect args count */
	dcl     cu_$arg_count_rel	 entry (fixed bin, ptr);
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	dcl     com_err_		 entry options (variable);
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_pdir_		 entry returns (char (168));


/*	CONSTANTS		*/

	dcl     BLANK		 char (1) int static options (constant) init (" ");
	dcl     OFF		 bit (1) int static options (constant) init ("0"b);
	dcl     ON		 bit (1) int static options (constant) init ("1"b);

/*	ERROR CODES	*/

	dcl     error_table_$bad_arg	 ext fixed bin (35);
	dcl     error_table_$badopt	 ext fixed bin (35);
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$bigarg	 fixed bin (35) ext static;
	dcl     mrds_error_$bad_source_path ext fixed bin (35);
	dcl     mrds_error_$no_temp_dir ext fixed bin (35);
%page;
%include mrds_rst_arg_info;

     end mrds_rst_proc_ctl_args;




		    mrds_rst_relation_handler.pl1   04/18/85  1454.7r w 04/18/85  0909.2      107433



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 - - october 1978

*/


mrds_rst_relation_handler: procedure (rsc_ptr, list_ptr);

/* DESCRIPTION:

   this routine builds/alters the mrds database model relation information
   and the global entity lists maintained by RMDB/CMDB,
   based upon the relation data and directive that is active when
   called by the RMDB/CMDB parser.
   the directive may be undefine, define, redefine, or cmdb and the data
   is either a relation name to be deleted or a linked list of
   structures holding the relation information and it's attribute list

*/

/* PARAMETERS:

   rsc_ptr - - (input) pointer to the common control segment

   list_ptr - - (input) pointer to the single relation name(undefine only) or
   to the relation structure headed list of attribute structures

   database model - - (output) updated model with altered relation information

   global lists - - (output) the list of database entities, updated
   according to directive and data

   error_output - - (output) via mrds_rst_error calls, of error messages

*/
%page;
/* REMAINING ERRORS:

   undefine:

   the relation name may be the &lt;error_symbol&gt;(this may be ignored)
   the relation may not be defined in the database


   define, cmdb:

   the relation name may be the &lt;error_symbol&gt;(this may be ignored)
   one of the attribute names may be the &lt;error_symbol&gt;(this may be ignored)
   the relation may already be defined in the database
   one of the given attributes may not be defined as part of the given relation
   the max_tuples will not be their final value until the file type is known for this relation

   redefine:

   same as define, except relation name may not be defined in the database

   note: "(this may be ignored)" means a previous error will prevent
   a database model with erroneous information from being built

*/
%page;
/* set semantic structure pointers */

	stmt_ptr = rsc_ptr -&gt; rsc.stmt_ptr;
	directive_ptr = rsc_ptr -&gt; rsc.directive_ptr;

	if directive.type = UNDEFINE then do;		/* input structure depends on directive */
		delete_name_ptr = list_ptr;
		relation_name = delete_name.overlay;
	     end;
	else do;
		relation_ptr = list_ptr;
		relation_name = relation.name;
	     end;

/* call trace if metering is on */

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_relation_handler", IN, relation_name);

/* check on which directive called us */

	if directive.type = UNDEFINE | directive.type = REDEFINE then do;
		if stmt (directive.type).relation.number &gt; 0 then ; /* not first time */
		else do;				/* first time only, issue error */
			call ioa_$rs ("^a ^a", message, message_length,
			     "The relation handler will not implement ""undefine"" or ""redefine""",
			     "directives until a later release.");
			call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_undone_option, (message));
		     end;
	     end;
	else do;

/* define or cmdb directive was caller, process newly defined relation */

		call define_relation ();

	     end;

/* call the trace routine if metering is turned on */

	if ^rsc.trace_sw then ;
	else call mrds_rst_meter (rsc_ptr, "mrds_rst_relation_handler", OUT, relation_name);
%page;
define_relation: procedure ();

/* using a previously unknown relation name,
   add this relation definition to the global lists for later use
   in building the new definition into the database model via the file handler */




/* make sure the relation is not already in the database or previously defined */

	call mrds_rst_list_element$add (relation.name, MAIN_LIST, rsc_ptr,
	     rsc.h_grel_ptr, gl_ptr, error_code);

	if error_code = 0 then
	     error_mode = OFF;
	else do;
		call ioa_$rs ("^a^a^a ^d ^a", message, message_length,
		     "The relation """, relation.name, """ given on line", relation.line_num,
		     "is already defined in the database, the duplicate will be ignored!!");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$dup_rel, (message));
		call mrds_rst_rsc_alloc (rsc_ptr, GL, gl_ptr); /* make dummy global element not in list */
		error_mode = ON;
	     end;



/* relation was not found in list so it was added,
   link list element to list head and fill in the blanks */

	gl.type = MAIN_LIST;
	gl.name = relation.name;
	gl.item_info_ptr = null ();			/* no relation_info yet */
	gl.parse_info_ptr = relation_ptr;
	gl.other_info_ptr = null ();			/* gile global element not known yet */
	gl.item_sub_list_ptr = null ();		/* no attributes yet */
	gl.file_info_ptr = null ();			/* no file defined to hold relation yet */
	gl.file_model_ptr = null ();
	gl.affected = ON;
	gl.undefine = OFF;
	gl.redefine = OFF;
	if directive.type = DEFINE then do;
		gl.define = ON;
		gl.cmdb = OFF;
	     end;
	else do;					/* CMDB directive */
		gl.define = OFF;
		gl.cmdb = ON;
	     end;
	gl.superior_assigned = OFF;			/* no file for this relation yet */
	gl.inferior_assigned = OFF;			/* no attributes for this relation yet */
	gl.complete = OFF;				/* no rel_info yet */
	gl.consistant = ON;				/* assume good till find error */
	gl.reserved = OFF;



/* process the list of attributes for this relation */

	attribute_ptr = relation.a_ptr;
	do while (attribute_ptr ^= null ());

	     call define_relation_attribute ();

	     attribute_ptr = attribute.next;
	end;

	if gl.inferior_assigned then ;
	else gl.consistant = OFF;			/* no good attribute's in relation */


     end;
%page;
define_relation_attribute: procedure ();


/* make sure that the given attribute is defined in the database */

	call mrds_rst_tree_search (attribute.name, rsc.h_gattr_ptr, node_ptr, parent_ptr, success);

	if ^success then do;			/* not found */
		call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length,
		     "The attribute """, attribute.name, """ on line",
		     attribute.line_num, "given for relation """,
		     relation.name, """ has not been defined in the database.");
		call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$undef_attr, (message));
	     end;
	else if error_mode then ;			/* previous error =&gt; relation not found, so don't add sublists */
	else do;
		attr_gl_ptr = node_ptr -&gt; node.data;	/* get attribute global element pointer */
		if attr_gl_ptr -&gt; gl.item_info_ptr = null () then ; /* check for assigned domain for this attribute */
		else if attr_gl_ptr -&gt; gl.item_info_ptr -&gt; sl.new_other_info_ptr = null () then ;
		else do;				/* get attr's domain global element pointer */
			dom_gl_ptr = attr_gl_ptr -&gt; gl.item_info_ptr -&gt; sl.new_other_info_ptr;
			dom_gl_ptr -&gt; gl.superior_assigned = ON; /* now domain referenced by relation */
		     end;






/* ATTRIBUTE SUBLIST INSERT */
/* attribute found, add this relation to it's "used in relation" sublist */

		call mrds_rst_list_element$add (relation.name, SUB_LIST, rsc_ptr,
		     attr_gl_ptr -&gt; gl.item_sub_list_ptr, sl_ptr, error_code);

		if error_code ^= 0 then do;		/* sub/main list disagreement */
			call ioa_$rs ("^a^a^a^a^a", message, message_length,
			     "LOGIC ERROR in mrds_rst_relation_handler, the relation """, relation.name,
			     """ was found the sublist of attribute """, attribute.name,
			     """ but wasn't found in the global relation list.");
			call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message));
		     end;
		else do;

/* fill in the sub list element info */

			sl.type = SUB_LIST;
			sl.name = relation.name;
			sl.item_info_ptr = null ();	/* no relation_info yet */
			sl.parse_info_ptr = relation_ptr;
			sl.old_other_info_ptr = null (); /* no attr info yet  */
			sl.new_other_info_ptr = attr_gl_ptr;
			sl.global_list_ptr = gl_ptr;
			sl.reserved = OFF;

			attr_gl_ptr -&gt; gl.superior_assigned = ON; /* relation present for this attribute */
		     end;






/* RELATION SUBLIST INSERT */
/* add this attribute to the relation's attribute sublist */

		call mrds_rst_list_element$add (attribute.name, SUB_LIST, rsc_ptr,
		     gl.item_sub_list_ptr, sl_ptr, error_code);

		if error_code ^= 0 then do;
			call ioa_$rs ("^a^a^a^a", message, message_length,
			     "LOGIC ERROR in  mrds_rst_relation_handler, a duplicate attribute """,
			     attribute.name,
			     """ was found in relation """, relation.name, """.");
			call mrds_rst_error (rsc_ptr, 4 /* severity */, error_code, (message));
		     end;
		else do;

/* fill in the sublist element */

			sl.type = SUB_LIST;
			sl.name = attribute.name;
			sl.item_info_ptr = attr_gl_ptr -&gt; gl.item_info_ptr; /* attribute info pointer */
			sl.parse_info_ptr = attribute_ptr; /* attr parse structure */
			sl.old_other_info_ptr = attr_gl_ptr -&gt; gl.other_info_ptr; /* domain info ptr */
			sl.new_other_info_ptr = attr_gl_ptr -&gt; gl.other_info_ptr; /* domain info ptr */
			sl.global_list_ptr = attr_gl_ptr;
			sl.reserved = OFF;

			gl.inferior_assigned = ON;	/* attribute(s) present */

		     end;

	     end;

     end;
%page;
	dcl     error_mode		 bit (1);		/* ON =&gt; error occurred, special handling in progress */
	dcl     relation_name	 char (32);	/* relation name for this call */
	dcl     sys_info$max_seg_size	 fixed bin (35) external; /* system constant */
	dcl     (fixed, rel, addr, null) builtin;	/* functions known to pl1 */
	dcl     ON		 bit (1) internal static options (constant) init ("1"b); /* true state */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b); /* false */
	dcl     error_code		 fixed binary (35); /* mrds_error_ table index */
	dcl     message		 char (256) varying;/* specifics of error message */
	dcl     message_length	 fixed bin (21);	/* length of specifics message */
	dcl     mrds_error_$rst_undone_option fixed bin (35) external; /* option not coded yet */
	dcl     mrds_error_$undef_attr fixed bin (35) external; /* item not in database */
	dcl     mrds_error_$dup_rel	 fixed bin (35) external; /* duplicate attr definition */
	dcl     mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* working area manager */
	dcl     mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* list searcher */
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error handler */
	dcl     ioa_$rs		 entry options (variable); /* string manipulator */
	dcl     mrds_rst_list_element$add entry (char (32) aligned, fixed binary, ptr, ptr, ptr, fixed bin (35));
	dcl     list_ptr		 ptr;		/* pointer to parse info list */
	dcl     IN		 bit (1) internal static options (constant) init ("1"b); /* input meter flag */
	dcl     OUT		 bit (1) internal static options (constant) init ("0"b); /* output meter flag */
	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* metering/tracing routine */
	dcl     attr_gl_ptr		 ptr;		/* temp storage for attribute global element pointer */
	dcl     dom_gl_ptr		 ptr;		/* pointer to attribute's domain global list element */
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_semantics;
%page;
%include mrds_rst_parse_info;
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_global_lists;


     end;
���



		    mrds_rst_rsc_alloc.pl1          10/16/86  1551.9r w 10/16/86  1144.0      112230



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

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

/* HISTORY:

   originally written by jim gray - - February 1979

   82-06-28 Roger Lackey: Removed code for struct type 52 thru 58
   chnaged the way type 25 was handled since no longer used.

*/

mrds_rst_rsc_alloc: procedure (rsc_ptr, struct_type, struct_ptr);

/*
   .                        BEGIN_DESCRIPTION
   this routine does all allocations in working storage known as "rsc"
   for restructure control. modules that create, modify, or display
   the mrds database model all use this working storage, which is structured
   as a directory with a common segment, and several segments acting as
   extensible areas. allocations are made in the segments according to
   type of structure and the policy as defined by the logic of this module.
   two additional entries are $variable, and $free for variable
   length allocations, and freeing of previously allocated space.
   .                        END_DESCRIPTION
*/

/* PARAMETERS:

   normal entry ===
   rsc_ptr - - (input) pointer to the common segment under the working
   storage directory created under the user specified directory

   struct_type - - (input) fixed binary number that indicates which structure
   is to be allocated, and according to the internal policy, where it will be allocated
   as well. the include file mrds_rst_struct_types.incl.pl1 gives the constants
   that are used for this purpose.

   struct_ptr - - (output) pointer to the newly allocated structure of the type
   given by struct_type.

   $variable entry ===
   struct_size - - (input) a fixed binary (35) number, in addition to those above,
   that gives the length for the current allocation of this
   structure type that has a variable length.

   $free entry ===
   same as the normal entry, except struct_ptr is an input parameter,
   and it points to the allocation instance to be freed
*/
%page;
/* normal allocation entry point */

	FREE = OFF;
	goto common;


/* freeing entry point */

mrds_rst_rsc_alloc$free: entry (rsc_ptr, struct_type, struct_ptr);

	FREE = ON;

/* determine if we are freeing a variable length allocation */

	if struct_type &lt;= hbound (case, 1) then
	     goto common;
	else goto var_common;


common:

	if ^rsc.trace_sw then ;
	else call trace (ON);			/* input call */
%page;
/* check that the encoding for structure type is within the legal range */

	if struct_type &lt; lbound (case, 1) | struct_type &gt; hbound (case, 1) then
	     call bad_struct_code ();

	else do;

/* good structure type code, go to the allocate that it indicates for the
   given structure to be allocated, and the area in which it will reside */

		goto case (struct_type);

/* parse info structures */

case (1):

		if FREE then
		     free struct_ptr -&gt; domain in (parse_info_area);
		else allocate domain set (struct_ptr) in (parse_info_area);
		goto return_label;

case (2):

		if FREE then
		     free struct_ptr -&gt; attribute_domain in (parse_info_area);
		else allocate attribute_domain set (struct_ptr) in (parse_info_area);
		goto return_label;

case (3):

		if FREE then
		     free struct_ptr -&gt; relation in (parse_info_area);
		else allocate relation set (struct_ptr) in (parse_info_area);
		goto return_label;

case (4):

		if FREE then
		     free struct_ptr -&gt; attribute in (parse_info_area);
		else allocate attribute set (struct_ptr) in (parse_info_area);
		goto return_label;

case (5):

		if FREE then
		     free struct_ptr -&gt; file in (parse_info_area);
		else allocate file set (struct_ptr) in (parse_info_area);
		goto return_label;

case (6):

		if FREE then
		     free struct_ptr -&gt; item in (parse_info_area);
		else allocate item set (struct_ptr) in (parse_info_area);
		goto return_label;

case (7):

		if FREE then
		     free struct_ptr -&gt; link in (parse_info_area);
		else allocate link set (struct_ptr) in (parse_info_area);
		goto return_label;

case (8):

		if FREE then
		     free struct_ptr -&gt; foreign_key in (parse_info_area);
		else allocate foreign_key set (struct_ptr) in (parse_info_area);
		goto return_label;

case (9):

		if FREE then
		     free struct_ptr -&gt; children in (parse_info_area);
		else allocate children set (struct_ptr) in (parse_info_area);
		goto return_label;

case (10):

		if FREE then
		     free struct_ptr -&gt; rel_index in (parse_info_area);
		else allocate rel_index set (struct_ptr) in (parse_info_area);
		goto return_label;

case (11):

		if FREE then
		     free struct_ptr -&gt; delete_name in (parse_info_area);
		else allocate delete_name set (struct_ptr) in (parse_info_area);
		goto return_label;

case (12):

		if FREE then
		     free struct_ptr -&gt; dom_list in (parse_info_area);
		else allocate dom_list set (struct_ptr) in (parse_info_area);
		goto return_label;
%page;
/* semantic structures */

case (13):

		if FREE then
		     free struct_ptr -&gt; directive in (static_info_area);
		else allocate directive set (struct_ptr) in (static_info_area);
		goto return_label;

case (14):

		if FREE then
		     free struct_ptr -&gt; stmt in (static_info_area);
		else allocate stmt set (struct_ptr) in (static_info_area);
		goto return_label;

/* parsing structures */

case (15):

		if FREE then
		     free struct_ptr -&gt; lex_stack in (static_info_area);
		else allocate lex_stack set (struct_ptr) in (static_info_area);
		goto return_label;

case (16):

		if FREE then
		     free struct_ptr -&gt; p_struct in (static_info_area);
		else allocate p_struct set (struct_ptr) in (static_info_area);
		goto return_label;

case (17):

		if FREE then
		     free struct_ptr -&gt; cur_lex_top in (static_info_area);
		else allocate cur_lex_top set (struct_ptr) in (static_info_area);
		goto return_label;

case (18):

		if FREE then
		     free struct_ptr -&gt; token in (static_info_area);
		else allocate token set (struct_ptr) in (static_info_area);
		goto return_label;

case (19):

		if FREE then
		     free struct_ptr -&gt; output_text in (static_info_area);
		else allocate output_text set (struct_ptr) in (static_info_area);
		goto return_label;
%page;
/* global list structures */

case (20):

		if FREE then
		     free struct_ptr -&gt; gl in (global_list_area);
		else allocate gl set (struct_ptr) in (global_list_area);
		goto return_label;

case (21):

		if FREE then
		     free struct_ptr -&gt; sl in (sublist_area);
		else allocate sl set (struct_ptr) in (sublist_area);
		goto return_label;

case (22):

		if FREE then
		     free struct_ptr -&gt; seg_info in (seg_info_area);
		else allocate seg_info set (struct_ptr) in (seg_info_area);
		goto return_label;

case (23):

		if FREE then
		     free struct_ptr -&gt; node in (tree_node_area);
		else allocate node set (struct_ptr) in (tree_node_area);
		goto return_label;
%page;
/* other structures */

case (24):

		if FREE then
		     free struct_ptr -&gt; saved_child_count in (other_area);
		else allocate saved_child_count set (struct_ptr) in (other_area);
		goto return_label;

case (25):

		if FREE then
		     call bad_struct_code ();		/* No longer implemented */
		else call bad_struct_code ();		/* No longer implemented */
		goto return_label;


	     end;
%page;
mrds_rst_rsc_alloc$variable: entry (rsc_ptr, struct_type, struct_size, struct_ptr);

/* entry to handle structures whose length is variable */

	FREE = OFF;

var_common:

	if ^rsc.trace_sw then ;
	else call trace (ON);			/* input call */

	if struct_type &lt; lbound (var_case, 1) | struct_type &gt; hbound (var_case, 1) then
	     call bad_struct_code ();
	else if struct_size &lt; 1 then
	     call bad_struct_size ();


/* good encoding and size given, go allocate the given structure
   with the specified size, and place it according to area policy */

	else do;

		goto var_case (struct_type);

var_case (50):

		if FREE then
		     free struct_ptr -&gt; fixup_token in (variable_length_area);
		else do;
			token_length = struct_size;
			allocate fixup_token set (struct_ptr) in (variable_length_area);
		     end;
		goto return_label;

var_case (51):

		if FREE then
		     free struct_ptr -&gt; string_source in (variable_length_area);
		else do;
			source_size = struct_size;
			allocate string_source set (struct_ptr) in (variable_length_area);
		     end;
		goto return_label;

	     end;
%page;
return_label:

	if ^rsc.trace_sw then ;
	else call trace (OFF);			/* output call */


	return;
%page;
bad_struct_code: procedure ();

/* report bad structure type encoding error */

	call ioa_$rs ("^a ^d ^a", message, message_length,
	     "LOGIC ERROR in mrds_rst_rsc_alloc,", struct_type, "is an invalid code for structure type.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message));

     end;
%page;
bad_struct_size: procedure ();

/* report bad structure allocation size */

	call ioa_$rs ("^a ^d ^a", message, message_length,
	     "LOGIC ERROR in mrds_rst_rsc_alloc,", struct_size, "is an illegal structure allocation size.");
	call mrds_rst_error (rsc_ptr, 4 /* severity */, mrds_error_$rst_logic_error, (message));


     end;
%page;
trace: procedure (in_out);

/* common call to the metering routine */

	struct_type_picture = struct_type;
	call mrds_rst_meter (rsc_ptr, "mrds_rst_rsc_alloc", in_out, (struct_type_picture));

	dcl     in_out		 bit (1);		/* on =&gt; input, off =&gt; output call */
	dcl     struct_type_picture	 picture "99";	/* for integer to char conversion */

     end;
%page;

	dcl     mrds_rst_meter	 entry (ptr, char (*), bit (1), char (*)); /* trace routine */
	dcl     parse_info_area	 area based (rsc.parse_info_area_ptr); /* location for parsing structures */
	dcl     seg_info_area	 area based (rsc.tree_data.seg_info_area_ptr); /* segment list location */
	dcl     global_list_area	 area based (rsc.tree_data.gl_area_ptr); /* global element location */
	dcl     sublist_area	 area based (rsc.tree_data.sl_area_ptr); /* sub list element location */
	dcl     tree_node_area	 area based (rsc.tree_node_area_ptr); /* location of tree head portion */
	dcl     static_info_area	 area based (rsc.static_info_area_ptr); /* static type info location */
	dcl     variable_length_area	 area based (rsc.variable_length_area_ptr); /* location for variable length allocations */
	dcl     other_area		 area based (rsc.other_area_ptr); /* all other information */
	dcl     struct_type		 fixed bin;	/* number corresponding to structure to be allocated */
	dcl     struct_size		 fixed bin (35);	/* number of words to allocate for varying types */
	dcl     struct_ptr		 ptr;		/* pointer to allocated structure */
	dcl     mrds_rst_error	 entry (ptr, fixed bin, fixed bin (35), char (*)); /* general error routine */
	dcl     ioa_$rs		 entry options (variable); /* string manipulator routine */
	dcl     FREE		 bit (1);		/* on =&gt; free structure, off =&gt; allocate */
	dcl     ON		 bit (1) internal static options (constant) init ("1"b); /* true value */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b); /* false value */
	dcl     mrds_error_$rst_logic_error fixed bin (35) external; /* bad program */
	dcl     message		 char (96) varying; /* returned formatted specifics of error */
	dcl     message_length	 fixed bin (21);	/* length of returned message */
	dcl     sys_info$max_seg_size	 fixed bin (35) external; /* max system segment length */
	dcl     (addr, lbound, hbound, rel, fixed) builtin;
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_global_lists;
%page;
%include mrds_rst_parse_info;
%page;
%include mrds_dm_display_info;
%page;
%include mrds_rst_semantics;
%page;
%include mrds_rst_scan;
%page;
%include mrds_rst_parse_stack;
%page;
%include mdbm_db_model;

     end;
��



		    mrds_rst_scanner.pl1            04/18/85  1454.7r w 04/18/85  0909.3      240903



/* ***********************************************************
   *                                                         *
   *                                                         *
   * 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 1978
   Modified by Jim Gray - - 80-11-07, to have identifier_handler get legal characters from
   a mrds_data_ item in common with the rest of mrds (this removed "." as a legal character)

   80-12-15 Jim Gray : added check for last token being "-" ahead of edit proc
   keywords, as part of un-reserving keywords in CMDB.

   81-06-04 Jim Gray : removed token types no longer
   acepted by mrds_rst_semantics, such as constants for the -check option
   which was never implemented.

   81-07-29 Jim Gray : added correct handling of a "/" by itself in the source.

   83-10-01 Roger Lackey : Modified to correct multi-line comment sometimes
            not putting all of comment in listing. (TR phx15198)
*/

mrds_rst_scanner: procedure (lex_stack_ptr, stack_index);
%page;
/* DESCRIPTION:
   lexical analyzer or scanner for returning tokens from the restructuring source to the parser.
   a token may be an identifier, keyword, number, special character or end of file.
   an integer encoding value is also returned for use by the parser in identifying the token
   and pointers to the token in the source, and the start of the current line are returned
   as well as the line number and length of the token. A line numbered version of the original source can be produced.
   comments and white space are skipped over, and any invalid characters are detected..

   there are two entries:
   init entry -  should be called first for initialization
   normal entry - for returning tokens from the source
*/

/* PARAMETERS:
   === normal entry ===
   lex_stack_ptr - - (input) pointer to the lexical stack

   stack_index - - (input) stack element which is hold the returned token, etc.

   lex_stack - - (output) the specified element contains the token pointer, length, encoding,
   and line number and line start pointer

   (output) for the line numbered listing goes to "source_segment".list

   === init entry ===
   err_ptr - - (input) pointer to retructure control segment

   source_seg_ptr - - (input) pointer to the restructuring directives source segment

   source_length - - (input) length in characters of the source segment */
%page;
/* normal entry */

	goto state (START);





/* initialization entry */

mrds_rst_scanner$init: entry (err_ptr, source_seg_ptr, source_length);


/* get restructure conrol pointer, set up line number and pointer,
   make first character and it's type available */

	static_rsc_ptr = err_ptr;
	call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, accum_token_ptr);
	call mrds_rst_rsc_alloc (static_rsc_ptr, OUTPUT_TEXT, output_text_ptr);
	call get_next_char_init (source_seg_ptr, source_length, char_ptr, char_type, char);
	call keyword_lookup ("check_proc", CHECK_PROC);
	call keyword_lookup ("encode_proc", ENCODE_PROC);
	call keyword_lookup ("decode_proc", DECODE_PROC);

	return;









/* START */
state (0):


/* using the type code for the current character, go to the appropiate state for that class of tokens,
   the parser having initialized the current character before the first call, and scanner obtaining the next
   character to be used when called again before returning to the parser */

	token = "";
	token_length = 0;
	fixed_value = 0;
	float_value = 0.0;
	symbol_found = "0"b;
	token_too_long_seen = "0"b;

/* continue on next page

   loop from start state to the recognition states,
   while a token is not found, and end of source is not detected */
%page;
	do while (^symbol_found);
	     goto state (char_type);

/* LETTER */
state (1):

/* letter found, accumulate characters that are letters, numbers, underscores, hyphens into an identifier token
   then make checks for keywords and pathnames that may follow to provide correct parser and scanner encoding */

	     call identifier_handler ();
	     call stack_put ();
	     symbol_found = "1"b;
	     goto state (CASE_END);

/* DIGIT */
state (2):

/* digit found, accumulate digits,
   into a number and convert from ascii to binary */

	     if ^number_convert () then ;
	     else do;
		     call stack_put ();
		     symbol_found = "1"b;
		end;
	     goto state (CASE_END);

/* SPECIAL */
state (3):

/* special character found, if slash, check for comment
   else return encoding for the character */

	     if comment_skip () then ;
	     else do;

/* not a comment, single character special instead, get it's encoding */

		     call encode_special ();
		     call stack_put ();
		     symbol_found = "1"b;
		end;
	     goto state (CASE_END);


/* A_PATH_ENTRY */
state (4):

/* start of a pathname or entry name detected */

	     call path_entry_handler ();
	     call stack_put ();
	     symbol_found = "1"b;
	     goto state (CASE_END);

/* NL */
state (5):

/* new line detected */

	     call get_next_char_new_line (char_ptr, char_type, char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* WHITE_SPACE */
state (6):

/* white space detected, skip over it */

	     call get_next_char_non_white (char_ptr, char_type, char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* ILLEGAL */
state (7):

/* illegal character detected */

	     call ioa_$rs ("^a^a^a ^d ^a ^d^a", message, message_length,
		"Character """, char, """, before token number", token_count + 1, "on line", line_number, ".");
	     call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_illegal_char, (message));
	     call get_next_char (char_ptr, char_type, char);
	     symbol_found = "0"b;
	     goto state (CASE_END);

/* EOF */
state (8):

/* end of input detected */

	     encoding = EOI;
	     token_ptr = char_ptr;
	     call stack_put ();
	     symbol_found = "1"b;
	     goto state (CASE_END);

/* CASE_END */
state (9):

	end;
	return;
%page;
stack_put: procedure ();

/* increment the number of tokens seen in this line */

	token_count = token_count + 1;

/* routine to put the token info into the stack */

	lex_stack (stack_index).symptr = token_ptr;
	lex_stack (stack_index).symlen = token_length;
	lex_stack (stack_index).line = line_number;
	lex_stack (stack_index).symbol = encoding;
	lex_stack (stack_index).val = fixed_value;
	lex_stack (stack_index).float = float_value;
	lex_stack (stack_index).line_strt = line_ptr;
	lex_stack (stack_index).line_size = line_length;
	lex_stack (stack_index).token_num = token_count;

	previous_token_type = encoding;
     end;
%page;
identifier_handler: procedure ();

/* routine to assemble identifiers, make keyword encodings,
   and set up for path names to follow certain keywords */

	token_ptr = char_ptr;
	do while (index (mrds_data_$valid_id_chars, char) ^= 0);
	     call add_char_to_token ();
	     call get_next_char (char_ptr, char_type, char);
	end;

/* find out if this is a keyword */

	call keyword_lookup (token, encoding);
	if encoding ^= 0 then ;
	else encoding = IDENTIFIER;

/* if this was a path name keyword, check for absolute pathname following(i.e. "&gt;" next),
   and set up char_type to get the pathname on the next call to scanner */

	if encoding = CHECK_PROC | encoding = ENCODE_PROC | encoding = DECODE_PROC then do;


/* do double check that the previous token was a "-", else
   we don't really have an edit procedure keyword */

		if previous_token_type ^= index (SPECIAL_LIST, "-") then
		     encoding = IDENTIFIER;		/* not a real keyword */
		else do;

/* get next good character after keyword, it should be "&gt;" */

			temp_line_number = line_number;
			good_char = "0"b;
			do while (^good_char);
			     if char_type ^= WHITE_SPACE &amp; char_type ^= NL then
				good_char = "1"b;
			     else if char_type = WHITE_SPACE then
				call get_next_char_non_white (char_ptr, char_type, char);
			     else if char_type = NL then
				call get_next_char_new_line (char_ptr, char_type, char);
			end;
			if char = "&gt;" then
			     char_type = A_PATH_ENTRY;
			else do;

				call ioa_$rs ("^a ^d^a ^d^a", message, message_length,
				     "Absolute pathname missing or not starting with ""&gt;"" after token",
				     token_count + 1, ", a procedure path keyword in line", temp_line_number, ".");
				call mrds_rst_error (static_rsc_ptr, 2 /* severity */,
				     mrds_error_$rst_missing_pathname, (message));

			     end;
		     end;

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

/* if max token size not exceeded, append current character
   to the accumulating token variable, else truncate it at the max size  */

	on stringsize /* capture max size exceeded */
	     begin;

/* issue error message on first occurence only */

		if token_too_long_seen then ;
		else do;
			token_too_long_seen = "1"b;
			call ioa_$rs ("^a ^d ^a ^d ^a", message, message_length,
			     "A token on line", line_number, "exceeds the maximum string size of",
			     mrds_data_$max_string_size, "characters, it is being truncated at that length.");
			call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_token_too_long, (message));
		     end;

		goto truncate_token;

	     end;

/* normal action appends character to token */

(stringsize): token = token || char;
	token_length = token_length + 1;

truncate_token:


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

/* routine to accumulate extent of number in ascii, and convert it to the
   appropriate internal form and give it the required parser encoding */

	fixup_done = "0"b;
	token_ptr = char_ptr;

/*    accumulate  positive integer numbers as the token */

	mantissa_end = "0"b;
	radix_found = "0"b;
	do while (^mantissa_end);

	     do while (char_type = DIGIT);
		call add_char_to_token ();
		call get_next_char (char_ptr, char_type, char);
	     end;


	     mantissa_end = "1"b;

	end;


/* good number found, check for possible exponent */

	number_found = "1"b;

/* number processed, assign the appropiate encoding value for the parser */

	encoding = INTEGER;

/* get the binary equivalent for this number, if semantics has not shut off converting */

	if static_rsc_ptr -&gt; rsc.skip_scanner_conversion then ;
	else call binary_conversion ();


/* return success for good number, failure for illegal character "." by itself, and use corrected token rather than source */

	if ^fixup_done then ;
	else call substitute_fixup_token ();

	return (number_found);
%page;
binary_conversion: procedure ();

/* routine to do ascii to binary conversion of numbers */

/* use the large number fixup on conversion overflow */

	on size call fixup_conversion;
	on fixedoverflow call fixup_conversion;
	on overflow call fixup_conversion;
	on underflow call fixup_conversion;
	on conversion call fixup_conversion;

/* convert the accumulated ascii token to binary */

	fixed_value = fixed (binary (token));


/* conversion error fixup return */
SKIP_CONVERT:

	return;



fixup_conversion: procedure ();

/* use the largest number in place of the one that is too big */

	fixup_done = "1"b;

	temp_token = copy ("1", 71) || "b";
	fixed_value = fixed (binary (temp_token));
	call ioa_$rs ("^a ^a ^a ^d ^a ^d ", message, message_length,
	     "The number", token, "in line", line_number, "is too large, using value", fixed_value);
	token = temp_token;

	call mrds_rst_error (static_rsc_ptr, 2 /* severity */,
	     mrds_error_$rst_conversion_error, (message));

	goto SKIP_CONVERT;

     end;

     end;

     end;
%page;
substitute_fixup_token: procedure ();

/* save the fixup version of the token, and point to it rather than the source */

	token_length = length (token);
	call mrds_rst_rsc_alloc$variable (static_rsc_ptr, FIXUP_TOKEN, (token_length), token_ptr);
	token_ptr -&gt; fixup_token = token;


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

/* check for presence of a comment, return failure if not found */

	token_ptr = char_ptr;
	token = char;
	call get_next_char (char_ptr, char_type, char);
	if (token = "/" &amp; char ^= "*") | (token ^= "/") then do;
		if token ^= "/" then
		     result = "0"b;
		else do;
			result = "1"b;		/* skip over illegal character */
			call ioa_$rs ("^a^a^a ^d ^a ^d^a", message, message_length,
			     "Character """, token, """, before token number", token_count + 1, "on line", line_number, ".");
			call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_illegal_char, (message));
		     end;
	     end;
	else do;

/* routine to bypass comments in the source */

		comment_end = "0"b;
		char = " ";
		do while (^comment_end);

		     do while (char ^= "*" &amp; char_type ^= EOF);
			if char_type ^= NL then
			     call get_next_char_non_white (char_ptr, char_type, char);
			if char_type = NL then
			     call get_next_char_new_line (char_ptr, char_type, char);
		     end;

		     if char_type = EOF then
			comment_end = "1"b;
		     else do;
			     call get_next_char (char_ptr, char_type, char);
			     if char ^= "/" &amp; char_type ^= EOF then ;
			     else comment_end = "1"b;
			     if char_type ^= NL then ;
			     else call get_next_char_new_line (char_ptr, char_type, char);
			end;

		end;


/* check for comment error */

		if char_type ^= EOF then ;
		else do;
			call ioa_$rs ("^a ^d^a", message, message_length,
			     "Comment ends line number", line_number, ".");
			call mrds_rst_error (static_rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_comment_ends_source, (message));
		     end;

		token = "";
		call get_next_char_non_white (char_ptr, char_type, char);
		symbol_found = "0"b;
		result = "1"b;

	     end;

	return (result);

     end;
%page;
encode_special: procedure ();

/* routine to produce the parser encoding of the special character just found */

	token_length = 1;
	special_index = index (SPECIAL_LIST, token);
	if special_index ^= 0 then
	     encoding = CODE (special_index);
	else do;
		encoding = EOI;
		call ioa_$rs ("^a ^a ^a ^d^a", message, message_length,
		     "Special character", token, "in line", line_number, ".");
		call mrds_rst_error (static_rsc_ptr, 4 /* severity */, mrds_error_$rst_bad_encoding, (message));
	     end;

     end;
%page;
path_entry_handler: procedure ();

/* routine to accumulate character strings representing either path names,
   or entry names into tokens and give them the proper parser encoding */


/* if path name detected by identifier handler, reset the "&gt;" char_type to special */

	if char ^= "$" then do;
		encoding = PATH_NAME;
		char_type = SPECIAL;
	     end;

/* else we have an entry name starting with "$", throw that character away */

	else do;
		encoding = ENTRY_NAME;
		call get_next_char (char_ptr, char_type, char);
	     end;

/* get the length for and pointer to this path/entry name
   path names end in white space or "$", entry names end in white space
   a "," or ";" also ends them due to domain statement syntax */

	token_ptr = char_ptr;
	do while (char_type ^= WHITE_SPACE &amp; char_type ^= NL &amp; char_type ^= A_PATH_ENTRY &amp; char_type ^= EOF
	     &amp; char ^= "," &amp; char ^= ";");
	     token_length = token_length + 1;
	     call get_next_char (char_ptr, char_type, char);
	end;

/* check for name ending source prematurely */

	if char_type ^= EOF then ;
	else do;
		call ioa_$rs ("^a ^d^a ^d^a", message, message_length,
		     "Pathname is token", token_count + 1, ", on line", line_number, ".");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */,
		     mrds_error_$rst_pathname_ends_source, (message));
	     end;

     end;
%page;
get_next_character_routine: procedure ();		/* dummy entry, not used */

/* This procedure has four entry points.
   get_next_char_init   should be called first to set up things
   get_next_char_new_line is used to advance the current line, output it, and get the first char
   get_next_char_non_white skips white spaces until a valid character is found
   get_next_char$get_next_char  returns only info about the next char in source
*/



/* INIT */
get_next_char_init: entry (s_seg_ptr, s_seg_len, chr_ptr, type, chr_val); /* This entry initializes internal stativ values */

	seg_ptr = s_seg_ptr;			/* Save source segment pointer and length */
	seg_len = s_seg_len;			/*   in internal static variable */
	pos = 1;					/* Starting position is first character */
	line_number = 0;



/* NEW LINE */
get_next_char_new_line: entry (chr_ptr, type, chr_val);	/* entry to advance to next line */

	if pos &gt; seg_len then ;
	else do;

/* find end of next line */

		line_ptr = addr (char_string (pos));
		line_length = index (substr (line_ptr -&gt; source, 1, seg_len - pos + 1), NL_CHAR);
		if line_length ^= 0 then ;		/* next lines NL found */
		else line_length = seg_len - pos + 1;	/* segment doesn't end last line with NL */

		line_number = line_number + 1;
		token_count = 0;

		if ^static_rsc_ptr -&gt; rsc.listing_seg_sw then ;
		else do;

/* listing switch on, output the current line */

			line_no_pic = line_number;
			output_text = line_no_pic || "   " || substr (line_ptr -&gt; source, 1, line_length);

			call iox_$put_chars (static_rsc_ptr -&gt; rsc.listing_iocb_ptr,
			     addrel (addr (output_text), 1), length (output_text), code);
			if code = 0 then ;
			else do;
				call ioa_$rs ("^a ^d ^a", message, message_length,
				     "Error in trying to output line number", line_number, "to listing segment rmdb.list");
				call mrds_rst_error (static_rsc_ptr, 4 /* severity */,
				     mrds_error_$rst_io_error, (message));
			     end;
		     end;
	     end;

	goto get_first_char;


/* NEXT NON WHITE */
get_next_char_non_white: entry (chr_ptr, type, chr_val);	/* This entry skips white space */

	if pos &lt;= seg_len then do;			/* for positions less than segment length + 1 */

		type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* get character type */

		do while (type = WHITE_SPACE &amp; pos &lt;= seg_len); /* Skip until type is not white space */
		     pos = pos + 1;			/* Current position gets bumped */
		     type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* Determine caracter type */
		end;
						/* pos is the index of the next non-white-space character */
	     end;



/* NEXT CHAR */
get_first_char: ;
get_next_char: entry (chr_ptr, type, chr_val);		/* return next character in source */

	if pos &lt;= seg_len then do;			/* Not passed end of segment */
		chr_val = char_string (pos);		/* Get character */
		type = mrds_rst_translate (fixed (char_bits (pos), 9)); /* Get character type from table */
		chr_ptr = addr (char_string (pos));	/* Get pointer to caracter */
		pos = pos + 1;			/* Bump index to next char posiition */
	     end;

	else do;
		type = EOF;			/* Position was beyond end of segment */
		chr_val = " ";
	     end;


	return;
%page;
/*	PARAMETERS	*/

	dcl     s_seg_ptr		 ptr;		/* (INPUT) Pointer to source segment */
	dcl     s_seg_len		 fixed bin (24);	/* (INPUT) Length of source segment in chars */

	dcl     chr_val		 char (1);	/* (OUTPUT) Current character */
	dcl     type		 fixed bin;	/* (OUTPUT) Character type from map */
	dcl     chr_ptr		 ptr;		/* (OUTPUT) Pointer to current character */

/*	STATIC VARIABLES	*/

	dcl     pos		 fixed bin (24) internal static init (1); /* Index position in to character string */
	dcl     seg_ptr		 ptr int static init (null); /* Pointer to input segment (source segment) */
	dcl     seg_len		 fixed bin (24) int static init (0); /* Length of input segment (source) */
	dcl     NL_CHAR		 char (1) internal static init ("
");						/* new line character */

/*	OTHERS		*/

	dcl     addr		 builtin;

/* 	BASED VARIABLES	*/

	dcl     char_string		 (seg_len) char (1) based (seg_ptr); /* Treat char string as char array */
	dcl     char_bits		 (seg_len) bit (9) unal based (seg_ptr); /* Treat char string as bit array */
%page;
%include mrds_rst_translate;
     end get_next_character_routine;
%page;
keyword_lookup: procedure (token, encodement);

/* routine to do binary search of keywords known to mrds restructuring
   against a supplied identifier and return an
   encoded value for the keyword if a match if found, else return zero */

/* initialize the starting range for the binary search
   as that of the whole array, and set the
   first probe point to its middle */

	low = lbound (keyword, 1);
	high = hbound (keyword, 1);
	middle = (low + high) / 2;

/* proceed to divide the range in half,
   searching the half remaining that contains
   the value range (in ascii sequence) of
   the supplied identifier */

	do while (token ^= keyword.name (middle) &amp; high &gt; low);

	     if token &gt; keyword.name (middle) then
		low = middle + 1;
	     else high = middle - 1;

	     middle = (low + high) / 2;

	end;

/* check to see if the search was successful */

	if token = keyword.name (middle) then
	     encodement = keyword.value (middle);
	else encodement = 0;
%page;
/* the following declaration that includes the encoding
   for keywords was generated by the keyword sorted list tool,
   for use with the terminal encoding as derived from
   use of the lrk tool on the mrds restructuring bnf - - see D. Ward's documentation */

%include mrds_rst_keywords;
%page;

	dcl     low		 fixed binary;	/* current low search for part of array left to be searched */
	dcl     high		 fixed binary;	/* current high search search */
	dcl     middle		 fixed binary;	/* current probe point in array */
	dcl     (lbound, hbound)	 builtin;		/* functions known to pl1 to get array bounds */
	dcl     token		 char (*) varying;	/* identifier to be searched for as keyword */
	dcl     encodement		 fixed binary;	/* encoding value to be given to found keyword */

     end;
%page;
	dcl     stack_index		 fixed bin (24) aligned; /* place in lexical stack to put returned token */
	dcl     encoding		 fixed binary;	/* integer value expected by parser to represent this token */
	dcl     token_too_long_seen	 bit (1);		/* ON =&gt; previous error message issued */
	dcl     stringsize		 condition;	/* target too small for string */
	dcl     good_char		 bit (1);		/* on =&gt; character is not white space or new line char */
	dcl     mantissa_end	 bit (1);		/* end of mantissa flag */
	dcl     radix_found		 bit (1);		/* on =&gt; radix point found in mantissa */
	dcl     fixed_value		 fixed binary (71); /* converted binary value of a fixed number */
	dcl     float_value		 float binary (63); /* converted binary value of a float number */
	dcl     symbol_found	 bit (1);		/* on =&gt; token has been found */
	dcl     comment_end		 bit (1);		/* on =&gt; end of comment reached */
	dcl     mrds_rst_rsc_alloc$variable entry (ptr, fixed bin, fixed bin (35), ptr); /* working area alloc routine */
	dcl     mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* for non-variable allocations */
	dcl     ioa_$rs		 entry options (variable); /* string manipulation routine for error messages */
	dcl     message		 char (256) varying;/* error message with details */
	dcl     message_length	 fixed binary;	/* length of error message */
	dcl     mrds_rst_error	 entry (ptr, fixed binary, fixed binary (35), char (*)); /* error handling routine */
	dcl     result		 bit (1);		/* on =&gt; a comment was found and skipped */
	dcl     number_found	 bit (1);		/* off =&gt; "." by itself skipped as illegal */
	dcl     token_ptr		 ptr;		/* pointer to token start in source */
	dcl     (size, overflow, underflow, fixedoverflow, conversion) condition; /* trap for conversion overflow */
	dcl     mrds_error_$rst_token_too_long fixed bin (35) external; /* token exceed max string size */
	dcl     mrds_error_$rst_pathname_ends_source fixed binary (35) external; /* premature segment end by a name */
	dcl     mrds_error_$rst_missing_pathname fixed binary (35) external; /* expected pathname missing after keyword */
	dcl     mrds_error_$rst_conversion_error fixed binary (35) external; /* number convert onverflow error */
	dcl     mrds_error_$rst_io_error fixed binary (35) external; /* error during io attempt */
	dcl     mrds_error_$rst_comment_ends_source fixed binary (35) external; /* long comment error code */
	dcl     mrds_error_$rst_illegal_char fixed binary (35) external; /* bad char error code */
	dcl     mrds_error_$rst_bad_encoding fixed binary (35) external; /* bad integer code for special char */
	dcl     special_index	 fixed binary;	/* index of special char encoding in the CODE array */
	dcl     index		 builtin;		/* search function known to pl1 */
	dcl     source_seg_ptr	 ptr;		/* pointer to restructuring directives source segment */
	dcl     err_ptr		 ptr;		/* pointer to restructure control segment */
	dcl     source_length	 fixed binary (24); /* character length of source segment */
	dcl     sys_info$max_seg_size	 fixed binary (35) external; /* system constant for largest size segment */
	dcl     (fixed, rel, addr)	 builtin;		/* functions known to pl1 */
	dcl     temp_line_number	 fixed binary (21); /* storage for error line number */
	dcl     line_no_pic		 picture "zzzzzz9"; /* number of output line, formatted */
	dcl     source		 char (sys_info$max_seg_size) based; /* overlay to extract source lines */
	dcl     fixup_done		 bit (1);		/* on =&gt; change made to token to correct error */
	dcl     code		 fixed binary (35); /* error code from subroutine calls */
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* listing io routine */
	dcl     (addrel, binary, copy, length, substr) builtin;
	dcl     temp_token		 char (96) varying; /* temp storage for fixup value */
	dcl     ENCODE_PROC		 fixed binary internal static; /* encoding value for keyword encode_proc */
	dcl     DECODE_PROC		 fixed binary internal static; /* encoding value for keyword decode_proc */
	dcl     CHECK_PROC		 fixed binary internal static; /* encoding value for keyword check_proc */
	dcl     mrds_data_$valid_id_chars char (128) varying ext; /* common place for getting legal identifier characters */
	dcl     previous_token_type	 fixed bin int static init (0); /* last token encoding */
%page;

%include mrds_rst_parse_stack;
%page;
%include mrds_rst_scan;
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;
%page;
%include mrds_rst_parse_info;

     end;


�



		    mrds_rst_semantics.pl1          10/16/86  1551.9rew 10/16/86  1142.9      587358



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


/****^  HISTORY COMMENTS:
  1) change(86-04-03,Spitzer), approve(86-04-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     remove unused dcls. remove PL/1 IO statement.
                                                   END HISTORY COMMENTS */


/* -alm
   -ssl
   -ct
   -term
   -sem mrds_rst_semantics
   -mla 10
   -table mrds_rst_parse_table
   -recover &lt;nil&gt; &lt;semicolon&gt;
   -mark &lt;identifier&gt;
   -order
   &lt;left_parenthesis&gt;
   &lt;right_parenthesis&gt;
   &lt;comma&gt;
   &lt;semicolon&gt;
   &lt;colon&gt;
   &lt;hyphen&gt;
   &lt;asterisk&gt;
   &lt;plus&gt;
   &lt;path_name&gt;
   &lt;entry_name&gt;
   &lt;positive_integer&gt;
   &lt;identifier&gt;
   &lt;domain&gt;
   &lt;attribute&gt;
   &lt;relation&gt;
   &lt;index&gt;
   &lt;real&gt;
   &lt;complex&gt;
   &lt;fixed&gt;
   &lt;float&gt;
   &lt;binary&gt;
   &lt;decimal&gt;
   &lt;precision&gt;
   &lt;char&gt;
   &lt;bit&gt;
   &lt;varying&gt;
   &lt;nonvarying&gt;
   &lt;aligned&gt;
   &lt;unaligned&gt;
   &lt;check_proc&gt;
   &lt;encode_proc&gt;
   &lt;decode_proc&gt;
   &lt;decode_dcl&gt;
   &lt;nil&gt;
   -parse */



/* IMPORTANT!!! - - - HOW TO UPDATE THIS SOURCE **************************************************************

   This  semantic routine interface, the parser, and the scanner
   were  all  developed with the aide of the automated "lrk" parser
   generator tool.  (see &gt;udd&gt;LIS&gt;Wardd&gt;MTB_lrk.runout for complete
   details)  The  following steps (say in an exec_com) must be done
   when the total parser or any part is to be modified, in order to
   insure proper operation.

   1)  make  changes to the grammar and/or pl1 code representing
   semantics  in  the  "lrk  source"  mrds_rst_parse.lrk via a text
   editor.   This  source  looks like this listing, except that the
   BNF  rules, and lrk options are not enclosed as comments, and it
   is  not indented.  DO NOT MODIFY mrds_rst_semantics.pl1 as those
   changes  would  be  lost  when  lrk is invoked, and would not be
   reflected in any tables generated.

   2) invoke the lrk program to generate

   a) the semantic routine source as pl1 code in
   mrds_rst_semantics.pl1
   from the bnf, control arguments, and pl1 code in the lrk source in
   mrds_rst_parse.lrk

   b) parsing tables for the table driven parsing algorithm(an lrk bottom up parser)
   (the source is in mrds_rst_parse.pl1)
   from an "lrk source" of backus-naur form grammer (this is in
   mrds_rst_parse.lrk) via the command line:

   &gt;udd&gt;LIS&gt;Wardd&gt;lrk  mrds_rst_parse

   the control arguments in the source direct lrk output as follows:
   "-table mrds_rst_parse_table" will build and initialize the basic lrk
   parsing table for the parsing algorithm
   "-sem mrds_rst_semantics" directs semantic output to the appropriate pl1 segment
   the "-order", and "-recover" control arguments affect error handling during parsing

   3) generate the keyword sorted list for the scanner using the
   kwsl   tool.   this  builds  an  include  file  that  is  a  pl1
   declaration  for  keyword  encodings.   the  source  of  keyword
   synonyms  is  in mrds_rst_keywords.syn and is in the development
   library  source  directory  the  tool is invoked via the command
   line:
   &gt;udd&gt;LIS&gt;Wardd&gt;kwsl mrds_rst_parse mrds_rst_keywords mrds_rst_keywords
   where arguments 1 to 3 are the lrk source, kwsl
   source, and include file name

   4) generate the error recovery skip table from the lrk tables
   by the following command line :
   udd&gt;LIS&gt;Wardd&gt;msd mrds_rst_parse mrds_rst_skip_table
   where the first argument is the lrk source, the
   other the include file name

   5)  generate  the error message terminal symbols file via the
   command line:
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;lrk|hal_dcl mrds_rst_parse mrds_rst_terminals
   where the first argument is the lrk source, the
   last the include file name

   6)  build  the ascii to decimal transliteration include file,
   input  is  is  mrds_rst_translate.mad  which may be found in the
   development library source directory.

   7)  add  include  file  comment  heading/trailing banners via
   command lines:
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;Wardd|incl_cmt mrds_rst_parse_table
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;Wardd|incl_cmt mrds_rst_skip_table

   8)  indent and compile the three affected parts of the parser
   on:
   mrds_rst_semantics.pl1
   mrds_rst_parse.pl1
   mrds_rst_scanner.pl1

   the   modification  to  the  parser  is  now  complete.   THE
   FOLLOWING EXEC COM DOES THE ABOVE TASKS:

   &amp;     indent the lrk source
   &amp;
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;lrk|ind mrds_rst_parse.lrk
   &amp;
   &amp;     generate the lrk tables from  mrds_rst_parse.lrk  source  bnf
   &amp;     with  control  arguments  inside  that  source  output is the
   &amp;     mrds_rst_parse  object  table  for  the  parser  the   source
   &amp;     mrds_rst_semantics.pl1,  and  the  intermediate  lrk  results
   &amp;     mrds_rst_parse.result and several  mrds_rst_parse.lrk.*  segs
   &amp;     with a listing of mrds_rst_parseg.list
   &amp;
   &gt;udd&gt;LIS&gt;Wardd&gt;lrk mrds_rst_parse
   &amp;
   &amp;     generate the  keyword  sorted  list  include  file  from  the
   &amp;     mrds_rst_keywords.syn    source    and    the    lrk   output
   &amp;     mrds_rst_parse.result     the     output     produced      is
   &amp;     mrds_rst_keywords.incl.pl1
   &amp;
   &gt;udd&gt;LIS&gt;Wardd&gt;kwsl mrds_rst_parse mrds_rst_keywords mrds_rst_keywords
   &amp;
   &amp;     generate  the  error  skip  table  include  the   source   is
   &amp;     mrds_rst_parse.result, output is mrds_rst_skip_table.incl.pl1
   &amp;
   &gt;udd&gt;LIS&gt;Wardd&gt;msd mrds_rst_parse mrds_rst_skip_table
   &amp;
   &amp;     generate the terminal symbols  include  file  the  source  is
   &amp;     mrds_rst_parse.result, output is mrds_rst_terminals.incl.pl1
   &amp;
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;lrk|hal_dcl mrds_rst_parse mrds_rst_terminals
   &amp;
   &amp;     build the ascii to decimal transliteration include file input
   &amp;     is          mrds_rst_translate.mad,         output         is
   &amp;     mrds_rst_translate.incl.pl1
   &amp;
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;Wardd|mad mrds_rst_translate.mad
   &amp;
   &amp;     put include file headers/trailer comments in  this  adds  the
   &amp;     BEGIN INCLUDE FILE.... and END INCLUDE FILE comments
   &amp;
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;Wardd|incl_cmt mrds_rst_parse_table
   ted -abort &gt;udd&gt;LIS&gt;Wardd&gt;Wardd|incl_cmt mrds_rst_skip_table
   &amp;
   &amp;     compile parser, scanner, and semantics PL1 routines
   &amp;
   pl1  mrds_rst_semantics
   pl1  mrds_rst_parse
   pl1  mrds_rst_scanner
   &amp;
   &amp;     get rid of lrk generated segments no longer needed they  were
   &amp;     used as intermediate results by lrk and it's tools
   &amp;
   dl mrds_rst_parse.lrk.TL
   dl mrds_rst_parse.lrk.THL
   dl mrds_rst_parse.lrk.TC
   dl mrds_rst_parse.lrk.DPDA
   dl mrds_rst_parse.result

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

/* HISTORY:

   originally written by jim gray - - july 1978

   Modified by Jim Gray  -  -  Jan.  1980,  to  add  packed  decimal
   capability.

   80-12-12 Jim Gray : added -mark &lt;identifier&gt; control to LRK input
   file  in  order  to be able to un-reserve keywords for CMDB. Also
   changed &lt;cmdb_statement&gt; and &lt;domain_stmt&gt; rules to avoid &lt;empty&gt;
   case  so  that could run with 6.2 LRK (previously used 5.5). This
   means that a domain keyword must always be  present,  even  if  a
   define does not add new domains.


   81-06-04 Jim Gray : removed unused rules and code, this  included
   blocked  file  and foreign key statements, the -check option, and
   the  restructuring  directives.  Also  re-did  scanner  -  parser
   constants according to the new -order statment.

   81-10-15 Davids: added rules to allow declarations of the form:
   .   varying char (64)
   .   nonvarying char (64)
   .   varying bit (64)
   .   nonvarying bit (64)
   Also modified  the  example  ec  and  explantion  before  it  and
   justified all the text.
*/

mrds_rst_semantics: procedure (rule, alternate, stkp, ls_top); goto SKIP_ENTRIES;

mrds_rst_semantics$rule_set: entry (); rule_sw = ^rule_sw; goto return_label;

/* DESCRIPTION:
   semantics routines for mrds restructuring
   it is called by the lrk parser whenever a rule is found to aply
   giving the rule number, alternate number, the stack pointer,
   and the current top of the lexical stack
   a goto the appropiate semantic action is given based on the rule number,
   and the semantic action routine implements the "meaning" of the parse
   tree which the lrk parser has determined that the syntax represents.
   after the action, it returns to the parser.

   entry mrds_rst_semantics$init should be called first to initialize

   an alternate entry mrds_rst_semantics$rule_set - allows debug output of rule numbers processed to
   be switched on or off on succeeding calls, it has no parameters
*/

/* PARAMETERS:
   rule - - (input) the rule number of the bnf at which the lrk parser
   has found the syntax to conform to, before the reduction takes place.

   alternate - - (input) the alternative of this rule which is being used

   stkp - - (input) the lexical stack pointer

   ls_top - - (input) current top of the lexical stack

   rsc_ptr - - (input) for the init entry only, a pointer to the restructure control segment
*/

/* initialization entry */

mrds_rst_semantics$init: entry (rsc_ptr);

	static_rsc_ptr = rsc_ptr;
	rsc.skip_scanner_conversion = OFF;

	call mrds_rst_rsc_alloc (static_rsc_ptr, DIRECTIVE, directive_ptr);
	rsc_ptr -&gt; rsc.directive_ptr = directive_ptr;
	directive.type = 0;				/* no directive seen yet */
	directive.undefine.active = OFF;
	directive.undefine.seen = OFF;
	directive.define.active = OFF;
	directive.define.seen = OFF;
	directive.redefine.active = OFF;
	directive.redefine.seen = OFF;

	call mrds_rst_rsc_alloc (static_rsc_ptr, STMT, stmt_ptr);
	rsc_ptr -&gt; rsc.stmt_ptr = stmt_ptr;
	do i = 1 by 1 to hbound (stmt_ptr -&gt; stmt, 1);
	     stmt (i).domain.active = OFF;
	     stmt (i).domain.number = 0;
	     stmt (i).attribute.active = OFF;
	     stmt (i).attribute.number = 0;
	     stmt (i).relation.active = OFF;
	     stmt (i).relation.number = 0;
	     stmt (i).file.active = OFF;
	     stmt (i).file.number = 0;
	     stmt (i).foreign_key.active = OFF;
	     stmt (i).foreign_key.number = 0;
	     stmt (i).index.active = OFF;
	     stmt (i).index.number = 0;
	end;

	max_string_size = mrds_data_$max_string_size;
	max_fixed_bin_17 = fixed (binary (copy ("1", 17) || "b"));
	max_fixed_bin_71 = fixed (binary (copy ("1", 71) || "b"));

	db_model_path = rtrim (rsc_ptr -&gt; rsc.temp_dir) || "&gt;db_model"; /* path name for the db_model must be saved */

	call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, name_ptr); /* space for token from stack */
	call mrds_rst_rsc_alloc (static_rsc_ptr, TOKEN, temp_source_ptr); /* space for string to be multiplied */

	goto return_label;

/* *******************************************************************

   normal entry for semantics case structure

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



SKIP_ENTRIES: ;



/* set local versions of parameters */

	lex_stack_ptr = stkp;
	stack_top = ls_top;

/* output the rule about to be executed, if debug switch is on */

	if ^rule_sw then ;
	else call ioa_ ("rule ^d", rule);

/* go do the case that this semantic rule number specifies */

	goto rule_label (rule);

/* **************************************************************************

   definitions for statements within the directives

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



/* &lt;source&gt; ::= &lt;domain_stmt&gt;&lt;attribute_stmt&gt;&lt;relation_stmt&gt;&lt;index_stmt&gt;  ! */

rule_label (0001):

/* define and redefine directives are made up of any combination of the six statement keywords
   followed by the specifications for the items to be newly created
   or to be given a new definition */

	goto return_label;

/* &lt;empty&gt; ::=  ! */

rule_label (0002):

/* null statement */

	goto return_label;


/* &lt;domain_keyword&gt; ::= &lt;domain&gt;&lt;colon&gt;  ! */

rule_label (0003):

/* start of domain delete/define/redefine, set it active */

	if directive.type = 0 then do;		/* no other directive seen */

/* cmdb source,  set up cmdb seen and active, check that this is a genuine cmdb command */

		directive.type = CMDB;
		directive.cmdb.seen = ON;
		directive.cmdb.active = ON;
	     end;
	stmt (directive.type).domain.active = ON;
	goto return_label;

/* &lt;attribute_keyword&gt; ::= &lt;attribute&gt;&lt;colon&gt;  ! */

rule_label (0004):

/* start of attribute delete/define/redefine, set it active */

	stmt (directive.type).attribute.active = ON;
	goto return_label;

/* &lt;relation_keyword&gt; ::= &lt;relation&gt;&lt;colon&gt;  ! */

rule_label (0005):

/* start of relation delete/define/redefine, set it active */

	stmt (directive.type).relation.active = ON;
	goto return_label;



/* &lt;index_keyword&gt; ::= &lt;index&gt;&lt;colon&gt;  ! */

rule_label (0006):

/* start of index delete/define/redefine, set it active */

	stmt (directive.type).index.active = ON;
	goto return_label;

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

   all the following rules apply to define and redefine statement lists only

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


/* &lt;domain_stmt&gt; ::= &lt;domain_keyword&gt;&lt;semicolon&gt; |  &lt;domain_keyword&gt;&lt;domain_list&gt;&lt;semicolon&gt; ! */

rule_label (0007):

/* domain processing complete, set it inactive, after defining default attributes for new domains */

	call mrds_rst_attribute_cleanup (static_rsc_ptr);
	stmt (directive.type).domain.active = OFF;
	goto return_label;


/* &lt;domain_list&gt; ::= &lt;domain_spec&gt;  ! */

rule_label (0008):
	goto return_label;


/* &lt;domain_list&gt; ::= &lt;domain_list&gt;&lt;comma&gt;&lt;domain_spec&gt;  ! */

rule_label (0009):
	goto return_label;


/* &lt;domain_spec&gt; ::= &lt;domain_name&gt;&lt;declaration&gt;&lt;check_list&gt;  ! */

rule_label (0010):

/* call the semantic handler for domains */

	call mrds_rst_domain_handler (static_rsc_ptr, domain_list_ptr);
	stmt (directive.type).domain.number = stmt (directive.type).domain.number + 1;
	goto return_label;




/* &lt;domain_name&gt; ::= &lt;identifier&gt;  ! */

rule_label (0011):

/* set up domain structure and get the domain name */

	call mrds_rst_rsc_alloc (static_rsc_ptr, DOMAIN, domain_list_ptr);
	call domain_initialize ();
	call set_declaration_defaults (domain_list_ptr -&gt; domain.descriptor);
	goto return_label;


/* &lt;declaration&gt; ::= &lt;number_declare&gt;  ! */

rule_label (0012):

/* build descriptor for number,  set packing, precision, scale, and type */

	if aligned then
	     descr_ptr -&gt; descriptor.packed = OFF;
	else descr_ptr -&gt; descriptor.packed = ON;

	call set_precision_and_scale ();
	call set_number_type ();
	goto return_label;


/* &lt;declaration&gt; ::= &lt;character_declare&gt;  ! */

rule_label (0013):

/* build descriptor for character string,  set type, packed, and size */

	call set_string_size_and_packing ();
	if nonvarying then
	     descr_ptr -&gt; descriptor.type = 21;
	else descr_ptr -&gt; descriptor.type = 22;
	goto return_label;


/* &lt;declaration&gt; ::= &lt;bit_declare&gt;  ! */

rule_label (0014):

/* build descriptor for bit string, set type, packed, and size */

	call set_string_size_and_packing ();
	if nonvarying then
	     descr_ptr -&gt; descriptor.type = 19;
	else descr_ptr -&gt; descriptor.type = 20;
	goto return_label;

domain_initialize: procedure ();

/* initialize the domain structure */

	domain_list_ptr -&gt; domain.name = get_name (stack_top, 32);
	domain_list_ptr -&gt; domain.descriptor = OFF;
	domain_list_ptr -&gt; domain.varying_avg_length = 0;
	domain_list_ptr -&gt; domain.options = OFF;
	domain_list_ptr -&gt; domain.pad = OFF;
	domain_list_ptr -&gt; domain.check.flag = OFF;
	domain_list_ptr -&gt; domain.check.pad = OFF;
	domain_list_ptr -&gt; domain.check.stack_ptr = null ();
	domain_list_ptr -&gt; domain.check.stack_size = 0;
	domain_list_ptr -&gt; domain.check_proc.flag = OFF;
	domain_list_ptr -&gt; domain.check_proc.pad = OFF;
	domain_list_ptr -&gt; domain.check_proc.path = BLANK;
	domain_list_ptr -&gt; domain.check_proc.entry = BLANK;
	domain_list_ptr -&gt; domain.encode_proc.flag = OFF;
	domain_list_ptr -&gt; domain.encode_proc.pad = OFF;
	domain_list_ptr -&gt; domain.encode_proc.path = BLANK;
	domain_list_ptr -&gt; domain.encode_proc.entry = BLANK;
	domain_list_ptr -&gt; domain.decode_proc.flag = OFF;
	domain_list_ptr -&gt; domain.decode_proc.pad = OFF;
	domain_list_ptr -&gt; domain.decode_proc.path = BLANK;
	domain_list_ptr -&gt; domain.decode_proc.entry = BLANK;
	domain_list_ptr -&gt; domain.decode_dcl.flag = OFF;
	domain_list_ptr -&gt; domain.decode_dcl.pad = OFF;
	domain_list_ptr -&gt; domain.decode_dcl.descriptor = OFF;
	domain_list_ptr -&gt; domain.line_num = get_line_number (stack_top);


/* set up duplicate check_list option flags */

	decode_dcl_seen = OFF;
	decode_proc_seen = OFF;
	encode_proc_seen = OFF;
	check_seen = OFF;
	multiplier = 1;
	string_average_length = 0;
	avg_length_seen = OFF;
	decode_dcl_mesg = "";


     end;

set_declaration_defaults: procedure (current_descriptor);


/* set up defaults */

	decimal = OFF;
	float = OFF;
	real = ON;
	aligned = ON;
	nonvarying = ON;
	string_length = 1;
	scale_factor = 0;

/* set up overlays and descriptor constants */

	descr_ptr = addr (current_descriptor);

	descr_ptr -&gt; descriptor.version = ON;
	descr_ptr -&gt; descriptor.number_dims = OFF;	/* dimension = 0 */
	num_dims = 0;

/* set up duplication and declaration flags */

	size_seen = OFF;
	type_seen = OFF;
	representation_seen = OFF;
	base_seen = OFF;
	precision_seen = OFF;
	alignment_seen = OFF;
	fixed_varying_seen = OFF;
	scale_seen = OFF;


	declare current_descriptor	 bit (36) aligned;	/* current descriptor to point to for this declaration */

     end;

set_number_type: procedure ();

/* set data type for number based on float/short/decimal/real attributes */
/* packed decimal data types 43-46, depend on the aligned attribute as well */


	if ^decimal then
	     if real then
		if ^float then
		     if short then
			descr_ptr -&gt; descriptor.type = 1;
		     else descr_ptr -&gt; descriptor.type = 2;
		else if short then
		     descr_ptr -&gt; descriptor.type = 3;
		else descr_ptr -&gt; descriptor.type = 4;
	     else if ^float then
		if short then
		     descr_ptr -&gt; descriptor.type = 5;
		else descr_ptr -&gt; descriptor.type = 6;
	     else if short then
		descr_ptr -&gt; descriptor.type = 7;
	     else descr_ptr -&gt; descriptor.type = 8;
	else if real then
	     if ^float then do;
		     if aligned then
			descr_ptr -&gt; descriptor.type = 9;
		     else descr_ptr -&gt; descriptor.type = 43;
		end;
	     else do;
		     if aligned then
			descr_ptr -&gt; descriptor.type = 10;
		     else descr_ptr -&gt; descriptor.type = 44;
		end;
	else if ^float then do;
		if aligned then
		     descr_ptr -&gt; descriptor.type = 11;
		else descr_ptr -&gt; descriptor.type = 45;
	     end;
	else do;
		if aligned then
		     descr_ptr -&gt; descriptor.type = 12;
		else descr_ptr -&gt; descriptor.type = 46;
	     end;

     end;

/* *************************************************************

   number precision and scale attribute processing

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


set_precision_and_scale: procedure ();

/* set default precision or check user values against limits */

	if ^precision_seen then

/* no precision given, set defaults */

	     if ^float then
		if ^decimal then
		     saved_precision = 17;
		else saved_precision = 7;
	     else if ^decimal then
		saved_precision = 27;
	     else saved_precision = 10;

/* check user's precision */

	else if ^decimal then
	     if ^float then
		if saved_precision &gt;= 1 &amp; saved_precision &lt;= 71 then ;
		else do;
			call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length,
			     "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
			     """ on line", domain_list_ptr -&gt; domain.line_num,
			     "has precision &lt;1 or &gt;71 for fixed binary number, using ""71"" instead.");
			call mrds_rst_error (static_rsc_ptr, 2 /* severity */,
			     mrds_error_$rst_bad_declaration, (message));
			saved_precision = 71;
		     end;
	     else if saved_precision &gt;= 1 &amp; saved_precision &lt;= 63 then ;
	     else do;
		     call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length,
			"The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
			""" on line", domain_list_ptr -&gt; domain.line_num,
			"has precision &lt;1 or &gt;63 for float binary number, using ""63"" instead.");
		     call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
		     saved_precision = 63;
		end;
	else if saved_precision &gt;= 1 &amp; saved_precision &lt;= 59 then ;
	else do;
		call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length,
		     "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     "has precision &lt;1 or &gt;59 for a decimal number, using ""59"" instead.");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
		saved_precision = 59;
	     end;

	descr_ptr -&gt; arith_size.precision = saved_precision;





/* set precision type as short or long */

	if decimal then ;
	else if ^float then
	     if saved_precision &lt;= 35 then
		short = ON;
	     else short = OFF;
	else if saved_precision &lt;= 27 then
	     short = ON;
	else short = OFF;

/* check on the scale factor */

	if ^(float &amp; scale_seen) then ;
	else do;
		call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length,
		     "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     "is declared float, it can not have scale specified,  --- the scale is ignored!!");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
		scale_factor = 0;
	     end;

	if scale_factor &gt;= -128 &amp; scale_factor &lt;= 127 then ;
	else do;
		if scale_factor &lt; 0 then
		     scale_factor = -128;
		else scale_factor = +127;
		call ioa_$rs ("^a ^a^a^a^a ^d ^a^d^a", message, message_length,
		     "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     "has a scale factor &lt;-128 or &gt;127, using """, scale_factor, """ instead.");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
	     end;

	descr_ptr -&gt; arith_size.scale = scale_factor;

     end;

set_string_size_and_packing: procedure ();

/* check alignment and varying attributes to determine packing,
   and set size from the string length */

	if nonvarying then
	     if alignment_seen then ;
	     else aligned = OFF;
	else if aligned then ;
	else do;
		aligned = ON;
		call ioa_$rs ("^a ^a^a^a^a ^d ^a", message, message_length,
		     "The", decode_dcl_mesg, "declaration of domain """, domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     "is being corrected, since varying strings must be ""aligned"".");
		call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_declaration, (message));
	     end;


	if aligned then
	     descr_ptr -&gt; descriptor.packed = OFF;
	else descr_ptr -&gt; descriptor.packed = ON;

	descr_ptr -&gt; string_size.length = string_length;

/* for normal declarations(not decode_dcl), and varying strings, remember the average length */

	if decode_dcl_mesg ^= "" then ;
	else if ^nonvarying then
	     domain_list_ptr -&gt; domain.varying_avg_length = string_average_length;
	else if ^avg_length_seen then ;
	else do;
		call ioa_$rs ("^a^a ^a^a^a^a ^d^a", message, message_length,
		     "The average length attribute is not allowed with nonvarying strings",
		     ", it is being ignored in the", decode_dcl_mesg, "declaration for domain """,
		     domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num, ".");
		call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_inconsis_option, (message));
	     end;

     end;

/* *********************************************

   attributes in number declarations can be in any order
   duplicates and contradictory attributes are checked for

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

/* &lt;number_declare&gt; ::= &lt;number_spec_list&gt;  ! */

rule_label (0015):
	goto return_label;


/* &lt;number_spec_list&gt; ::= &lt;number_spec&gt;  ! */

rule_label (0016):
	goto return_label;


/* &lt;number_spec_list&gt; ::= &lt;number_spec_list&gt;&lt;number_spec&gt;  ! */

rule_label (0017):
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;real&gt;  ! */

rule_label (0018):

/* set real attribute */

	if duplicate ("real or complex", addr (type_seen)) then ;
	else real = ON;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;complex&gt; ! */

rule_label (0019):

/* set complex attribute */

	if duplicate ("real or complex", addr (type_seen)) then ;
	else real = OFF;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;fixed&gt;  ! */

rule_label (0020):

/* set fixed attribute */

	if duplicate ("float or fixed", addr (representation_seen)) then ;
	else float = OFF;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;float&gt;  ! */

rule_label (0021):

/* set float attribute */

	if duplicate ("float or fixed", addr (representation_seen)) then ;
	else float = ON;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;binary&gt;  ! */

rule_label (0022):

/* set binary attribute */

	if duplicate ("binary or decimal", addr (base_seen)) then ;
	else decimal = OFF;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;decimal&gt;  ! */

rule_label (0023):

/* set decimal attribute */

	if duplicate ("binary or decimal", addr (base_seen)) then ;
	else decimal = ON;
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;precision&gt;&lt;precision_stmt&gt;  ! */


rule_label (0024):
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;precision_stmt&gt;  ! */

rule_label (0025):
	goto return_label;

/* &lt;sign&gt; ::= &lt;plus&gt;  ! */

rule_label (0026):

/* set positive sign */

	sign_flag = OFF;
	goto return_label;


/* &lt;sign&gt; ::= &lt;hyphen&gt;  ! */

rule_label (0027):

/* set negative sign */

	sign_flag = ON;
	goto return_label;


/* &lt;sign&gt; ::= &lt;empty&gt;  ! */

rule_label (0028):

/* set sign positive */

	sign_flag = OFF;
	goto return_label;

/* &lt;precision_stmt&gt; ::= &lt;left_parenthesis&gt; &lt;positive_integer&gt; &lt;comma&gt;&lt;sign&gt; &lt;positive_integer&gt; &lt;right_parenthesis&gt;  ! */

rule_label (0029):

/* set precision attribute with scale factor (negative) */

	if duplicate ("precision", addr (precision_seen)) then ;
	else do;
		saved_precision = get_fixed_value (stack_top - 4, max_fixed_bin_71);
		if sign_flag then
		     scale_factor = -get_fixed_value (stack_top - 1, max_fixed_bin_71);
		else scale_factor = get_fixed_value (stack_top - 1, max_fixed_bin_71);
		scale_seen = ON;
	     end;
	goto return_label;


/* &lt;precision_stmt&gt; ::= &lt;left_parenthesis&gt; &lt;positive_integer&gt; &lt;right_parenthesis&gt;  ! */

rule_label (0030):

/* set precision attribute */

	if duplicate ("precision", addr (precision_seen)) then ;
	else saved_precision = get_fixed_value (stack_top - 1, max_fixed_bin_71);
	goto return_label;


/* &lt;number_spec&gt; ::= &lt;alignment&gt;  ! */

rule_label (0031):
	goto return_label;


/* &lt;alignment&gt; ::= &lt;aligned&gt;  ! */

rule_label (0032):

/* set aligned attribute */

	if duplicate ("aligned or unaligned", addr (alignment_seen)) then ;
	else aligned = ON;
	goto return_label;


/* &lt;alignment&gt; ::= &lt;unaligned&gt;  ! */

rule_label (0033):

/* set unaligned attribute */

	if duplicate ("aligned or unaligned", addr (alignment_seen)) then ;
	else aligned = OFF;
	goto return_label;

/* *******************************************************

   make sure that attributes are not repeated in a declaraion

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


duplicate: procedure (attribute, flag_ptr) returns (bit (1));

/* check to see if this attribute has already been used in this declaration */

	if ^flag_ptr -&gt; flag_overlay then do;

/* attribute not yet seen, flag it as seen, return no duplication */

		flag_ptr -&gt; flag_overlay = ON;
		duplication = OFF;
	     end;

	else do;

/* attribute duplicate, issue error, return duplication */

		duplication = ON;
		call ioa_$rs ("^a^a^a ^a^a^a^a ^d^a", message, message_length,
		     "The attribute """, attribute, """ appears more than once in the",
		     decode_dcl_mesg, "declaration of domain """,
		     domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     ", the first occurence will be used.");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
	     end;

	return (duplication);

	declare duplication		 bit (1);		/* ON =&gt; this is a previously seen attribute */
	declare flag_ptr		 ptr;		/* pointer to attribute flag */
	declare flag_overlay	 bit (1) based;	/* overlay structure for flag */
	declare attribute		 char (*);	/* attribute name being checked */

     end;

/* ***********************************************************************

   bit and character string declarations can have the attributes in any order
   but duplicates will be flagged as errors and ignored
   as with number precision and scale, string size is checked for a legal range

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


/* &lt;bit_declare&gt; ::= &lt;bit&gt;&lt;string_type&gt;  ! */

rule_label (0034):
	goto return_label;

/* &lt;bit_declare&gt; ::= &lt;varying&gt;&lt;bit&gt;&lt;string_type&gt; ! */

rule_label (0035):
	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = OFF;
	goto return_label;

/* &lt;bit_declare&gt; ::= &lt;nonvarying&gt;&lt;bit&gt;&lt;string_type&gt; ! */

rule_label (0036):
	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = ON;
	goto return_label;

/* &lt;string_type&gt; ::= &lt;string_attr_list&gt;  ! */

rule_label (0037):
	goto return_label;


/* &lt;string_type&gt; ::= &lt;empty&gt;  ! */

rule_label (0038):
	goto return_label;


/* &lt;string_attr_list&gt; ::= &lt;string_attr&gt;  ! */

rule_label (0039):
	goto return_label;


/* &lt;string_attr_list&gt; ::= &lt;string_attr_list&gt;&lt;string_attr&gt;  ! */

rule_label (0040):
	goto return_label;


/* &lt;string_attr&gt; ::= &lt;left_parenthesis&gt;&lt;positive_integer&gt;&lt;right_parenthesis&gt;   ! */

rule_label (0041):

/* set string length attribute(and default average length for normal declarations) */

	if duplicate ("string size", addr (size_seen)) then ;
	else do;
		temp_number = get_fixed_value (stack_top - 1, max_fixed_bin_71);
		call string_size_check (temp_number);
		string_length = temp_number;
		avg_length_seen = OFF;
		if decode_dcl_mesg ^= "" then ;
		else string_average_length = string_length;
	     end;
	goto return_label;


/* &lt;string_attr&gt; ::= &lt;alignment&gt;  ! */

rule_label (0042):
	goto return_label;


/* &lt;string_attr&gt; ::= &lt;varying&gt;  ! */

rule_label (0043):

/* set varying attribute */

	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = OFF;
	goto return_label;


/* &lt;string_attr&gt; ::= &lt;nonvarying&gt; ! */

rule_label (0044):

/* set nonvarying attribute */

	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = ON;
	goto return_label;

/* &lt;character_declare&gt; ::= &lt;char&gt;&lt;string_type&gt;  ! */

rule_label (0045):
	goto return_label;

/* &lt;character_declare&gt; ::= &lt;varying&gt;&lt;char&gt;&lt;string_type&gt; ! */

rule_label (0046):
	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = OFF;
	goto return_label;

/* &lt;character_declare&gt; ::= &lt;nonvarying&gt;&lt;char&gt;&lt;string_type&gt; ! */

rule_label (0047):
	if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ;
	else nonvarying = ON;
	goto return_label;

string_size_check: procedure (number);

/* make sure number for string length is less than maximum allowable */

	if number &lt;= max_string_size then ;
	else do;

		call ioa_$rs ("^a^d^a ^d^a ^a^a^a^a ^d^a", message, message_length,
		     "String size """, number, """ exceeds the maximum allowable length of",
		     max_string_size, ", using the maximum instead in the",
		     decode_dcl_mesg, "declaration of domain """,
		     domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num, ".");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
		number = max_string_size;
	     end;



/* fixup unwanted zero values */

	if number ^= 0 then ;
	else do;
		number = 1;
		call ioa_$rs ("^a ^a^a^a^a ^d^a", message, message_length,
		     "Illegal zero value is being replaced by ""1"" in size attribute of",
		     decode_dcl_mesg, "declaration for domain """,
		     domain_list_ptr -&gt; domain.name,
		     """ on line", domain_list_ptr -&gt; domain.line_num, ".");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message));
	     end;

	declare number		 fixed binary (71); /* number under test as string length */

     end;

/* *****************************************************************

   the check, check_proc, encode_proc, decode_proc options may be in any order
   however, check and check_proc are mutually exclusive options

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

/* &lt;check_list&gt; ::= &lt;proc_list&gt;  ! */

rule_label (0048):

/* set options present */

	domain_list_ptr -&gt; domain.options = ON;
	goto return_label;

/* &lt;check_list&gt; ::= &lt;empty&gt;  ! */

rule_label (0049):

/* set no options present */

	domain_list_ptr -&gt; domain.options = OFF;
	goto return_label;

/* &lt;proc_list&gt; ::= &lt;proc_list&gt;&lt;proc_item&gt;  ! */

rule_label (0050):
	goto return_label;

/* &lt;proc_list&gt; ::= &lt;proc_item&gt;  ! */

rule_label (0051):
	goto return_label;

/* &lt;proc_item&gt; ::= &lt;check_proc_option&gt;  ! */

rule_label (0052):
	goto return_label;

/* &lt;proc_item&gt; ::= &lt;encode_proc_option&gt;  ! */

rule_label (0053):
	goto return_label;

/* &lt;proc_item&gt; ::= &lt;decode_proc_option&gt;  ! */

rule_label (0054):
	goto return_label;

/* &lt;proc_item&gt; ::= &lt;decode_declaration&gt;  ! */

rule_label (0055):
	goto return_label;

/* *****************************

   decode declaration option

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


/* &lt;decode_declaration&gt; ::= &lt;decode_dcl_keyword&gt;&lt;declaration&gt;  ! */

rule_label (0056):

/* decode declaration finished, restore normal declaration pointers */

	descr_ptr = saved_descr_ptr;
	decode_dcl_mesg = "";

/* if a duplicate caused the descriptor to be saved, restore it */

	if ^descriptor_saved then ;
	else domain_list_ptr -&gt; domain.decode_dcl.descriptor = saved_decode_descriptor;
	goto return_label;

/* &lt;decode_dcl_keyword&gt; ::= &lt;hyphen&gt;&lt;decode_dcl&gt;  ! */

rule_label (0057):

/* set up for handling a decode declaration, save normal declaration pointers */

	saved_descr_ptr = descr_ptr;
	call set_declaration_defaults (domain_list_ptr -&gt; domain.decode_dcl.descriptor);

/* only set this option on if this is not a duplicate
   else remember the first declaration seen(via the descriptor) */

	if duplicate ("decode_dcl", addr (decode_dcl_seen)) then do;
		descriptor_saved = ON;
		saved_decode_descriptor = domain_list_ptr -&gt; domain.decode_dcl.descriptor;
	     end;
	else do;
		domain_list_ptr -&gt; domain.decode_dcl.flag = ON;
		descriptor_saved = OFF;
	     end;

/* set up error messages for decode declarations */

	decode_dcl_mesg = "decode_";
	goto return_label;

/* ************************************************

   gather pathnames and entry names for procedure options

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


/* &lt;check_proc_option&gt; ::= &lt;hyphen&gt;&lt;check_proc&gt;&lt;path_name&gt;&lt;entry_name&gt;  ! */

rule_label (0058):

/* set up check procedure path and entry names */

	temp_index = stack_top - 1;
	call get_check_path_entry ();
	goto return_label;


/* &lt;check_proc_option&gt; ::= &lt;hyphen&gt;&lt;check_proc&gt;&lt;path_name&gt;  ! */

rule_label (0059):

/* set up check procedure pathname and missing entry name */

	temp_index = stack_top;
	call get_check_path_entry ();
	goto return_label;


/* &lt;encode_proc_option&gt; ::= &lt;hyphen&gt;&lt;encode_proc&gt;&lt;path_name&gt;&lt;entry_name&gt;  ! */

rule_label (0060):

/* set up encode procedure path and entry names */

	temp_index = stack_top - 1;
	call get_encode_path_entry ();
	goto return_label;


/* &lt;encode_proc_option&gt; ::= &lt;hyphen&gt;&lt;encode_proc&gt;&lt;path_name&gt;  ! */

rule_label (0061):

/* set up encode pathname and missing entryname */

	temp_index = stack_top;
	call get_encode_path_entry ();
	goto return_label;


/* &lt;decode_proc_option&gt; ::= &lt;hyphen&gt;&lt;decode_proc&gt;&lt;path_name&gt;&lt;entry_name&gt;  ! */

rule_label (0062):

/* set up decode procedure path and entry names */

	temp_index = stack_top - 1;
	call get_decode_path_entry ();
	goto return_label;



/* &lt;decode_proc_option&gt; ::= &lt;hyphen&gt;&lt;decode_proc&gt;&lt;path_name&gt;  ! */

rule_label (0063):

/* set up decode procedure pathname and missing entryname */

	temp_index = stack_top;
	call get_decode_path_entry ();
	goto return_label;

get_check_path_entry: procedure ();

/* get pathname from the stack and entry name if there,
   else get entry name from path name.  Set this option on */

	if duplicate ("check_proc", addr (check_seen)) then ;
	else do;
		domain_list_ptr -&gt; domain.check_proc.flag = ON;
		domain_list_ptr -&gt; domain.check_proc.path = get_name (temp_index, 168);
		if temp_index = stack_top then
		     domain_list_ptr -&gt; domain.check_proc.entry = get_entry (domain_list_ptr -&gt; domain.check_proc.path);
		else domain_list_ptr -&gt; domain.check_proc.entry = get_name (stack_top, 32);
	     end;

     end;

get_encode_path_entry: procedure ();

/* get pathname from the stack and entry name if there,
   else get entry name from path name.  Set this option on */

	if duplicate ("encode_proc", addr (encode_proc_seen)) then ;
	else do;
		domain_list_ptr -&gt; domain.encode_proc.flag = ON;
		domain_list_ptr -&gt; domain.encode_proc.path = get_name (temp_index, 168);
		if temp_index = stack_top then
		     domain_list_ptr -&gt; domain.encode_proc.entry =
			get_entry (domain_list_ptr -&gt; domain.encode_proc.path);
		else domain_list_ptr -&gt; domain.encode_proc.entry = get_name (stack_top, 32);
	     end;

     end;

get_decode_path_entry: procedure ();

/* get pathname from the stack and entry name if there, else
   get entry name from path name.  Set this option on */

	if duplicate ("decode_proc", addr (decode_proc_seen)) then ;
	else do;
		domain_list_ptr -&gt; domain.decode_proc.flag = ON;
		domain_list_ptr -&gt; domain.decode_proc.path = get_name (temp_index, 168);
		if temp_index = stack_top then
		     domain_list_ptr -&gt; domain.decode_proc.entry =
			get_entry (domain_list_ptr -&gt; domain.decode_proc.path);
		else domain_list_ptr -&gt; domain.decode_proc.entry = get_name (stack_top, 32);
	     end;

     end;

get_entry: procedure (pathname) returns (char (32));

/* extract the entry name from the pathname */

	if lex_stack_ptr -&gt; lex_stack (stack_top).token_num ^= 0 &amp; search (reverse (pathname), "&gt;") ^= 0 then

/* absolute pathname, extract the rightmost component */

	     entry_portion = substr (pathname, length (pathname) - search (reverse (pathname), "&gt;") + 2);

/* either dummy "&lt;error_symbol&gt;" or relative pathname, use path as entry name */

	else entry_portion = pathname;

/* make sure the entry name is not too big */

	entry_portion = rtrim (entry_portion);
	if length (entry_portion) &lt;= 32 then ;
	else do;
		call ioa_$rs ("^a^a^a ^d^a", message, message_length,
		     "The entry name portion exceeds 32 characters in pathname """, pathname,
		     """ on line", domain_list_ptr -&gt; domain.line_num,
		     ", it is being truncated to that length!!");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_too_long, (message));
	     end;

	entryname = entry_portion;
	return (entryname);

	declare pathname		 char (*) aligned;	/* absolute or relative pathname */
	declare entryname		 char (32);	/* final extracted entry name */
	declare entry_portion	 char (168) varying;/* intermediate entry portion */

     end;

/* *************************************************

   attribute specification processing

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

/* &lt;attribute_stmt&gt; ::= &lt;attribute_keyword&gt;&lt;attribute_domain_list&gt; &lt;semicolon&gt;  ! */

rule_label (0064):

/* attribute declaration processing complete, set it inactive */

	stmt (directive.type).attribute.active = OFF;
	goto return_label;

/* &lt;attribute_stmt&gt; ::= &lt;empty&gt; | &lt;attribute_keyword&gt;&lt;semicolon&gt;  ! */

rule_label (0065):
	goto return_label;

/* &lt;attribute_domain_list&gt; ::= &lt;attribute_domain&gt;  ! */

rule_label (0066):

/* count the last attribute specification */

	stmt (directive.type).attribute.number = stmt (directive.type).attribute.number + 1;
	goto return_label;

/* &lt;attribute_domain_list&gt; ::= &lt;attribute_domain_list&gt;&lt;comma&gt;&lt;attribute_domain&gt;  ! */

rule_label (0067):
	goto return_label;

/* &lt;attribute_domain&gt; ::= &lt;identifier&gt;&lt;identifier&gt;  ! */

rule_label (0068):

/* get the attribute domain pair, and call the semantic routine for this declaration */

	call mrds_rst_rsc_alloc (static_rsc_ptr, ATTRIBUTE_DOMAIN, attribute_list_ptr);
	attribute_list_ptr -&gt; attribute_domain.attr = get_name (stack_top - 1, 32);
	attribute_list_ptr -&gt; attribute_domain.dom = get_name (stack_top, 32);
	attribute_list_ptr -&gt; attribute_domain.line_num = get_line_number (stack_top - 1);
	attribute_list_ptr -&gt; attribute_domain.default = OFF; /* defined in source */
	attribute_list_ptr -&gt; attribute_domain.unused = OFF;

	call mrds_rst_attribute_handler (static_rsc_ptr, attribute_list_ptr);
	stmt (directive.type).attribute.number = stmt (directive.type).attribute.number + 1;
	goto return_label;

/* ***************************************************

   relation specification processing

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


/* &lt;relation_stmt&gt; ::= &lt;relation_keyword&gt;&lt;relation_spec_list&gt; &lt;semicolon&gt;  ! */

rule_label (0069):

/* relation processing complete, set it inactive */

	call mrds_rst_file_cleanup (static_rsc_ptr);
	stmt (directive.type).relation.active = OFF;
	goto return_label;


/* &lt;relation_stmt&gt; ::= &lt;empty&gt; | &lt;relation_keyword&gt;&lt;semicolon&gt;  ! */

rule_label (0070):

/* no relation statement, set it inactive */

	stmt (directive.type).relation.active = OFF;
	goto return_label;


/* &lt;relation_spec_list&gt; ::= &lt;relation_spec&gt;  ! */

rule_label (0071):
	goto return_label;


/* &lt;relation_spec_list&gt; ::= &lt;relation_spec_list&gt;&lt;comma&gt;&lt;relation_spec&gt;  ! */

rule_label (0072):
	goto return_label;


/* &lt;relation_spec&gt; ::= &lt;relation_name&gt; &lt;left_parenthesis&gt; &lt;relation_attr_list&gt; &lt;right_parenthesis&gt;  ! */

rule_label (0073):

/* relation list built, call the semantic routine for relation declarations */

	if key_order ^= 0 then ;
	else call fixup_key_attribute ();
	call mrds_rst_relation_handler (static_rsc_ptr, relation_list_ptr);
	stmt (directive.type).relation.number = stmt (directive.type).relation.number + 1;
	goto return_label;


/* &lt;relation_name&gt; ::= &lt;identifier&gt;  ! */

rule_label (0074):

/* start relation list, get name from stack */

	call get_relation_name ();
	goto return_label;


/* &lt;relation_attr_list&gt; ::= &lt;attr_spec&gt;  ! */

rule_label (0075):
	goto return_label;


/* &lt;relation_attr_list&gt; ::=  &lt;relation_attr_list&gt;&lt;attr_spec&gt;  ! */

rule_label (0076):
	goto return_label;


/* &lt;attr_spec&gt; ::= &lt;identifier&gt;  ! */

rule_label (0077):

/* get non key attribute for this relation list */

	temp_index = stack_top;
	key_attribute = OFF;
	call get_relation_attribute ();
	goto return_label;


/* &lt;attr_spec&gt; ::= &lt;identifier&gt; &lt;asterisk&gt;  ! */

rule_label (0078):

/* get key attribute for this relation list */

	temp_index = stack_top - 1;
	key_attribute = ON;
	call get_relation_attribute ();
	goto return_label;


fixup_key_attribute: procedure ();

/* assume the first attrubte defined is the key when none given */

	attribute_ptr = relation_list_ptr -&gt; relation.a_ptr;
	attribute_ptr -&gt; attribute.pr_key = ON;
	attribute_ptr -&gt; attribute.key_order = 1;

	call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length,
	     "Relation """, relation_list_ptr -&gt; relation.name,
	     """ on line", relation_list_ptr -&gt; relation.line_num,
	     "does not specify any key attributes, assuming """,
	     attribute_ptr -&gt; attribute.name, """ is a key attribute.");
	call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_no_key_attr, (message));

     end;

get_relation_name: procedure ();

/* get relation name from stack and build list header */

	call mrds_rst_rsc_alloc (static_rsc_ptr, RELATION, relation_list_ptr);
	relation_list_ptr -&gt; relation.a_ptr = null ();
	relation_list_ptr -&gt; relation.name = get_name (stack_top, 30);
	relation_list_ptr -&gt; relation.max_tup = 0;
	relation_list_ptr -&gt; relation.num_items = 0;
	relation_list_ptr -&gt; relation.line_num = get_line_number (stack_top);
	relation_list_ptr -&gt; relation.unused = OFF;
	key_order = 0;
	definition_order = 0;
	saved_attr_ptr = relation_list_ptr;

     end;

get_relation_attribute: procedure ();

/* get attribute name from stack and add it to the relation's list */

	if list_duplicate (ATTRIBUTES, relation_list_ptr -&gt; relation.a_ptr, temp_index, 32) then ;
	else do;
		call mrds_rst_rsc_alloc (static_rsc_ptr, ATTRIBUTE, attribute_ptr);
		attribute.next = null ();
		saved_attr_ptr -&gt; attribute.next = attribute_ptr;
		attribute.name = get_name (temp_index, 32);
		attribute.pr_key = key_attribute;
		attribute.pad = OFF;
		definition_order = definition_order + 1;
		attribute.defn_order = definition_order;
		if ^key_attribute then
		     attribute.key_order = 0;
		else do;
			key_order = key_order + 1;
			attribute.key_order = key_order;
		     end;
		attribute.line_num = get_line_number (temp_index);
		relation_list_ptr -&gt; relation.num_items = relation_list_ptr -&gt; relation.num_items + 1;
		saved_attr_ptr = attribute_ptr;
	     end;

     end;

/* ******************************************************

   index specification processing

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


/* &lt;index_stmt&gt; ::= &lt;index_keyword&gt;&lt;index_list&gt; &lt;semicolon&gt; ! */

rule_label (0079):

/* index processing complete, set it inactive */

	stmt (directive.type).index.active = OFF;
	goto return_label;


/* &lt;index_stmt&gt; ::= &lt;empty&gt; | &lt;index_keyword&gt;&lt;semicolon&gt;  ! */

rule_label (0080):

/* set index statement inactive */

	stmt (directive.type).index.active = OFF;
	goto return_label;


/* &lt;index_list&gt; ::= &lt;index_spec&gt;  ! */

rule_label (0081):
	goto return_label;


/* &lt;index_list&gt; ::= &lt;index_list&gt;&lt;comma&gt;&lt;index_spec&gt;  ! */

rule_label (0082):
	goto return_label;


/* &lt;index_spec&gt; ::= &lt;index_relation_name&gt; &lt;left_parenthesis&gt; &lt;index_attr_list&gt; &lt;right_parenthesis&gt;  ! */

rule_label (0083):

/* index definition list complete, go process the definition */

	call mrds_rst_index_handler (static_rsc_ptr, index_list_ptr);
	stmt (directive.type).index.number = stmt (directive.type).index.number + 1;
	goto return_label;


/* &lt;index_relation_name&gt; ::= &lt;identifier&gt;  ! */

rule_label (0084):

/* start a index definition list with the relation name */

	call get_index_relation ();
	goto return_label;


/* &lt;index_attr_list&gt; ::= &lt;identifier&gt;  ! */

rule_label (0085):

/* add the last attribute to this index definition list */

	call get_index_attribute ();
	goto return_label;


/* &lt;index_attr_list&gt; ::= &lt;index_attr_list&gt;&lt;identifier&gt;  ! */

rule_label (0086):

/* add the next attribute to this index definition list */

	call get_index_attribute ();
	goto return_label;




/* case statement common exit */
return_label:

	return;

get_index_relation: procedure ();

/* get the relation name and build list head for this index statment */

	call mrds_rst_rsc_alloc (static_rsc_ptr, INDEX, index_list_ptr);
	index_list_ptr -&gt; rel_index.i_ptr = null ();
	index_list_ptr -&gt; rel_index.rel_name = get_name (stack_top, 32);
	index_list_ptr -&gt; rel_index.num_items = 0;
	index_list_ptr -&gt; rel_index.unused = OFF;
	index_list_ptr -&gt; rel_index.line_num = get_line_number (stack_top);
	saved_attr_ptr = index_list_ptr;

     end;

get_index_attribute: procedure ();

/* add attribute name to the list for this index */

	if list_duplicate (ATTRIBUTES, index_list_ptr -&gt; rel_index.i_ptr, stack_top, 32) then ;
	else do;
		call mrds_rst_rsc_alloc (static_rsc_ptr, ITEM, item_ptr);
		item.name = get_name (stack_top, 32);
		item.next = null ();
		item.unused = OFF;
		item.line_num = get_line_number (stack_top);
		saved_attr_ptr -&gt; item.next = item_ptr;
		index_list_ptr -&gt; rel_index.num_items = index_list_ptr -&gt; rel_index.num_items + 1;
		saved_attr_ptr = item_ptr;
	     end;


     end;

list_duplicate: procedure (list_type, list_ptr, stack_pos, size) returns (bit (1));

/* check that the given attribute/relation name appears only once in the
   given list. (i.e. attributes in a relation, relations in a file) */

	name_duplicate = OFF;
	name = get_name (stack_pos, size);

/* set up list start depending on list type and status */

	if list_type ^= CHILD then
	     item_ptr = list_ptr;
	else if list_ptr = null () then
	     item_ptr = null ();
	else do;
		children_ptr = list_ptr;
		item_ptr = children_ptr -&gt; children.child_ptr;
	     end;

/* run through linked list of names, checking for duplicates, until list end */

	do while (item_ptr ^= null ());
	     if item_ptr -&gt; item.name ^= name then /* not duplicate, set next list element for list type */
		if list_type ^= CHILD then
		     item_ptr = item_ptr -&gt; item.next;
		else do;
			children_ptr = children_ptr -&gt; children.next;
			if children_ptr = null () then
			     item_ptr = null ();
			else item_ptr = children_ptr -&gt; children.child_ptr;
		     end;

	     else do;				/* duplicate found, issue error, quit search */
		     name_duplicate = ON;
		     item_ptr = null ();
		     if list_type = CHILD then
			duplicate_type = "child relation in a foreign key";
		     else if list_type = FILE_REL then
			duplicate_type = "relation in a file";
		     else duplicate_type = "attribute in a relation";
		     call ioa_$rs ("^a^a^a ^d ^a ^a^a", message, message_length,
			"The name """, name, """ given on line", get_line_number (stack_pos),
			"is a duplicate", duplicate_type, ", --- it will be ignored!!");
		     call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_duplicate, (message));
		end;
	end;

	return (name_duplicate);

	declare stack_pos		 fixed binary;	/* stack index for this item */
	declare size		 fixed binary;	/* allowable length of name */
	declare duplicate_type	 char (36) varying; /* error list message */
	declare list_ptr		 ptr;		/* overlay list pointer */
	declare name		 char (32);	/* name that is to be checked for duplicate */
	declare list_type		 fixed bin;	/* 8 =&gt; child relation, 9 =&gt; file relation, 10 =&gt; attribute */
	declare name_duplicate	 bit (1);		/* ON =&gt; name already in list */

     end;

get_name: procedure (stack_pos, name_size) returns (char (*));

/*  return the identifier from the given stack position,
   checking that it does not exceed the given size.
   Note that "&lt;error_symbol&gt;" is used when a missing identifier
   has been detected and a dummy inserted for it. */

	length = lex_stack_ptr -&gt; lex_stack (stack_pos).symlen;
	name = substr (lex_stack_ptr -&gt; lex_stack (stack_pos).symptr -&gt; source, 1, length);
	token_pos = lex_stack_ptr -&gt; lex_stack (stack_pos).token_num;

/* check on the token size */

	if length &lt;= name_size then ;
	else do;
		length = name_size;
		lex_stack_ptr -&gt; lex_stack (stack_pos).symlen = name_size;
		call ioa_$rs ("^a^a^a ^d ^a ^d ^a", message, message_length,
		     "The string """, name, """ in line", get_line_number (stack_pos),
		     "is longer than", name_size, "characters, it is being truncated at that length.");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_name_too_long, (message));
	     end;

/* if this is the dummy symbol(token_pos = 0), issue a warning, the first time */

	if token_pos ^= 0 then ;
	else do;
		lex_stack_ptr -&gt; lex_stack (stack_pos).token_num = -1;
		call ioa_$rs ("^a^a^a ^d^a", message, message_length,
		     "The string """, name, """ is being used for a missing token in line",
		     get_line_number (stack_pos), ".");
		call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_semantics, (message));
	     end;

	name_overlay_ptr = addrel (addr (name), 1);	/* point to data portion of varying string */

	return (name_overlay);


	declare length		 fixed binary (24); /* length of token */
	declare name		 char (mrds_data_$max_string_size) varying based (name_ptr); /* token character string */
	declare name_overlay	 char (length) based (name_overlay_ptr); /* exact length token to return */
	declare name_overlay_ptr	 ptr;		/* points to data portion */
	declare token_pos		 fixed binary (24); /* position of token in line */
	declare stack_pos		 fixed binary;	/* index into stack for this identifier */
	declare name_size		 fixed binary;	/* maximum legal size for this token */

     end;

get_fixed_value: procedure (stack_pos, max_value) returns (fixed bin (71));

/* get a fixed binary value from the stack at the given position */

	if lex_stack_ptr -&gt; lex_stack (stack_pos).token_num ^= 0 then
	     value = lex_stack_ptr -&gt; lex_stack (stack_pos).val;

	else do;

/* token_num = 0 means dummy "&lt;error_symbol&gt;" on stack for missing number,
   use a fixup value and issue error message */

		value = 1;
		lex_stack_ptr -&gt; lex_stack (stack_pos).val = 1;
		call ioa_$rs ("^a^d^a ^d^a", message, message_length,
		     "The value """, value, """ is being used for a missing number in line",
		     get_line_number (stack_pos), ".");
		call mrds_rst_error (static_rsc_ptr, 1 /* severity */, mrds_error_$rst_bad_semantics, (message));
	     end;

/* check that the number is within the range of the option */

	if value &lt;= max_value then ;
	else do;
		call ioa_$rs ("^a^d^a ^d ^a^d^a", message, message_length,
		     "The value """, value, """ in line", get_line_number (stack_pos),
		     "exceeds the maximum allowable for this option, using """, max_value, """ instead.");
		call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_option_limit, (message));
		value = max_value;
		lex_stack_ptr -&gt; lex_stack (stack_pos).val = max_value;
	     end;

	return (value);

	declare value		 fixed binary (71); /* value of number to be returned */
	declare stack_pos		 fixed binary;	/* index into stack for this number */
	declare max_value		 fixed binary (71); /* largest allowed value */

     end;

get_line_number: procedure (stack_pos) returns (fixed binary (24));

/* routine to obtain line number from parse stack */

	line_number = lex_stack_ptr -&gt; lex_stack (stack_pos).line;

	return (line_number);


	declare line_number		 fixed binary (24); /* value to be returned */
	declare stack_pos		 fixed binary;	/* index into stack for this item */

     end;

	declare rule_sw		 bit (1) static init ("0"b); /* switch for debug output of rule numbers */
	declare saved_attr_ptr	 ptr internal static; /* last attr pointer */
	declare saved_decode_descriptor bit (36) aligned internal static; /* first given decode_dcl descriptor */
	declare descriptor_saved	 bit (1) internal static; /* on =&gt; the first decode descriptor was saved */
	declare (fixed, addr, search, binary) builtin; /* functions known to pl1 */
	declare stkp		 ptr;		/* lexical stack pointer parameter */
	declare ls_top		 fixed binary (24); /* parameter for top of stack */
	declare sign_flag		 bit (1) internal static; /* on =&gt; negative value needed */
	declare mrds_error_$rst_no_key_attr fixed binary (35) external; /* no attr given as key in relation */
	declare mrds_error_$rst_option_limit fixed binary (35) external; /* number too large for receiving field */
	declare mrds_error_$rst_name_duplicate fixed binary (35) external; /* dup name in rel/attr or file/rel list */
	declare mrds_error_$rst_bad_declaration fixed binary (35) external; /* error in domain declaration */
	declare mrds_error_$rst_inconsis_option fixed binary (35) external; /* contradictory option */
	declare mrds_error_$rst_name_too_long fixed binary (35) external; /* oversize name error */
	declare mrds_error_$rst_bad_semantics fixed binary (35) external; /* meaning of source may be lost */
	declare EQUAL		 fixed bin internal static options (constant) init (1); /* = op code */
	declare NOT_EQUAL		 fixed bin internal static options (constant) init (2); /* ^= op code */
	declare GREATER		 fixed bin internal static options (constant) init (3); /* &gt; op code */
	declare LESS		 fixed bin internal static options (constant) init (4); /* &lt; op code */
	declare GREATER_EQUAL	 fixed bin internal static options (constant) init (5); /* &gt;= op code */
	declare LESS_EQUAL		 fixed bin internal static options (constant) init (6); /* &lt;= op code */
	declare AND		 fixed binary internal static options (constant) init (10); /* &amp; op code */
	declare OR		 fixed binary internal static options (constant) init (20); /* | op code */
	declare NOT		 fixed binary internal static options (constant) init (30); /* ^ op code */
	declare MINUS		 fixed binary internal static options (constant) init (40); /* - unary operator code */
	declare DOMAIN_VARIABLE	 fixed binary internal static options (constant) init (50); /* domain id code */
	declare ELEMENT		 fixed bin internal static options (constant) init (60); /* code for constant */
	declare OFF		 bit (1) internal static options (constant) init ("0"b); /* flag reset value */
	declare ON		 bit (1) internal static options (constant) init ("1"b); /* flag set value */
	declare BLOCKED		 fixed binary internal static options (constant) init (2); /* code for blocked file type */
	declare UNBLOCKED		 fixed binary internal static options (constant) init (1); /* code for unblocked file type */
	declare BLANK		 char (1) internal static options (constant) init (" "); /* blank fill constant */
	declare max_string_size	 fixed binary (35) internal static; /* descriptor string size limit */
	declare descr_ptr		 ptr internal static; /* pointer to current descriptor */
	declare saved_descr_ptr	 ptr internal static; /* normal desc pointer temp storage */
	dcl     decode_dcl_mesg	 char (8) var internal static; /* "" =&gt; normal, else decode_dcl declare message */
	declare mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* working area allocation routine */
	declare db_model_path	 char (168) internal static; /* saved db_model pathname */
	declare ioa_$rs		 entry options (variable); /* string building routine */
	declare mrds_rst_domain_handler entry (ptr, ptr); /* domain declaration semantic routine */
	declare mrds_rst_attribute_handler entry (ptr, ptr); /* attribute declaration semantic routine */
	declare mrds_rst_relation_handler entry (ptr, ptr); /* relation declaration semantic routine */
	declare mrds_rst_index_handler entry (ptr, ptr);	/* index declaration semantic routine */
	declare mrds_rst_file_cleanup	 entry (ptr);	/* undeclared file semantic routine */
	declare mrds_rst_attribute_cleanup entry (ptr);	/* domain default attribute routine */
	declare stack_top		 fixed binary;	/* current top of lexical stack */
	declare message		 char (512) varying;/* error message of specifics */
	declare message_length	 fixed binary (21); /* length of error message */
	declare mrds_rst_error	 entry (ptr, fixed binary, fixed binary (35), char (*)); /* error handling routine */

/* note: changing the declaration of multiplier, requires changing the
   code for the &lt;quantity&gt; rule (the any_to_any parameters) */
	declare multiplier		 fixed bin (24) internal static aligned; /* string multiplier */
	declare source		 char (sys_info$max_seg_size) based; /* string overlay for getting tokens */
	declare sys_info$max_seg_size	 fixed binary (35) external; /* system maximum segment size */
	declare rule		 fixed binary (24); /* current rule number returned by parser */
	declare alternate		 fixed binary (24); /* current allternate of rule number */
	declare max_fixed_bin_17	 fixed binary (71) internal static; /* largest 17 bit value */
	declare max_fixed_bin_71	 fixed binary (71) internal static; /* largest 71 bit value */
	declare static_rsc_ptr	 ptr internal static; /* pointer to restructure control segment */
	declare index_list_ptr	 ptr internal static; /* pointer to list of index information */
	declare relation_list_ptr	 ptr internal static; /* pointer to list of relation information */
	declare attribute_list_ptr	 ptr internal static; /* pointer to list of attribute information */
	declare domain_list_ptr	 ptr internal static; /* pointer to list of domain information */
	declare definition_order	 fixed bin internal static; /* order of attribute definition */
	declare key_order		 fixed bin internal static; /* order of key attribute definition */
	declare string_length	 fixed bin (24) internal static; /* size of bit or char string declaration */
	declare string_average_length	 fixed bin (24) internal static; /* average varying string size */
	declare temp_number		 fixed binary (71); /* storage for number checks */
	declare i			 fixed binary;	/* index for initialization loop */
	declare saved_precision	 fixed bin (71) internal static; /* remembered number precision */
	declare scale_factor	 fixed bin (71) internal static; /* remembered number scale value declaration */
	declare avg_length_seen	 bit (1) internal static; /* ON =&gt; varying average size declared */
	declare size_seen		 bit (1) internal static; /* on =&gt; string size was declared */
	declare decode_proc_seen	 bit (1) internal static; /* on =&gt; decode_proc option was declared */
	declare encode_proc_seen	 bit (1) internal static; /* on =&gt; encode_proc option was declared */
	declare check_seen		 bit (1) internal static; /* on =&gt; check or check_proc option declared */
	declare type_seen		 bit (1) internal static; /* on =&gt; a type was declared */
	declare representation_seen	 bit (1) internal static; /* on =&gt; representation was declared */
	declare base_seen		 bit (1) internal static; /* on =&gt; base was declared */
	declare precision_seen	 bit (1) internal static; /* on =&gt; precision was declared */
	declare alignment_seen	 bit (1) internal static; /* on =&gt; alignment was declared */
	declare fixed_varying_seen	 bit (1) internal static; /* on =&gt;  fixed or varying was declared */
	declare scale_seen		 bit (1) internal static; /* on =&gt; scale was declared */
	declare decode_dcl_seen	 bit (1) internal static; /* on =&gt; decode declaration seen */
	declare MULTIPLIER		 fixed bin internal static options (constant) init (1); /* any to any of multiplier */
	declare A_CONSTANT		 fixed bin internal static options (constant) init (2); /* any to any of constant */
	declare NUMBER		 fixed bin internal static options (constant) init (3); /* number constant to convert */
	declare BIT_STRING		 fixed bin internal static options (constant) init (4); /* bit_string to convert */
	declare CHAR_STRING		 fixed bin internal static options (constant) init (5); /* char_string to convert */
	declare RMDB		 fixed bin internal static options (constant) init (5); /* rmdb fixup */
	declare CHILD		 fixed bin internal static options (constant) init (8); /* child rel dup check */
	declare FILE_REL		 fixed bin internal static options (constant) init (9); /* file rel dup check */
	declare ATTRIBUTES		 fixed bin internal static options (constant) init (10); /* attr dup check */
	declare decimal		 bit (1) internal static; /* on =&gt; decimal declared */
	declare real		 bit (1) internal static; /* on =&gt; real declared */
	declare (addrel, hbound, copy, length) builtin;
	declare (null, reverse, rtrim, substr) builtin;
	declare float		 bit (1) internal static; /* on =&gt; float declared */
	declare aligned		 bit (1) internal static; /* on =&gt; aligned was declared */
	declare nonvarying		 bit (1) internal static; /* on =&gt; nonvarying was declared */
	declare temp_index		 fixed binary;	/* storage for stack position of a token */
	declare key_attribute	 bit (1);		/* on =&gt; attribute is part of primary key */
	declare short		 bit (1) internal static; /* on =&gt; short precision */
	declare 1 arith_size	 unal based,	/* overlay for scale and precision fields of descriptor */
		2 unused		 bit (12),
		2 scale		 fixed bin (11),
		2 precision	 fixed binary (11); /* equivalent to bit(12) */
	declare 1 string_size	 unal based,	/* overlay for size field in descriptor */
		2 unused		 bit (12),
		2 length		 fixed binary (23); /* equivalent to bit(24) */
	declare name_ptr		 ptr int static;	/* pointer to token space when needed from stack */
	declare temp_source_ptr	 ptr int static;	/* pointer to temp token space when to be multiplied */
	declare ioa_		 entry() options(variable);



%include mrds_rst_parse_stack;
%include mrds_rst_semantics;
%include mdbm_descriptor;
%include mrds_rst_rsc;
%include mrds_rst_parse_info;
%include mdbm_db_model;
%include mrds_rst_struct_types;


     end;
��



		    mrds_rst_tree_delete.pl1        04/18/85  1454.7r w 04/18/85  0909.3       64395



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

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

mrds_rst_tree_delete: procedure (key, rsc_ptr, root_ptr, data_ptr, success);

/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree deletion routine
   A search is made for the key in the tree
   specified by the root pointer.
   If the key is not found,
   the deletion fails.
   Otherwise the tree node area is unlinked
   from the tree, and the space freed */

/* PARAMETERS:

   key - - (input) word in tree indicating node to be deleted

   rsc_ptr - - (input) pointer to common working storage

   root_ptr - - (input/output) pointer to root node of desired tree,
   may be changed if key is at root node

   data_ptr - - (output) pointer extracted from data field of deleted node

   success - - (output) bit value indicating deletion done(on),
   or attempt to delete node not in tree(off)     */

/* basic algorithm

   simple case - delete node has no right subtree
   make delete node's left subtree the new descendent of delete node's parent

   complex case - delete node has a right subtree
   subcase 1 - delete node's successor is direct descendent
   replace delete node with successor, giving it the
   delete node's left subtree
   subcase 2 - delete node's successor is not a direct descendent
   same as subcase 1 but additionally
   successor's parent get's successors right subtree as it's left subtree
   and successor's right subtree becomes that of the delete node's */


/* get pointer to node to be deleted and to it's parent */

	call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success);

/* if node to be deleted is not found, deletion fails */

	if ^success then ;

	else do;

/* node found, save data pointer, and rearrange tree links to eliminate the node */

		data_ptr = node_ptr -&gt; node.data;
		thread = "0"b;

/* fix predecessor thread

   since we are replacing the delete node with it's successor(if it has one),
   the delete node's predecessor must have its's right thread
   point to this new node(the delete node's successor) */

		if node_ptr -&gt; node.right.thread then ;
		else call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);
		if node_ptr -&gt; node.left.thread then ;
		else do;
			call mrds_rst_tree_predecessor (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success);
			if node_ptr -&gt; node.right.thread then
			     predecessor_ptr -&gt; node.right.link = node_ptr -&gt; node.right.link;
			else do;
				predecessor_ptr -&gt; node.right.link = successor_ptr;
			     end;
		     end;

/* if simple case of no inorder successor(right link a thread)
   then use the left subtree of delete node as his parent's new descendent,
   when the left link of the delete node is not a thread,
   else a left thread means that the parent link will become a thread.
   the left thread of the delete node may be used as this thread unless it points
   to the parent, in which case the right thread must be used. */

		if node_ptr -&gt; node.right.thread then
		     if ^node_ptr -&gt; node.left.thread then
			successor_ptr = node_ptr -&gt; node.left.link;
		     else do;
			     thread = "1"b;
			     if parent_ptr ^= node_ptr -&gt; node.left.link then
				successor_ptr = node_ptr -&gt; node.left.link;
			     else successor_ptr = node_ptr -&gt; node.right.link;
			end;

		else do;

/* complex case - delete node has a successor
   give the successor node a new left subtree(previously a thread)
   that is the current delete node's left subtree
   this is the first step in moving the successor node
   into the delete node's place in the tree */

			successor_ptr -&gt; node.left.link = node_ptr -&gt; node.left.link;
			successor_ptr -&gt; node.left.thread = node_ptr -&gt; node.left.thread;

/* for direct descendent successor, ignore right subtrees */

			if node_ptr = successor_parent_ptr then ;
			else do;

/* for successor not a direct descendent, the successor's new right subtree
   will be that of the delete node's.   The successor's old right subtree becomes
   the left subtree of the successor's old parent */

/* fix successor's parent's threads for case of delete node's right link not a thread,
   and successor is not direct descendent of delete node,

   successor node's right link a thread means that the successor node's
   parent's left link must become a thread to the successor node since the successor node
   is being made the predecessor of the successor node's parent.
   also the successor's right thread must be changed to pointer
   since it will link to delete node's right subtree(known to be nonempty).

   successor node's right link not a thread means that the successor's
   parent node's left link will be a pointer set equal to the successor
   node's right link. (the successor parent gets as his left, the successor's rught subtree) */

				if successor_ptr -&gt; node.right.thread then do;
					successor_parent_ptr -&gt; node.left.thread = "1"b;
					successor_ptr -&gt; node.right.thread = "0"b;
				     end;
				else successor_parent_ptr -&gt; node.left.link = successor_ptr -&gt; node.right.link;
				successor_ptr -&gt; node.right.link = node_ptr -&gt; node.right.link;

			     end;

		     end;

/* for all cases, change parent of delete node to point to it's new successor.
   determine which branch of delete node parent to change.
   the link from the parent will be a thread only if
   the delete node's links were both threads */

		if node_ptr = parent_ptr -&gt; node.left.link then do;
			parent_ptr -&gt; node.left.link = successor_ptr;
			parent_ptr -&gt; node.left.thread = thread;
		     end;

		else do;
			parent_ptr -&gt; node.right.link = successor_ptr;
			parent_ptr -&gt; node.right.thread = thread;
		     end;


/* release deleted nodes space */

		call mrds_rst_rsc_alloc$free (rsc_ptr, NODE, node_ptr);
		success = "1"b;

	     end;




	declare mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* binary tree search */
	declare mrds_rst_rsc_alloc$free entry (ptr, fixed bin, ptr); /* working area manager */
	declare mrds_rst_tree_successor entry (ptr, ptr, ptr, ptr, bit (1));
	declare mrds_rst_tree_predecessor entry (ptr, ptr, ptr, ptr, bit (1));


%include mrds_rst_tree;
%include mrds_rst_rsc;
%include mrds_rst_struct_types;



     end;
�



		    mrds_rst_tree_insert.pl1        04/18/85  1454.7r w 04/18/85  0909.3       41958



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

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

mrds_rst_tree_insert: procedure (key, rsc_ptr, root_ptr, node_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   Threaded binary tree insertion routine
   Given a pointer to the root of the desired list, a search is made
   for the key.
   If the key is found, the insertion fails to
   avoid duplicating keys.
   A successful insertion returns a pointer to
   the new tree node */

/* PARAMETERS:

   key - - (input) word to be inserted as key in new node

   rsc_ptr - - (input) pointer to common working storage

   root_ptr - - (input/output) pointer to root node of tree,
   will be modified on empty tree insert

   node_ptr - - (output) pointer to the node just inserted

   success - - (output) bit value indicating good insertion(on)
   or failure due to key duplication attempt(off)

*/
%page;

/* get pointer to inorder parent in tree */

	call mrds_rst_tree_search (key, root_ptr, node_ptr, parent_ptr, success);

/*  A search success(key was found) means a duplication
   of keys is being attempted, return failure */

	if success then success = "0"b;

/* Normal insertion, get a new list element, and fill in the blanks */

	else do;
		success = "1"b;

		call mrds_rst_rsc_alloc (rsc_ptr, NODE, node_ptr);
		node_ptr -&gt; node.key = key;
		node_ptr -&gt; node.right.thread = "1"b;
		node_ptr -&gt; node.left.thread = "1"b;
		node_ptr -&gt; node.data = null ();
		node_ptr -&gt; node.pad = "0"b;

/* Add the new element to the tree.
   Change the head pointer if empty tree */

		if root_ptr ^= null () then ;
		else do;

/* no dummy node for tree head, get new node for it,
   then make its right link a pointer to itself, and
   make it's left link a thread to itself thus indicating
   that the tree is empty */

			call mrds_rst_rsc_alloc (rsc_ptr, NODE, root_ptr);

			root_ptr -&gt; node.right.link = root_ptr;
			root_ptr -&gt; node.right.thread = "0"b;

			root_ptr -&gt; node.left.link = root_ptr;
			root_ptr -&gt; node.left.thread = "1"b;

			root_ptr -&gt; node.data = null ();
			root_ptr -&gt; node.pad = "0"b;

		     end;

/* dummy head node for tree exists for all cases now, but tree may still
   be empty(dummy node left link = thread), if so then force the
   dummy node to be a right parent of the new data node
   this is done by making the dummy node pointer serve as the
   new node parent and setting the dummy node key equal to
   the new node key so the test for descendent direction
   will cause a left insert to take place */

		if ^root_ptr -&gt; node.left.thread then ;
		else do;
			parent_ptr = root_ptr;
			root_ptr -&gt; node.key = key;
		     end;

/* good parent within tree, determine if node is right
   or left descendent.   right descendents have a left thread
   to their direct parent, and a right thread
   to their inorder successor. left descendents have a right
   thread to their direct parent, and a left thread
   to their inorder predecessor */

		if key &gt; parent_ptr -&gt; node.key then do;

			node_ptr -&gt; node.right.link = parent_ptr -&gt; node.right.link;
			node_ptr -&gt; node.left.link = parent_ptr;

			parent_ptr -&gt; node.right.link = node_ptr;
			parent_ptr -&gt; node.right.thread = "0"b;

		     end;

		else do;

			node_ptr -&gt; node.left.link = parent_ptr -&gt; node.left.link;
			node_ptr -&gt; node.right.link = parent_ptr;

			parent_ptr -&gt; node.left.link = node_ptr;
			parent_ptr -&gt; node.left.thread = "0"b;

		     end;


	     end;
%page;

	dcl     null		 builtin;
	dcl     mrds_rst_tree_search	 entry (char (32) aligned, ptr, ptr, ptr, bit (1)); /* binary tree search */
	dcl     mrds_rst_rsc_alloc	 entry (ptr, fixed bin, ptr); /* working area manager */
%page;
%include mrds_rst_tree;
%page;
%include mrds_rst_rsc;
%page;
%include mrds_rst_struct_types;


     end;

��



		    mrds_rst_tree_predecessor.pl1   04/18/85  1454.7r w 04/18/85  0909.3       27252



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

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

mrds_rst_tree_predecessor: procedure (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree inorder predecessor retrieval routine
   given a pointer to the current node in the tree
   ( set node_ptr = root_ptr to get last tree element )
   and a pointer to the root of the tree
   a pointer to it's inorder predecessor and that nodes parent
   are returned with a success indication, or
   when end of tree(no more predecessors) or empty tree is detected,
   a failure indication is returned */

/* PARAMETERS:

   root_ptr - - (input) pointer to root of desired tree

   node_ptr - - (input) pointer to current for which the predecessor is desired

   predecessor_ptr - - (output) pointer to resulting inorder predecessor of current node

   predecessor_parent_ptr - - (output) pointer to predecessor node direct tree parent

   success - - (output) bit value that is on when predecessor found,
   and off when end of tree or empty tree is detected

*/



/* no current node means no predecessor */

	if node_ptr = null () then
	     success = "0"b;

	else do;

/* current node exists, if it's left link is a thread
   it is either a pointer to the root meaning no more predecessors
   (or empty tree when node_ptr was root_ptr)
   or it points to the current node's inorder predecessor */

		predecessor_parent_ptr = node_ptr;
		predecessor_ptr = node_ptr -&gt; node.left.link;

		if node_ptr -&gt; node.left.thread then

		     if predecessor_ptr = root_ptr then
			success = "0"b;
		     else success = "1"b;

		else do;

/* current node's left link is not a thread,
   go left from current node's left descendent until
   a right thread is found and return it's owner
   as the inorder predecessor */

			success = "1"b;

			do while (^predecessor_ptr -&gt; node.right.thread);

			     predecessor_parent_ptr = predecessor_ptr;
			     predecessor_ptr = predecessor_ptr -&gt; node.right.link;

			end;

		     end;


	     end;

	dcl     null		 builtin;


%include mrds_rst_tree;




     end;




		    mrds_rst_tree_search.pl1        04/18/85  1454.7r w 04/18/85  0909.3       27855



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

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

mrds_rst_tree_search: procedure (key, root_ptr, node_ptr, parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   Threaded binary tree search
   Given a pointer to the desired list, do a binary search for the key.
   Return either a not found indication,
   or a found indication with a pointer to the key node,
   and a pointer to it's parent */

/* PARAMETERS:

   key - - (input) word to be searched for as key to tree node

   root_ptr - - (input) pointer to root node of desired tree

   node_ptr - - (output) pointer to node containing key when found,
   else root pointer pointer

   parent_ptr - - (output) pointer to direct tree parent when key node found,
   else pointer to prospective parent for insertion of key

   success - - (output) bit value indicating key was found in tree(on),
   or that place for it's  insertion was found(off)

*/


/* Initialize search loop
   note: parent_ptr is root_ptr when no dummy head exists,
   or when the dummy head node left link is a thread
   thus indicating a empty tree */

	parent_ptr = root_ptr;
	success = "0"b;

/* if dummy node at head of tree missing,
   we fail since tree was never built */

	if root_ptr = null () then ;
	else do;
		node_ptr = root_ptr -&gt; node.left.link;
		thread = root_ptr -&gt; node.left.thread;


/* Search the tree while the data key is not found,
   and branches remain to be searched .
   failure to make even one loop pass means the tree is empty,
   because the dummy head node left link is a thread to itself */

		do while (^thread &amp; ^success);

/* Branch left for smaller or right for larger keys.
   If key matches, note success and remember pointers. */

		     if key &gt; node_ptr -&gt; node.key then do;
			     thread = node_ptr -&gt; node.right.thread;
			     parent_ptr = node_ptr;
			     node_ptr = node_ptr -&gt; node.right.link;
			end;

		     else if key &lt; node_ptr -&gt; node.key then do;
			     thread = node_ptr -&gt; node.left.thread;
			     parent_ptr = node_ptr;
			     node_ptr = node_ptr -&gt; node.left.link;
			end;

		     else success = "1"b;

		end;

	     end;

	dcl     null		 builtin;


%include mrds_rst_tree;


     end;
�



		    mrds_rst_tree_successor.pl1     04/18/85  1454.7r w 04/18/85  0909.3       27981



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

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

mrds_rst_tree_successor: procedure (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success);


/* HISTORY:

   originally written by jim gray - - july 1978

*/

/* DESCRIPTION:
   threaded binary tree inorder successor retrieval routine
   given a pointer to the current node in the tree
   ( set node_ptr = root_ptr to get first tree element )
   and a pointer to the root of the tree
   a pointer to it's inorder successor and that nodes parent
   are returned with a success indication, or
   when end of tree(no more successors) or empty tree is detected,
   a failure indication is returned */

/* PARAMETERS:

   root_ptr - - (input) pointer to root of desired tree

   node_ptr - - (input) pointer to current for which the successor is desired

   successor_ptr - - (output) pointer to resulting inorder successor of current node

   successor_parent_ptr - - (output) pointer to successor node direct tree parent

   success - - (output) bit value that is on when successor found,
   and off when end of tree or empty tree is detected

*/



/* no current node means no successor */

	if node_ptr = null () then
	     success = "0"b;

	else do;

/* current node exists, if it's right link is a thread
   it is either a pointer to the root meaning no more successors
   or it points to the current node's inorder successor */

		successor_parent_ptr = node_ptr;
		successor_ptr = node_ptr -&gt; node.right.link;

		if node_ptr -&gt; node.right.thread then

		     if successor_ptr = root_ptr then
			success = "0"b;
		     else success = "1"b;

		else do;

/* current node's right link is not a thread,
   go left from current node's right descendent until
   a left thread is found and return it's owner
   as the inorder successor */

			do while (^successor_ptr -&gt; node.left.thread);

			     successor_parent_ptr = successor_ptr;
			     successor_ptr = successor_ptr -&gt; node.left.link;

			end;

/* if pointer is still to root, the dummy head node
   left link was a thread indicating an empty tree */

			if successor_ptr = root_ptr then
			     success = "0"b;
			else success = "1"b;

		     end;


	     end;

	dcl     null		 builtin;


%include mrds_rst_tree;




     end;
���



		    restructure_mrds_db.pl1         10/16/86  1551.9rew 10/16/86  1143.2      294525



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

restructure_mrds_db: rmdb: proc;



/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     initialize added ctl_info fields, change hardcoded path to
     mrds_data_$rmdb_info_directory. Add -force/-no_force and -relation_type
     control arguments.
                                                   END HISTORY COMMENTS */


/*
   .		       BEGIN_DESCRIPTION
   This command is used  to  enter  the  restructure_mrds_db  (rmdb)
   subsystem.  It  sets  up a subsystem environment as determined by
   control arguments  and  then  enters  the  subsystem  by  calling
   ssu_$listen.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .		       HISTORY
   82-03-09 Davids: Written

   82-04-27 Davids: to  create  a  new  directory  under  the  user
   .                supplied  temp dir or the pdir and use that new
   .                dir as the temp dir. This allows cleanups to be
   .                very simple, safe and complete  -  just  delete
   .                the created temp dir.

   82-05-03 Davids: modified so that the request ready_db is called
   .                via ssu_$execute_string if a database  path  is
   .                supplied on the rmdb command line.

   82-06-01 Davids: modified so that abbrev is off by default

   82-06-07 Davids: modified so that negative quiesce_wait_times are
   .                handled correctly as are times larger than those
   .                that can fit in a fixed bin variable  (&gt;131071).
   .                Also so that -profile imples -abbrev and so that

   .                if a wait time is supplied but a  database  path
   .                is not an error is reported.

   82-06-09 Harvey: modified so that iteration  will always  be done 
   .		by ssu_.

   82-06-22 Davids: removed	some   declared  by  never  referenced
   .                variables, declared  some  variables  that  were
   .                being  implicitly declared and changed some line
   .                formats to prevent wrap-arround.

   82-07-15 Davids: modified   so   that  the  prompt_string  is  not
   .                assigned from the arg if the arg is  longer  than
   .                the  prompt  string.  instead it is assign from a 
   .                substr. This prevents a stringsize condition.

   82-10-19 Harvey: modified to allow db path to  be anywhere on  the
   .		rmdb command line without the -pn argument.

   83-05-24 Davids: Modified call to rmdb_free_db in the internal proc
   clean_up to include the rmdb_control.saved_res_version_ptr argument

   83-10-04 Benjamin: Added call to ssu_$add_request_table.

   84-09-10 Thanh Nguyen: Modified call ssu_requests_$standard_requests
   to ssu_request_tables_$standard_requests.

   84-10-23 Paul Benjamin: Changed to only call free_db if rmdb readied it to
   begin with.  Added call to ssu_$add_info_dir.

   85-01-23 Paul Benjamin: Fixed the bug where the temp_dir always has ring
   brackets of 4,4.  Now uses (V,V) where V = validation level.
*/

/* COMMAND ARGUMENTS (based) */

	dcl     arg		 char (arg_len) based (arg_ptr);

/* EXTERNAL STATIC */

	dcl     error_table_$bad_arg	 fixed bin (35) external static;
	dcl     error_table_$badcall	 fixed bin (35) external static;
	dcl     error_table_$bad_conversion fixed bin (35) external static;
	dcl     error_table_$bigarg	 fixed bin (35) external static;
	dcl     error_table_$inconsistent fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) external static;
	dcl     error_table_$not_act_fnc fixed bin (35) external static;
	dcl     iox_$user_input	 ptr external static;
	dcl     mrds_data_$rmdb_info_directory char (168) ext static;
	dcl     rmdb_rq_tb_$rmdb_rq_tb_ fixed bin (35) external static;
	dcl     ssu_et_$subsystem_aborted fixed bin (35) external static;
	dcl     ssu_info_directories_$standard_requests char (168) external;
	dcl     ssu_request_tables_$standard_requests bit (36) aligned external static;
	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* ENTRIES */

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	dcl     active_fnc_err_	 entry options (variable);
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$af_arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_group_id_	 entry () returns (char (32));
	dcl     get_pdir_		 entry () returns (char (168));
	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_$initiate	 entry (char (*), char (*), char (*), fixed bin (1),
				 fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     mdbm_util_$cleanup_temp_dir entry (char (*), fixed bin (35));
	dcl     mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
	dcl     rmdb_free_db	 entry (char (168), ptr, char (500), fixed bin (35));
	dcl     ssu_$add_info_dir	 entry (ptr, char (*), fixed bin, fixed bin (35));
	dcl     ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$execute_line	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     ssu_$execute_string	 entry (ptr, char (*), fixed bin (35));
	dcl     ssu_$listen		 entry (ptr, ptr, fixed bin (35));
          dcl     ssu_$print_blast       entry (ptr, ptr, fixed bin, char(*) var, fixed bin(35));
	dcl     ssu_$print_message	 entry options (variable);
	dcl     ssu_$set_abbrev_info	 entry (ptr, ptr, ptr, bit (1) aligned);
	dcl     ssu_$set_prompt	 entry (ptr, char (64) varying);
	dcl     ssu_$set_prompt_mode	 entry (ptr, bit (*));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/* CONDITIONS */

	dcl     cleanup		 condition;
	dcl     size		 condition;

/* INTERNAL AUTOMATIC */

	dcl     abbrev_processing	 bit (1);		/* true if abbrev processing is to be done */
	dcl     abbrev_profile_dname	 char (168);	/* directory name of profile to use for abbrev processing */
	dcl     abbrev_profile_ename	 char (32);	/* entry name of profile to use for abbrev processing */
	dcl     abbrev_profile_expected bit (1);	/* true if profile path expected as the next argument */
	dcl     abbrev_profile_path	 char (168);	/* profile path argument */
	dcl     abbrev_profile_ptr	 ptr;		/* pointer to abbrev profile */
	dcl     abbrev_profile_supplied bit (1);	/* true if profile path supplied */
	dcl     arg_len		 fixed bin (21);	/* length of an argument */
	dcl     arg_ptr		 ptr;		/* pointer to an argument */
	dcl     code		 fixed bin (35);	/* standard error code */
	dcl     db_path		 char (168);	/* database path supplied as an argument */
	dcl     db_path_expected	 bit (1);		/* true if a database path is expected as the next argument */
	dcl     db_path_supplied	 bit (1);		/* true if a database path is supllied as an argument */
	dcl     error_message	 char (500);	/* error message returned from rmdb_ready_db and rmdb_free_db */
	dcl     force_sw		 bit (1) aligned;	/* if create the db without the query */
	dcl     i			 fixed bin;	/* loop index */
	dcl     nargs		 fixed bin;	/* number of arguments the command was called with */
	dcl     prompt_string	 char (64) varying; /* prompt string argument supplied by the caller */
	dcl     prompt_string_expected bit (1);		/* true if a prompt string is expected as the next argument */
	dcl     prompt_string_supplied bit (1);		/* true if a prompt string has been supplied as an argument */
	dcl     prompting		 bit (1);		/* true if prompting is to be done */
	dcl     quiesce_wait_time	 fixed bin;	/* how many seconds the caller will wait
						   to try to quiesce the database, supplied as an argument */
	dcl     quiesce_wait_time_expected bit (1);	/* true if a wait time is expected as the next argument */
	dcl     quiesce_wait_time_supplied bit (1);	/* true if a wait time has been supplied as an argument */
	dcl     ready_request_string	 char (512) varying;/* string passed to ready_db request */
	dcl     relation_type	 char (32);
	dcl     relation_type_expected bit (1) aligned;	/* true if a relation type is expected as the next argument */
	dcl     relation_type_supplied bit (1) aligned;	/* true if a relation type has been supplied as an argument */
	dcl     relation_modes	 char (256);
	dcl     request_string_expected bit (1);	/* true if a request sring is expected as the next argument */
	dcl     request_string_len	 fixed bin (21);	/* length of the request string */
	dcl     request_string_ptr	 ptr;		/* pointer to the requerst string */
	dcl     request_string_supplied bit (1);	/* true if a request string has been supplied */
	dcl     ring_array		 (3) fixed bin (3); /* ring brackets for the tem_dir_sub_dir_name dir */
	dcl     sci_ptr		 ptr;		/* subsystem control info pointer */
	dcl     temp_dir_abs_path	 char (168);	/* absoutute path to the user supplied temp dir or the pdir */
	dcl     temp_dir_path	 char (168);	/* temp dir path - needed if process dir does not have enough
						   quota to set up working space for very large databases */
	dcl     temp_dir_path_expected bit (1);		/* true if a temp dir path is expected as the next argument */
	dcl     temp_dir_path_supplied bit (1);		/* true if a temp dir path has been supplied as an argument */
	dcl     temp_dir_sub_dir_name	 char (32);	/* name of the dir created under the temp_dir_abs_path which
						   will house all the temp segments */
	dcl     validation_level	 fixed bin;	/* the user's current validation level */
	dcl     01 rmdb_control	 like rmdb_ctl;	/* automatic copy of the rmdb_ctl structure */

/* CONSTANTS */

          dcl     BLAST_MESSAGE          char (72) varying init (
"Type ""help rmdb"" to review new features in restructure_mrds_db.");
	dcl     LAST_IN_SEQUENCE	 fixed bin internal static options (constant) init (9999);
						/* passed to ssu to put standard_requests stuff last */
	dcl     MAX_PROMPT_STRING_LEN	 fixed bin internal static options (constant) init (64);
						/* maximum length of the prompt string */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b);
	dcl     ON		 bit (1) internal static options (constant) init ("1"b);
	dcl     PROC_NAME		 char (4) internal static options (constant) init ("rmdb");
						/* use the shorter of the two names to keep messages short */

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     char		 builtin;
	dcl     empty		 builtin;
	dcl     index		 builtin;
	dcl     null		 builtin;
	dcl     rtrim		 builtin;
	dcl     substr		 builtin;
	dcl     verify		 builtin;

/* BASED */

	dcl     work_area		 area (sys_info$max_seg_size) based (rmdb_control.work_area_ptr);

/* INCLUDE FILES */
%page;
%include access_mode_values;
%page;
%include mrds_rmdb_ctl;
%page;
%include ssu_prompt_modes;

/*
   Determine the number of arguments that this  command  was  called
   with,  it  may  be called with any number. Also determine if this
   command was called as a command or an active function. An  active
   function  call  is  an  error, it should be reported and then the
   system exited. Since nothing has been done no cleanup is needed.
*/



	call cu_$af_arg_count (nargs, code);
	if code ^= error_table_$not_act_fnc
	then do;
		if code = 0
		then call active_fnc_err_ (error_table_$badcall, PROC_NAME,
			"^/This command cannot be called as an active function");
		else call com_err_ (code, PROC_NAME,
			"^/An error occured while trying to determine the number of arguments");
		goto exit_rmdb;
	     end;







/*
   Assign initial values.
*/

	rmdb_control.version = RMDB_CTL_VERSION_1;	/* set the version of rmdb_ctl structure */
	rmdb_control.rmdb_version = "2.0";		/* the version of the subsystem */
	rmdb_control.absolute_db_path = "";		/* no path is known yet */
	rmdb_control.temp_dir_path = "";		/* no temp_dir path is known */
	rmdb_control.work_area_ptr = null;		/* no work area has been set up yet */
	rmdb_control.db_model_ptr = null;		/* since the path is not known there is no pointer */
						/* the relmgr_entries will be set in rmdb_ready_db */
						/* and will not be used until after they are set */
	rmdb_control.crossref_file_info.iocb_ptr = null;	/* iocb to keyed vfile containing th db crossreference */
	rmdb_control.crossref_file_info.name = "";	/* entryname of crossreference file */

	db_path_supplied = OFF;			/* flags indicating what information */
	prompt_string_supplied = OFF;			/* the user supplied */
	abbrev_profile_supplied = OFF;
	request_string_supplied = OFF;
	relation_type_supplied = OFF;
	quiesce_wait_time_supplied = OFF;
	temp_dir_path_supplied = OFF;

	prompting = ON;				/* states that by default are on for the subsystem */

	abbrev_processing = OFF;			/* states that are off */

	db_path_expected = OFF;			/* No user arguments are expected yet */
	prompt_string_expected = OFF;
	abbrev_profile_expected = OFF;
	request_string_expected = OFF;
	relation_type_expected = OFF;
	force_sw = OFF;
	quiesce_wait_time_expected = OFF;
	temp_dir_path_expected = OFF;

	relation_modes = "";
	sci_ptr = null ();

/*
   loop through all the user supplied arguments 1 at a time. Control
   arguments  expecting  an argument set a flag indicating that that
   argument is next, this is so that the call to cu_$arg_ptr and its
   error  handling  occurs  in  only  1 place. The first argument is
   special cased in that if it is  not  a  control  argument  it  is
   assumed to be the database path. There are 3 kinds of arguments:

   .   arguments that control the state of the subsystem,  i.e.
   .      prompting on or off
   .   arguments that set values to modify the subsystem,  i.e.
   .      set a new prompting string. these may also change the
   .      state of the subsystem, i.e.  setting  a  new  prompt
   .      string also turns prompting on
   .   arguments that are the new values, i.e. "new prompt:"

   Arguments may occur in any order and may be over ruled  by  later
   arguments,  i.e.  the  profile  path  associated  with  the  last
   -profile control  argument  will  be  the  profile  used  by  the
   subsystem.
*/



	do i = 1 to nargs;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, PROC_NAME, "Could not get argument ^i", i);
		     goto exit_rmdb;
		end;

	     if i = 1 &amp; index (arg, "-") ^= 1
	     then db_path_expected = ON;

	     if db_path_expected | prompt_string_expected | abbrev_profile_expected |
		request_string_expected | quiesce_wait_time_expected | temp_dir_path_expected |
		relation_type_expected
	     then do;				/* arguments for the control arguments */
		     if index (arg, "-") = 1 &amp; ^(verify (arg, "-0123456789.") = 0 &amp; quiesce_wait_time_expected)
						/* if a control argument is expecting an argument and */
						/* another control argument appears it should be reported */
						/* as an error, negative numbers for a wait time should */
						/* not be confused as a control argument */
		     then call report_missing_args;	/* expected flags are global */
		     else
			if db_path_expected
		     then do;
			     db_path_expected = OFF;
			     db_path_supplied = ON;
			     db_path = arg;
			end;
		     else
			if prompt_string_expected
		     then do;
			     prompt_string_expected = OFF;
			     prompt_string_supplied = ON;
			     if arg_len &lt;= MAX_PROMPT_STRING_LEN
			     then prompt_string = arg;
			     else do;
				     prompt_string = substr (arg, 1, MAX_PROMPT_STRING_LEN);
				     call com_err_ (error_table_$bigarg, PROC_NAME,
					"Prompt string ^a is longer than the maximum allowed length of ^i"
					|| "^/Prompt will be truncated to ^a^/",
					arg, MAX_PROMPT_STRING_LEN, prompt_string);
				end;
			end;
		     else
			if abbrev_profile_expected
		     then do;
			     abbrev_profile_expected = OFF;
			     abbrev_profile_supplied = ON;
			     abbrev_profile_path = arg;
			end;
		     else
			if relation_type_expected
		     then do;
			     relation_type_expected = OFF;
			     relation_type_supplied = ON;
			     relation_type = arg;
			     if i = nargs
			     then relation_modes = "";
			     else do;
				     call cu_$arg_ptr (i+1, arg_ptr, arg_len, code);
				     if index (arg, "-") ^= 1
				     then do;
					     relation_modes = arg;
					     i = i + 1;
					end;
				end;
			end;
		     else
			if request_string_expected
		     then do;
			     request_string_expected = OFF;
			     request_string_supplied = ON;
			     request_string_ptr = arg_ptr;
			     request_string_len = arg_len;
			end;
		     else
			if quiesce_wait_time_expected
		     then do;
			     quiesce_wait_time_expected = OFF;
			     quiesce_wait_time_supplied = ON;
			     on size begin;
				     call com_err_ (error_table_$bad_conversion, PROC_NAME,
					"^/The size of the quiesce wait time ^a " ||
					"is larger than the maximum of 131071.", arg);
				     goto exit_rmdb;
				end;
(size):			     quiesce_wait_time = cv_dec_check_ (arg, code);
			     revert size;
			     if code ^= 0
			     then do;
				     call com_err_ (error_table_$bad_conversion, PROC_NAME,
					"Could not convert ^a into an integer representing the quiesce wait-time",
					arg);
				     goto exit_rmdb;
				end;
			     if quiesce_wait_time &lt; 0
			     then do;
				     call com_err_ (error_table_$bad_conversion, PROC_NAME,
					"^/The quiesce wait time ^a is negative, wait times must be &gt;= 0.", arg);
				     goto exit_rmdb;
				end;
			end;
		     else
			if temp_dir_path_expected
		     then do;
			     temp_dir_path_expected = OFF;
			     temp_dir_path_supplied = ON;
			     temp_dir_path = arg;
			end;
		end;
						/* control arguments which expect arguments */
	     else
		if arg = "-prompt" | arg = "-pmt"
	     then do;
		     prompt_string_expected = ON;
		     prompting = ON;		/* for this case it also sets a state */
		end;
	     else
		if arg = "-profile" | arg = "-pf"
	     then do;
		     abbrev_profile_expected = ON;
		     abbrev_processing = ON;		/* for this case it also sets a state */
		end;
	     else
		if arg = "-pathname" | arg = "-pn"
	     then db_path_expected = ON;
	     else
		if arg = "-request" | arg = "-rq"
	     then request_string_expected = ON;
	     else
		if arg = "-quiesce_wait_time" | arg = "-qwt"
	     then quiesce_wait_time_expected = ON;
	     else
		if arg = "-temp_dir" | arg = "-td"
	     then temp_dir_path_expected = ON;
						/* control arguments which set states */
	     else
		if arg = "-no_prompt" | arg = "-npmt"
	     then prompting = OFF;
	     else
		if arg = "-force" | arg = "-fc"
	     then force_sw = ON;
	     else
		if arg = "-no_force" | arg = "-nfc"
	     then force_sw = OFF;
	     else
		if arg = "-relation_type" | arg = "-rt"
	     then relation_type_expected = ON;
	     else
		if arg = "-abbrev" | arg = "-ab"
	     then abbrev_processing = ON;
	     else
		if arg = "-no_abbrev" | arg = "-nab"
	     then abbrev_processing = OFF;
	     else
		if index (arg, "-") ^= 1		/* database path */
	     then do;
		     db_path_supplied = ON;
		     db_path = arg;
		end;
						/* unknown control argument */
	     else do;
		     call com_err_ (error_table_$bad_arg, PROC_NAME, "Argument ^i (^a) is unrecognized", i, arg);
		     goto exit_rmdb;
		end;
	end;




/*
   Once all the arguments have been processed a check must  be  made
   to  be  sure  that  all  control  argument  arguments  have  been
   supplied. Note that in general it is not necessary for a database
   path to have been supplied unless the -path control arg was used.
   If report_missing_args returns then no arguments were missing and
   everything is ok. If an argument is  missing  report_missing_args
   will report it and goto exit_rmdb.
*/


	call report_missing_args;			/* expected flags are global */

/*
   If a quiesce_wait_time was supplied but  a  database  path  was  not
   supplied  it  will be considered as an inconsistent set of arguments
   and an error will be reported.
*/

	if quiesce_wait_time_supplied &amp; ^db_path_supplied
	then do;
		call com_err_ (error_table_$inconsistent, PROC_NAME,
		     "^/A wait time can be supplied only if a database to be readied is also supplied");
		goto exit_rmdb;
	     end;

/*
   Creates a temporary directory in the user supplied temporary  dir
   or pdir if the user did not supply a temporary dir. This makes it
   easy  to  cleanup  after  the invocation - just delete the entire
   temp dir.

   Creates a temporary segment in the new temporary dir to  be  used
   as a work area for the rmdb requests.

   The  system routine get_temp_segment has not been used because it
   always creates the segments in the  pdir  and  the  mrds  routine
   mu_temp_segments  has  not  been used because it requires an open
   data base.

   Note that from this point on any errors  which  will  cause  this
   command  to  return  to  the  user  will  have  to first call the
   clean_up procedure. Likewise a cleanup condition handler must  be
   established incase it is signaled after this point.
*/



	on cleanup call clean_up;

	if ^temp_dir_path_supplied
	then temp_dir_abs_path = get_pdir_ ();
	else do;
		call absolute_pathname_ (temp_dir_path, temp_dir_abs_path, code);
		if code ^= 0
		then do;
			call com_err_ (code, PROC_NAME,
			     "^/Could not determine the absolute path of the given temp_dir path (^a)", temp_dir_path);
			goto cleanup_and_exit_rmdb;
		     end;
	     end;

	temp_dir_sub_dir_name = unique_chars_ (OFF) || ".rmdb";
	call cu_$level_get (validation_level);
	ring_array (*) = validation_level;
	call hcs_$append_branchx (temp_dir_abs_path, temp_dir_sub_dir_name, SMA_ACCESS_BIN,
	     ring_array, get_group_id_ (), 1, 0, 0, code);
	if code ^= 0
	then do;
		call com_err_ (code, PROC_NAME,
		     "^/Could not create the temp dir ^a&gt;^a, in the temporary directory ^a",
		     temp_dir_abs_path, temp_dir_sub_dir_name, temp_dir_abs_path);
		goto cleanup_and_exit_rmdb;
	     end;

	rmdb_control.temp_dir_path = rtrim (temp_dir_abs_path) || "&gt;" || temp_dir_sub_dir_name;

	call hcs_$make_seg (rmdb_control.temp_dir_path, unique_chars_ ("0"b) || ".rmdb", "",
	     RW_ACCESS_BIN, rmdb_control.work_area_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, PROC_NAME, "^/Could not make a scratch segment in the dir ^a", temp_dir_abs_path);
		goto cleanup_and_exit_rmdb;
	     end;

	work_area = empty ();

/*
   Create  the  subsystem  invocation.
*/



	call ssu_$create_invocation (PROC_NAME, (rmdb_control.rmdb_version), addr (rmdb_control),
	     addr (rmdb_rq_tb_$rmdb_rq_tb_), mrds_data_$rmdb_info_directory, sci_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, PROC_NAME, "Could not invoke the rmdb subsystem");
		goto cleanup_and_exit_rmdb;
	     end;


/* Add the standard request table supplied by ssu_, to get things like do, if,
   answer, exec_com, etc. */

	call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), LAST_IN_SEQUENCE, code);

	if code ^= 0
	then goto cleanup_and_exit_rmdb;

/* And the info segs for 'em */

	call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, LAST_IN_SEQUENCE, code);

	if code ^= 0
	then goto cleanup_and_exit_rmdb;

/*
   If a database path has been supplied then the  database  must  be
   readied for restructuring.

   The request level routine rmdb_rq_ready_db is called  (via  ssu_)
   instead  of  the  subroutine  level  rmdb_ready_db  because  the
   subroutine level does not know about ssu_ and there  exists  the
   possiblility  that  ready  will  have to call an rmdb request in
   order to make an inconsistent db consistent.

   If the caller did not supply a maximum amount of time to wait for
   the data base to be quiesced a default wait time of 10 seconds is
   used.
*/



	if db_path_supplied
	then do;
	          ready_request_string = "ready_db " || rtrim (db_path);

		if quiesce_wait_time_supplied
		then ready_request_string = ready_request_string || " -quiesce_wait_time " || rtrim (char (quiesce_wait_time));

		if relation_type_supplied
		then ready_request_string = ready_request_string || " -relation_type " || rtrim (relation_type) || " " || rtrim (relation_modes);

		if force_sw
		then ready_request_string = ready_request_string || " -force";

		call ssu_$execute_string (sci_ptr, (ready_request_string), code);
		if code ^= 0
		then goto cleanup_and_exit_rmdb;
	     end;

/*
   abbrev processing is off by default. ssu will interpret a null
   abbrev_profile_ptr  to  mean  that  the user's default profile
   should be used. If a profile path is specified a pointer to it
   is obtained to pass to ssu.
*/



	if abbrev_processing
	then do;
		abbrev_profile_ptr = null ();
		if abbrev_profile_supplied
		then do;
			call expand_pathname_$add_suffix (abbrev_profile_path, "profile",
			     abbrev_profile_dname, abbrev_profile_ename, code);
			if code ^= 0
			then do;
				call com_err_ (code, PROC_NAME, "Could not expand the profile path ^a",
				     abbrev_profile_path);
				goto cleanup_and_exit_rmdb;
			     end;
			call hcs_$initiate (abbrev_profile_dname, abbrev_profile_ename, "",
			     0, 0, abbrev_profile_ptr, code);
			if abbrev_profile_ptr = null ()
			then do;
				call com_err_ (code, PROC_NAME, "Could not initiate the profile at ^a&gt;^a",
				     abbrev_profile_dname, abbrev_profile_ename);
				goto cleanup_and_exit_rmdb;
			     end;
		     end;
		call ssu_$set_abbrev_info (sci_ptr, abbrev_profile_ptr, null (), "1"b);
	     end;


/*
   If the user supplies a prompt string than this string is given to
   ssu,  normally  ssu will use the subsystem name. Note that seting
   the prompt string and having prompts are  independent.  The  user
   may  set  a  prompt  string  and  turn prompts off (perhaps to be
   turned on later).
*/
/* Set up and execute print_blast. */

	call ssu_$print_blast (sci_ptr, codeptr (rmdb), 3, BLAST_MESSAGE, code);


	if prompt_string_supplied
	then call ssu_$set_prompt (sci_ptr, prompt_string);

	if ^prompting
	then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT);


/*
   If the user supplied a request string it is executed  here.  Note
   that  most  errors  during  the  execution of the request are not
   considered as fatal errors for the whole subsystem. The error  is
   merely  reported.  The  exception  is the subsystem_aborted error
   which does cause the subsystem to  be  aborted  and  is  probably
   caused by a quit in the request string.
*/



	if request_string_supplied
	then do;
		call ssu_$execute_line (sci_ptr, request_string_ptr, request_string_len, code);
		if code = ssu_et_$subsystem_aborted
		then goto cleanup_and_exit_rmdb;
		else if code ^= 0
		then call ssu_$print_message (sci_ptr, code);
	     end;

/*
   the call to ssu_$listen essentially puts the  user  at  subsystem
   request level. If listen returns with the subsystem aborted error
   it means that either the user requested to  quit  or  some  other
   subsystem  error  occured  which  was  reported  by the subsystem
   before it returned. If  some  other  error  occured  it  must  be
   reported.

   Regardless of how listen returns the command must clean itself up
   before returning to the caller.
*/


	call ssu_$listen (sci_ptr, iox_$user_input, code);
	if code ^= ssu_et_$subsystem_aborted
	then call com_err_ (code, PROC_NAME, "Subsystem aborted abnormally");









cleanup_and_exit_rmdb:
	call clean_up;

exit_rmdb:
	return;

report_missing_args: proc;

/*
   If any of the expected flags is set it indicates that an argument
   to a control arg has not been supplied. Report  the  omission  to
   the  caller and exit the command. If this procedure does a return
   it means that no arguments were missing.
*/

/* GLOBAL

   db_path_expected					true if the next argument should be a database path
   prompt_string_expected				true if the next argument should be a prompt string
   abbrev_profile_expected				true if the next argument should be a profile path
   relation_type_expected				true if the next argument should be a relation type
   request_string_expected				true if the next argument should be a request string
   quiesce_wait_time_expected				true if the next argument should be a wait time
   temp_dir_path_expected				true if the next argument should be a temp dir path */


	if db_path_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -pathname (-pn) control arg was given but no pathname was supplied");
		goto exit_rmdb;
	     end;

	if prompt_string_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -prompt (-pmt) control arg was given but no prompt was supplied");
		goto exit_rmdb;
	     end;

	if abbrev_profile_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -profile (-pf) control arg was given but no profile was supplied");
		goto exit_rmdb;
	     end;

	if request_string_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -request (-rq) control arg was given but no request string was supplied");
		goto exit_rmdb;
	     end;

	if quiesce_wait_time_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -quiesce_wait_time (-qwt) control arg was given but no wait time was supplied");
		goto exit_rmdb;
	     end;

	if temp_dir_path_expected
	then do;
		call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -temp_dir (-td) control arg was given but no temp dir path was supplied");
		goto exit_rmdb;
	     end;

	if relation_type_expected
	then do;
	          call com_err_ (error_table_$noarg, PROC_NAME,
		     "The -relation_type (-rt) control arg was given but no relation types was supplied");
		goto exit_rmdb;
	     end;

	return;

     end report_missing_args;

clean_up: proc;

/*
   To exit this command the rmdb subsystem must be destroyed  if  it
   has been invoked, the readied database must be freed and the temp
   dir  that was created under the users temp dir (or the pdir) must
   be deleted.
*/

/* GLOBAL

   code						standard error code
   PROC_NAME		                              the name of this command
   rmdb_control					control info structure
   sci_ptr					subsystem control info pointer */

/* AUTOMATIC */

	dcl     temp_dir_dir	 char (168);	/* path to either the pdir or the user supplied temp dir */
	dcl     temp_dir_name	 char (32);	/* name of the rmdb created temp dir undet temp_dir_dir */





	if sci_ptr ^= null ()
	then call ssu_$destroy_invocation (sci_ptr);

	if rmdb_control.absolute_db_path ^= "" /* this is set only if a data base has been readied */
	     &amp; rmdb_control.flags.database_readied_by_rmdb/* only free it if we readied it */
	then do;
		call rmdb_free_db (rmdb_control.absolute_db_path, rmdb_control.saved_res_version_ptr, error_message, code);
		if code ^= 0
		then call com_err_ (code, PROC_NAME, error_message);
	     end;

	if rmdb_control.crossref_file_info.iocb_ptr ^= null
	then call mdbm_util_$xref_destroy (rmdb_control.crossref_file_info.iocb_ptr,
	     rmdb_control.temp_dir_path, rmdb_control.crossref_file_info.name, (""), (0));

	if rmdb_control.temp_dir_path ^= ""
	then do;
		call expand_pathname_ (rmdb_control.temp_dir_path, temp_dir_dir, temp_dir_name, code);
		if code ^= 0
		then call com_err_ (code, PROC_NAME, "^/Could not expand the temp_dir path.");
		else do;
		     	call mdbm_util_$cleanup_temp_dir (rmdb_control.temp_dir_path, (0));
			call delete_$path (temp_dir_dir, temp_dir_name, "101000"b, "rmdb", code);
			if code ^= 0
			then call com_err_ (code, PROC_NAME, "^/Could not delete the temporary directory ^a",
				rmdb_control.temp_dir_path);
		     end;
	     end;

	return;

     end clean_up;

     end restructure_mrds_db;
���



		    rmdb_add_rmdb_history.pl1       10/16/86  1551.9rew 10/16/86  1142.9       84393



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

rmdb_add_rmdb_history:
add_rmdb_history:
     proc (db_model_ptr, type_of_object_restructured, object_name,
	operation, secondary_object_name, error_message, code);


/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     Add new operations create_(attribute domain), delete_(attribute domain),
     rename_(attribute domain)
                                                   END HISTORY COMMENTS */


/*
   .		       BEGIN_DESCRIPTION
   This procedure is used to record a database  restructuring  event
   in the data model by allocating a rmdb_history_entry structure in
   the data model and linking it to the  end  of  a  chain  of  such
   structures   which   record   previous   events.   The  chain  is
   doubly  linked with offsets to the first and last elements in the
   data model.

   There  are  three  objects  in  a  mrds  database  that  can   be
   restructured:  domains,  attributes  and  relations.  Things like
   indices and edit_procs  are  considered  part  of  relations  and
   domains respectively.

   This code has developed  it  own  data  structures  to  record  a
   restructuring  event  rather  than  using  the changer structures
   which are already in the data and file models and  were  designed
   to  be  used  when  restructuring was implemented. The reason for
   this is two fold. First the  changer  structures  are  associated
   with  each  of  the  domain,  attribute,  and relation structures
   therefore certain types of restructuring like adding a  secondary
   index  to  a relation would see two changer structures allocated,
   one for the relation  and  one  for  the  attribute.  Second  the
   changer structures record only the date-time of the event and the
   person id  who  did  it  but  not  what  was  done.  The  changer
   structures  where  not removed from the data and file models when
   this code  was  implemented  becuase  one  only  1  structure  is
   actually  allocated  and  that  one contains the date-time of the
   creation and the creator of the  database  which  is  still  very
   usefull.  Second for compatability reasons the data base and file
   models must remain the same size so the 18 bits used to store the
   offset to the structure would still have to be in the models.

   quits are delayed while the datamodel is actually being updated.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-04-13 Davids: written

   82-05-04 Davids: modified so that the rmdb_history_entry  list
   .                is  doubly  linked  with offsets to the first
   .                and last entries in the data model.

   82-06-22 Davids: declared some implicitly  declared  builtins,
   .                changed  call to clock_ to a reference to the
   .                pl1  clock  builtin,  and  put  a  quit_delay
   .                sequence around the allocate and link code.

   82-07-07 Roger Lackey: added rmdb_add_history entry point for binding.
*/

   /* PARAMETERS */

	dcl     db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     type_of_object_restructured fixed bin;	/* (input) index indicating the type of
						   .       object that has been restructured */
	dcl     object_name		 char (32);	/* (input) name of the object that has been restructured */
	dcl     operation		 fixed bin;	/* (input) index indicating the
						   .       type of restructuring that was done */
	dcl     secondary_object_name	 char (32);	/* (input) name of any secondary object involved with
						   .       the restructuring, i.e. attr name that was indexed */
	dcl     error_message	 char (500);	/* (output) standard error message */
	dcl     code		 fixed bin (35);	/* (output) standard error code */

/* INTERNAL AUTOMATIC */

	dcl     last_rmdb_history_entry_ptr ptr;	/* pointer to last entry in history list */
	dcl     new_rmdb_history_entry_ptr ptr;		/* pointer to the structure just allocated */
	dcl     quit_signaled	 bit (1);		/* true if the user hit a quit during the
                                                               execution of the critical region */

/* INTERNAL CONSTANTS */

	dcl     NULL_OFFSET		 bit (18) init ("111111111111111111"b) internal static options (constant);

/* EXTERNAL CONSTANTS */

	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     error_table_$area_too_small fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;


/* ENTRIES */

	dcl     get_group_id_	 entry () returns (char (32));
	dcl     ioa_$rs		 entry () options (variable);

/* CONDITIONS */

	dcl     area		 condition;
	dcl     quit		 condition;


/* BUILTINS */

	dcl     addr		 builtin;
	dcl     clock		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     pointer		 builtin;
	dcl     rel		 builtin;

/* INCLUDES */
%page;
%include mdbm_db_model;
%page;
%include rmdb_history_entry;

/*
   The user has not yet hit a quit
*/

	quit_signaled = "0"b;



/*
   Check the ranges on the object_type and operation to be sure that
   garbage will not be stored in the model.
*/


	if type_of_object_restructured &lt; 1 | type_of_object_restructured &gt; RMDB_REL_TYPE
	then do;
		code = error_table_$action_not_performed;
		call ioa_$rs ("type of object restructured indicator &lt;^i&gt; not within range of 1 -- ^i",
		     error_message, length (error_message), type_of_object_restructured, RMDB_REL_TYPE);
		goto exit_rmdb_add_rmdb_history;
	     end;
	else
	     if operation &lt; 1 | operation &gt; RMDB_RN_REL_OP
	then do;
		code = error_table_$action_not_performed;
		call ioa_$rs ("type of operation indicator &lt;^i&gt; not within range of 1 -- ^i",
		     error_message, length (error_message), operation, RMDB_RN_REL_OP);
		goto exit_rmdb_add_rmdb_history;
	     end;
	else do;
		error_message = "";
		code = 0;
	     end;





/*
   In the event that the area in the data model  is  so  small  that
   another  rmdb_history_event structure cannot be allocated, return
   a suitable message to the user instead of having him blow up with
   an area condition.
*/


	on area begin;
		error_message = "Area in model is not large enough to " ||
		     "allocate another history entry - database will not be restructured";
		code = error_table_$area_too_small;
		goto exit_rmdb_add_rmdb_history;
	     end;

/*
   Make sure that the caller  cannot  interrupt  while  the  history
   entry is being added to the model. But if he hits a quit remember
   so it can be signaled after the model is updated.
*/

	on quit quit_signaled = "1"b;



/*
   allocate a new the rmdb_history_entry structure and fill it.
*/

	allocate rmdb_history_entry set (new_rmdb_history_entry_ptr) in (db_model_ptr -&gt; db_model.dbm_area);

	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.user_id = get_group_id_ ();
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.date_time_restructured = clock;
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.type_of_object_restructured = type_of_object_restructured;
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.object_name = object_name;
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.operation = operation;
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.secondary_object_name = secondary_object_name;
	new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.offset_to_next_entry = NULL_OFFSET;





/*
   Link  the  new  structure  to  the  end  of  the  chain.   If the
   first_restructuring_history_offset  in  the  db_model  is null it
   implies  that this is the first restructuring event and that this
   structure   will   be   the   first   in   the   list.    If  the
   restructuring_history_offset     is     not    null    use    the
   last_restructuring_history_offset  to  find the last entry in the
   list.     The    last    thing    done    is    to   update   the
   last_restructuring_history_offset  in  the  data  model  with the
   offset to the just created structure.
*/


	if db_model_ptr -&gt; db_model.first_restructuring_history_offset = NULL_OFFSET
	then do;
		db_model_ptr -&gt; db_model.first_restructuring_history_offset = rel (new_rmdb_history_entry_ptr);
		new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.offset_to_previous_entry = NULL_OFFSET;
	     end;
	else do;
		last_rmdb_history_entry_ptr = pointer (db_model_ptr,
		     db_model_ptr -&gt; db_model.last_restructuring_history_offset);
		last_rmdb_history_entry_ptr -&gt; rmdb_history_entry.offset_to_next_entry = rel (new_rmdb_history_entry_ptr);
		new_rmdb_history_entry_ptr -&gt; rmdb_history_entry.offset_to_previous_entry =
		     db_model_ptr -&gt; db_model.last_restructuring_history_offset;
	     end;

	db_model_ptr -&gt; db_model.last_restructuring_history_offset = rel (new_rmdb_history_entry_ptr);

exit_rmdb_add_rmdb_history:

/*
   If the user hit a quit now is the time to signal it for him 
*/

	if quit_signaled
	then do;
		revert quit;
		signal quit;
	     end;

	return;
     end rmdb_add_rmdb_history;
���



		    rmdb_build_attr_info.pl1        10/16/86  1551.9r w 10/16/86  1143.7       82440



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


rmdb_build_attr_info: proc (I_dbm_ptr, I_adi_ptr, I_fm_ptr, I_di_ptr, O_err_msg, O_err_code);

/* .		        BEGIN_DESCRIPTION

   The purpose of this procedure is to add the attr_info for the attribute
   defined in I_adi_ptr -&gt; attr_def_info.   The definition order of the
   attributes will be the order in which they are supplied to this procedure.
   The necessary rel_info structure elements are also updated.

   .		         END_DESCRIPTION
*/



/* HISTORY:
   82-04-13 Originally written by R. Lackey.

   82-06-25 Roger Lackey : Added the divide builting and the
   constants VARYING_CHAR_TYPE = 22 and VARYING_BIT_TYPE = 20

   82-07-02 R. Harvey : changed mu_data_length reference to
	     mdbm_util_$mu_data_length

   83-01-10 R. Harvey : changed so the attribute index_id is set to
	     all zeroes and the max_attr_index_id field is set beyond
	     the maximum for pre-relation manager MRDS.
*/

/*      PARAMETERS      */

	dcl     I_dbm_ptr		 ptr parameter;	/* Pointer to the db_model */
	dcl     I_adi_ptr		 ptr parameter;	/* Pointer to attr_def_info */
	dcl     I_fm_ptr		 ptr parameter;	/* Pointer to file_model */
	dcl     I_di_ptr		 ptr parameter;	/* Pointer to domain_info */
	dcl     O_err_msg		 char (*) parameter;/* Error message text */
	dcl     O_err_code		 fixed bin (35) parameter; /* Error code */

%page;
/* rmdb_build_attr_info: proc (I_dbm_ptr, I_adi_ptr, I_fm_ptr, I_di_ptr, O_err_msg, O_err_code); */

	dbm_ptr = I_dbm_ptr;			/* Pointer to db_model */
	adi_ptr = I_adi_ptr;			/* Pointer to atr_def_info */
	fm_ptr = I_fm_ptr;				/* Pointer to file_model */
	di_ptr = I_di_ptr;				/* pointer to domain_info for this attribute */
	O_err_msg = "";
	O_err_code = 0;

	ri_ptr = ptr (fm_ptr, file_model.rel_ptr);	/* Pointer to rel_info */

/* Find end of attr_info list and check for dup attr_names
   count the attributes to determine attr order number.
   count key attributes. */

	prev_ptr = null;

	key_attribute_count = 0;

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

	     if attr_def_info.name = attr_info.name then do; /* Found a duplicate name */
		     O_err_msg = rtrim (attr_info.name);/*   so return an error */
		     O_err_code = mrds_error_$rst_name_duplicate;
		     return;
		end;

	     if attr_info.key_attr then key_attribute_count = key_attribute_count + 1; /* Count key attributes */
	     prev_ptr = ai_ptr;

	end;

	if rel_info.num_attr + 1 &gt; mrds_data_$max_attributes then do;
		O_err_code = mrds_error_$max_attributes;
		return;
	     end;

	rel_info.num_attr = rel_info.num_attr + 1;

	allocate attr_info in (fm_area) set (ai_ptr);
%page;
	if prev_ptr = null then rel_info.attr_ptr = rel (ai_ptr); /* Link new attr_inof into list */
	else prev_ptr -&gt; attr_info.fwd_thread = rel (ai_ptr);

	attr_info.name = attr_def_info.name;

	if attr_def_info.primary_key then do;		/* If it is part of the primary key */
		attr_info.key_attr = "1"b;
		attr_info.key_order = key_attribute_count + 1;
		rel_info.num_key_attrs = rel_info.num_key_attrs + 1; /* Bump key attr count in rel_info */
	     end;
	else do;					/* Not part of primary key */
		attr_info.key_attr = "0"b;
		attr_info.key_order = 0;
	     end;

	attr_info.link_attr = "0"b;
	attr_info.reserved = "0"b;

	if attr_def_info.indexed then do;		/*  It is an indexed attribute */
		if mdbm_util_$mu_data_length ((domain_info.db_desc)) &gt; 2277 /* 253* 9 */
		then do;
			O_err_code = mrds_error_$long_index;
			O_err_msg =
			     "The attribute has a domain that allows a values with length greater then 253 characters. "
			     || attr_def_info.name;
			return;
		     end;


		attr_info.index_attr = "1"b;
		rel_info.indexed = "1"b;		/* Set rel_info stuff */
		rel_info.max_attr_index_id = 257;	/* set so old rmdb will not be able to add indexes */
		attr_info.index_id = "0"b;
	     end;
	else do;					/* NOT an indexed attribute */
		attr_info.index_id = "0"b;
		attr_info.index_attr = "0"b;
	     end;

	attr_info.defn_order = rel_info.num_attr;	/* Same order that they are added to the attribute_list */

	call compute_bit_offset_and_length;		/* Internal proc */

	attr_info.link_child_cnt = 0;
	attr_info.link_par_cnt = 0;
	attr_info.domain_ptr = rel (di_ptr);
	attr_info.rslt_ptr = "0"b;
	attr_info.fwd_thread = NULL_OFFSET;
	attr_info.changer_ptr = db_model.changer_ptr;

%page;
	if ceil (divide (rel_info.max_key_len, 9, 35)) &gt; mrds_data_$max_key_len then do;
		O_err_msg = rtrim (rel_info.name);
		O_err_code = mrds_error_$long_key;
	     end;

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

compute_bit_offset_and_length: proc;

/* routine to convert the attribute's domain descriptor into
   the required tuple offset and space required and update the
   corresponding statistics for the relation information
   NOTE: the padding routines were introduced to make the data stored
   in the tuple(via bit offset/length) relect the pl1 definition
   of storage locations needed for unaligned and aligned data types */

	varying_string = "0"b;

	desc_ptr = addr (domain_info.db_desc);		/* get descriptor for this attribute */

	attr_info.bit_length =
	     mdbm_util_$get_data_bit_length (desc_ptr -&gt; descriptor_bit_36_ovrly);

	if descriptor.type = VARYING_BIT_TYPE |
	     descriptor.type = VARYING_CHAR_TYPE then
	     varying_string = "1"b;

/* fixed length attribute/domain handling */

	if ^varying_string then do;			/* fixed attributes */
		padding =
		     mdbm_util_$align_data_item (desc_ptr, rel_info.var_offset - 1);
		attr_info.bit_offset = rel_info.var_offset + padding;
						/* set to end of fixed data */
		rel_info.var_offset =
		     rel_info.var_offset + attr_info.bit_length + padding;
						/* set new fixed data end */
	     end;

/* varying string handling */

	else do;					/* varying strings */
		rel_info.nvar_atts = rel_info.nvar_atts + 1; /* count up varying attributes */
		attr_info.bit_offset = rel_info.nvar_atts; /* varying array index, not offset */
		padding = pad (WORD, attr_info.bit_length); /* varying must start/stop on word boundary */
	     end;

/* set the maximum tuple and key bit lengths */

	rel_info.max_data_len =
	     rel_info.max_data_len + attr_info.bit_length + padding;
	if attr_def_info.primary_key then

	     rel_info.max_key_len = rel_info.max_key_len + attr_info.bit_length;

     end compute_bit_offset_and_length;
%page;
/*   * * * * * * * * * * * * * *        pad         * * * * * * * * * * * *  */

pad: proc (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 (35);	/* 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;
%page;
	dcl     NULL_OFFSET		 bit (18) internal static options (constant) init ((18)"1"b); /* db version of null offset */
	dcl     addr		 builtin;
	dcl     ceil		 builtin;
	dcl     WORD		 fixed bin int static options (constant) init (36);
	dcl     descriptor_bit_36_ovrly bit (36) based;	/* overlay for descriptor */
	dcl     divide		 builtin;
	dcl     fixed		 builtin;
	dcl     key_attribute_count	 fixed bin;
	dcl     mdbm_util_$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin);
	dcl     mdbm_util_$get_data_bit_length entry (bit (36)) returns (fixed bin (35));
	dcl     mod		 builtin;
	dcl     mrds_data_$max_attributes ext fixed bin (35);
	dcl     mrds_data_$max_key_len fixed bin (35) ext;
	dcl     mrds_error_$long_index fixed bin (35) ext static;
	dcl     mrds_error_$long_key	 fixed bin (35) ext static;
	dcl     mrds_error_$max_attributes fixed bin (35) ext static;
	dcl     mrds_error_$rst_name_duplicate fixed bin (35) ext static;
	dcl     mdbm_util_$mu_data_length entry (bit (36)) returns (fixed bin (35));
	dcl     null		 builtin;
	dcl     padding		 fixed bin;
	dcl     prev_ptr		 ptr;
	dcl     ptr		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     VARYING_BIT_TYPE	 fixed bin int static options (constant) init (20);
	dcl     VARYING_CHAR_TYPE	 fixed bin int static options (constant) init (22);
	dcl     varying_string	 bit (1);
%page;
%include rmdb_create_rel_info;
%page;
%include mdbm_db_model;
%include mdbm_file_model;
%page;
%include mdbm_descriptor;

     end rmdb_build_attr_info;





		    rmdb_copy_relation.pl1          12/07/87  1328.9rew 12/07/87  1319.8      220635



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

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

/*DESCRIPTION
  This subroutine creates a file_model and data relation from the description
  of an already present relation and a list of attributes to be deleted from
  or added to that relation. (Note: the add is not implemented yet, it should
  only be used by the restructure_relation operation of rmdb. */

/****^  HISTORY COMMENTS:
  1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
  2) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     Rework code so that the new relation (the one without the deleted domains)
     is created correctly.  Be sure to close it before we start putting tuples
     into it so that it will be up to date with index ids and all the
     information we collect and put into the model *after* the relation is
     first created and opened.
  3) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis),
     install(87-12-07,MR12.2-1008):
     Initialize mstxn_txn_id to 0 so that we won't get caught in the cleaner by
     trying to delete a txn that doesn't exist.
                                                   END HISTORY COMMENTS */

rmdb_copy_relation:
     proc (Idbm_ptr, Idb_path, Itemp_dir_path, Irmdb_relmgr_entries_ptr, Irelation_ptr, Oerror_message, Ocode);

	dbm_ptr = Idbm_ptr;
	db_path = Idb_path;
	temp_dir_path = Itemp_dir_path;
	rmdb_relmgr_entries_ptr = Irmdb_relmgr_entries_ptr;
	relation_ptr = Irelation_ptr;

	fm_ptr = relation.file_model_ptr;

	delete_model_sw, delete_relation_sw = "0"b;
	control_area_ptr, new_file_model_ptr = null;
	new_file_info_ptr, last_file_info_ptr = null;
	new_relation_id, old_relation_id = "0"b;
	mstxn_txn_id = "0"b;

	on cleanup call cleaner;
	
	create_relation_name = unique_chars_ ("0"b);
	create_model_name = rtrim (create_relation_name) || ".m";

	call make_area (control_area_ptr);

/* Mark in file_model segment that the relation copy and file_model code are
   not current. */
	file_model.file_model_copy_good = "0"b;
	file_model.relation_copy_good = "0"b;

	call copy_file_model;			/* create and copy the file model information */
	call transaction_in_progress;
	if mstxn_transactions_needed
	then do;
	     on cleanup
		begin;
		call mstxn_cleanup;
		call cleaner;
		end;
	     on any_other call mstxn_any_other;
%include mrds_start_transaction;
               if mstxn_code ^= 0
               then call error (mstxn_code, "Could not start a transaction.");
               end;

	call create_relation;			/* create the empty data relation */
	call copy_data;				/* copy the data from the old relation to the new */
	if mstxn_transactions_needed 
	then do;
	     mftxn_code = 0;
%include mrds_finish_transaction;
               end;

/* At this point we have esentially created the new relation. Mark the delete
   switches so that the cleanup handler doesn't get rid of them. Now we must
   copy the new model on the old, and the new data relation onto the old. If
   either the system or process crash now, we can recover by attempting this
   operation multiple times (rmdb_salvage_db does this when attempting the
   undo request). */
	delete_relation_sw, delete_model_sw = "0"b;
	new_file_model_ptr -&gt; file_model.relation_copy_good = "1"b;
	new_file_model_ptr -&gt; file_model.file_model_copy_good = "1"b;

	call error (0, "");
%page;
/*DESCRIPTION
  Create a non-freeing, non-zeroing extensible area to allocate structures in.
  When we return and finish using these structures, we will simply throw away
  the area. This subroutine is also used to reinitialize the area to empty so
  that we may reuse it for other purposes. */

make_area:
     proc (area_ptr);

dcl  area_ptr ptr parameter;

	if area_ptr = null
	then do;
	     call mdbm_util_$get_temp_segment_path (temp_dir_path, myname, area_ptr, code);
	     if code ^= 0
	     then call error (code, "Cannot get a temp segment in the temp dir.");

	     unspec (ai) = "0"b;
	     ai.version = area_info_version_1;
	     ai.extend = "1"b;
	     ai.dont_free = "0"b;
	     ai.no_freeing = "0"b;
	     ai.owner = myname;
	     ai.size = sys_info$max_seg_size;
	     ai.areap = area_ptr;
	     end;
	else call release_area_ (area_ptr);

	call define_area_ (addr (ai), code);
	if code ^= 0
	then call error (code, "Defining an area.");

	return;
     end make_area;
%page;
/*DESCRIPTION
  Create the new relation from the description of the old minus the attributes
  that are to be deleted. */

create_relation:
     proc;

dcl  cr_loop fixed bin;

/* initialize for calls to relation manager */
	tva_number_of_vector_slots = 0;
	tva_number_of_dimensions = rel_info.num_attr;
	tva_maximum_dimension_name_length = 32;
	allocate typed_vector_array in (control_area) set (typed_vector_array_ptr);

	typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
	typed_vector_array.number_of_dimensions = 0;

	il_number_of_ids = rel_info.num_attr;
	allocate id_list in (control_area) set (id_list_ptr);
	id_list.number_of_ids = 0;
	id_list.version = ID_LIST_VERSION_1;

/* Set up the list of descriptors for the create relation operation. */
	ai_ptr = ptr (new_file_model_ptr, rel_info.attr_ptr);
	do cr_loop= 1 to tva_number_of_dimensions;
	          
	          if attr_info.key_attr then do;
		     id_list.number_of_ids = id_list.number_of_ids + 1;
		     id_list.id (id_list.number_of_ids) = attr_info.defn_order;
		     end;
		di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
		typed_vector_array.number_of_dimensions = typed_vector_array.number_of_dimensions + 1;
		typed_vector_array.dimension_table (typed_vector_array.number_of_dimensions).name = attr_info.name;
		typed_vector_array.dimension_table (typed_vector_array.number_of_dimensions).descriptor_ptr =
		     addr (domain_info.db_desc);
		ai_ptr = ptr (new_file_model_ptr, attr_info.fwd_thread);
	end;

	if id_list.number_of_ids = 0
	then call error (mrds_error_$no_primary_key, "For relation " || relation.name);
	
	allocate rel_creation_info in (control_area) set (rel_creation_info_ptr);
	allocate file_create_info in (control_area) set (file_create_info_ptr);

/* Initialize values for the create relation operation. */
	rel_creation_info.version = REL_CREATION_INFO_VERSION_2;
	rel_creation_info.esm_info_ptr = null;
	rel_creation_info.cism_info_ptr = null;
	rel_creation_info.file_create_info_ptr = file_create_info_ptr;
	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 = db_model.db_type_flags.transactions_needed;
	file_create_info.flags.no_concurrency = ^db_model.db_type_flags.concurrency_on;
	file_create_info.flags.no_rollback = ^db_model.db_type_flags.rollback_on;
	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;

	call rmdb_relmgr_entries
	     .
	     create_relation (db_path, create_relation_name, rel_creation_info_ptr, typed_vector_array_ptr,
	     new_relation_id, rel_info.id, code);
	if code ^= 0
	then call error (code, "While creating relation " || create_relation_name);

	delete_relation_sw = "1"b;

/* initialize values for create_index */
	style = 1;
	relation_index_flags_ptr = addr (flag_list);
	flag_list = "0"b;
	relation_index_flags.index_is_unique = "1"b;	/* for primary key */

/* create the primary index for the relation */
	call rmdb_relmgr_entries
	     .create_index (new_relation_id, id_list_ptr, flag_list, style, rel_info.primary_key_index_id, code);
	if code ^= 0
	then call error (code, "While creating the primary index for" || create_relation_name);

/* create the secondary indexes for the relation */
	relation_index_flags.index_is_unique = "0"b;	/* index need not be unique for secondary index */
	id_list.number_of_ids = 1;			/* secondary indices involve only one attribute */

	ai_ptr = ptr (new_file_model_ptr, rel_info.attr_ptr);
	do cr_loop = 1 to rel_info.num_attr;
		if attr_info.index_attr
		then do;
		     id_list.id (1) = attr_info.defn_order;
		     call rmdb_relmgr_entries
			.create_index (new_relation_id, id_list_ptr, flag_list, style, attr_info.index_id, code);
		     if code ^= 0
		     then call error (code, "While creating secondary indices for " || create_relation_name);
		     end;
		ai_ptr = ptr (new_file_model_ptr, attr_info.fwd_thread);
	     end;					/* do relation_idx */

	return;
     end create_relation;
%page;
/*DESCRIPTION
  This subroutine copies the data from the relation MSF/DMF to a new file 
  without the attributes that are to be deleted. */

copy_data:
     proc;

dcl  based_bit36a bit (36) aligned based;
dcl  descriptor bit (36) aligned;
dcl  loop fixed bin (35);
dcl  new_cursor_ptr ptr;
dcl  old_cursor_ptr ptr;
dcl  tuple_bit_length fixed bin (35);

/* Open the relation that contains the data to copy from. */
          call rmdb_relmgr_entries.close (new_relation_id,(0));
	call rmdb_relmgr_entries.open (db_path, create_relation_name, new_relation_id, code);
	
	call rmdb_relmgr_entries.open (db_path, relation.name, old_relation_id, code);
	if code ^= 0
	then call error (code, "Unable to open data relation " || relation.name);

/* Create cursors for both the from and to relations. These cursors are
   allocated in an area that is to be released, so there is no need to clean up
   and get rid of them. */
	call rmdb_relmgr_entries.create_cursor (old_relation_id, control_area_ptr, old_cursor_ptr, code);
	if code ^= 0
	then call error (code, "Unable to create a cursor for relation " || relation.name);

	call rmdb_relmgr_entries.create_cursor (new_relation_id, control_area_ptr, new_cursor_ptr, code);
	if code ^= 0
	then call error (code, "Unable to create a cursor for copy of relation " || relation.name);

/* Create the select structure */
	rss_number_of_and_groups = 0;
	rss_maximum_number_of_constraints = 0;
	allocate relation_search_specification in (control_area) set (relation_search_specification_ptr);

	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;

	unspec(relation_search_specification.flags) = "0"b;

	relation_search_specification.range.type = LOW_RANGE_TYPE;
						/* all tuples */
	relation_search_specification.range.size = mrds_data_$max_tids_returned_per_call;

/* Populate the retrieval id list (the list of attributes to retrieve from the
   old relation). Since we are omitting attributes, we only need to retrieve the
   ones we are actually going to store. While we are building the id_list,
   calculate the maximum size (in bits) of the tuple. */
	il_number_of_ids = relation.attribute_count;
	allocate id_list in (control_area) set (id_list_ptr);
	id_list.version = ID_LIST_VERSION_1;
	id_list.number_of_ids = 0;

	tuple_bit_length = 0;
	do loop = 1 to relation.attribute_count;
	     if ^relation.attribute (loop).flags.delete
	     then do;
		id_list.number_of_ids = id_list.number_of_ids + 1;
		id_list.id (id_list.number_of_ids) = loop;

		di_ptr = ptr (dbm_ptr, relation.attribute (loop).domain_info_ptr);
		descriptor = domain_info.db_desc;
		if domain_info.db_desc_is_ptr
		then descriptor = ptr (dbm_ptr, descriptor) -&gt; based_bit36a;

		tuple_bit_length = tuple_bit_length + mdbm_util_$get_data_bit_length (descriptor);
		end;
	     end;					/* do loop */

	simple_typed_vector_ptr, element_id_list_ptr = null;

/* create an element_id_list for the call to get_tuple_ids */
	eil_number_of_elements = mrds_data_$max_tids_returned_per_call;
	allocate element_id_list in (control_area) set (element_id_list_ptr);
	element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
	
/* Read all the data from the old relation data file and store it into the new
   one. If we get a dup_store error, then deleting one or more of the attributes
   would cause the primary key to be non-unique and is not allowed. */
	code = 0;
	do while (code = 0);     

	     element_id_list.number_of_elements = 0;
	     element_id_list.id (*) = "0"b;

	     call rmdb_relmgr_entries
		.
		get_tuple_id (old_cursor_ptr, relation_search_specification_ptr, control_area_ptr,
		element_id_list_ptr, code);

	     if code = 0 &amp; element_id_list.number_of_elements &gt; 0
		then do loop = 1 repeat loop + 1 while (loop &lt;= element_id_list.number_of_elements &amp; code = 0);
		
/* let the relmgr create the simple_typed vector and fill the value_ptrs and 
   then we'll use the same one after the first time */

		     if mstxn_transactions_needed
		     then	call manage_transaction;

			call rmdb_relmgr_entries
			.
			get_tuple_by_id (old_cursor_ptr, element_id_list.id (loop), id_list_ptr, control_area_ptr, simple_typed_vector_ptr, code);

			if code = 0
			then call rmdb_relmgr_entries.put_tuple (new_cursor_ptr, simple_typed_vector_ptr, element_id_list.id (loop), code);
			if mstxn_transactions_needed
		          then call manage_transaction;

	     end;                  /* loop through all tuples in element_id_list */
	     

	     if code = 0
	     then relation_search_specification.head.type = RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE;     

	     end;              /* all tuples in the relation have been copied */

	if code ^= dm_error_$no_tuple
	then if code = dm_error_$key_duplication
	     then call error (code,
		     "Deleting key attributes from relation " || rtrim (relation.name)
		     || " would cause primary keys to be non-unique.");
	     else call error (code, "Deleting attributes from relation " || relation.name);
	code = 0;

/* Close both data files. */
	call rmdb_relmgr_entries.close (new_relation_id, (0));
	call rmdb_relmgr_entries.close (old_relation_id, (0));

	new_relation_id, old_relation_id = "0"b;

/* Mark in the file_model that the data relation is usable. */
	file_model.relation_copy_good = "1"b;

	return;
     end copy_data;
%page;
/*DESCRIPTION
  This subroutine creates an empty file_model segment, and populates it with
  the attributes that are not deleted from the old file_model segment. */

copy_file_model:
     proc;

dcl  1 adi like attr_def_info;
dcl  add_name char (32);
dcl  amount_to_pad fixed bin;
dcl  WORD fixed bin internal static options (constant) init (36);
     
	call initiate_file_$create (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, ("0"b), (0), code);
	if code ^= 0
	then call error (code, "While creating the file_model copy for relation " || relation.name);
	
	delete_model_sw = "1"b;			/* the model copy must be cleaned up if we abort */

/* Add a name of &lt;relation&gt;.k to &lt;unique&gt;.m. This is the only indicator of what
   the name of the relation is. The salvager is going to need this to complete
   the copy operation. */
	add_name = rtrim (relation.name) || ".k";
	call hcs_$chname_file (db_path, create_model_name, "", add_name, code);
	if code ^= 0
	then do;
	     if code = error_table_$namedup
	     then do;
		call hcs_$chname_file (db_path, add_name, add_name, "", (0));
		call hcs_$chname_file (db_path, create_model_name, "", add_name, code);
		end;
	     if code ^= 0
	     then call error (code, "Adding a name on model " || create_model_name);
	     end;

	new_file_model_ptr -&gt; like_file_model = init_file_model;
	new_file_model_ptr -&gt; file_model.fm_area = empty ();
	new_file_model_ptr -&gt; file_model.changer_ptr = db_model.changer_ptr;
	
	allocate rel_info in (new_file_model_ptr -&gt; file_model.fm_area) set (ri_ptr);

	new_file_model_ptr -&gt; file_model.rel_ptr = rel (ri_ptr);

	rel_info = init_rel_info; 
	rel_info.name = relation.name;
	rel_info.changer_ptr = db_model.changer_ptr;
		
/* Create all the attr_info structures in the new file_model segment */
	do relation_idx = 1 to relation.attribute_count;
	     if ^relation.attribute (relation_idx).flags.delete
	     then do;
		ai_ptr = relation.attribute (relation_idx).attribute_info_ptr;
		di_ptr = ptr (dbm_ptr, relation.attribute (relation_idx).domain_info_ptr);
		adi.name = attr_info.name;
		adi.primary_key = attr_info.key_attr;
		adi.indexed = attr_info.index_attr;
		adi.mbz = "0"b;

		call rmdb_build_attr_info (dbm_ptr, addr (adi), new_file_model_ptr, di_ptr, error_message, code);
		if code ^= 0
		then call error (code, error_message);

		end;
	     end;					/* do relation_idx */

/* we've built all the attr infos, but we still need to align varying data */
          if rel_info.nvar_atts = 0 then;
	else do;
	     if mod (rel_info.var_offset-1, WORD) = 0 then
		amount_to_pad = 0;
	     else amount_to_pad = WORD - mod (rel_info.var_offset -1, WORD);

	     rel_info.var_offset = rel_info.var_offset + amount_to_pad;
	     rel_info.max_data_len = rel_info.max_data_len + amount_to_pad;
	     end;

	call adjust_bit_count_ (db_path, create_model_name, "0"b, new_model_bit_count, (0));

/* Mark the fact that the file_model describing the new relation is ok to use. */
	file_model.file_model_copy_good = "1"b;

/* Create a file_info structure and add it to the end of the list of file_infos
   in db_model (if we are operating on a MSF). We don't really want to do this
   because we only have to undo it later, but vfile_relmgr_ requires that
   all these structures be there. */

	     do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= NULL_OFFSET);
		last_file_info_ptr = fi_ptr;
		end;

	     allocate file_info in (dbm_area) set (new_file_info_ptr);
	     relation.copy_file_model_ptr = new_file_info_ptr;
	     new_file_info_ptr -&gt; file_info.file_name = create_relation_name;
	     new_file_info_ptr -&gt; file_info.file_id = "000000000000000000000000000000000001"b;
	     new_file_info_ptr -&gt; file_info.fwd_ptr = NULL_OFFSET;
	     new_file_model_ptr -&gt; file_model.fi_ptr = rel (fi_ptr);
	     
	     if last_file_info_ptr = null
	     then db_model.file_ptr = rel (new_file_info_ptr);
	     else last_file_info_ptr -&gt; file_info.fwd_ptr = rel (new_file_info_ptr);

	return;
     end copy_file_model;
%page;
/*DESCRIPTION
  This subroutine ensures that no transaction is in progress, and sets a flag
  bit for use later. */

transaction_in_progress:
     proc;

	if db_model.db_type_flags.transactions_needed
	then do;
	     mstxn_transactions_needed = "1"b;
	     call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
	     if mstxn_code = 0
	     then do;
		mstxn_txn_id = "0"b;
		call error (error_table_$action_not_performed,
		     "A transaction is in progress. Commit or abort the transaction and try the operation again.");
		end;
	     end;
	else mstxn_transactions_needed = "0"b;

	return;
     end transaction_in_progress;

/*DESCRIPTION
     This routine takes care of starting and stopping new transactions as needed.
*/

manage_transaction:
     proc ();
     
          call transaction_manager_$commit_txn (mstxn_txn_id, mftxn_code);
	if mftxn_code ^= 0
	then do;
	     call transaction_manager_$abort_txn (mstxn_txn_id, mftxn_temp_code);
	     if mftxn_temp_code ^= 0
	     then call transaction_manager_$abandon_txn (mstxn_txn_id, mftxn_temp_code);
	     call error (mftxn_temp_code, "Unable to finish a transaction.");
	     end;
	
	mstxn_txn_id = "0"b;
          call transaction_manager_$begin_txn (TM_NORMAL_MODE, 0, mstxn_txn_id, mstxn_code);
	if mstxn_code ^= 0
	then call error (mstxn_code, "Could not start a transaction.");

	return;

     end manage_transaction;
%page;
/*DESCRIPTION
  Error handler and cleanup handler. This is the only way to exit these
  subroutines.
*/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	if code = 0
	then Oerror_message = "";
	else Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;

RETURN_TO_CALLER:
	call cleaner;
	return;

cleaner:
     proc;

dcl  id bit (36) aligned;
dcl  p ptr;

	do p = control_area_ptr;
	     if p ^= null
	     then do;
		call release_area_ (p);
		call mdbm_util_$free_temp_segment (myname, p, (0));
		end;
	     end;
	do id = new_relation_id, old_relation_id;
	     if id ^= "0"b
	     then call rmdb_relmgr_entries.close (id, (0));
	     end;

	if mstxn_txn_id ^= "0"b
	then do;
	     call transaction_manager_$abort_txn (mstxn_txn_id, code);
	     if code ^= 0
	     then call transaction_manager_$abandon_txn (mstxn_txn_id, (0));
	     end;

	return;
     end cleaner;

restore_significant_data:
     proc;
	return;
     end restore_significant_data;

should_rollback:
     proc returns (bit (1) aligned);
	return ("0"b);
     end should_rollback;
%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include dm_element_id_list;
%page;
%include dm_file_create_info;
%page;
%include dm_id_list;
%page;
%include dm_range_constants;
%page;
%include dm_rel_creation_info;
%page;
%include dm_relation_index_flags;
%page;
%include dm_relation_spec;
%page;
%include dm_specification_head;
%page;
%include vu_typed_vector;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mdbm_file_model_init;
%page;
%include rmdb_create_rel_info;
%page;
%include rmdb_crossref_info;
%page;
%include rmdb_relmgr_entries;
%page;
%include vu_typed_vector_array;
%page;
dcl  addr builtin;
dcl  adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35));
dcl  1 ai aligned like area_info;
dcl  any_other condition;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  control_area area (sys_info$max_seg_size) based (control_area_ptr);
dcl  control_area_ptr ptr;
dcl  create_model_name char (32);
dcl  create_relation_name char (30);
dcl  db_path char (168);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  delete_model_sw bit (1) aligned;
dcl  delete_relation_sw bit (1) aligned;
dcl  dm_error_$key_duplication fixed bin (35) ext static;
dcl  dm_error_$no_tuple fixed bin (35) ext static;
dcl  empty builtin;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$namedup fixed bin(35) ext static;
dcl  fixed builtin;
dcl  flag_list bit (36) aligned;
dcl  hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  Idb_path char (*) parameter;
dcl  Idbm_ptr ptr parameter;
dcl  initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
dcl  Irelation_ptr ptr parameter;
dcl  Irmdb_relmgr_entries_ptr ptr parameter;
dcl  Itemp_dir_path char (*) parameter;
dcl  last_file_info_ptr ptr;
dcl  mdbm_util_$get_data_bit_length entry (bit (36) aligned) returns (fixed bin (35));
dcl  mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mod builtin;
dcl  mrds_data_$max_tids_returned_per_call external static fixed bin (35);
dcl  mrds_data_$relation_blocking_factor external static fixed bin (17);
dcl  mrds_error_$no_primary_key fixed bin (35) ext static;
dcl  myname char (32) int static options (constant) init ("rmdb_copy_relation");
dcl  new_file_info_ptr ptr;
dcl  new_file_model_ptr ptr;
dcl  new_model_bit_count fixed bin (35);
dcl  new_relation_id bit (36) aligned;
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  old_relation_id bit (36) aligned;
dcl  ptr builtin;
dcl  rel builtin;
dcl  relation_idx fixed bin;
dcl  release_area_ entry (ptr);
dcl  rmdb_build_attr_info entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35));
dcl  rtrim builtin;
dcl  style fixed bin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  temp_dir_path char (168);
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  unspec builtin;

     end rmdb_copy_relation;
�



		    rmdb_create_and_pop_rel.pl1     08/01/88  1435.5rew 08/01/88  1300.0      172413



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

rmdb_create_and_pop_rel: proc (I_rmdb_ctl_ptr, I_db_path, I_temp_dir_path, I_sel_exp,
	I_rmdb_sel_val_info_ptr, I_index_attrs_ptr, O_err_msg, O_err_code);

/* 		    BEGIN_DESCRIPTION

   The purpose of this procedure is to  create  and populate a relation
   given a selection expression like that provided for define_temp_rel.
   The relation name is contained in the  I_index_attrs  structure. The
   attributes for the relation are defined by the  selected  attributes
   specified in the  selection expression.  Indexed  attributes  are in
   the index_attr_structure, and  were defined  outside this procedure.

   This procedure opens  the database twice: to translate the selection
   expression  to get the relation  attributes, and after the  relation
   has been created and is needed to store the selected tuples.

   .                     END_DESCRIPTION
*/

/* HISTORY
   82-04-23 Written by Roger Lackey

   82-06-15 Roger Lackey : added the init of db_model_ptr to
	                 rmdb_delete_rel_info in tidy_up procedure.

   82-06-25 Roger Lackey : changed to use divide builtin and undo request 
	                 to use -brief instead of -force

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
	                  mdbm_util_$inconsistent_* for binding.

   82-07-02 R. Harvey : Modified calls to mrds_dsl_translate, mu_define_area,
	              and mu_get_tuple for binding.

  82-07-01 Roger Lackey : changed mu_database_index$get_resultant_model_pointer
	                to mdbm_util_$get_resultant_model_pointer and
	                mu_store$store_direct to mdbm_util_$store_direct
	                for binding

  82-08-20 D. Woodka : deleted reference to rm_rel_info.max_data_len for
	             DMS conversion.

  82-09-15 Mike Kubicar : converted to use vectors.

  82-11-18 D. Woodka : changed calling sequence to include rmdb_ctl_ptr. 

  83-02-07 Mike Kubicar : Added transaction processing include files.

  83-02-15 Davids: modified to use the new db_type_flags in the db_model
  structure instead of the old numeric db_type.

  83-04-08 Mike Kubicar : Changed calling sequence of mdbm_util_$direct.

*/


/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-26,Dupuis), install(88-08-01,MR12.2-1073):
     For new parser, changed referneces of sel_ptr to select_list_ptr.
                                                   END HISTORY COMMENTS */


/*        PARAMETERS       */
	dcl     I_rmdb_ctl_ptr	 ptr;		/* ptr to rmdb_ctl used to access relation_manager entries */
	dcl     I_db_path		 char (*) parameter;/* Database path were are working with */
	dcl     I_temp_dir_path	 char (*) parameter;/* Temporary diretory pathname */
	dcl     I_sel_exp		 char (*) parameter;/* Selection expresion like that of define_temp_rel */
	dcl     I_rmdb_sel_val_info_ptr ptr parameter;	/* Pointer rmdb_sel_val_info structure */
	dcl     I_index_attrs_ptr	 pointer parameter; /* Pointer to the rmdb_index_attrs structure */
	dcl     O_err_msg		 char (*) parameter;/* Error message text */
	dcl     O_err_code		 fixed bin (35) parameter; /* Error code */

%page;
/* rmdb_create_and_pop_rel: proc (I_rmdb_ctl_ptr, I_db_path, I_temp_dir_path, I_sel_exp,
   I_rmdb_sel_val_info_ptr, I_index_attrs_ptr, O_err_msg, O_err_code); */


	must_delete_relation = "0"b;
	sel_exp_ptr = addr (I_sel_exp);
	sel_exp_len = length (I_sel_exp);
	rmdb_sel_val_info_ptr = I_rmdb_sel_val_info_ptr;
	rmdb_ix_attrs_ptr = I_index_attrs_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;
	O_err_msg = "";
	O_err_code = 0;
	rel_name = rtrim (rmdb_ix_attrs.relation_name);
	dbi = 0;
	ftf = "1"b;				/* first time flag */

	on cleanup call tidy_up;

	if I_db_path = " " then
	     call error (mrds_error_$no_db_path, "");
	else db_path = I_db_path;

	call hcs_$initiate (db_path, "db_model", "", 0, 0, dbm_ptr, code); /* Get pointer to db_model */
	if dbm_ptr = null then call error (mrds_error_$no_database, "^/" || db_path);

	if db_model.db_type_flags.transactions_needed
	then do;
		mstxn_transactions_needed = "1"b;
		call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
		if mstxn_code = 0 then do;
			mstxn_txn_id = "0"b;
			call error (error_table_$action_not_performed,
			     "Relations may not be created while a transaction " ||
			     "is in progress.  Commit or abort the transaction " ||
			     "and try again.");
		     end;
	     end;
	else mstxn_transactions_needed = "0"b;
	mstxn_txn_id = "0"b;

/* See if a relation by this name already exists in db */

	call hcs_$initiate (db_path, rel_name || ".m", "", 0, 0, fm_ptr, code);

	if fm_ptr ^= null then call error (mrds_error_$dup_rel, "^/" || rel_name);

	on cleanup
	     begin;
		call tidy_up;
		call mstxn_cleanup;
	     end;
	on any_other call mstxn_any_other;
%include mrds_start_transaction;
	if mstxn_code ^= 0
	then call error (mstxn_code, "Could not start a transaction while creating relation " || rtrim (rel_name) || ".");
	call dsl_$open (db_path, dbi, EXCLUSIVE_UPDATE, code);
	if code ^= 0 then call error (code, "^/" || db_path);

	call mdbm_util_$get_resultant_model_pointer (dbi, dbcb_ptr); /* Get the dbcb pointer */
	if dbcb_ptr = null then
	     call error (mrds_error_$invalid_db_index, "Getting dbcb_ptr");

	call mdbm_util_$define_temp_dir_area (dbcb.def_temp_rel_area_ptr, dbi, (sys_info$max_seg_size),
	     "MRDS.def_tr", "0"b /* not extensible */, "1"b /* no freeing */, "0"b,
	     "0"b /* no zeroing */, code);
	work_area_ptr = dbcb.def_temp_rel_area_ptr;
	if code ^= 0 then call error (code, "");

	num_sel_vals = rmdb_sel_val_info.sv_num;	/* Cause translate changes them */
	sel_val_arg_list_ptr = rmdb_sel_val_info.data_list_ptr;
	sel_val_desc_list_ptr = rmdb_sel_val_info.desc_list_ptr;

	call mdbm_util_$mrds_dsl_translate (dbcb_ptr, work_area_ptr, 4, sel_exp_ptr, sel_exp_len,
	     sel_val_arg_list_ptr, sel_val_desc_list_ptr,
	     num_sel_vals, code);
	if code ^= 0 then call error (code, "^/""" || I_sel_exp || """");

	if ^dbcb.val_dtr then call error (mrds_error_$inval_dtr_expr,
		"^/""" || I_sel_exp || """");
%page;
	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);
	     end;
	else do;
		range_ptr = dbcb.range_ptr;		/* initialize */
		select_list_ptr = dbcb.select_ptr;
	     end;

	rmdb_create_rel_info_alloc = select_list.num_items;
	allocate rmdb_create_rel_info in (work_area) set (rmdb_create_rel_info_ptr);
	rmdb_create_rel_info.version = RMDB_CREATE_REL_INFO_VERSION_1;
	rmdb_create_rel_info.db_path = I_db_path;
	rmdb_create_rel_info.temp_directory_path = I_temp_dir_path;
	rmdb_create_rel_info.db_model_ptr = dbm_ptr;
	rmdb_create_rel_info.relation_name = rmdb_ix_attrs.relation_name;
	rmdb_create_rel_info.num_attrs = select_list.num_items;

	do i = 1 to select_list.num_items;
	     rai_ptr = select_list.item.ai_ptr (i);	/* Get rm_attr_info_ptr */
	     rmdb_create_rel_info.attrs (i).name = rm_attr_info.model_name;
	     rmdb_create_rel_info.attrs (i).primary_key = select_list.item (i).key;
	     rmdb_create_rel_info.attrs (i).indexed = "0"b; /* Will mark those index  in index_attr_mark proc */
	     rmdb_create_rel_info.attrs (i).mbz = "0"b;
	end;

	call index_attr_mark;			/* Internal proc */

	must_delete_relation = "1"b;			/* In case an error occurs during creating */

/* The call to rmdb_create_relation will set the db inconsistent during the
   creation period but will then return the db to a consistent state prior to
   returning  */

	call rmdb_create_relation (rmdb_ctl_ptr, rmdb_create_rel_info_ptr, "0"b /* Not called from request level */, err_msg, code);
	if code ^= 0 then call error (code, err_msg);

	call dsl_$close (dbi, code);
	if code ^= 0 then call error (code, "First close of db");

	dbi = 0;

	call store;				/* Internal procedure */

	must_delete_relation = "0"b;

	if ftf then /* The relation was created
						   but no tuples stored because nothing was found that
						   matched the selection_exp */
	     call error (mrds_error_$no_tuple,
		"^/The relation was created but was not populated because" ||
		"^/there were no tuples that satisfied the selection expression.");
	call tidy_up;

exit:
	mftxn_code = O_err_code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0 then do;
		O_err_code = mftxn_code;
		O_err_msg = "Could not finish a transaction while creating relation " || rtrim (rel_name) || ".";
	     end;
	return;

%page;
/*  * * * * * * * * * * * *   index_attr_mark   * * * * * * * * * * * * * * */


index_attr_mark: proc;

	do k = 1 to rmdb_ix_attrs.num_used;		/* All indexed attrs */

	     attr_name = rmdb_ix_attrs.an (k);

	     found = "0"b;

	     do j = 1 to rmdb_create_rel_info.num_attrs while (^found); /* Search for name in list */

		if attr_name = rmdb_create_rel_info.attrs (j).name then do;

			if rmdb_create_rel_info.attrs (j).indexed = "1"b then
			     call error (mrds_error_$previously_defined_index, "^/" || attr_name);

			rmdb_create_rel_info.attrs (j).indexed = "1"b; /* Mark as indexed */
			found = "1"b;
		     end;

	     end;

	     if ^found then call error (mrds_error_$undef_attr,
		     "^/" || attr_name);

	end;					/* END All indexed attrs */

     end index_attr_mark;
%page;
/*   * * * * * * * * * * * * * *   store     * * * * * * * * * * * * * * *   */

store: proc;

/* This internal procedure opens the db for the second time so the opening
   includes the newly created relation and stores each tuple selected.

   If a tuple's primary key is found to duplicate that of a previously stored
   tuple the second tuple is NOT stored and no error reported.

   The database is set inconsistent just prior to beginning the stores */



/* Open db again this time with new relation in it */

	call dsl_$open (db_path, dbi, EXCLUSIVE_UPDATE, code);
	if code ^= 0 then call error (code, "^/" || db_path);

	call mdbm_util_$get_resultant_model_pointer (dbi, dbcb_ptr); /* Get the dbcb pointer */
	if dbcb_ptr = null then
	     call error (mrds_error_$invalid_db_index, "Getting dbcb_ptr");

	call mdbm_util_$define_temp_dir_area (dbcb.def_temp_rel_area_ptr, dbi, (sys_info$max_seg_size),
	     "MRDS.def_tr", "0"b /* not extensible */, "1"b /* no freeing */, "0"b,
	     "0"b /* no zeroing */, code);
	work_area_ptr = dbcb.def_temp_rel_area_ptr;

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

	num_sel_vals = rmdb_sel_val_info.sv_num;	/* Cause translate changes them */
	sel_val_arg_list_ptr = rmdb_sel_val_info.data_list_ptr;
	sel_val_desc_list_ptr = rmdb_sel_val_info.desc_list_ptr;

	call mdbm_util_$mrds_dsl_translate (dbcb_ptr, work_area_ptr, 4, sel_exp_ptr, sel_exp_len,
	     sel_val_arg_list_ptr, sel_val_desc_list_ptr,
	     num_sel_vals, code);
	if code ^= 0 then call error (code, "^/""" || I_sel_exp || """");
%page;
	if dbcb.ss_ptr ^= null then do;		/* set ptrs needed later */
		ss_ptr = dbcb.ss_ptr;
		select_list_ptr = select_sets.items (1).select_ptr;
		range_ptr = select_sets.items (1).range_ptr;
		ti_ptr = select_sets.items (1).ti_ptr;
	     end;
	else do;
		range_ptr = dbcb.range_ptr;		/* initialize */
		select_list_ptr = dbcb.select_ptr;
		ti_ptr = dbcb.ti_ptr;
	     end;

	rdbi_ptr = dbcb.rdbi_ptr;			/*  Pointer to rm_db_info */
	rmra_ptr = rm_db_info.ra_ptr;			/* find rel info */

/* search for rel_name in rm_rel_array  so we can get the rmri_ptr */

	i = index (string (rm_rel_array.name), "!" ||
	     rmdb_ix_attrs.relation_name);
	i = (divide ((i - 1), 33, 17)) + 1;		/* convert from char to array index */
	rmri_ptr = rm_rel_array.rel_data.ri_ptr (i);
	dbcb.last_store_rel_name = "!!!!!!!... ...!!!!!"; /*  Temparory store bad rel name incase this store fails */
%page;
	call mdbm_util_$inconsistent_set (dbm_ptr, "create_relation", /* Cause rmdb_create_relation reset it */
	     "Creating relation " || rel_name, "delete_relation " || rel_name || " -brief");

	quit_received = "0"b;			/* Not yet */

	stv_number_of_dimensions = mrds_data_$max_attributes;
	allocate simple_typed_vector;

	simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;


	call mdbm_util_$mu_get_tuple (dbcb_ptr, work_area_ptr, rmri_ptr, simple_typed_vector_ptr, code); /* get a tuple */

RESTART:	on quit quit_received = "1"b;			/* Hold off quits til end of loop */

	do while (code = 0);			/* As long as there are tuples to be retrieved */

	     call mdbm_util_$store_direct (dbcb_ptr,
		rmri_ptr, simple_typed_vector_ptr, code); /* add tuple */
	     if code = 0 | code = dm_error_$key_duplication then do;
						/* ignore duplicates */
		     ftf = "0"b;
		     dbcb.another_flag = "1"b;
		     call mdbm_util_$mu_get_tuple (dbcb_ptr, work_area_ptr, rmri_ptr, simple_typed_vector_ptr, code);
		end;

	     if quit_received then do;		/* If user quit during the loop so we will NOW let it go thru */
		     quit_received = "0"b;
		     revert quit;
		     signal quit;
		     on quit quit_received = "1"b;
		end;

	end;

	revert quit;

	if quit_received then do;			/* If user quit during the loop so we will NOW let it go thru */
		quit_received = "0"b;
		signal quit;
	     end;

	on cleanup call tidy_up;

	if code = mrds_error_$tuple_not_found then code = 0;
	else call error (code, "");

%page;

     end store;
%page;

/*  * * * * * * * * * * * * * *      error     * * * * * * * * * * * * * *   */



error: proc (err_code, err_message);

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


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

     end error;








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

tidy_up: proc;

	code = 0;

	if dbi ^= 0 then call dsl_$close (dbi, code);
	if code = 0 then dbi = 0;

	if must_delete_relation then do;
		delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1;
		delete_rel_info.absolute_db_path = db_path;
		delete_rel_info.db_model_ptr = dbm_ptr;
		delete_rel_info.relation_name = rel_name;
		delete_rel_info.brief = "1"b;
		delete_rel_info.mbz = "0"b;

		call rmdb_delete_relation$cleanup (rmdb_ctl_ptr, addr (delete_rel_info), err_msg, code);
	     end;

	if code = 0 then call mdbm_util_$inconsistent_reset (dbm_ptr); /* Make db consistnert */


     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;
	delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1;
	delete_rel_info.absolute_db_path = db_path;
	delete_rel_info.db_model_ptr = dbm_ptr;
	delete_rel_info.relation_name = rel_name;
	delete_rel_info.brief = "1"b;
	delete_rel_info.mbz = "0"b;
	call rmdb_delete_relation$cleanup (rmdb_ctl_ptr,
	     addr (delete_rel_info), err_msg, code);
	must_delete_relation = "0"b;
	ftf = "1"b;
     end restore_significant_data;



should_rollback:
     proc returns (bit (1));
	return ("0"b);
     end should_rollback;

%page;
	dcl     addr		 builtin;
	dcl     any_other		 condition;
	dcl     attr_name		 char (32);
	dcl     cleanup		 condition;
	dcl     code		 fixed bin (35);
	dcl     dbi		 fixed bin (35);
	dcl     db_path		 char (168);
	dcl     divide		 builtin;
	dcl     dsl_$close		 entry () options (variable);
	dcl     dsl_$open		 entry () options (variable);
	dcl     err_msg		 char (256);
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     EXCLUSIVE_UPDATE	 int static options (constant) init (4);
	dcl     fixed		 builtin;
	dcl     fm_ptr		 ptr;
	dcl     found		 bit (1);
	dcl     ftf		 bit (1) aligned;
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     i			 fixed bin;
	dcl     index		 builtin;
	dcl     j			 fixed bin;
	dcl     k			 fixed bin;
	dcl     length		 builtin;
	dcl     dm_error_$key_duplication fixed bin (35) ext static;
	dcl     mrds_data_$max_select_items ext fixed bin (35);
	dcl     mdbm_util_$mrds_dsl_translate entry (ptr, ptr, fixed bin, ptr, fixed bin, ptr, ptr, fixed bin, fixed bin (35));
	dcl     mrds_error_$dup_rel	 fixed bin (35) ext static;
	dcl     mrds_error_$invalid_db_index fixed bin (35) ext static;
	dcl     mrds_error_$inval_dtr_expr fixed bin (35) ext static;
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_db_path fixed bin (35) ext static;
	dcl     mrds_error_$no_tuple	 fixed bin (35) ext static;
	dcl     mrds_error_$previously_defined_index fixed bin (35) ext static;
	dcl     mrds_error_$tuple_not_found fixed bin (35) ext static;
	dcl     mrds_error_$undef_attr fixed bin (35) ext static;
	dcl     must_delete_relation	 bit (1);
	dcl     mdbm_util_$get_resultant_model_pointer entry (fixed bin (35), ptr);
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
	dcl     mdbm_util_$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     mdbm_util_$mu_get_tuple entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     mdbm_util_$store_direct entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_data_$max_attributes ext fixed bin (35);
	dcl     null		 builtin;
	dcl     num_sel_vals	 fixed bin;
	dcl     quit		 condition;
	dcl     quit_received	 bit (1);
	dcl     range_ptr		 ptr;
	dcl     rel		 builtin;
	dcl     rel_name		 char (32) varying;
	dcl     rmdb_create_relation	 entry (ptr, ptr, bit (1), char (*), fixed bin (35));
	dcl     rmdb_ctl_ptr	 ptr;
	dcl     rmdb_delete_relation$cleanup entry (ptr, ptr, char (*), fixed bin (35));
	dcl     rtrim		 builtin;
	dcl     sel_exp_len		 fixed bin;
	dcl     sel_exp_ptr		 ptr;
	dcl     sel_val_arg_list_ptr	 ptr;
	dcl     sel_val_desc_list_ptr	 ptr;
	dcl     string		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     work_area		 area based (work_area_ptr);
	dcl     work_area_ptr	 ptr;




	dcl     1 delete_rel_info	 aligned
				 like rmdb_delete_rel_info;

%page;
%include mrds_dbcb;
%page;
%include mdbm_rm_rel_array;
%page;
%include mdbm_db_model;
%page;
%include mrds_select_list;
%page;
%include mrds_select_sets;
%page;
%include rmdb_create_rel_info;
%page;
%include mdbm_rm_rel_info;
%page;
%include mdbm_rm_db_info;
%page;
%include mdbm_rm_attr_info;
%page;
%include mrds_tuple_info;
%page;
%include rmdb_delete_rel_info;
%page;
%include vu_typed_vector;


     end rmdb_create_and_pop_rel;
���



		    rmdb_create_attribute.pl1       10/16/86  1532.6rew 10/16/86  1530.3       87129



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

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

/*DESCRIPTION
  This module actually creates an unreferenced attribute. First, it verifies
  the input structure, creates the attribute/domain file if necessary, then
  builds the appropriate structures in the db model segment and adds these
  structures to the linked list of unreferenced attributes.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

rmdb_create_attribute:
     proc (Irmdb_ctl_ptr, Icreate_attr_info_ptr, Oerror_message, Ocode);

/* Initialization */
	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	create_attr_info_ptr = Icreate_attr_info_ptr;

	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;
	dbm_ptr = rmdb_ctl.db_model_ptr;

/* Check input arguments */
	if create_attr_info.version ^= create_attr_info_version_1
	then call error (error_table_$unimplemented_version, "For create_attr_info structure.");

	if rmdb_ctl.absolute_db_path = ""
	then call error (mrds_error_$no_db_path, "");

	if create_attr_info.count = 0
	then call error (error_table_$wrong_no_of_args, "No attributes to be created.");

/* Check to see if the attributes named do not exist and the domains named
do exist. */
	if local_iocb = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr,
		rmdb_ctl.crossref_file_info.name, local_iocb, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     rmdb_ctl.crossref_file_info.iocb_ptr = local_iocb;
	     end;

	do loop = 1 to create_attr_info.count;
	     call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, create_attr_info.attribute (loop).domain,
		null, 0, error_message, code);
	     if code = error_table_$no_record
	     then call error (mrds_error_$undefined_domain, create_attr_info.attribute (loop).domain);

	     call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD, create_attr_info.attribute (loop).name,
		null, 0, error_message, code);
	     if code = 0
	     then call error (mrds_error_$attr_already_exists, create_attr_info.attribute (loop).name);
	     end;					/* do loop */

	crossref_info_record_ptr = addr (local_record_buffer);
	crossref_info_record.count = 0;

/* Finished verifying input structure, actually create them now. */
	do loop = 1 to create_attr_info.count;
	     call create_an_attribute (loop);
	     end;					/* do loop */

/* Finish up */
	call adjust_bit_count_ (rmdb_ctl.absolute_db_path, DB_MODEL_NAME, "1"b, bcnt, code);
	if code ^= 0
	then call error (code, pathname_ (rmdb_ctl.absolute_db_path, DB_MODEL_NAME));
	call error (0, "");

RETURN_TO_CALLER:
	return;

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;
%page;
/* This routine creates exactly one unreferenced attribute. First it locks the
db model segment, creates the necessary structure, initializes it, then links
it to the linked list of unreferenced attributes. It then unlocks the model
segment and adds the necessary history structure. Note: quits are noticed but
deferred until after critical code is finished. */

create_an_attribute:
     proc (attribute_index);

dcl  attribute_index fixed bin (17) parameter;

	quit_intercept_flag = "0"b;
	on quit quit_intercept_flag = "1"b;

	new_ua_ptr = null;				/* BEGINNING OF CRITICAL CODE */
	on cleanup
	     begin;
		call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
		     rmdb_ctl.crossref_file_info.name, (""), (0));
		if new_ua_ptr ^= null
		then free new_ua_ptr -&gt; unreferenced_attribute in (dbm_area);

		call mdbm_util_$inconsistent_reset (dbm_ptr);
	     end;

	call mdbm_util_$inconsistent_set (dbm_ptr, "create_attribute",
	     "Creating attribute " || create_attr_info.attribute (attribute_index).name,
	     "delete_attribute -force -inhibit_error " || rtrim (create_attr_info.attribute (attribute_index).name));

/* Trap area conditions so that we can abort with a reasonable error message */
	on area
	     call error (error_table_$area_too_small,
		"No room left in the db_model segment area to add the attribute "
		|| create_attr_info.attribute (attribute_index).name);

/* Create the unreferenced_attribute structure */
	allocate unreferenced_attribute in (dbm_area) set (new_ua_ptr);
	unspec (new_ua_ptr -&gt; unreferenced_attribute) = "0"b;
	revert area;

/* Add domain record to the crossreference file */
	call mdbm_util_$xref_reference (local_iocb, DOMAIN_KEY_HEAD,
	     create_attr_info.attribute (attribute_index).domain, create_attr_info.attribute (attribute_index).name,
	     crossref_info_record_ptr, 4, error_message, code);
	if code ^= 0
	then call error (code, error_message);

/* Add attribute record to crossreference file */
	call mdbm_util_$xref_create_record (local_iocb, ATTRIBUTE_KEY_HEAD,
	     create_attr_info.attribute (attribute_index).name, crossref_info_record.offset, error_message, code);
	if code ^= 0
	then call error (code, error_message);

/* Fill it the unreferenced_attribute structure. */
	new_ua_ptr -&gt; unreferenced_attribute.name = create_attr_info.attribute (attribute_index).name;
	new_ua_ptr -&gt; unreferenced_attribute.domain_ptr = crossref_info_record.offset;
	new_ua_ptr -&gt; unreferenced_attribute.fwd_thread = NULL_OFFSET;

/* Mark the domain in db_model referenced */
	di_ptr = ptr (dbm_ptr, new_ua_ptr -&gt; unreferenced_attribute.domain_ptr);
	domain_info.unreferenced = "0"b;

/* Add to the linked list */
	if db_model.unreferenced_attribute_ptr = NULL_OFFSET
	then db_model.unreferenced_attribute_ptr = rel (new_ua_ptr);
	else do;					/* chase down to end of list */
	     do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
		repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET);
		prev_ua_ptr = ua_ptr;
		end;				/* do ua_ptr */
	     prev_ua_ptr -&gt; unreferenced_attribute.fwd_thread = rel (new_ua_ptr);
	     end;

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, create_attr_info.attribute (attribute_index).domain,
	     RMDB_ADD_ATTR_OP, create_attr_info.attribute (attribute_index).name, error_message, code);

	call mdbm_util_$inconsistent_reset (dbm_ptr);

	revert quit;				/* END OF CRITICAL CODE */
	if quit_intercept_flag
	then signal quit;

	if code ^= 0
	then call error (code, error_message);		/* from rmdb_add_rmdb_history */

	return;
     end create_an_attribute;
%page;
%include mdbm_db_model;
%include mdbm_file_model;
%include mrds_rmdb_ctl;
%include rmdb_create_attr_info;
%include rmdb_crossref_info;
%include rmdb_history_entry;
%page;
dcl  addr builtin;
dcl  adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (35), fixed bin (35));
dcl  area condition;
dcl  bcnt fixed bin (35);				/* bit count */
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  DB_MODEL_NAME char (32) int static options (constant) init ("db_model");
dcl  error_message char (500);
dcl  error_table_$area_too_small fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;
dcl  fixed builtin;
dcl  Icreate_attr_info_ptr ptr parameter;
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  local_iocb ptr;				/* attribute/domain file iocb */
dcl  local_record_buffer (4) fixed bin (35);		/* large enough to read the header of the crossref_info_record into */
dcl  loop fixed bin (17);				/* loop index */
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
dcl  mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35));
dcl  mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  mdbm_util_$xref_reference entry (ptr, char (*), char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  mrds_error_$attr_already_exists fixed bin (35) ext static;
dcl  mrds_error_$no_db_path fixed bin (35) ext static;
dcl  mrds_error_$undefined_domain fixed bin (35) ext static;
dcl  new_ua_ptr ptr;				/* points the new create unreferenced_attribute structure in the db_model */
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  prev_ua_ptr ptr;
dcl  ptr builtin;
dcl  quit condition;
dcl  quit_intercept_flag bit (1) aligned;		/* true ::= break key was pressed */
dcl  rel builtin;
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
dcl  rtrim builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  unspec builtin;

     end rmdb_create_attribute;
���



		    rmdb_create_db.pl1              10/16/86  1534.4rew 10/16/86  1144.1       90522



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

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

/*
                            BEGIN_DESCRIPTION
   This procedure creates the skeleton of a database, including:
   db_model (data base model segment)
   dbc (database control segment)

   These segments are initialized before returning.
   If an error occures the data base is not created (it is deleted).

 		        END_DESCRIPTION
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     This routine is really mrds_rst_create_db with some changes in order that
     we may call it from something else besides the cmdb parser.
                                                   END HISTORY COMMENTS */

rmdb_create_db:
     proc (Idb_path, Irelation_type, Irelation_modes, Oabsolute_path, Odbm_ptr, Oerror_message, Ocode);

	relation_type = Irelation_type;
	relation_modes = Irelation_modes;

	db_created_sw = OFF;

	on cleanup call tidy_up;			/* Set a cleanup handler */

	call expand_pathname_$add_suffix (Idb_path, "db", dir, db_ent, code);
	if code ^= 0
	then call error (code, Idb_path);
	absolute_path = pathname_ (dir, db_ent);

	call hcs_$append_branchx (dir, db_ent, 11, RINGS, /* Create the data base directory */
	     get_group_id_$tag_star (), 1, 0, 0, code);
	if code ^= 0
	then call error (code, absolute_path);

	db_created_sw = ON;				/* Remember database directory was created */

/* create the submodel_dir */
	call hcs_$append_branchx (absolute_path, mrds_data_$submodel_dir_name, 11, RINGS, get_group_id_$tag_star (), 1,
	     0, 0, code);
	if code ^= 0
	then call error (code, pathname_ (absolute_path, mrds_data_$submodel_dir_name));

	call hcs_$make_seg (absolute_path, "db_model", "", 10, dbm_ptr, code);
						/* Create the db_model */
	if dbm_ptr = null
	then call error (code, pathname_ (absolute_path, DB_MODEL_NAME));
	else call init_db_model;

	call mdbm_util_$create_control_segment (absolute_path, dbc_ptr, dbc_bit_count, code);
	if code ^= 0
	then call error (code, pathname_ (absolute_path, DB_CONTROL_NAME));

	Oabsolute_path = absolute_path;		/* set output parameters */
	Odbm_ptr = dbm_ptr;
	db_created_sw = OFF;			/* so cleanup won't delete it */

	call error (0, "");

/* Only exit from this procedure */
exit:
	return;

%page;
error:
     proc (cd, msg);

dcl  cd fixed bin (35) parameter;
dcl  msg char (*) parameter;

	call tidy_up;
	Ocode = cd;				/* Set return error code */
	if cd = 0
	then Oerror_message = "";
	else Oerror_message = msg;
	goto exit;

     end error;

tidy_up:
     proc;					/* Clean up procedure */

	if db_created_sw				/* If database created then delete it */
	then do;
	     delete_options.force = ON;
	     delete_options.question = OFF;
	     delete_options.directory = ON;
	     delete_options.segment = ON;
	     delete_options.link = ON;
	     delete_options.chase = ON;
	     delete_options.raw = OFF;
	     delete_options.library = OFF;
	     delete_options.mbz = OFF;

	     call delete_$path (dir, db_ent, string (delete_options), MODULE_NAME, (0));

	     end;

     end tidy_up;
%page;
init_db_model:
     procedure;

/* This procedure initializes the db_model */

	db_model_path = rtrim (absolute_path) || DB_MODEL_NAME;

	db_model.version = mdbm_data_$current_version;
	db_model.dbm_area = empty;
	db_model.version_ptr = set_version ();
	db_model.changer_ptr = set_change_time ();
	db_model.uniq_sw_name = unique_chars_ ("0"b) || ".mrds";

	if relation_type = "vfile"
	then do;
	     db_model.db_type_flags.vfile_type = "1"b;
	     db_model.db_type_flags.transactions_needed = "0"b;
	     end;	     
	else if relation_type = "data_management_file"
	     then do;
		db_model.db_type_flags.vfile_type = "0"b;
		mode_bits.dm_file_type = "1"b;	/* default all on */
		mode_bits.protection_on = "1"b;
		mode_bits.concurrency_on = "1"b;
		mode_bits.rollback_on = "1"b;

		call mrds_rst_proc_ctl_args$parse_mode_string (relation_modes, mode_bits, code, error_message);
		if code ^= 0
		then call error (code, "Parsing the mode string """ || rtrim (relation_modes)
		     || """, encountered " || rtrim (error_message));

		db_model.db_type_flags.concurrency_on = mode_bits.concurrency_on;
		db_model.db_type_flags.transactions_needed = "1"b;
		db_model.db_type_flags.rollback_on = mode_bits.rollback_on;
		end;
	     else call error (error_table_$bad_arg, relation_type);

	db_model.consistant = "1"b;
	db_model.mdbm_secured = "0"b;
	db_model.copy_good = "0"b;
	db_model.reserved = "0"b;
	db_model.num_rels = 0;
	db_model.blk_file_id_len = 0;
	db_model.unblk_file_id_len = 0;
	db_model.num_blk_files = 0;
	db_model.num_unblk_files = 0;
	db_model.num_domains = 0;
	db_model.num_dyn_links = 0;
	db_model.max_max_tuples = 0;
	db_model.pad_1 = 0;
	db_model.pad_2 = 0;
	db_model.file_ptr = NULL_OFFSET;
	db_model.domain_ptr = NULL_OFFSET;
	db_model.unreferenced_attribute_ptr = NULL_OFFSET;
	db_model.unused_offsets (*) = NULL_OFFSET;
	db_model.last_restructuring_history_offset = NULL_OFFSET;
	db_model.inconsistent_message_offset = NULL_OFFSET;
	db_model.first_restructuring_history_offset = NULL_OFFSET;

	return;
     end init_db_model;
%page;
set_version:
     procedure () returns (bit (18));

/* fill in the version structure */
/* this major number was 7 for the MR8 mrds release,
   it was changed to 8 on 80-11-06, to signify the addition of the submodel_dir to the architecture */

	allocate version_status in (db_model.dbm_area) set (version_status_ptr);

/* CMDB/RMDB source code version */

	version_status.cmdb_rmdb.major = mrds_data_$current_version_status;
						/* MR8.0 */
	version_status.cmdb_rmdb.minor = 0;
	version_status.cmdb_rmdb.modification = " ";

/* database model version */

	version_status.model.major = mrds_data_$current_version_status;
	version_status.model.minor = 0;
	version_status.model.modification = " ";

/* resultant model version */

	version_status.resultant.major = mrds_data_$current_version_status;
	version_status.resultant.minor = 0;
	version_status.resultant.modification = " ";

	return (rel (version_status_ptr));

     end set_version;
%page;
set_change_time:
     procedure () returns (bit (18));

/* fill in the user_id and time for the database creator */

	allocate changer in (db_model.dbm_area) set (changer_ptr);

	changer.id = get_group_id_ ();
	changer.time = clock ();
	changer.next = NULL_OFFSET;			/* creator = last on list */

	return (rel (changer_ptr));

     end set_change_time;
%page;
%include mdbm_db_model;
%page;
%include mdbm_dbc;
%page;
%include mrds_rst_arg_info;
%page;
%include delete_options;
%page;
/* External entries */

dcl  empty builtin;
dcl  null builtin;
dcl  error_message char (500);
dcl  absolute_path char (168);
dcl  addr builtin;
dcl  cleanup condition;
dcl  clock builtin;
dcl  code fixed bin (35);				/* error code */
dcl  DB_CONTROL_NAME char (32) int static options (constant) init ("db.control");
dcl  db_created_sw bit (1);				/* ON =&gt; Db_directory was created */
dcl  db_ent char (32);				/* Data base directory name */
dcl  DB_MODEL_NAME char (32) int static options (constant) init ("db_model");
dcl  db_model_path char (168);			/* path down to db_model segment */
dcl  dbc_bit_count fixed bin (24);
dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  dir char (168);				/* Directory superior to data base */
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  fixed builtin;
dcl  get_group_id_ entry returns (char (32));
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_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  Idb_path char (*) parameter;
dcl  Irelation_modes char (*) parameter;
dcl  Irelation_type char (*) parameter;
dcl  mdbm_data_$current_version ext fixed bin (35);
dcl  mdbm_util_$create_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35));
dcl  1 mode_bits like db_relation_modes;
dcl  MODULE_NAME char (18) int static options (constant) init ("rmdb_create_db");
dcl  mrds_data_$current_version_status fixed bin (35) ext;	/* display_mrds_dm needs to know about this */
dcl  mrds_data_$submodel_dir_name char (16) ext;		/* common place to get name of submodel dir */
dcl  mrds_rst_proc_ctl_args$parse_mode_string entry (char(*), 1, 2 bit(1) unal, 2 bit(1) unal, 2 bit(1) unal,
	2 bit(1) unal, fixed bin(35), char(*));
dcl  NULL_OFFSET bit (18) unal int static options (constant) init ("111111111111111111"b);
dcl  Oabsolute_path char (*) parameter;
dcl  Ocode fixed bin (35) parameter;
dcl  Odbm_ptr ptr parameter;
dcl  Oerror_message char (*) parameter;
dcl  OFF bit (1) int static options (constant) init ("0"b);
dcl  ON bit (1) int static options (constant) init ("1"b);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  rel builtin;
dcl  relation_modes char (256);
dcl  relation_type char (32);
dcl  RINGS (3) fixed bin (3) init static options (constant) init (7, 7, 7);
						/* Ring brackets */
dcl  rtrim builtin;
dcl  string builtin;
dcl  sys_info$max_seg_size ext fixed bin (35);
dcl  unique_chars_ entry (bit (*)) returns (char (15));	/* unique char string routine */

     end rmdb_create_db;
��



		    rmdb_create_descriptor.rd       10/16/86  1534.1rew 10/16/86  1530.3      136998



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

/* HISTORY COMMENTS:
  1) change(85-12-03,JBlair), approve(85-12-03,MCR7311),
     audit(86-09-24,Gilcrease), install(86-10-16,MR12.0-1187):
     Modified from the new_call subroutine. Added complex numbers. Enforce
     max string length.
                                                   END HISTORY COMMENTS */

/*++
PUSH DOWN LANGUAGE \
BEGIN	/ &lt;no-token&gt;		/						/ error	\

attr	/ dimension		/ 		DELETE LEX(2)			/ error   \
	/ dim			/ 		DELETE LEX(2)			/ error	\
	/ aligned			/ set (aligned, 1) 	DELETE				/ attr	\
	/ unaligned		/ set (aligned, 0) 	DELETE				/ attr	\
	/ unal			/ set (aligned, 0) 	DELETE				/ attr	\
	/ fixed			/ set (type, 1)	DELETE				/ attr	\
	/ float			/ set (type, 3)	DELETE				/ attr	\
	/ binary			/ set (base, 1)	DELETE				/ attr	\
	/ bin			/ set (base, 1)	DELETE				/ attr	\
	/ decimal			/ set (base, 2)	DELETE				/ attr	\
	/ dec			/ set (base, 2)	DELETE				/ attr	\
	/ real			/ set (mode, 1)	DELETE				/ attr	\
	/ complex			/ set (mode, 2)	DELETE				/ attr	\
	/ cplx			/ set (mode, 2)	DELETE				/ attr	\
	/ precision		/ 		DELETE LEX(2)			/ prec	\
	/ prec			/ 		DELETE LEX(2)			/ prec	\
	/ (			/        		       LEX(2)			/ prec	\
	/ bit			/ set (type, 19)	DELETE				/ length	\
	/ character		/ set (type, 21)	DELETE				/ length	\
	/ char			/ set (type, 21)	DELETE				/ length	\
	/ varying			/ set (varying, 1)	DELETE				/ attr	\
	/ var			/ set (varying, 1)	DELETE				/ attr	\
	/ nonvarying		/ set (varying, 0)	DELETE				/ attr	\
	/ signed			/ set (signed, 1)	DELETE				/ attr	\
	/ uns			/ set (signed, 0)	DELETE				/ attr	\
	/ unsigned		/ set (signed, 0)	DELETE				/ attr	\
	/ &lt;any-token&gt;		/ [code = mrds_error_$bad_attribute]			/ RETURN	\
	/ &lt;no-token&gt;		/						/ RETURN	\


error	/ ) &lt;any-token&gt;		/ [code = error_table_$improper_data_format]		/ RETURN	\


prec_err	/			/ [code = mrds_error_$bad_precision]			/ RETURN	\

length	/ (			/		       LEX(2)			/ length_	\
	/			/						/ attr	\
length_	/ ( &lt;decimal-integer&gt; )	/ LEX(-1) set(LENGTH, token.Nvalue) DELETE(-1,+1)		/ attr	\
	/ ( * )			/	set(LENGTH, 16777215)     DELETE(-2,0)		/ attr	\
	/			/						/ error	\

prec	/ ( &lt;decimal-integer&gt; )	/ LEX(-1) set(SIZE, token.Nvalue) DELETE(-1,+1)		/ attr	\
	/ ( &lt;decimal-integer&gt; ,	/ LEX(2)						/	\
	/ ( &lt;decimal-integer&gt; , &lt;decimal-integer&gt; )
				/ LEX(-3) set(SIZE, token.Nvalue)
				  LEX(+2) set(scale,token.Nvalue) DELETE(-3,+1)		/ attr	\
	/			/						/ prec_err \
										++*/

rmdb_create_descriptor: procedure (Astring, Ptemp, Pdesc, code);
						/* This internal procedure converts an argument	*/
						/*  declaration (PL/I style) into an argument	*/
						/*  descriptor.				*/
     dcl	Astring			char(*),		/* argument declaration. (In)			*/
	Ptemp			ptr,		/* ptr to a translator_temp_ segment in which	*/
						/*  allocations can be made. (In)		*/
						/* ptr to created argument descriptor. (Out)	*/
	Saddr			bit(1) aligned,	/* on if addr(declaration) was given. (Out)	*/
	code			fixed bin(35);	/* error code diagnosing any errors. (Out)	*/

     dcl	1 D			aligned,
	  2 type			fixed bin,
	  2 Spacked		bit(1),
	  2 Ndims			fixed bin,
	  2 size			fixed bin(24),
	  2 scale			fixed bin(24),
	Lit			fixed bin,
	Lstr			fixed bin,
	Ndims			fixed bin,
	Nparens			fixed bin,
	Pit			ptr,
	Pstr			ptr,
         (aligned, address, signed,
	varying)	                    fixed bin(1),
         (base, mode)		fixed bin(2),
          i			fixed bin,
         (LENGTH, SIZE)		fixed bin(24),
	scale			fixed bin(8),
	type			fixed bin(6);

     dcl	it			char(Lit) based (Pit),
	str			char(Lstr) based (Pstr),
	str_array (Lstr)		char(1) based (Pstr),
          value			bit(36) aligned based (Pdesc); 
     dcl  Pdesc	ptr;
		
	
     dcl (addr, bit, divide, length, null, search, size, string)
				builtin;

     dcl	set			generic (	set1  when (fixed bin(1),*),
					set2  when (fixed bin(2),*),
					set6  when (fixed bin(6),*),
					set8  when (fixed bin(8),*),
					set24 when (fixed bin(24),*));

     dcl (mrds_error_$bad_array_bounds,
	mrds_error_$bad_attribute,
	mrds_error_$bad_precision,
          mrds_error_$inconsistent_attributes,
	mrds_error_$invalid_string_length,
	mrds_data_$max_string_size,
	error_table_$improper_data_format,
	error_table_$unbalanced_parentheses)
				fixed bin(35) ext static;

	Saddr = "0"b;
	code = 0;					/* clear error code.			*/
	Ptoken, Pthis_token = null;			/* initialize semantic analysis variables.	*/
	Nparens = 0;				/* initialize parenthesis depth count.		*/
	Pstr = addr(Astring);			/* overlay PL/I argument declaration.		*/
	Lstr = length(Astring);
	aligned = -1;
	type = -1;
	base = -1;
	mode = -1;
	signed = -1;
	varying = -1;
	address = -1;
	Ndims = 0;
	LENGTH = -1;
	SIZE = -1;
	scale = -129;

	do while (Lstr &gt; 0);			/* parse declaration into tokens.		*/
	     i = search (str, " _,():");
	     if i = 0 then
		i = Lstr + 1;
	     if i &gt; 1 then do;
		Pit = Pstr;
		Lit = i-1;
		call make_token (it);
		if i &lt;= Lstr then do;
		     Pstr = addr(str_array(i));
		     Lstr = Lstr - (i-1);
		     end;
		else Lstr = 0;
		end;
	     if Lstr &gt; 0 then do;
		Pit = Pstr;
		Lit = 1;
		if      it = "(" then Nparens = Nparens + 1;
		else if it = ")" then Nparens = Nparens - 1;
		if      it = " " then;
		else if it = "_" then;
		else call make_token(it);
		if Lstr &gt; 1 then
		     Pstr = addr(str_array(2));
		Lstr = Lstr - 1;
		end;
	     end;
	if Nparens ^= 0 then do;
	     code = error_table_$unbalanced_parentheses;
	     return;
	     end;
	call SEMANTIC_ANALYSIS();
	if code = -1 then do;
	     code = 0;
	     return;
	     end;
	if code ^= 0 then return;

						/* apply PL/I Lanuage Default Rules.		*/
	if type = -1 then				/* default(^(character|bit|pointer|offset|area|	*/
	     if base = -1 then			/*  label|entry|file|fixed|float|binary|decimal|	*/
		if mode = -1 then do;		/*  real|complex)) fixed binary real;		*/
		     type = 1;
		     base = 1;
		     mode = 1;
		     end;
	if type = -1 then do;
	     if mode ^= -1 then			/* default((real|complex)&amp;^float) fixed;	*/
	          if type ^= 3 then type = 1;
	     if base ^= -1 then			/* default((binary|decimal)&amp;^float) fixed;	*/
	          if type ^= 3 then type = 1;
	     end;
	if (type = 1) | (type = 3) then		/* default((fixed|float)&amp;^complex) real;	*/
	     if mode ^= 2 then mode = 1;
	if (type = 1) | (type = 3) then		/* default((fixed|float)&amp;^decimal) binary;	*/
	     if base ^= 2 then base = 1;
	if type = 1 then				/* default(fixed&amp;binary&amp;^precision)		*/
	     if base = 1 then			/*  precison(17,0);				*/
		if SIZE = -1 then do;
		     SIZE = 17;
		     scale = 0;
		     end;
		else if scale = -129 then
		     scale = 0;
	if type = 1 then				/* default(fixed&amp;decimal&amp;^precision)		*/
	     if base = 2 then			/*  precision(7,0);				*/
		if SIZE = -1 then do;
		     SIZE = 7;
		     scale = 0;
		     end;
		else if scale = -129 then
		     scale = 0;
	if type = 3 then				/* default(float&amp;binary&amp;^precision)		*/
	     if base = 1 then			/*  precision(27);				*/
		if SIZE = -1 then SIZE = 27;
	if type = 3 then				/* default(float&amp;decimal&amp;^precision)		*/
	     if base = 2 then			/*  precision(10);				*/
		if SIZE = -1 then SIZE = 10;
	if type = 18 then				/* default(character&amp;^length) length(1024);	*/
	     if LENGTH = -1 then LENGTH = 1024;
	if (type = 19) | (type = 21) then do;		/* default((character|bit)&amp;^length) length(1);	*/
	     if LENGTH = -1 then LENGTH = 1;
						/* default((character|bit)&amp;^varying) nonvarying;	*/
	     if varying ^= 1 then varying = 0;
						/* default((character|bit)&amp;^aligned) unaligned;	*/
	     if aligned ^= 1 then aligned = 0;
	     end;
	if aligned ^= 0 then aligned = 1;		/* default(^unaligned) aligned;		*/

	go to do(type);

do(1):						/* it's a fixed number.			*/
	     if base = 1 then do;			/*      a fixed binary number.		*/
		if SIZE  &gt;   35 then type = type + 1;	/*      a fixed binary long number.		*/
		if mode  =    2 then type = type + 4;	/*      a complex fixed binary number.		*/
		if SIZE  &gt;   71 then go to error_oob;
		if SIZE  &lt;    1 then go to error_oob;
		if scale &gt; +127 then go to error_oob;
		if scale &lt; -128 then go to error_oob;
		end;
	     else  /* if base = 2 then */  do;		/*      a fixed decimal number.		*/
		type = type + 8;
		if mode  =    2 then type = type + 2;	/*      a complex fixed decimal number.		*/
		if aligned = 0 then type = type + 34;        /*      4-bit byte aligned.                       */
		if SIZE  &gt;   59 then go to error_oob;
		if SIZE  &lt;    1 then go to error_oob;
		if scale &gt; +127 then go to error_oob;
		if scale &lt; -128 then go to error_oob;
		end;
	     if varying ^= -1 then go to error;
	     if LENGTH ^= -1 then go to error;
	     if type &lt; 3 &amp; signed = 0 then
		type = type + 32;
	     go to join;

do(3):						/* it's a floating number.			*/
	     if base = 1 then do;			/*      a float binary number.		*/
		if SIZE  &gt;   27 then type = type + 1;	/*      a float binary long number.		*/
		if mode  =    2 then type = type + 4;	/*      a complex float binary number.		*/
		if SIZE  &gt;   63 then go to error_oob;
		if SIZE  &lt;    1 then go to error_oob;
		if scale = -129 then;
		else            go to error;
		end;
	     else  /* if base = 2 then */  do;		/*      a float decimal number.		*/
		type = type + 7;
		if mode  =    2 then type = type + 2;	/*      a complex float decimal number.		*/
		if aligned = 0 then type = type + 34;        /*      4-bit byte aligned.                       */
		if SIZE  &gt;   59 then go to error_oob;
		if SIZE  &lt;    1 then go to error_oob;
		if scale = -129 then;
		else            go to error;
		end;
	     if varying ^= -1 then go to error;
	     if LENGTH ^= -1 then go to error;
	     scale = 0;
	     go to join;


do(19):						/* it's a bit string.			*/
do(21):						/* it's a character string.			*/
	     if varying = 1 then do;			/*      a varying string.			*/
		type = type + 1;
		if aligned ^= 1 then aligned = 1;
		end;
	     if base ^= -1 then go to error;
	     if mode ^= -1 then go to error;
	     if scale ^= -129 then go to error;
	     if SIZE ^= -1 then go to error;
	     if LENGTH &lt; 0 then go to error_oob;
	     if (type = 19 &amp; divide (LENGTH+35, 36, 24, 0) &gt; mrds_data_$max_string_size) |
	        (type = 21 &amp; LENGTH &gt; mrds_data_$max_string_size)
	     then do;
		code = mrds_error_$invalid_string_length;
		return;
		end;
	     SIZE = LENGTH;
	     go to join;

join:
	D.type = type;
	D.Spacked = ^bit(aligned,1);
	D.Ndims = 0;
	D.size = SIZE;
	D.scale = scale;

	D.Ndims = Ndims;
	call encode_descriptor (D.type, D.Spacked, D.Ndims, D.size, D.scale, value);
	if address = 1 then Saddr = "1"b;
	return;

error:	code = mrds_error_$inconsistent_attributes;
	return;
error_array:
	code = mrds_error_$bad_array_bounds;
	return;
error_oob:
	code = mrds_error_$bad_precision;
	return;

%include translator_temp_alloc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


make_token: proc (value);				/* internal procedure to make a token descriptor.	*/

     dcl	value			char(*);		/* value of the token.			*/
     dcl	P			ptr;		/* ptr to newly-allocated token.		*/

	P = allocate (Ptemp, size(token));
	if Ptoken = null then do;
	     P-&gt;token.Plast = null;
	     Pthis_token = P;
	     Ptoken = P;
	     end;
	else do;
	     token.Pnext = P;
	     P-&gt;token.Plast = Ptoken;
	     Ptoken = token.Pnext;
	     end;
	token.Pnext = null;
	token.Pvalue = addr(value);
	token.Lvalue = length(value);
	token.Nvalue = 0;
	token.Pstmt = null;
	token.Psemant = null;
	string(token.S) = ""b;

	end make_token;

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


set1:	procedure (var1, value);			/* if var hasn't been set1 yet, set1 it to value;	*/
						/*  else complain.				*/
     dcl	var1			fixed bin(1),
	var2			fixed bin(2),
	var6			fixed bin(6),
	var8			fixed bin(8),
	var24			fixed bin(24),
	value			fixed bin(35) unal;

	if var1 ^= -1 then go to error;
	var1 = value;
	return;


set2:	entry	(var2, value);

	if var2 ^= -1 then go to error;
	var2 = value;
	return;



set6:	entry 	(var6, value);

	if var6 ^= -1 then go to error;
	var6 = value;
	return;

set8:	entry	(var8, value);

	if var8 ^= -129 then go to error;
	var8 = value;
	return;


set24:	entry	(var24, value);

	if var24 ^= -1 then go to error;
	var24 = value;

	end set1;
%page;

encode_descriptor: procedure (type, packed, Ndims, size, scale, descriptor);

     dcl	type			fixed bin,	/* data type	*/
	packed			bit(1) aligned,	/* on if data packed*/
	Ndims			fixed bin,	/* dimension (data)	*/
	size			fixed bin (24),	/* size (data)	*/
	scale			fixed bin (24),	/* scale (data)	*/
	descriptor		bit(36) aligned;	/* descriptor (data)*/

     dcl	1 D			based (addr (descriptor)) aligned,
	 (2 flag			bit (1),
	  2 type			bit (6),
	  2 packed		bit (1),
	  2 Ndims			bit (4),
	  2 size			bit (24)) unaligned;

     dcl (addr, bit, fixed, substr)	builtin;



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


	D.flag = "1"b;				/* new type desc.	*/
	D.type = bit (fixed (type, 6), 6);		/* set type	*/
	D.packed = packed;				/* set packed bit	*/
	go to set (type);

set( 1):				/* real fixed bin short		*/
set( 2):				/* real fixed bin long		*/
set( 3):				/* real float bin short		*/
set( 4):				/* real float bin long		*/
set( 5):				/* complex fixed bin short		*/
set( 6):				/* complex fixed bin long		*/
set( 7):				/* complex float bin short		*/
set( 8):				/* complex float bin long		*/
set( 9):				/* real fixed decimal		*/
set(10):				/* real float decimal		*/
set(11):				/* complex fixed decimal		*/
set(12):				/* complex float decimal		*/
set(33):	                              /* real fixed binary short unsigned     */
set(34):	                              /* real fixed binary long unsigned
   */
set(43):	                              /* real fixed decimal 4-bit byte-aligned*/
set(44):	                              /* real float decimal 4-bit byte_aligned*/
set(45):	                              /* complex fixed dec 4-bit byte_aligned */
set(46):	                              /* complex float dec 4-bit byte_aligned */
	D.Ndims = bit (fixed (Ndims, 4), 4);
	if scale &lt; 0 then
	     substr (D.size, 1, 12) = bit (fixed (scale + 1000000000000b, 12), 12);
	else
	     substr (D.size, 1, 12) = bit (fixed (scale, 12), 12);
	substr (D.size, 13, 12) = bit (fixed (size, 12), 12);
	return;


set(19):				/* bit string			*/
set(20):				/* varying bit string		*/
set(21):				/* character string			*/
set(22):				/* varying character string		*/
	D.Ndims = bit (fixed (Ndims, 4), 4);
	D.size = bit (fixed (size, 24), 24);
	return;

	end encode_descriptor;
��



		    rmdb_create_domain.pl1          10/16/86  1532.7rew 10/16/86  1530.3      102195



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

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

/*DESCRIPTION
  This routine creates unreferenced domains in the db_model segment. The
  specified domains must not already exist. The crossreference is updated with
  the created domains.
/*

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-24,Blair), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

rmdb_create_domain:
     proc (Irmdb_ctl_ptr, Icreate_domain_info_ptr, Oerror_message, Ocode);

	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	if rmdb_ctl.version ^= RMDB_CTL_VERSION_1
	then call error (error_table_$unimplemented_version,
		"Version " || ltrim (char (rmdb_ctl.version)) || " of rmdb_ctl structure.");

	create_domain_info_ptr = Icreate_domain_info_ptr;

	if create_domain_info.version ^= create_domain_info_version_1
	then call error (error_table_$unimplemented_version,
		"Version " || create_domain_info.version || " of create_domain_info structure.");

	if create_domain_info.count &lt; 1
	then call error (error_table_$action_not_performed, "No domains to create.");

	dbm_ptr = rmdb_ctl.db_model_ptr;
	if rmdb_ctl.crossref_file_info.iocb_ptr = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr,
		rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     end;
	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;

/* Loop through all domains to be created to see if they already exist. */
	do loop = 1 to create_domain_info.count;
	     call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (loop), null, 0,
		error_message, code);
	     if code = 0
	     then call error (mrds_error_$domain_already_defined, create_domain_info.name (loop));
	     else if code ^= error_table_$no_record
		then call error (code, error_message);
	     end;					/* do loop */

/* Find the pointer to the last domain_info structure so we can add on the end
   of the linked list. */
	last_di_ptr = null;
	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
	     while (rel (di_ptr) ^= NULL_OFFSET);
	     last_di_ptr = di_ptr;
	     end;					/* do di_ptr */

/* Trap areas so we can return a intelligable error message. */
	on area call error (error_table_$area_too_small, "Creating domain_info in the db_model segment.");

/* Now go through and create each domain. */
	do loop = 1 to create_domain_info.count;
	     call create_a_domain (loop);
	     end;					/* do loop */

	call error (0, "");

RETURN_TO_CALLER:
	return;

error:
     proc (cd, msg);

dcl  cd fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = cd;
	if cd = 0
	then Oerror_message = "";
	else Oerror_message = error_message;
	goto RETURN_TO_CALLER;
     end error;
%page;
create_a_domain:
     proc (idx);

dcl  idx fixed bin parameter;
dcl  new_changer_ptr ptr;
dcl  new_di_ptr ptr;
dcl  new_path_ptr (3) ptr;
dcl  quit_occured bit (1) aligned;

	quit_occured = "0"b;

	new_di_ptr, new_path_ptr (*), new_changer_ptr = null;
	on cleanup call cleaner;

	on quit quit_occured = "1"b;			/* BEGIN CRITICAL CODE */

	call mdbm_util_$inconsistent_set (dbm_ptr, "create_attribute",
	     "Creating attribute " || create_domain_info.name (idx),
	     "delete_domain -force -inhibit_error " || create_domain_info.name (idx));

/* Create the new domain_info structure and populate it */
	allocate domain_info in (db_model.dbm_area) set (new_di_ptr);
	unspec (new_di_ptr -&gt; domain_info) = "0"b;
	new_di_ptr -&gt; domain_info.name = create_domain_info.name (idx);
	new_di_ptr -&gt; domain_info.unreferenced = "1"b;

	new_di_ptr -&gt; domain_info.db_desc = create_domain_info.descriptor (idx);
	new_di_ptr -&gt; domain_info.user_desc = create_domain_info.decode_declare_data_descriptor (idx);
	if new_di_ptr -&gt; domain_info.user_desc = "0"b
	then new_di_ptr -&gt; domain_info.user_desc = new_di_ptr -&gt; domain_info.db_desc;

	new_di_ptr -&gt; domain_info.fwd_thread = NULL_OFFSET;

	call set_path (new_di_ptr -&gt; domain_info.check_path_ptr, create_domain_info.check_proc_path (idx), 1);
	call set_path (new_di_ptr -&gt; domain_info.encd_path_ptr, create_domain_info.encode_proc_path (idx), 2);
	call set_path (new_di_ptr -&gt; domain_info.decd_path_ptr, create_domain_info.decode_proc_path (idx), 3);

	new_di_ptr -&gt; domain_info.ck_stack_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.str_before_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.str_err_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.str_after_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.get_before_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.get_err_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.get_after_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.mod_before_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.mod_err_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.mod_after_path_ptr = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.unused_1 = NULL_OFFSET;
	new_di_ptr -&gt; domain_info.unused_2 = NULL_OFFSET;

/* Create the changer structure and populate it. */
	allocate changer in (db_model.dbm_area) set (new_changer_ptr);
	new_changer_ptr -&gt; changer.id = get_group_id_ ();
	new_changer_ptr -&gt; changer.time = clock ();
	new_changer_ptr -&gt; changer.next = NULL_OFFSET;

	new_di_ptr -&gt; domain_info.changer_ptr = rel (new_changer_ptr);

/* Add the new domain to the crossreference file */
	call mdbm_util_$xref_create_record (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (idx),
	     rel (new_di_ptr), error_message, code);
	if code ^= 0
	then do;
	     call cleaner;
	     call error (code, error_message);
	     end;

/* Add a new attribute record to the crossreference file, as all domains have
   an attribute with the same name be default. */
	call mdbm_util_$xref_create_record (local_iocb, ATTRIBUTE_KEY_HEAD, create_domain_info.name (idx),
	     rel (new_di_ptr), error_message, code);
	if code ^= 0
	then do;
	     call cleaner;
	     call error (code, error_message);
	     end;

/* Now we mark the created domain record as referenced by the attribute with
   the same name */
	call mdbm_util_$xref_reference (local_iocb, DOMAIN_KEY_HEAD, create_domain_info.name (idx),
	     create_domain_info.name (idx), null, (0), error_message, code);
	if code ^= 0
	then do;
	     call cleaner;
	     call error (code, error_message);
	     end;

/* Add the new domain_info to the end of the linked list. */
	if last_di_ptr = null
	then db_model.domain_ptr = rel (new_di_ptr);
	else last_di_ptr -&gt; domain_info.fwd_thread = rel (new_di_ptr);
	last_di_ptr = new_di_ptr;

	db_model.num_domains = db_model.num_domains + 1;

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, create_domain_info.name (idx), RMDB_ADD_DMN_OP, "",
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

	call mdbm_util_$inconsistent_reset (dbm_ptr);

	revert quit;				/* END CRITICAL CODE */
	if quit_occured
	then signal quit;

	return;
%page;
cleaner:
     proc;

dcl  based_item fixed bin (35) based;
dcl  p ptr;

/* Free all the created structures in db_model segment */
	do p = new_changer_ptr, new_di_ptr, new_path_ptr (1), new_path_ptr (2), new_path_ptr (3);
	     if p ^= null
	     then free p -&gt; based_item;
	     end;

	call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
	     rmdb_ctl.crossref_file_info.name, (""), (0));

	call mdbm_util_$inconsistent_reset (dbm_ptr);

	return;
     end cleaner;

set_path:
     proc (sp_offset, sp_path, sp_idx);

dcl  sp_dir char (168);
dcl  sp_dollar_index fixed bin;
dcl  sp_entry char (32);
dcl  sp_idx fixed bin parameter;
dcl  sp_name char (32);
dcl  sp_offset bit (18) unaligned parameter;
dcl  sp_path char (*) parameter;

	if sp_path = ""
	then do;
	     sp_offset = NULL_OFFSET;
	     new_path_ptr (idx) = null;
	     end;
	else do;
	     sp_dollar_index = index (sp_path, "$");
	     if sp_dollar_index ^= 0
	     then do;
		sp_entry = substr (sp_path, sp_dollar_index + 1);
		substr (sp_path, sp_dollar_index) = "";
		end;
	     else sp_entry = "";
	     call expand_pathname_ (sp_path, sp_dir, sp_name, code);
	     if code ^= 0
	     then call error (code, sp_path);

	     allocate path_entry in (db_model.dbm_area) set (new_path_ptr (idx));
	     new_path_ptr (idx) -&gt; path_entry.path = pathname_ (sp_dir, sp_name);
	     if sp_entry = ""
	     then new_path_ptr (idx) -&gt; path_entry.entry = sp_name;
	     else new_path_ptr (idx) -&gt; path_entry.entry = sp_entry;

	     new_path_ptr (idx) -&gt; path_entry.reserved = "0"b;
	     sp_offset = rel (new_path_ptr (idx));
	     end;

	return;
     end set_path;

     end create_a_domain;
%page;
%include mdbm_db_model;
%page;
%include rmdb_create_domain_info;
%include rmdb_crossref_info;
%include rmdb_history_entry;
%include mrds_rmdb_ctl;
%page;
dcl  addr builtin;
dcl  area condition;
dcl  char builtin;
dcl  cleanup condition;
dcl  clock builtin;
dcl  code fixed bin (35);
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$area_too_small fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  fixed builtin;
dcl  get_group_id_ entry () returns (char (32));
dcl  Icreate_domain_info_ptr ptr parameter;
dcl  index builtin;
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  last_di_ptr ptr;
dcl  local_iocb ptr;
dcl  loop fixed bin (17);
dcl  ltrim builtin;
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
dcl  mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35));
dcl  mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  mdbm_util_$xref_reference entry (ptr, char (*), char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  mrds_error_$domain_already_defined fixed bin (35) ext static;
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  ptr builtin;
dcl  quit condition;
dcl  rel builtin;
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  unspec builtin;

     end rmdb_create_domain;
�



		    rmdb_create_index.pl1           10/16/86  1551.9r w 10/16/86  1143.2      242442



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


/****^  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-06 by Thanh
     Nguyen. (see mrds #136)
                                                   END HISTORY COMMENTS */


rmdb_create_index: proc (rci_rmdb_ctl_ptr, rci_db_abs_path, rci_db_model_ptr, rci_rel_name, rci_attr_name, rci_error_message, rci_code);

/*
                           BEGIN_DESCRIPTION
   This module will change a non-indexed  attribute  in  a  relation
   into an indexed attribute.

   This process involves both updating the structures in  the  model
   and writing the new index.

   An  attempt  has   been   made   to   make   certain   operations
   uninterruptable  by the user. These operations are the updates to
   the data model (including marking the data base as  inconsistent)
   and the addition of  a   new index. To do this any quits signaled
   by the  user  are  delayed  until  the  operations  are  complete.


   NOTE:
         Naming convention: because of the number of  internal  routines
         and the need for descriptive 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.
   
         In order to reduce the complexity of this module, none  of  the
         internal  routines  have  an error code parameter. Instead they
         set a global error code declared in the main routine, call  the
         clean_up  routine,  and  perform  a non-local goto to leave the
         module.
                          END_DESCRIPTION

   Known Bugs:

   Other Problems:

                          HISTORY
   82-04-23 Davids: Written

   82-04-29 Davids: changed   to   use   the  new  calling   sequence  of
                    mu_db_inconsistent also changed the  output  messages
                    and  comments  to  reflect  that amdb will NOT have a
                    -consistent control arg.
    
                    changed cleanup routine so that calls to  iox_$detach
                    and  iox_$destroy are always made even if the call to
                    iox_close fails, this is because the  iocb  could  be
                    attached but not open.
   
   82-04-30 Davids: changed to use the $set entry  in  mu_db_inconsistent
                    which  is  still  the main entry but more discriptive
                    also added the " -brief"  control  arg  on  the  undo
                    request and added the call to iox_$control "start" to
                    the cleanup handler.

   82-05-07 Davids: added    code    to    signal    quit    after    the
                    exit_rmdb_create_index label so that  if  the  caller
                    hits  quit and then an error occurs the quit does not
                    get  lost  because  the  error  handling  code  calls
                    cleanup   and   then   does   a   non-local  goto  to
                    exit_rmdb_create_index.

   82-05-25 Davids: added rci_db_model_ptr  parameter  and  removed  code
                    that used toget the pointer.

   82-06-24 Davids: removed   declared   but   unreferenced    variables,
                    reformated  lines  to  prevent  wrap-around.  changed
                    -force to -brief in the undo request.

   82-07-01  Roger Lackey : Modified the calls to  mu_db_inconsistent  to
	                  use mdbm_util_$inconsistent_* for binding.

   82-07-02 R. Harvey : Modified the calls to mu_data_length, mu_data_class$*,
	              mu_encd_key$*, mu_scan_records$* for binding

   82-07-20 Davids: corrected  the way that the tuple_id was built in the
                    get_a_tuple procedure, it was taking the first 7 bits
                    from the  file_id , it  was supposed to be taking the 
                    last 7. 

   82-08-20 D. Woodka : deleted references to mdbm_tuple_id  include file
	              for DMS conversion.

   82-09-15 D. Woodka : Modified for DMS Conversion: removed references
	              to tuples and modified the module to call 
	              rmdb_relmgr_entries.open and
	              rmdb_relmgr_entries.create_index

   83-01-06 Davids: Modified the internal procedure get_attribute_data to
   no longer calculate the new_index_id and to no longer check the
   rel_info.max_attr_index_id to be sure its &lt; 512 which was needed to be 
   sure that the newly calculated value would fit in the 8-bit field.
   The relation manager will be suppling the new index_id. Also modified
   the internal proc update_model to null the attr_info.index_id and set
   rel_info.max_attr_index_id to 512. The index_id must be nulled so that
   when the vfile relation manager looks at the model it knows that the field
   is not an index yet. The value of max_attr_index_id is set to 512 to keep
   MR10.1 rmdb from working since once MR10.2 rmdb is used the way that
   MR10.1 rmdb calcualted the index id cannot be guarenteeded to produce an
   index_id that MR10.2 rmdb did not already use.

   Added code to handle transactions.

   83-01-14 Davids: Modified code to report error in transaction finishing and
   to correctly handle reporting errors in the clean_up procedure.

   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-05-24 Davids: Added code to change the version of the saved resultant
   so that it will not be incorrectly used in an opening.
*/
%page;
/* PARAMETERS */

	dcl     rci_db_abs_path	 char (168);	/* (input) path to the data base to be restructured */
	dcl     rci_db_model_ptr	 ptr;		/* (input) pointer to the db_model for the database */
	dcl     rci_rel_name	 char (*);	/* (input) name of relation to be restructured */
	dcl     rci_attr_name	 char (*);	/* (input) name of attribute to be indexed */
	dcl     rci_error_message	 char (500);	/* (output) text of message in the event of an error */
	dcl     rci_code		 fixed bin (35);	/* (output) standard error message */

/* AUTOMATIC */

	dcl     rci_attr_defn_order	 fixed bin;
	dcl     rci_attr_desc	 bit (36);	/* standard multics descriptor of the attribute to be indexed */
	dcl     rci_attr_ptr	 ptr;		/* pointer to the attr_info structure */
	dcl     rci_backout_occured	 bit (1);		/* true if restore_significant_data has been called */
	dcl     rci_caller_name	 char (17);	/* for call to get_temp_segment_ */
	dcl     rci_file_id		 bit (36);	/* id of the file as defined in the database model */
	dcl     rci_file_model_ptr	 ptr;		/* pointer to the file model that contains the relation */
	dcl     rci_flag_list	 bit (36) aligned;	/* flag structure for create_index */
	dcl     rci_max_data_length	 fixed bin;	/* maximum number of bits of data a tuple may have, if tuple */
						/* contains varying data the actual number may be less */
	dcl     rci_number_of_attrs	 fixed bin;	/* number of attributes in the relation */
	dcl     rci_number_of_varying_attrs fixed bin;	/* number of varying attributes in the relation */
	dcl     rci_original_rel_info_indexed bit (1);	/* value of the indexed element in rel_info before the model was updated */
	dcl     rci_original_rel_info_max_attr_index_id fixed bin; /* ditto */
	dcl     rci_quit_signaled
				 bit (1);		/* true if a quit was signaled */
	dcl     rci_rel_id		 bit (36);	/* id of the relation as defined in rel_info */
	dcl     rci_rel_opening_id	 bit (36) aligned;	/* opening identifier of the relation */
	dcl     rci_rel_ptr		 ptr;		/* pointer to the rel_info structure */
	dcl     rci_rmdb_ctl_ptr	 ptr;
	dcl     rci_style		 fixed bin (17) init (1);
	dcl     wa		 area;


/* BUILTINS */

	dcl     addr		 builtin;
	dcl     ceil		 builtin;
	dcl     empty		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     pointer		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;

/* BAESED */

	dcl     rci_based_char8	 char (8) based;	/* overlay on the saved res version */

/* CONDITIONS */

	dcl     any_other		 condition;
	dcl     cleanup		 condition;
	dcl     quit		 condition;
%page;
/* ENTRIES */

	dcl     hcs_$initiate	 entry (char (*), char (*), char (*),
				 fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     ioa_$rs		 entry () options (variable);
	dcl     mdbm_util_$mu_data_length entry (bit (36)) returns (fixed bin (35));
	dcl     mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     rmdb_add_rmdb_history	 entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static; /* needed by include files */

/* INCLUDES */
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mdbm_index;
%page;
%include rmdb_history_entry;
%page;
%include mrds_rmdb_ctl;
%page;
%include dm_rel_creation_info;
%page;
%include dm_id_list;
%page;
%include dm_relation_index_flags;
%page;
/*
   Initialize variables which may be referenced before they are  set
   somewhere else
*/
	rci_quit_signaled = "0"b;
	rmdb_ctl_ptr = rci_rmdb_ctl_ptr;
	rci_rel_opening_id = "0"b;
	rci_backout_occured = "0"b;
	mstxn_transactions_needed = "0"b;
	mstxn_txn_id = "0"b;

/* 
   If the database needs transactions and one is already in progress stop right now.
*/
	if rci_db_model_ptr -&gt; db_model.db_type_flags.transactions_needed
	then do;
		mstxn_transactions_needed = "1"b;
		call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
		if mstxn_code ^= dm_error_$no_current_transaction
		then do;
			rci_code = error_table_$action_not_performed;
			rci_error_message = "Indexes may not be created while a transaction is in progress, " ||
			     "commit or abort current transaction and try again.";
			goto exit_rmdb_create_index;
		     end;
	     end;

/*
   Get pointers to the db_model and relation's file  model,  extract
   from  the  models  those values needed to build the index
*/

	call initiate_models (rci_db_abs_path, rci_rel_name, rci_file_model_ptr);

	call get_relation_data (rci_db_model_ptr, rci_file_model_ptr, rci_rel_name, rci_file_id,
	     rci_rel_ptr, rci_rel_id, rci_number_of_attrs, rci_number_of_varying_attrs, rci_max_data_length);

	call get_attribute_data (rci_db_model_ptr, rci_file_model_ptr, rci_rel_ptr,
	     rci_rel_name, rci_attr_name, rci_attr_ptr, rci_attr_desc, rci_attr_defn_order);


	on cleanup call mstxn_cleanup;

	on any_other call mstxn_any_other;



	rci_caller_name = "rmdb_create_index";
	ai_ptr = rci_attr_ptr;
	il_number_of_ids = 1;
	allocate id_list in (wa);
	id_list.number_of_ids = 1;
	id_list.version = ID_LIST_VERSION_1;
	id_list.id (1) = rci_attr_ptr -&gt; attr_info.defn_order;

/* initialize values for create_index */
	rci_style = 1;
	relation_index_flags_ptr = addr (rci_flag_list);
	relation_index_flags.relation_must_be_empty = "0"b;
	relation_index_flags.index_is_clustering = "0"b;
	relation_index_flags.index_is_unique = "0"b;
	relation_index_flags.pad = "0"b;
%page;
%include mrds_start_transaction;

	if mstxn_code ^= 0
	then do;
		rci_error_message = "Could not start a transaction";
		goto exit_rmdb_create_index;
	     end;

	rci_backout_occured = "0"b;

/*
   Update the model. This operation consists  of  marking  the  data
   base  as  inconsistent  and  updating  the relation and attribute
   models. The version of the saved resultant is also changed so that
   it will not be used for opening the database. In addition a history
   entry is added  to  the  data  base model.  This  update is done
   before any of the data is changed so that there is enough information
   avaiable so that the delete_index request can work.

   If a quit is signaled during this time, the fact is recorded, but
   the  quit  is  not processed. After the model has been completely
   updated the quit is signaled.
*/

	on quit rci_quit_signaled = "1"b;
	rmdb_ctl_ptr -&gt; rmdb_ctl.saved_res_version_ptr -&gt; rci_based_char8 = "RESTRUCT";
	call mdbm_util_$inconsistent_set (rci_db_model_ptr, "create_index", "Indexing attribute " ||
	     rtrim (rci_attr_name) || " in relation " || rtrim (rci_rel_name),
	     "delete_index " || rtrim (rci_rel_name) || " " || rtrim (rci_attr_name) || " -brief");
	call update_model (rci_db_model_ptr, rci_rel_ptr, rci_attr_ptr);
	revert quit;
	if rci_quit_signaled
	then do;
		rci_quit_signaled = "0"b;
		signal quit;
	     end;

	on cleanup begin;
		call mstxn_cleanup;
		call clean_up ("0"b, "1"b);
	     end;

	call rmdb_ctl.relmgr_entries.open (rci_db_abs_path, rci_rel_name,
	     rci_rel_opening_id, rci_code);
	if rci_code ^= 0
	then do;
		rci_error_message = "Could not open the relation to create the index.";
		call restore_significant_data;
		goto mftxn_exit;			/* need to reset the inconsistency of db */
	     end;

	call rmdb_ctl.relmgr_entries.create_index (rci_rel_opening_id,
	     id_list_ptr, rci_flag_list, rci_style,
	     attr_info.index_id, rci_code);

	mftxn_code = rci_code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then do;
		rci_error_message = "Cound not finish the transaction.";
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_create_index;
	     end;

	if ^rci_backout_occured &amp; rci_code ^= 0		/* if error occured during creation process */
	then do;
		rci_error_message = "Could not add an index";
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_create_index;
	     end;

/*
   Mark the data  base  as  consistent  again  don't  let  the  user
   interrupt.  Also  cleanup  attachments  in  this  case  the  "1"b
   indicates that any non-zero error code produced  in  the  cleanup
   handler should be returned to the user, since the database is not
   marked inconsistent the value of the second switch is "0"b.
*/

	on quit rci_quit_signaled = "1"b;
	call mdbm_util_$inconsistent_reset (rci_db_model_ptr);
	revert quit;
	if rci_quit_signaled
	then do;
		rci_quit_signaled = "0"b;
		signal quit;
	     end;

	call clean_up ("1"b, "0"b);

exit_rmdb_create_index:
	if rci_quit_signaled
	then do;
		revert quit;
		rci_quit_signaled = "0"b;
		signal quit;
	     end;
	return;
%page;
should_rollback: proc () returns (bit (1));
	return ("0"b);
     end should_rollback;






restore_significant_data: proc;

	dcl     rsd_code		 fixed bin (35);
	dcl     rsd_error_message	 char (500);


	rci_rel_ptr -&gt; rel_info.indexed = rci_original_rel_info_indexed;
	rci_rel_ptr -&gt; rel_info.max_attr_index_id =
	     rci_original_rel_info_max_attr_index_id;
	rci_attr_ptr -&gt; attr_info.index_attr = "0"b;

	call rmdb_add_rmdb_history (rci_db_model_ptr, RMDB_REL_TYPE, (rci_rel_ptr -&gt; rel_info.name),
	     RMDB_DEL_IDX_OP, (rci_attr_ptr -&gt; attr_info.name), rsd_error_message, rsd_code);

	rci_error_message = rtrim (rci_error_message) || " Backout has occured.";

	if rci_rel_opening_id ^= "0"b then
	     call rmdb_ctl.relmgr_entries.close (rci_rel_opening_id, rsd_code);
	rci_rel_opening_id = "0"b;

	rci_backout_occured = "1"b;

	return;
     end restore_significant_data;
%page;
initiate_models: proc (im_db_abs_path, im_rel_name, im_file_model_ptr);

/*
   This routine initiates a pointer to the  file_model segment that
   contains the relation model. If the file model cannot be found
   it indicates that  the  data  base does not contain the relation.
*/

/* PARAMETERS */

	dcl     im_db_abs_path	 char (168);	/* (input) path to the data base to be restructured */
	dcl     im_rel_name		 char (*);	/* (input) name of relation to be restructured */
	dcl     im_file_model_ptr	 ptr;		/* (output) pointer to the file model
						   .        that contains the relation */


	call hcs_$initiate (im_db_abs_path, rtrim (im_rel_name) || ".m", "", 0, 0, im_file_model_ptr, rci_code);
	if im_file_model_ptr = null ()
	then do;
		call ioa_$rs ("^/The relation ^a does not exist in the data base.",
		     rci_error_message, length (rci_error_message), im_rel_name);
		goto exit_rmdb_create_index;
	     end;
	else rci_code = 0;

	return;

     end initiate_models;
%page;
get_relation_data: proc (grd_db_model_ptr, grd_file_model_ptr, grd_rel_name, grd_file_id, grd_rel_ptr, grd_rel_id,
	grd_number_of_attrs, grd_number_of_varying_attrs, grd_max_data_length);

/*
   This routine extracts information from the rel_info and file_info
   structures for the relation to be restructured, i.e. the relation
   with an attribute being indexed.
*/

/* PARAMETERS */

	dcl     grd_db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     grd_file_model_ptr	 ptr;		/* (input) pointer to the file model that contains the relation */
	dcl     grd_rel_name	 char (*);	/* (input) name of relation to be restructured */
	dcl     grd_file_id		 bit (36);	/* (output) id of the file as defined in the database model */
	dcl     grd_rel_ptr		 ptr;		/* (output) pointer to the rel_info structure */
	dcl     grd_rel_id		 bit (36);	/* (output) id of the relation as defined in rel_info */
	dcl     grd_number_of_attrs	 fixed bin;	/* (output) number of attributes in the relation */
	dcl     grd_number_of_varying_attrs fixed bin;	/* (output) number of varying attributes in the relation */
	dcl     grd_max_data_length	 fixed bin;	/* (output) maximum number of bits of data a tuple
						   .          may have, if tuple contains varying
						   .          data the actual number may be less */


	grd_file_id = pointer (grd_db_model_ptr, grd_file_model_ptr -&gt; file_model.fi_ptr) -&gt; file_info.file_id;

	grd_rel_ptr = pointer (grd_file_model_ptr, grd_file_model_ptr -&gt; rel_ptr);

	if grd_rel_ptr -&gt; rel_info.name ^= grd_rel_name
	then do;
		rci_code = error_table_$action_not_performed;
		call ioa_$rs ("Data model inconsistant - file ^a contains a relation named ^a",
		     rci_error_message, length (rci_error_message), grd_rel_name, grd_rel_ptr -&gt; rel_info.name);
		goto exit_rmdb_create_index;
	     end;
	else do;
		grd_rel_id = grd_rel_ptr -&gt; rel_info.id;
		grd_number_of_attrs = grd_rel_ptr -&gt; rel_info.num_attr;
		grd_number_of_varying_attrs = grd_rel_ptr -&gt; rel_info.nvar_atts;
		grd_max_data_length = ceil (grd_rel_ptr -&gt; rel_info.max_data_len / 9);
	     end;

	return;

     end get_relation_data;
%page;
get_attribute_data: proc (gad_db_model_ptr, gad_file_model_ptr, gad_rel_ptr, gad_rel_name, gad_attr_name,
	gad_attr_ptr, gad_attr_desc, gad_attr_defn_order);

/*
   This  routine  extracts  information  out  of   the   attribute's
   attr_info  and  rel_info structures that have to do with the attr
   being indexed. It also checks various attributes of the attribute
   and reports errors if
   .   1) attribute is already indexed
   .   2) attribute is the first attribute of the  primary  key  and
   .      hence does not need to be indexed
   .   3) attribute's domain will  allow  values  &gt;  253  characters
   .      which is the maximum length of an index
   .   4) relation does not contain the indicated attribute
*/

/* PARAMETERS */

	dcl     gad_db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     gad_file_model_ptr	 ptr;		/* (input) pointer to the file model that contains the relation */
	dcl     gad_rel_ptr		 ptr;		/* (input) pointer to the rel_info structure */
	dcl     gad_rel_name	 char (*);	/* (input) name of relation to be restructured */
	dcl     gad_attr_name	 char (*);	/* (input) name of attribute to be indexed */
	dcl     gad_attr_ptr	 ptr;		/* (output) pointer to the attr_info structure */
	dcl     gad_attr_desc	 bit (36);	/* (output) standard multics descriptor
						   .        of the attribute to be indexed */
	dcl     gad_attr_defn_order	 fixed bin;

/* AUTOMATIC */

	dcl     gad_domain_ptr	 ptr;		/* pointer to attribute's domain info */
	dcl     gad_found		 bit (1);		/* true if the attribute exists in the relation */
	dcl     gad_i		 fixed bin;	/* loop index */

	gad_attr_ptr = pointer (gad_file_model_ptr, gad_rel_ptr -&gt; rel_info.attr_ptr);
	gad_found = "0"b;
	do gad_i = 1 to gad_rel_ptr -&gt; rel_info.num_attr while (^gad_found);
	     if gad_attr_ptr -&gt; attr_info.name = gad_attr_name
	     then do;
		     gad_found = "1"b;
		     if gad_attr_ptr -&gt; attr_info.index_attr
		     then do;
			     rci_code = error_table_$action_not_performed;
			     call ioa_$rs ("^/Attribute ^a in relation ^a is already indexed",
				rci_error_message, length (rci_error_message), gad_attr_name, gad_rel_name);
			     goto exit_rmdb_create_index;
			end;
		     if gad_attr_ptr -&gt; attr_info.key_attr &amp; gad_attr_ptr -&gt; attr_info.key_order = 1
		     then do;
			     rci_code = error_table_$action_not_performed;
			     call ioa_$rs ("^/Attribute ^a in relation ^a is the first attribute of the^/" ||
				"relation's primary key and can already be used as an index",
				rci_error_message, length (rci_error_message), gad_attr_name, gad_rel_name);
			     goto exit_rmdb_create_index;
			end;
		     gad_attr_defn_order = gad_attr_ptr -&gt; attr_info.defn_order;
		     gad_domain_ptr = pointer (gad_db_model_ptr, gad_attr_ptr -&gt; attr_info.domain_ptr);
		     gad_attr_desc = gad_domain_ptr -&gt; domain_info.db_desc;
		     if mdbm_util_$mu_data_length (gad_attr_desc) &gt; 2277 /* 253 * 9 */
		     then do;
			     rci_code = error_table_$action_not_performed;
			     call ioa_$rs (
				"^/Attribute ^a has a domain that allows values with lengths " ||
				"^/longer than 253 characters - the maximum allowable index length.",
				rci_error_message, length (rci_error_message), gad_attr_name);
			     goto exit_rmdb_create_index;
			end;
		end;
	     else gad_attr_ptr = pointer (gad_file_model_ptr, gad_attr_ptr -&gt; attr_info.fwd_thread);
	end;
	if ^gad_found
	then do;
		rci_code = error_table_$action_not_performed;
		call ioa_$rs ("^/Relation ^a does not contain an attribute named ^a",
		     rci_error_message, length (rci_error_message), gad_rel_name, gad_attr_name);
		goto exit_rmdb_create_index;
	     end;

	return;

     end get_attribute_data;
%page;
update_model: proc (um_db_model_ptr, um_rel_ptr, um_attr_ptr);

/*
   This procedure updates the model to indicate the new index and to
   record that restructuring has taken place. The index_id will be set
   by the relation_manager when it creates the index but the rel_mgr
   expects the id to be "0"b until it actually sets it. It also sets the
   max_attr_index_id to 512 so that MR10.1 rmdb will die. This is needed
   because the max_attr_index_id which is used by MR10.1 rmdb to calculate
   the new index_id can no longer be guarenteeded to be the maximum index
   id once MR10.2 rmdb has been used. MR10.1 rmdb had a check that refused
   to allow the index_id to go above 511 because it was only 8 bits long,
   setting max_attr_index_id (which is fixed bin) will therefore stop
   MR10.1 rmdb.
*/

/* PARAMETERS */

	dcl     um_db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     um_rel_ptr		 ptr;		/* (input) pointer to the rel_info structure */
	dcl     um_attr_ptr		 ptr;		/* (input) pointer to the attr_info structure */

	rci_original_rel_info_indexed = um_rel_ptr -&gt; rel_info.indexed;
	um_rel_ptr -&gt; rel_info.indexed = "1"b;

	rci_original_rel_info_max_attr_index_id = um_rel_ptr -&gt; rel_info.max_attr_index_id;
	um_rel_ptr -&gt; rel_info.max_attr_index_id = 512;

	um_attr_ptr -&gt; attr_info.index_attr = "1"b;
	um_attr_ptr -&gt; attr_info.index_id = "0"b;

	call rmdb_add_rmdb_history (um_db_model_ptr, RMDB_REL_TYPE, (um_rel_ptr -&gt; rel_info.name),
	     RMDB_ADD_IDX_OP, (um_attr_ptr -&gt; attr_info.name), rci_error_message, rci_code);
	if rci_code ^= 0
	then do;
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_create_index;
	     end;

	return;

     end update_model;
%page;
clean_up: proc (cu_set_code, cu_leave_db_inconsistent);

/*
   This procedure is called both during normal and error termination
   and in the event that the cleanup condition is signaled.

   In the event that this procedure is called due  to  an  error  we
   want  to  be sure that the error code reported to the user is the
   one that caused the error. There is therefore a local error  code
   in  this procedure which is set to the global error code (the one
   returned  to   the   user)   only   during   normal   (non-error,
   non-cleanup_condition) termination and if an error occurs in this
   procedure (this could occur  during  io  attachment  cleanup).  A
   record  of  the  error is concatinated onto the end of the global
   error_message so that the caller has some indication of what went
   wrong.
*/






/* PARAMETERS */

	dcl     cu_set_code		 bit (1);		/* (input) true ==&gt; if error occurs during cleanup, global error
						   .       code will be set to error */
	dcl     cu_leave_db_inconsistent bit (1);	/* (input) true ==&gt; the dba will not be queried if indexing is
						   .       to continue and the message giving directions for
						   .       how to make the db consistent will be concatinated
						   .       to the returned error message */

/* AUTOMATIC */

	dcl     cu_code		 fixed bin (35);	/* local error code */




	if cu_leave_db_inconsistent
	then rci_error_message = rtrim (rci_error_message) ||
		"^/The data base is being left in an inconsistant state," ||
		"^/to make the database consistent use the delete_index request" ||
		"^/to delete the partially created index.";


	if rci_rel_opening_id ^= "0"b then
	     call rmdb_ctl.relmgr_entries.close (rci_rel_opening_id, cu_code);
	if cu_set_code
	then do;					/* set global error code, if error in cleanup occured */
		if cu_code ^= 0			/* if error didn't occur don't change anything */
		then do;
			rci_code = cu_code;
			if rci_code = 0		/* keep old message if there was another error */
			then rci_error_message = "^/The relation could not be closed.";
			else rci_error_message = rtrim (rci_error_message) ||
				"^/The relation could not be closed.";
		     end;
	     end;
	else do;
		if cu_code ^= 0			/* even if code is not reset, let user know error occured */
		then rci_error_message = rtrim (rci_error_message) ||
			"^/The relation could not be close.";
	     end;

	return;

     end clean_up;


     end rmdb_create_index;
��



		    rmdb_create_relation.pl1        12/09/86  1247.6rew 12/09/86  1234.8      273177



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

/****^  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-06 by Thanh
     Nguyen. (see mrds #136)
  2) change(85-12-18,Spitzer), approve(85-12-18,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Add code to use the database crossreference file. Update the
     unreferenced_attribute list in db_model.
  3) change(86-11-18,Blair), approve(86-11-18,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     Change to use mrds_data_$relation_blocking_factor when creating new
     relations.
                                                   END HISTORY COMMENTS */

rmdb_create_relation: proc (I_rmdb_ctl_ptr, I_rmdb_create_rel_info_ptr, I_called_from_request_level, O_err_msg, O_err_code);

/*                          BEGIN_DESCRIPTION

   The purpose of  this procedure is to provide the internal interface for the
   restructuring  create_relation.   It is expected that the validation of the
   user as a DBA and the quiescing of the database has already been done prior
   to calling this procedure.

   If successful it  will create the relation data file, create the file_model
   segment and link the new relation into the data_model.

   The new  relation  name  and attribute  info is  provided  as  input in the
   rmdb_create_rel_info structure.  The  relation  name can  not  exist in the
   database.   Only attributes  that already  exist in the  data_model  can be
   used in the relation definition.

   Temporary  space is created and  cleaned  up in the  directory specified by
   rmdb_create_rel_info.temp_directory_path.  This space is used to create the
   keyed sequential file for attribute name that  exists in the db_model.

   If an error occurs during the creation of the new relation all segments and
   files created prior to the error will be deleted.

                               END_DESCRIPTION

   HISTORY:
   82-03-23   Originally written by R. Lackey

   82-06-25  Roger Lackey : added %include access_mode_values
   and changed make_seg call to use RW_ACCESS_BIN

   Also converted undo request to use -brief instead of -force

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   82-09-22 D. Woodka : Modified for DMS conversion to call relation_manager
   create_relation, create_index, and close.

   83-01-11 R. Harvey : Fixed create_index code so that one call is made per
   index to be created.

   83-02-04 Mike Kubicar : Added calls to transaction processing routines.

   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-22 Harvey: Changed calling sequence to $create_relation for attribute
   names.

   83-02-24 Davids: Modified to set the protected, no_concurrency and
   no_rollback elements of the file_create_info structure from the
   transactions_needed, concurrency_on, and rollback_on elements of the
   db_model structure.

   83-05-24 Davids: Added code to change the saved_res_verion so that the
   saved resultant will not get incorrectly used in an opening.

   84-08-22 Pierret: Changed file_create_info structure to use version
   FILE_CREATE_INFO_VERSION_2 and to set the new 
   file_create_info.ring_brackets (*) to 0, meaning use default value.
*/

/*           PARAMETERS            */

	dcl     I_rmdb_create_rel_info_ptr ptr parameter; /* Pointer to the rmdb_create_rel_info structure */
	dcl     I_rmdb_ctl_ptr	 ptr parameter;	/* Pointer to the rmdb_ctl_info structure */
	dcl     I_called_from_request_level bit (1);	/* True if rmdb_create_rel was called from the request level,
                                                               false if from rmdb_create_and_pop_rel */
	dcl     O_err_msg		 char (*) parameter;/* Error message text */
	dcl     O_err_code		 fixed bin (35) parameter; /* Error code */
%page;
/* rmdb_create_relation: proc (I_rmdb_ctl_ptr, I_rmdb_create_rel_info_ptr, I_called_from_request_level, O_err_msg, O_err_code); */

/*      Init parameters          */

	rmdb_create_rel_info_ptr = I_rmdb_create_rel_info_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;
	called_from_request_level = I_called_from_request_level;
	O_err_msg = "";
	O_err_code = 0;

/*     Init   for cleanup                   */

	temp_file_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr;
	file_model_ptr, temp_seg_ptr = null;
	must_delete_relation = "0"b;
	db_path = rmdb_create_rel_info.db_path;
	temp_dir_path = rmdb_create_rel_info.temp_directory_path;
	dbm_ptr = rmdb_create_rel_info.db_model_ptr;

	if db_model.db_type_flags.transactions_needed &amp; called_from_request_level then do;
		mstxn_transactions_needed = "1"b;
		call transaction_manager_$get_current_txn_id (mstxn_txn_id,
		     mstxn_code);
		if mstxn_code = 0 then do;
			mstxn_txn_id = "0"b;	/* So that we don't try to commit the transaction */
			call error (error_table_$action_not_performed,
			     "Relations may not be created while a transaction is " ||
			     "in progress.  Commit or abort the transaction and try " ||
			     "again.");
		     end;
	     end;
	else mstxn_transactions_needed = "0"b;
	mstxn_txn_id = "0"b;			/* transaction_manager_ doesn't guarantee 0 after previous call */

	fm_ptr = null;
	on cleanup call tidy_up;			/* Establish a cleanup handler */

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

	if db_model.num_rels + 1 &gt; mrds_data_$max_relations then /* Can only have so many */
	     call error (mrds_error_$max_rels, rmdb_create_rel_info.relation_name);
%page;
/* Validate the relation name supplied */

	rel_name = rtrim (rmdb_create_rel_info.relation_name);

	first_char = substr (rel_name, 1, 1);		/* Get first char of rel_name */

	if first_char = "_" then
	     call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name ||
		"^/Relation names cannot begin with an underscore.");

	if first_char = "-" then
	     call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name ||
		"^/Relation names cannot begin with a hyphen.");

	if verify (first_char, "0123456789") = 0 then
	     call error (mrds_error_$inv_rel_name_first_char, "^/" || rel_name ||
		"^/Relation names cannot begin with a numeric.");


	s = verify (rel_name, mrds_data_$valid_rel_and_attr_name_chars);
	if s ^= 0 then
	     call error (mrds_error_$bad_rel_name, "^/" || rel_name ||
		"^/First bad character is:  " || substr (rel_name, s, 1));

	if rel_name = "db_model" then call error (mrds_error_$rst_reserved_name,
		"^/" || rel_name ||
		"^/The name ""db_model"" is a reserved name for MRDS and cannot be used as a relation name.");

	call check_supplied_attr_list;		/* Internal procedure */

/* See if a relation by this name already exists in db */

	call initiate_file_ (db_path, rel_name || ".m", R_ACCESS, fm_ptr, (0), code);

	if fm_ptr ^= null then do;
	     call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
	     call error (mrds_error_$dup_rel, "^/" || rel_name);
	     end;
%page;
	must_delete_relation = "1"b;			/* In case of an error */

/* Changed the version on the saved resultant so it doesn't get used
   incorrectly and mark database as inconsistent and set undo string.
   This is done at this point in the procedure because until now, nothing
   has been added to the db that would need to be removed in case of an error.
   */

	rmdb_ctl_ptr -&gt; rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";
	call mdbm_util_$inconsistent_set (dbm_ptr, "create_relation",
	     "Creating relation " || rel_name, "delete_relation " || rtrim (rel_name) || " -brief");

/* Create file_model segment */

	call initiate_file_$create (db_path, rel_name || ".m", RW_ACCESS, file_model_ptr, ("0"b), (0), code);
	if code ^= 0 then call error (code, pathname_ (db_path, (rel_name)));

	call rmdb_init_file_model (dbm_ptr, file_model_ptr, err_msg, code); /* External proc
						   That inits file_model structure and rel_info structure */
	if code ^= 0 then call error (code, err_msg);

	call build_db_attr_list;			/* Internal proc  creates a list of all unique attribute names */


/* Find last file_info in db_model so we can link in the new file_info */

	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr)
	     repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while (rel (fi_ptr) ^= NULL_OFFSET);

	     last_fi_ptr = fi_ptr;
	end;

	on area begin;				/* In case there is not enough room to allocate file_info */
		O_err_msg = "Area in model is not large enough to add the relation "
		     || rel_name || "^/Relation will not be added.";
		O_err_code = error_table_$area_too_small;
		call tidy_up;
		goto exit;
	     end;

	allocate file_info in (dbm_area) set (fi_ptr);	/* New file_info */
	file_model_ptr -&gt; file_model.fi_ptr = rel(fi_ptr);/* Save the ptr in case we have to back out */

	revert area;

	file_info.file_name = rel_name;
	file_info.file_id = "000000000000000000000000000000000001"b;
	file_info.fwd_ptr = NULL_OFFSET;
%page;
/* Start of critical code that links new relation in to database
   Errors that occur prior to this will cause the data_file and file_model to
   be deleted and leave that database consistent. */

	quit_intercept_flag = "0"b;

	on quit quit_intercept_flag = "1"b;		/* hold off any QUITs til finished updating db_model */

	call add_supplied_attrs;			/* Internal proc */

 /* Add the relation name to the xref file. */

	call mdbm_util_$xref_create_record (temp_file_iocb_ptr, RELATION_KEY_HEAD, rmdb_create_rel_info.relation_name, rel( fi_ptr), err_msg, code);
	if code ^= 0
	then call error (code, err_msg);

 /* Link new file_info into list */
	if db_model.file_ptr = NULL_OFFSET then
	     db_model.file_ptr = rel (fi_ptr);
	else last_fi_ptr -&gt; file_info.fwd_ptr = rel (fi_ptr);

	db_model.num_unblk_files = db_model.num_unblk_files + 1; /* Just added new file */
	db_model.num_rels = db_model.num_rels + 1;	/* Just added new relation */


/* Start a transaction */

	on cleanup
	     begin;
		call tidy_up;
		call mstxn_cleanup;
	     end;
	on any_other call mstxn_any_other;
%include mrds_start_transaction;
	if mstxn_code ^= 0
	then call error (mstxn_code,
		"Could not start a transaction, while creating relation " ||
		rtrim (rel_name) || ".");

/* Create and init relations data file */

	call create_relation_data_file;		/* Internal proc */

	must_delete_relation = "0"b;			/* So tidy_up won't delete it */

/* Add the history entry to the db_model */

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name),
	     RMDB_ADD_REL_OP, "", long_err_msg, code);

	revert quit;

	if quit_intercept_flag then signal quit;	/* Now signal the quit that was intecepted */

	if code ^= 0 then call error (code, long_err_msg);/* Error code from rmdb_add_rmdb_history */

	call adjust_bit_count_ ((db_path), rel_name || ".m", "1"b, bcnt, code);
	if code ^= 0 then call error (code, pathname_ (db_path, rel_name || ".m"));

	call adjust_bit_count_ ((db_path), "db_model", "1"b, bcnt, code);
	if code ^= 0 then call error (code, pathname_ (db_path, "db_model"));

	call tidy_up;				/* Release temp file and undo openings and
						   set database as consistent */

exit:
	mftxn_code = O_err_code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0 then do;
		O_err_code = mftxn_code;
		O_err_msg = "Could not commit or abort the transaction, while "
		     || "creating relation " || rtrim (rel_name) || ".";
	     end;
	return;
%page;
/* * * * * * * * * * * * *   check_supplied_attr_list    * * * * * * * * * * */

check_supplied_attr_list: proc;

/* Checks attribute names supplied for this relation against themselves
   for duplication.  It also sees if there is a primary key attribute supplied,
   and check for valid attribute names.
*/

	primary_key_found = "0"b;

	do x = 1 to rmdb_create_rel_info.num_attrs;

	     if rmdb_create_rel_info.attrs (x).primary_key then primary_key_found = "1"b;

	     do j = x+1 to rmdb_create_rel_info.num_attrs;

		if x ^= j &amp; /* If not itself  */
		     rmdb_create_rel_info.attrs (x).name = rmdb_create_rel_info.attrs (j).name then
		     call error (mrds_error_$rst_name_duplicate, "^/" ||
			rmdb_create_rel_info.attrs (x).name);
	     end;

	     attr_name = rtrim (rmdb_create_rel_info.attrs (x).name);
	     first_char = substr (attr_name, 1, 1);	/* Get first char of attr_name */

	     if first_char = "_" then
		call error (mrds_error_$inv_attr_name_first_char,
		     "^/" || attr_name ||
		     "^/Attribute names cannot begin with an underscore.");

	     if first_char = "-" then
		call error (mrds_error_$inv_attr_name_first_char,
		     "^/" || attr_name ||
		     "^/Attribute names cannot begin with a hyphen.");

	     if verify (first_char, "0123456789") = 0 then
		call error (mrds_error_$inv_attr_name_first_char,
		     "^/" || attr_name ||
		     "^/Attribute names cannot begin with a numeric.");

	     s = verify (attr_name, mrds_data_$valid_rel_and_attr_name_chars);
	     if s ^= 0 then
		call error (mrds_error_$bad_attr_name, "^/" ||
		     attr_name ||
		     "^/First bad character is:  " || substr (attr_name, s, 1));

	end;

	if ^primary_key_found then
	     call error (mrds_error_$no_primary_key, rmdb_create_rel_info.relation_name);

     end check_supplied_attr_list;
%page;
/*  * * * * * * * * * * *  build_db_attr_list  * * * * * * * * * * * * * *   */


build_db_attr_list: proc;

/* This internal subroutine calls the database crossreference package to create
   the crossreference file if it does not already exist.  */

	if temp_file_iocb_ptr ^= null
	then return;

	call mdbm_util_$xref_build (temp_dir_path, db_path, dbm_ptr, rmdb_ctl.crossref_file_info.name,
	     rmdb_ctl.crossref_file_info.iocb_ptr, err_msg, code);
	if code ^= 0 then call error (code, err_msg);

	temp_file_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr;
	return;

     end build_db_attr_list;
%page;
/*  * * * * * * * * * *    add_supplied_attrs    * * * * * * * * * * *  */



add_supplied_attrs: proc;

/* This procedure checks to see if the supplied attributes are defined in the
   database by looking each name up in the attribute list created by
   build_db_attr_list. If the attribute is valid the appropiate attr_info is
   added to the file_model.  After all the attributes are processed, we have
   to adjust alignment for the varying attributes.*/

dcl  WORD fixed bin internal static options (constant) init (36);
dcl  amount_to_pad fixed bin;
dcl  prev_ua_ptr ptr;
dcl  this_ua_ptr ptr;

	crossref_info_record_ptr = addr (record_buffer);
	do i = 1 to rmdb_create_rel_info.num_attrs;	/* Check each attr name */

/* Read the first 8 bytes (2 words) of the crossreferece record. This will
   contain the domain_info offset and the count of relations this attribute
   is used in. If the attribute is unreferenced, delete the attr_info in the
   db_model for this one. */

	     call mdbm_util_$xref_find_record (temp_file_iocb_ptr, ATTRIBUTE_KEY_HEAD,
		rmdb_create_rel_info.attrs (i).name, crossref_info_record_ptr,
		8, err_msg, code);
	     if code ^= 0
	     then if code = error_table_$long_record
		then ;				/* ignore this error */
	          else if code = error_table_$no_record
		     then call error (mrds_error_$undef_attr,
			          "^/" || rmdb_create_rel_info.attrs (i).name);
		     else call error (code, err_msg);

	     di_ptr = ptr (dbm_ptr, crossref_info_record.offset);

/* Add the attr_info to the rel_info */
	     call rmdb_build_attr_info (dbm_ptr, addr (rmdb_create_rel_info.attrs (i)),
		file_model_ptr, di_ptr, err_msg, code);
	     if code ^= 0 then call error (code, err_msg);

/* Add this relation to the attribute crossreference list */
	     call mdbm_util_$xref_reference (temp_file_iocb_ptr, ATTRIBUTE_KEY_HEAD,
		rmdb_create_rel_info.attrs (i).name, rmdb_create_rel_info.relation_name,
		null, 0, err_msg, code);
	     if code ^= 0 then call error (code, err_msg);

/* Mark that the domain is used, in case this is a generated attribute for a
   domain. */
	     domain_info.unreferenced = "0"b;

/* if it was an unreferenced_attribute, delete it from the db_model */
	     if crossref_info_record.count = 0
	     then do;
		prev_ua_ptr, this_ua_ptr = null;
		do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
		     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread)
		     while (rel (ua_ptr) ^= NULL_OFFSET &amp; this_ua_ptr = null);

		     if unreferenced_attribute.name = rmdb_create_rel_info.attrs (i).name
		     then this_ua_ptr = ua_ptr;
		     else prev_ua_ptr = ua_ptr;
		     end;				/* do ua_ptr */

/* When we get here, if this_ua_ptr is nonnull, it will point to a matching
   unreferenced_attribute in the db_model and is the one that we are going to
   free. prev_ua_ptr will point to the previous one on the list or be null. If
   it is null, then we are freeing the first one in the list and must set the
   head of the list in the db_model. Otherwise, we change the offset of the
   previous unreferenced_attribute fwd_thread to point to the next one in the
   list. This operation only unchains it from the linked list. */

		if this_ua_ptr ^= null
		then do;
		     if prev_ua_ptr = null
		     then db_model.unreferenced_attribute_ptr = this_ua_ptr -&gt; unreferenced_attribute.fwd_thread;
		     else prev_ua_ptr -&gt; unreferenced_attribute.fwd_thread = this_ua_ptr -&gt; unreferenced_attribute.fwd_thread;

		     free this_ua_ptr -&gt; unreferenced_attribute in (dbm_area);
		     end;
		end;
	end;					/* do i */
          
/* Here is where we adjust alignment for varying length attributes. */
          ri_ptr = ptr (file_model_ptr, file_model_ptr -&gt; file_model.rel_ptr);
          if rel_info.nvar_atts = 0 then;
	else do;
	     if mod (rel_info.var_offset-1, WORD) = 0 then
		amount_to_pad = 0;
	     else amount_to_pad = WORD - mod (rel_info.var_offset -1, WORD);

	     rel_info.var_offset = rel_info.var_offset + amount_to_pad;
	     rel_info.max_data_len = rel_info.max_data_len + amount_to_pad;
	     end;

     return;
     end add_supplied_attrs;
%page;
/*  * * * * * * * * * * *   create_relation_data_file   * * * * * * * * *    */

create_relation_data_file: proc;

	file_model_name = rel_name || ".m";
	call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
	if fm_ptr = null then call error (code, " The file model," || rtrim (file_model_name) || "could not be initiated.");

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

/* set up working area */
	caller_name = "rmdb_create_relation";
	call mdbm_util_$get_temp_segment_path (temp_dir_path, caller_name, temp_seg_ptr, code);
	if code ^= 0 then call error (code, "getting temp segment.");

	work_area_ptr = temp_seg_ptr;
	wa = empty ();

/* initialize for calls to relation manager */

	tva_number_of_vector_slots = 0;
	tva_number_of_dimensions = rel_info.num_attr;
	tva_maximum_dimension_name_length = 32;
	allocate typed_vector_array in (wa);

	il_number_of_ids = rel_info.num_attr;
	allocate id_list in (wa);
	id_list.number_of_ids = 0;
	id_list.version = ID_LIST_VERSION_1;

	typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;

	ai_ptr = ptr (fm_ptr, rel_info.attr_ptr);	/* get attribute info  */
	do i = 1 to tva_number_of_dimensions;

	     if attr_info.key_attr then do;		/* set up the primary key index */
		     id_list.number_of_ids = id_list.number_of_ids + 1;
		     id_list.id (id_list.number_of_ids) = attr_info.defn_order;
		end;
	     di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);/* set up descriptor list for create relation */
	     typed_vector_array.dimension_table (i).name = attr_info.name;
	     typed_vector_array.dimension_table (i).descriptor_ptr = addr (domain_info.db_desc);
	     ai_ptr = ptr (fm_ptr, attr_info.fwd_thread);

	end;
	allocate rel_creation_info in (wa);
	allocate file_create_info in (wa);

/* initialize values for create_relation */

	rel_creation_info.version = REL_CREATION_INFO_VERSION_2;
	rel_creation_info.esm_info_ptr = null;
	rel_creation_info.cism_info_ptr = null;
	rel_creation_info.file_create_info_ptr = file_create_info_ptr;
	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 = db_model.db_type_flags.transactions_needed;
	file_create_info.flags.no_concurrency = ^db_model.db_type_flags.concurrency_on;
	file_create_info.flags.no_rollback = ^db_model.db_type_flags.rollback_on;
	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;

/* initialize values for create_index */
	style = 1;
	relation_index_flags_ptr = addr (flag_list);
	relation_index_flags.relation_must_be_empty = "0"b;
	relation_index_flags.index_is_clustering = "0"b;
	relation_index_flags.index_is_unique = "1"b;	/* for primary key */

	create_rel_name = rtrim (rel_name);


	call rmdb_ctl.relmgr_entries.create_relation (db_path, create_rel_name,
	     rel_creation_info_ptr, typed_vector_array_ptr,
	     rel_opening_id, rel_info.id, code);

	if code ^= 0 then call error (code, "While creating relation " || rel_name);


/* create the primary index for the relation */

	call rmdb_ctl.relmgr_entries.create_index (rel_opening_id,
	     id_list_ptr, flag_list, style, rel_info.primary_key_index_id, code);

	if code ^= 0 then
	     call error (code, "while creating the primary index for" || rel_name);



/* create the secondary indexes for the relation */

	relation_index_flags.index_is_unique = "0"b;	/* index need not be unique for secondary index */

	id_list.number_of_ids = 1;			/* secondary indices involve only one attribute */

	ai_ptr = ptr (fm_ptr, rel_info.attr_ptr);
	do i = 1 to rel_info.num_attr;
	     if attr_info.index_attr
	     then do;
		     id_list.id (1) = attr_info.defn_order;
		     call rmdb_ctl.relmgr_entries.create_index (rel_opening_id,
			id_list_ptr, flag_list, style, attr_info.index_id, code);
		     if code ^= 0 then
			call error (code, " while creating secondary indices for " || rel_name);
		end;

	     ai_ptr = ptr (fm_ptr, attr_info.fwd_thread);

	end;

	call rmdb_ctl.relmgr_entries.close (rel_opening_id, code);
	if code ^= 0 then
	     call error (code, " while closing the relation " || rel_name);



     end create_relation_data_file;
%page;
/*  * * * * * * * * * * * * * *      error     * * * * * * * * * * * * * *   */



error: proc (err_code, err_message);			/* Error procedure for rmdb_create_relation.pl1 */

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


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

     end error;





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

tidy_up: proc;

	if must_delete_relation then do;		/* Unlink relation from db_model
						   and delete file_model and relation_data_file */


		delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1;
		delete_rel_info.absolute_db_path = db_path;
		delete_rel_info.db_model_ptr = rmdb_create_rel_info.db_model_ptr;
		delete_rel_info.relation_name = rel_name;
		delete_rel_info.brief = "1"b;
		delete_rel_info.mbz = "0"b;

		call rmdb_delete_relation$cleanup (rmdb_ctl_ptr, addr (delete_rel_info), err_msg, code);
		fm_ptr = null;
		call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
		     rmdb_ctl.crossref_file_info.name, (""), (0));
		end;

	if code = 0 then call mdbm_util_$inconsistent_reset (dbm_ptr); /* Make db consistent */

	if temp_seg_ptr ^= null then call mdbm_util_$free_temp_segment (caller_name, temp_seg_ptr, (0));

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

     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.  In this module, restore data must add a history section
*   note that the relation created has been deleted.  This is just a
*   stopgap measure until add history is smart enough to be able to delete
*   history entries.  Should_rollback determines whether a transaction should
*   be rolled back or aborted on error.  Currently, it is always aborted.
*
**********/


restore_significant_data:
     proc;

	dcl     add_history_code	 fixed bin (35);
	dcl     add_history_err_msg	 char (500);

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name),
	     RMDB_DEL_REL_OP, "", add_history_err_msg, add_history_code);
	must_delete_relation = "1"b;
     end restore_significant_data;



should_rollback:
     proc returns (bit (1));
	return ("0"b);
     end should_rollback;
%page;
	dcl     addr		 builtin;
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     any_other		 condition;
	dcl     area		 condition;
	dcl     attr_name		 char (32) varying;
	dcl     based_char8		 char (8) based;
	dcl     bcnt		 fixed bin (35);
	dcl     called_from_request_level bit (1);
	dcl     caller_name		 char (20);
	dcl     cleanup		 condition;
	dcl     create_rel_name	 char (32);
	dcl     code		 fixed bin (35);
	dcl     db_path		 char (168);
	dcl     empty		 builtin;
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     error_table_$area_too_small fixed bin (35) ext static;
	dcl     error_table_$long_record fixed bin(35) ext static;
	dcl     error_table_$no_record fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     err_msg		 char (256);
	dcl     file_model_name	 char (32);
	dcl     file_model_ptr	 ptr;
	dcl     first_char		 char (1);
	dcl     fixed		 builtin;
	dcl     flag_list		 bit (36) aligned;
	dcl     mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
          dcl     mdbm_util_$xref_create_record entry (ptr, char (*), char (*), bit (18), char (*), fixed bin (35));
	dcl     mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
	dcl     initiate_file_	 entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl     initiate_file_$create	 entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24), fixed bin(35));
	dcl     i			 fixed bin;
	dcl     j			 fixed bin;
	dcl     last_fi_ptr		 ptr;
	dcl     long_err_msg	 char (500);
	dcl     mrds_data_$max_relations ext fixed bin (35);
          dcl     mrds_data_$relation_blocking_factor fixed bin (17) external static;
	dcl     mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext;
	dcl     mrds_error_$bad_attr_name fixed bin (35) ext static;
	dcl     mrds_error_$bad_rel_name fixed bin (35) ext static;
	dcl     mrds_error_$dup_rel	 fixed bin (35) ext static;
	dcl     mrds_error_$inv_attr_name_first_char fixed bin (35) ext static;
	dcl     mrds_error_$inv_rel_name_first_char fixed bin (35) ext static;
	dcl     mrds_error_$max_rels	 fixed bin (35) ext static;
	dcl     mrds_error_$no_primary_key fixed bin (35) ext static;
	dcl     mrds_error_$rst_name_duplicate fixed bin (35) ext static;
	dcl     mrds_error_$rst_reserved_name fixed bin (35) ext static;
	dcl     mrds_error_$undef_attr fixed bin (35) ext static;
	dcl     must_delete_relation	 bit (1);
	dcl     mdbm_util_$free_temp_segment entry (char(*), ptr, fixed bin(35));
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
	dcl     mdbm_util_$xref_build	 entry (char(*), char(*), ptr, char(*), ptr, char(*), fixed bin(35));
	dcl     mdbm_util_$xref_find_record entry (ptr, char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35));
	dcl     mdbm_util_$xref_reference entry (ptr, char(*), char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35));
          dcl     mod                    builtin;
	dcl     null		 builtin;
	dcl     NULL_OFFSET		 int static bit (18) unal init ((18)"1"b) options (constant);
	dcl     pathname_		 entry (char(*), char(*)) returns(char(168));
	dcl     primary_key_found	 bit (1);
	dcl     ptr		 builtin;
	dcl     quit		 condition;
	dcl     quit_intercept_flag	 bit (1);
	dcl     record_buffer	 (2) fixed bin (35);
	dcl     rel		 builtin;
	dcl     rel_opening_id	 bit (36) aligned;
	dcl     rel_name		 char (32) varying;
	dcl     rmdb_add_rmdb_history	 entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
	dcl     rmdb_build_attr_info	 entry (ptr, ptr, ptr, ptr, char (*), fixed bin (35));
	dcl     rmdb_delete_relation$cleanup entry (ptr, ptr, char (*), fixed bin (35));
	dcl     rmdb_init_file_model	 entry (ptr, ptr, char (*), fixed bin (35));
	dcl     rtrim		 builtin;
	dcl     s			 fixed bin;
	dcl     style		 fixed bin (17);
	dcl     substr		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     temp_dir_path	 char (168);
	dcl     temp_file_iocb_ptr	 ptr;
	dcl     temp_seg_ptr	 ptr;
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     verify		 builtin;
	dcl     wa		 area (sys_info$max_seg_size) based (work_area_ptr);
	dcl     work_area_ptr	 ptr;
	dcl     x			 fixed bin;

	dcl     1 delete_rel_info	 aligned
				 like rmdb_delete_rel_info;

%page;
%include access_mode_values;
%page;
%include dm_file_create_info;
%page;
%include dm_id_list;
%page;
%include dm_rel_creation_info;
%page;
%include dm_relation_index_flags;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mdbm_rs_info;
%page;
%include mrds_rmdb_ctl;
%page;
%include rmdb_create_rel_info;
%page;
%include rmdb_crossref_info;
%page;
%include rmdb_delete_rel_info;
%page;
%include rmdb_history_entry;
%page;
%include terminate_file;
%page;
%include vu_typed_vector_array;

     end rmdb_create_relation;
���



		    rmdb_delete_all.pl1             12/07/87  1328.9rew 12/07/87  1320.2      119718



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

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

/*DESCRIPTION
  This set of entry points deletes either all the 1) domains, 2) attribute, or
  3) relations, depending on which entry point it is entered at. */

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
  2) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis),
     install(87-12-07,MR12.2-1008):
     Initialize mstxn_txn_id to 0 before establishing the cleanup handler so
     that we don't get caught trying to abort a txn based on some bogus value.
                                                   END HISTORY COMMENTS */

rmdb_delete_all:
     proc;

	return;					/* not an entry point */

/*DESCRIPTION
  This entry point deletes all defined domains. This implies all existing
  attributes and relations must be deleted. For speed, we don't update the
  crossreference file (if it even exists) as we are doing the task, but delete
  it as everything in it becomes invalid. */

rmdb_delete_all$domains:
     entry (Irmdb_ctl_ptr, Oerror_message, Ocode);

	entry_point = DOMAINS;
	goto COMMON;

rmdb_delete_all$attributes:
     entry (Irmdb_ctl_ptr, Oerror_message, Ocode);

	entry_point = ATTRIBUTES;
	goto COMMON;

rmdb_delete_all$relations:
     entry (Irmdb_ctl_ptr, Oerror_message, Ocode);

	entry_point = RELATIONS;
	goto COMMON;

COMMON:
	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	dbm_ptr = rmdb_ctl.db_model_ptr;

	call transaction_in_progress;
	mstxn_txn_id = "0"b;

	quit_occurred = "0"b;			/* BEGIN CRITICAL CODE */

	on quit quit_occurred = "1"b;

/* Invalidate the resultant. */
	rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";

	call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
	     rmdb_ctl.crossref_file_info.name, (""), (0));

	temp_ptr = null;
	on cleanup
	     begin;
		call mstxn_cleanup;
		call cleaner;
	     end;
	on any_other call mstxn_any_other;

	if mstxn_transactions_needed
	then do;
%include mrds_start_transaction;
	     if mstxn_code ^= 0
	     then call error (mstxn_code, "Could not start a transaction.");
	     end;

	if entry_point = DOMAINS
	then call delete_domains;

/* Note that we don't have to expressly delete all the attributes if we entered
   through the $attributes entry point. This is because all mention of
   referenced attributes is in the model files, and we will later delete the
   unreferenced attributes. */
	call delete_relations;

	if mstxn_transactions_needed
	then do;
	     mftxn_code = 0;
%include mrds_finish_transaction;
	     end;

	if (entry_point = DOMAINS) | (entry_point = ATTRIBUTES)
	then call delete_unreferenced_attributes;

	if entry_point = DOMAINS
	then call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE,
	          "-all", RMDB_DEL_DMN_OP, "", error_message, (0));
	else if entry_point = ATTRIBUTES
	     then call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE,
		     "-all", RMDB_DEL_ATTR_OP, "", error_message, (0));
	     else call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE,
		     "-all", RMDB_DEL_REL_OP, "", error_message, (0));

	call mdbm_util_$inconsistent_reset (dbm_ptr);

	revert quit;				/* END CRITICAL CODE */
	if quit_occurred
	then signal quit;

	call error (0, "");
%page;
delete_relations:
     proc;

dcl  last_unreferenced_attribute_ptr ptr;
dcl  model_name char (32);
dcl  relation_name char (32);

	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;

	if entry_point = RELATIONS
	then do;
	     call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, temp_ptr, code);
	     if code ^= 0
	     then call error (code, "Unable to get a temp segment.");

	     attribute_list_ptr = temp_ptr;
	     attribute_list.count = 0;

/* Find the last unreferenced_attribute structure so we can add on the end. */
	     last_unreferenced_attribute_ptr = null;
	     do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
		repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET);

		last_unreferenced_attribute_ptr = ua_ptr;
		end;				/* do ua_ptr */

	     end;

/* Process all the relations. */
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, db_model.file_ptr)
	     while (rel (fi_ptr) ^= NULL_OFFSET);

	     relation_name = file_info.file_name;
	     model_name = rtrim (relation_name) || ".m";

/* If we are deleting all the relations, we must make all attributes be
   unreferenced. */
	     if entry_point = RELATIONS
	     then do;

/* Initiate the file_model segment so we can get to the list of attributes used
   within this relation. We don't need to terminate the file_model as
   we are shortly going to delete it. */
		call initiate_file_ (rmdb_ctl.absolute_db_path, model_name, R_ACCESS, fm_ptr, (0), code);
		if fm_ptr ^= null
		then do;

/* Process all the attributes in this relation. */
		     ri_ptr = ptr (dbm_ptr, rel_ptr);
		     do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread)
			while (rel (ai_ptr) ^= NULL_OFFSET);

			call make_attribute_unreferenced;
			end;			/* do ai_ptr */
		     end;				/* initiated the file_model */
		end;

/* Delete the file_model segment and the relation file. */
	     call delete_$path (rmdb_ctl.absolute_db_path, model_name, "101111"b, myname, (0));
	     call rmdb_ctl.relmgr_entries.delete_relation (rmdb_ctl.absolute_db_path, relation_name, (0));

	     db_model.file_ptr = file_info.fwd_ptr;
	     call free (dbm_ptr, rel (fi_ptr));

	     end;					/* do fi_ptr */

/* If we are deleting all the attributes, we must make all domains be unreferenced. */
	if entry_point = ATTRIBUTES
	then do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
		while (rel (di_ptr) ^= NULL_OFFSET);

		domain_info.unreferenced = "1"b;
		end;				/* do di_ptr */

/* Mark in the db_model that there aren't any type of files or relations left. */
	db_model.num_blk_files, db_model.num_unblk_files, db_model.num_rels = 0;
	return;

make_attribute_unreferenced:
     proc;

dcl  position fixed bin;
dcl  search_name char (33);

	search_name = OBJECT_HEAD || attr_info.name;
	position = index (attribute_list_names, search_name);
	if position = 0
	then do;					/* not in list yet */
	     attribute_list.count = attribute_list.count + 1;
	     attribute_list.name (attribute_list.count) = search_name;

	     allocate unreferenced_attribute in (dbm_area) set (ua_ptr);
	     unreferenced_attribute.name = attr_info.name;
	     unreferenced_attribute.domain_ptr = attr_info.domain_ptr;
	     unreferenced_attribute.fwd_thread = NULL_OFFSET;
	     unreferenced_attribute.unused (*) = NULL_OFFSET;

	     if last_unreferenced_attribute_ptr = null
	     then db_model.unreferenced_attribute_ptr = rel (ua_ptr);
	     else last_unreferenced_attribute_ptr -&gt; unreferenced_attribute.fwd_thread = rel (ua_ptr);
	     last_unreferenced_attribute_ptr = ua_ptr;

	     end;

	return;
     end make_attribute_unreferenced;

     end delete_relations;
%page;
delete_domains:
     proc;

	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, db_model.domain_ptr)
	     while (rel (di_ptr) ^= NULL_OFFSET);

	     db_model.domain_ptr = domain_info.fwd_thread;

	     call free (dbm_ptr, domain_info.check_path_ptr);
	     call free (dbm_ptr, domain_info.ck_stack_ptr);
	     call free (dbm_ptr, domain_info.encd_path_ptr);
	     call free (dbm_ptr, domain_info.decd_path_ptr);
	     call free (dbm_ptr, domain_info.str_before_path_ptr);
	     call free (dbm_ptr, domain_info.str_err_path_ptr);
	     call free (dbm_ptr, domain_info.str_after_path_ptr);
	     call free (dbm_ptr, domain_info.get_before_path_ptr);
	     call free (dbm_ptr, domain_info.get_err_path_ptr);
	     call free (dbm_ptr, domain_info.get_after_path_ptr);
	     call free (dbm_ptr, domain_info.mod_before_path_ptr);
	     call free (dbm_ptr, domain_info.mod_err_path_ptr);
	     call free (dbm_ptr, domain_info.mod_after_path_ptr);
	     call free (dbm_ptr, rel (di_ptr));
	     end;					/* do while */

	db_model.num_domains = 0;

	return;
     end delete_domains;
%page;
delete_unreferenced_attributes:
     proc;

	do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
	     repeat ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) while (rel (ua_ptr) ^= NULL_OFFSET);

	     db_model.unreferenced_attribute_ptr = unreferenced_attribute.fwd_thread;
	     call free (dbm_ptr, rel (ua_ptr));
	     end;					/* do while */

	return;
     end delete_unreferenced_attributes;
%page;
transaction_in_progress:
     proc;

	if db_model.db_type_flags.transactions_needed
	then do;
	     mstxn_transactions_needed = "1"b;
	     call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
	     if mstxn_code = 0
	     then do;
		mstxn_txn_id = "0"b;
		call error (error_table_$action_not_performed,
		     rtrim (ENTRY_POINT_NAMES (entry_point)) ||
		     " may not be deleted while a transaction is in progress. Commit or abort the transaction and try again.");
		end;
	     end;
	else mstxn_transactions_needed = "0"b;

	if entry_point = DOMAINS
	then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_domain", "Deleting all domains.",
		"delete_domain -all -brief");
	else if entry_point = ATTRIBUTES
	     then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_attribute", "Deleting all attributes.",
		     "delete_attribute -all -brief");
	     else call mdbm_util_$inconsistent_set (dbm_ptr, "delete_relation", "Deleting all relations.",
		     "delete_relation -all -brief");

	return;
     end transaction_in_progress;
%page;
free:
     proc (base_ptr, offset);

dcl  base_ptr ptr parameter;				/* base of segment */
dcl  based_variable fixed bin (35) based;		/* used just to free structures */
dcl  freeing_ptr ptr;				/* -&gt; structure to free */
dcl  offset bit (18) unaligned parameter;		/* offset to base_ptr of structure */

	if offset ^= NULL_OFFSET
	then do;
	     freeing_ptr = ptr (base_ptr, offset);
	     free freeing_ptr -&gt; based_variable;
	     offset = NULL_OFFSET;
	     end;
	return;
     end free;
%page;
/*DESCRIPTION
  Error handler and cleanup handler. This is the only way to exit these
  subroutines.
*/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;

RETURN_TO_CALLER:
	call cleaner;
	return;

cleaner:
     proc;

	if temp_ptr ^= null
	then call mdbm_util_$free_temp_segment (myname, temp_ptr, (0));

	return;
     end cleaner;

restore_significant_data:
     proc;
	return;
     end restore_significant_data;

should_rollback:
     proc returns (bit (1) aligned);
	return ("0"b);
     end should_rollback;
%page;
%include access_mode_values;
%include mrds_rmdb_ctl;
%include mdbm_db_model;
%include mdbm_file_model;
%include rmdb_crossref_info;
%include rmdb_history_entry;
%page;
dcl  addr builtin;
dcl  any_other condition;
dcl  ATTRIBUTES fixed bin int static options (constant) init (2);
dcl  based_char8 char (8) based;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  DOMAINS fixed bin int static options (constant) init (1);
dcl  entry_point fixed bin;
dcl  ENTRY_POINT_NAMES (3) char (32) int static options (constant) init ("Domains", "Attributes", "Relations");
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  fixed builtin;
dcl  index builtin;
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  local_iocb ptr;
dcl  mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
dcl  mdbm_util_$xref_destroy entry (ptr, char(*), char(*), char(*), fixed bin(35));
dcl  myname char (32) int static options (constant) init ("rmdb_delete_all");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  ptr builtin;
dcl  quit condition;
dcl  quit_occurred bit (1) aligned;
dcl  rel builtin;
dcl  RELATIONS fixed bin int static options (constant) init (3);
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char(32), fixed bin, char(32), char(500), fixed bin(35));
dcl  rtrim builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  temp_ptr ptr;

     end rmdb_delete_all;
��



		    rmdb_delete_attribute.pl1       12/07/87  1328.9rew 12/07/87  1321.2      304515



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

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

/*DESCRIPTION
  This subroutine deletes one or more attributes from a MRDS database. Each of
  the attributes is examined, and a list of relations to be operated upon is
  created. This is so that if more than one referenced attribute is being
  deleted, each relation is only reformatted once. If an attribute is
  unreferenced, it is simply removed from the db_model linked list. If it is
  referenced, the relations that contain those attribute must be reformatted. */

/****^  HISTORY COMMENTS:
  1) change(85-02-07,Spitzer), approve(85-02-07,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
  2) change(86-10-30,Blair), approve(86-10-30,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     Re-arrange the quit handler so that we only hold quits while we're
     cleaning up the model, switching relation names and updating the xref and
     history files.  No need elsewhere because once the model is marked
     inconsistent the salvager will roll back the relations and model if
     anything goes wrong.
  3) change(87-09-30,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis),
     install(87-12-07,MR12.2-1008):
     Set the undo_request variable to null so that if a problem occurs during
     execution of this request we will not loop endlessly trying to execute
     the request and roll the database back.  Set mstxn-txn_id to zero so we
     don't get caught if we have a vfile_ database, but we try to abort a txn
     during cleanup based on some residue value in the field,
                                                   END HISTORY COMMENTS */

rmdb_delete_attribute:
     proc (Irmdb_ctl_ptr, Idelete_object_info_ptr, Oerror_message, Ocode);

	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	delete_object_info_ptr = Idelete_object_info_ptr;

	user_area_ptr = null;

	if delete_object_info.version ^= delete_object_info_version_1
	then call error (error_table_$unimplemented_version,
		"Version " || delete_object_info.version || " for delete_object_info structure.");

	db_path = rmdb_ctl.absolute_db_path;		/* Create the xref file if not already created. */
	if rmdb_ctl.crossref_file_info.iocb_ptr = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, db_path, rmdb_ctl.db_model_ptr,
		rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     end;

	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;
	mstxn_txn_id = "0"b;
	
	on cleanup
	     begin;
		call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
		     rmdb_ctl.crossref_file_info.name, (""), (0));
		call cleaner;
	     end;

	dbm_ptr = rmdb_ctl.db_model_ptr;

	if delete_object_info.all
	then call rmdb_delete_all$attributes (rmdb_ctl_ptr, error_message, code);
	else do;

/* Create a non-freeing, non-zeroing extensible area to allocate structures in.
   When we return and finish using these structures, we will simply throw away
   the area. */
	     call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, user_area_ptr, code);
	     if code ^= 0
	     then call error (code, "Unable to get a temp segment in the temp dir.");

	     unspec (ai) = "0"b;
	     ai.version = area_info_version_1;
	     ai.extend = "1"b;
	     ai.dont_free = "1"b;
	     ai.no_freeing = "1"b;
	     ai.owner = myname;
	     ai.size = sys_info$max_seg_size;
	     ai.areap = user_area_ptr;

	     call define_area_ (addr (ai), code);
	     if code ^= 0
	     then call error (code, "Defining a user area.");

	     domain_list_ptr, attribute_list_ptr, relation_list_ptr = null;
	     if delete_object_info.unreferenced
	     then call make_unreferenced_attribute_list;
	     else do;
		call rmdb_relations_used$attributes (rmdb_ctl_ptr, delete_object_info_ptr, user_area_ptr,
		     domain_list_ptr, attribute_list_ptr, relation_list_ptr, error_message, code);
		if code ^= 0
		then call error (code, error_message);

		call check_for_deletion_of_generated_attributes;

		if ^delete_object_info.force
		then do;
		     unspec (query_info) = "0"b;
		     query_info.version = query_info_version_6;
		     query_info.yes_or_no_sw = "1"b;
		     query_info.suppress_name_sw = "1"b;
		     query_info.question_iocbp = delete_object_info.check_iocb_ptr;
		     query_info.answer_iocbp = delete_object_info.query_iocb_ptr;
		     query_info.explanation_ptr = addr (QUERY_MSG);
		     query_info.explanation_len = length (rtrim (QUERY_MSG));
		     end;

		call print_information;

		if (delete_object_info.long = UNSPEC &amp; delete_object_info.check)
		then do;
		     code = 0;
		     call error (code, error_message);
		     end;
	     end;

	     call check_for_deletion_of_primary_key;

	     make_consistent_msg = "";          /* if anything goes wrong we can't retry */
	

	     call mdbm_util_$inconsistent_set (dbm_ptr, "delete_attribute", "Deleting attributes",
		rtrim (make_consistent_msg));


/* Invalidate the resultant. */
	     if ^delete_object_info.unreferenced
	     then do;
		rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";

		last_unreferenced_attribute_ptr = null;
		relation_good_count, save_code = 0;

		do relation_index = 1 to relation_list.count;
		     relation_ptr = relation_list.relation_ptr (relation_index);
		     relation_good_count = relation_good_count + 1;
		     call process_single_relation;
		     if code ^= 0
		     then do;
			save_code = code;
			goto cleanup_directory;
		     end;				/* do relation_index */
		end;
/* If we get here, we have copied all the relations, so now we need to clean
   up by deleting the copies of the file model and the old relations.       */

cleanup_directory:	

/* The real work starts here - hold quits till we're done */
	     quit_occurred = "0"b;			/* BEGIN CRITICAL CODE */
	     on quit quit_occurred = "1"b;

	     do relation_index = 1 to relation_good_count;
		     relation_ptr = relation_list.relation_ptr (relation_index);
		     fm_ptr = relation.file_model_ptr;
		     call transaction_in_progress;
		     if mstxn_transactions_needed
		     then do;
			on cleanup
			     begin;
			     call mstxn_cleanup;
			     call cleaner;
			     end;
			on any_other call mstxn_any_other;
%include mrds_start_transaction;
                              if mstxn_code ^= 0
			then call error (mstxn_code, "Could not start a transaction.");
			end;
		     call switch_names;

		     if mstxn_transactions_needed
		     then do;
			mftxn_code = 0;
%include mrds_finish_transaction;
                              end;
		     end;
	     end;                               /* do relation_index */

	     if save_code ^= 0
	     then do;
		call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,   
		     rmdb_ctl.crossref_file_info.name, (""), (0));
	          call error (save_code, error_message);
		end;
	     	     
/* Unlink the unreferenced_attribute structure in the db_model if any of the
   attributes being deleted are unreferenced. */
	     call delete_unreferenced_attribute_list;

	     call mdbm_util_$inconsistent_reset (dbm_ptr);
	     call process_xref_records;

	     revert quit;				/* END CRITICAL CODE */
	     if quit_occurred
	     then signal quit;

	     code = 0;
	     end;

	call error (code, error_message);
%page;
/*DESCRIPTION
  Error handler and cleanup handler. This is the only way to exit these
  subroutines.
*/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	if code = 0
	then Oerror_message = "";
	else Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;

RETURN_TO_CALLER:
	call cleaner;
	return;

cleaner:
     proc;

	if user_area_ptr ^= null
	then do;
	     call release_area_ (user_area_ptr);
	     call mdbm_util_$free_temp_segment (myname, user_area_ptr, (0));
	     end;

	if mstxn_txn_id ^= "0"b
	then do;
	     call transaction_manager_$abort_txn (mstxn_txn_id, code);
	     if code ^= 0
	     then call transaction_manager_$abandon_txn (mstxn_txn_id, (0));
	     end;

	return;
     end cleaner;

restore_significant_data:
     proc;
	return;
     end restore_significant_data;

should_rollback:
     proc returns (bit (1) aligned);
	return ("0"b);
     end should_rollback;
%page;
make_name:
     proc (input_name) returns (char (33));

dcl  input_name char (*) parameter;

	return (OBJECT_HEAD || input_name);
     end make_name;

unmake_name:
     proc (input_name) returns (char (32));

dcl  input_name char (*) parameter;

	return (substr (input_name, 2, 32));
     end unmake_name;

/*DESCRIPTION
  This subroutine ensures that no transaction is in progress, and sets a flag
  bit for use later. */

transaction_in_progress:
     proc;

	if db_model.db_type_flags.transactions_needed
	then do;
	     mstxn_transactions_needed = "1"b;
	     call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
	     if mstxn_code = 0
	     then do;
		mstxn_txn_id = "0"b;
		call error (error_table_$action_not_performed,
		     "A transaction is in progress. Commit or abort the transaction and try the operation again.");
		end;
	     end;
	else mstxn_transactions_needed = "0"b;

	return;
     end transaction_in_progress;

%page;
/*DESCRIPTION
  This subroutine checks all attributes in the attribute_list structure to
  ensure that none of the requested attributes are generated attributes
  (attributes that don't really exist, but are present because for each domain
  there is a generated attribute with the same name). These cannot be deleted. */

check_for_deletion_of_generated_attributes:
     proc;

	do attribute_list_idx = 1 to attribute_list.count;
	     di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx));
	     if domain_info.name = unmake_name (attribute_list.name (attribute_list_idx))
	     then if delete_object_info.inhibit_errors
		then attribute_list.name (attribute_list_idx) = "";
		else call error (error_table_$unsupported_operation,
			"Attempt to delete a generated attribute " || domain_info.name);
	     end;					/* do attribute_list_idx */

	return;
     end check_for_deletion_of_generated_attributes;
%page;
check_for_deletion_of_primary_key:
     proc;

dcl attr_idx fixed bin;
dcl deletion_attributes char (500);
dcl no_primary_key bit (1) aligned;

/* Check to make sure that we wouldn't be getting rid of a primary key. */

          deletion_attributes = "";
	no_primary_key = "1"b;
	do attribute_list_idx = 1 to attribute_list.count;
	     attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
	     if attribute_ptr ^= null then do attr_idx = 1 to attribute.count;
		relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attr_idx));
		do attribute_idx = 1 to relation.attribute_count;
		     if relation.attribute(attribute_idx).flags.part_of_key 
			&amp; relation.attribute_names (attribute_idx) = attribute_list.name (attribute_list_idx)
		     then do;
			no_primary_key = "0"b;
			relation.attribute(attribute_idx).flags.to_be_deleted = "1"b;
			end;
		end;
	     end;
	end;
	if ^no_primary_key 
	then do relation_index = 1 to relation_list.count while (^no_primary_key);
	     relation_ptr = relation_list.relation_ptr(relation_index);
	     do attribute_idx = 1 to relation.attribute_count while (^no_primary_key);
		if relation.attribute(attribute_idx).flags.part_of_key 
		then if ^relation.attribute(attribute_idx).flags.to_be_deleted
		     then no_primary_key = "1"b;
		     else do;
			attribute_name = unmake_name (relation.attribute_names (attribute_idx));
			relation.attribute(attribute_idx).flags.to_be_deleted = "0"b;
			deletion_attributes = rtrim(deletion_attributes) || " " || rtrim(attribute_name);
			end;
		end;
	     if ^no_primary_key 
	     then do;
		code = mrds_error_$no_primary_key;
		call error (code, "Deletion of the attribute(s) " || rtrim(deletion_attributes) || " would result in no primary key in relation "  || rtrim(relation.name) || ".");
		end;
	end;
	end check_for_deletion_of_primary_key;
%page;
/*DESCRIPTION
  Delete all the attribute crossreference records, and update all the domain
  records to indicate that the attributes in attribute_list don't exist so
  therefore cannot be referenced by a domain. */

process_xref_records:
     proc;

	do attribute_list_idx = 1 to attribute_list.count;
	     if attribute_list.name (attribute_list_idx) ^= ""
	     then do;
		attribute_name = unmake_name (attribute_list.name (attribute_list_idx));
		call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, error_message,
		     code);
		if code ^= 0
		then if (code ^= error_table_$no_record) &amp; (^delete_object_info.inhibit_errors)
		     then call error (code, error_message);

		di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx));
		call mdbm_util_$xref_dereference (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), attribute_name,
		     reference_count , error_message, code);
		if code ^= 0
		then if ^delete_object_info.inhibit_errors
		     then call error (code, error_message);

		if reference_count &lt;= 1 
		then domain_info.unreferenced = "1"b;
		
		call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (domain_info.name), RMDB_DEL_ATTR_OP, attribute_name, (""), (0));
		end;
	     end;					/* do attribute_list_idx */

     end process_xref_records;
%page;
/*DESCRIPTION
  This subroutine frees the unreferenced_attribute structure in the db_model for
  each attribute in the attribute_list. It assumes that each of the entries in
  that list are unreferenced attributes. */

delete_unreferenced_attribute_list:
     proc;

	do attribute_list_idx = 1 to attribute_list.count;
	     if (attribute_list.name (attribute_list_idx) ^= "")
		&amp; (attribute_list.attribute_ptr (attribute_list_idx) = null)
	     then do;
		di_ptr = ptr (dbm_ptr, attribute_list.domain_info_ptr (attribute_list_idx));
		attribute_name = unmake_name (attribute_list.name (attribute_list_idx));
		previous_ptr, save_ptr = null;
		do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
		     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread)
		     while ((rel (ua_ptr) ^= NULL_OFFSET) &amp; (save_ptr = null));

		     if attribute_name = unreferenced_attribute.name
		     then save_ptr = ua_ptr;
		     else previous_ptr = ua_ptr;
		     end;				/* do ua_ptr */

		if save_ptr ^= null
		then do;
		     if previous_ptr = null
		     then db_model.unreferenced_attribute_ptr = save_ptr -&gt; unreferenced_attribute.fwd_thread;
		     else previous_ptr -&gt; unreferenced_attribute.fwd_thread =
			     save_ptr -&gt; unreferenced_attribute.fwd_thread;

		     free save_ptr -&gt; unreferenced_attribute in (dbm_area);
		     end;

		call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (domain_info.name), RMDB_DEL_ATTR_OP, attribute_name, (""), (0));

		end;
	     end;					/* do attribute_list_idx */

	return;
     end delete_unreferenced_attribute_list;
%page;
/*DESCRIPTION
  Create an attribute_list structure populated by all the entries in the
  unreferenced_attribute list in the db_model. */

make_unreferenced_attribute_list:
     proc;

/* Count up the unreferenced attributes */
	attribute_list_count = 0;
	do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
	     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET);
	     attribute_list_count = attribute_list_count + 1;
	     end;					/* do ua_ptr */

	if attribute_list_count = 0
	then if delete_object_info.inhibit_errors
	     then call error (0, "");
	     else call error (mrds_error_$no_unref_attr, "");

/* Create the attribute_list structure and populate it. */
	allocate attribute_list in (user_area) set (attribute_list_ptr);
	attribute_list_count = 0;
	do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
	     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET);

	     attribute_list_count = attribute_list_count + 1;
	     attribute_list.name (attribute_list_count) = make_name ((unreferenced_attribute.name));
	     attribute_list.attribute_ptr (attribute_list_count) = null;
	     attribute_list.domain_info_ptr (attribute_list_count) = unreferenced_attribute.domain_ptr;
	     end;					/* do ua_ptr */

	return;
     end make_unreferenced_attribute_list;
%page;
/*DESCRIPTION
  Print the information for the -check option. Optionally query to check for
  deletion. */

print_information:
     proc;

dcl  cancel_attribute bit (attribute_list.count);
dcl  first_cancel_attribute fixed bin;

	cancel_attribute = "0"b;
	first_cancel_attribute = 0;

	do attribute_list_idx = 1 to attribute_list.count;
	     if attribute_list.name (attribute_list_idx) ^= ""
	     then do;
		attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
		attribute_name = unmake_name (attribute_list.name (attribute_list_idx));

		if delete_object_info.check
		then do;
		     if attribute_ptr = null
		     then call ioa_$ioa_switch (delete_object_info.check_iocb_ptr, "^/Attribute ""^a"" is unreferenced.",
			attribute_name);
		     else do;
			call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr,
			     "^/Attribute ""^a"" is used in relation^[s^]", attribute_name, attribute.count &gt; 1);
			do attribute_idx = 1 to attribute.count;
			     relation_name = unmake_name (relation_list.name (attribute.relation_idx (attribute_idx)));
			     if attribute_idx = 1
			     then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, " ""^a""", relation_name);
			     else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ and^;,^] ""^a""",
				(attribute.count = attribute_idx), relation_name);
			     end;			/* do attribute_idx */
			call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ".^/");
			end;
		     end;
		
		if (delete_object_info.check &amp; delete_object_info.long = UNSPEC) then;
		else if ^delete_object_info.force 
		then if ^query ()
		     then do;
			substr (cancel_attribute, attribute_list_idx, 1) = "1"b;
			if first_cancel_attribute = 0
			then first_cancel_attribute = attribute_list_idx;
			end;

		end;
	     end;					/* do attribute_list_idx */

	if first_cancel_attribute ^= 0
	then call recalculate_attributes_deleted;

	return;
%page;
query:
     proc returns (bit (1) aligned);

dcl  answer char (3);

	call command_query_ (addr (query_info), answer, delete_object_info.request_name,
	     "     Do you wish to delete the attribute " || rtrim(attribute_name) || " ?");
	if answer = "no"
	then return ("0"b);
	else return ("1"b);

     end query;
%page;
/*DESCRIPTION
  If any of delete operations have been cancelled, this subroutine recalculates
  which attributes of which relations have to be deleted. */

recalculate_attributes_deleted:
     proc;

dcl  have_attributes_to_process bit (1) aligned;
dcl  position fixed bin;
dcl  search_name char (33);

/* First mark all attributes in all referenced relations undeleted. */
	do relation_index = 1 to relation_list.count;
	     relation_ptr = relation_list.relation_ptr (relation_index);
	     unspec (relation.attribute (*).flags) = "0"b;
	     end;					/* do relation_index */

/* Now walk through the attribute list, marking each attribute in the relation
   structures deleted or not. */
	have_attributes_to_process = "0"b;
	do attribute_list_idx = 1 to attribute_list.count;
	     if substr (cancel_attribute, attribute_list_idx, 1)
	     then attribute_list.name (attribute_list_idx) = "";
	     else do;
		have_attributes_to_process = "1"b;
		attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
		if attribute_ptr ^= null
		then do;
		     search_name = attribute_list.name (attribute_list_idx);
		     do attribute_idx = 1 to attribute.count;
			relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx));
			position = index (relation_attribute_names, search_name);
			if position ^= 0
			then do;
			     position = divide (position, 33, 17, 0) + 1;
			     relation.attribute (position).flags.delete = "1"b;
			     end;
			end;			/* do attribute_idx */
		     end;
		end;
	     end;					/* do attribute_list_idx */

	if ^have_attributes_to_process
	then call error (0, "");

	return;
     end recalculate_attributes_deleted;

     end print_information;
%page;
/*DESCRIPTION
  This subroutine either deletes all information pertaining to a relation (if
  all attributes are deleted) or reformats it (if only some attributes are
  deleted. */

process_single_relation:
     proc;

	if all_attributes_are_deleted ()
	then call delete_relation_information;
	else call rmdb_copy_relation (dbm_ptr, db_path, rmdb_ctl.temp_dir_path, addr (rmdb_ctl.relmgr_entries),
		relation_ptr, error_message, code);
	return;
     end process_single_relation;
%page;
/* DESCRIPTION
*  This module was brought over from rmdb_copy_relation since we can't really 
*  clean up before we have finished with ALL the relations.  It performs 
*  several steps;  initiate the copy of the file_model (.k), get the name of
*  the associated relation, copy contents of new file_model to the old one,
*  move the data from the old file to the new one, delete the old relation,
*  rename the new relation to the old name (or physically copy to old name if
*  dm file), remove the copy of the file_info from the db_model and free the
*  space.  Finally, we must update the xref file to show that the relation is
*  no longer in the attribute key record. */
	 

switch_names:
     proc;

dcl  1 local_status_branch like status_branch;
dcl  create_model_name char (32);
dcl  create_relation_name char (32);
dcl  data_acl_ptr ptr;
dcl  r_index fixed bin;
dcl  index builtin;
dcl  move_string char (move_string_length) based;
dcl  move_string_length fixed bin (35);
dcl  new_model_bit_count fixed bin (24);
dcl  new_file_model_ptr ptr;
dcl  last_file_info_ptr ptr;
dcl  1 co aligned like copy_options;
dcl  cvds bit (1) aligned;
dcl  ivds bit (1) aligned;
dcl  to_char fixed bin;

          create_model_name = rtrim (relation.name) || ".k";
	status_area_ptr = user_area_ptr;
	status_ptr = addr (local_status_branch);
	call hcs_$status_ (db_path, create_model_name, 0, status_ptr, status_area_ptr, code);
	to_char = index(status_entry_names (1), ".m");
	to_char = to_char -1;
	create_relation_name = rtrim(substr(status_entry_names (1), 1, to_char));
          call initiate_file_ (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, new_model_bit_count, code);
	if code ^= 0
          then call error (code, "While initiating the new_file_model for relation " || relation.name);
	rmdb_relmgr_entries_ptr = addr (rmdb_ctl.relmgr_entries);

/* Move the contents of the new relation.m to old relation.m. */
	if (file_model.file_model_copy_good &amp; file_model.relation_copy_good &amp; save_code = 0)  
	then do;
	     move_string_length = divide (new_model_bit_count, 9, 35, 0);
	     fm_ptr -&gt; move_string = new_file_model_ptr -&gt; move_string;

/* Move the contents of the data relation. First we must get the attributes of
   the old data file (ACL, mode switches) and move them to the new data file. */
	     data_acl_ptr = null;
	     call fs_util_$list_acl (db_path, relation.name, GENERAL_ACL_VERSION_1, user_area_ptr, data_acl_ptr, code);
	     if code ^= 0
	     then call error (code, "Getting the ACL to relation " || relation.name);

	     call fs_util_$replace_acl (db_path, create_relation_name, data_acl_ptr, "1"b, code);
	     if code ^= 0
	     then call error (code, "Setting the ACL on relation " || create_relation_name);

	     cvds, ivds = "0"b;
	     call fs_util_$get_switch (db_path, relation.name, "complete_volume_dump", cvds, (0));
	     call fs_util_$get_switch (db_path, relation.name, "incremental_volume_dump", ivds, (0));
	     
	     call fs_util_$set_switch (db_path, create_relation_name, "complete_volume_dump", cvds, (0));
	     call fs_util_$set_switch (db_path, create_relation_name, "incremental_volume_dump", ivds, (0));

/* Now get rid of the old data file. */
	     call rmdb_relmgr_entries.delete_relation (db_path, relation.name, code);
	     if code ^= 0
	     then call error (code, "Deleting relation " || relation.name);

/* If we are dealing with DM files, we need to physically copy the relation
   file. If not, then we can simply rename the new one to the old name. */
	     if mstxn_transactions_needed
	     then do;
		co.version = COPY_OPTIONS_VERSION_1;
		co.caller_name = myname;
		co.source_dir, co.target_dir = db_path;
		co.source_name = create_relation_name;
		co.target_name = relation.name;

		unspec (co.flags) = "0"b;
		unspec (co.copy_items) = "0"b;

		call fs_util_$copy (addr (co), code);
		if code ^= 0
		then call error (code, "Copying the new data file onto the old data file for relation " || relation.name);
		end;
	     else do;
		call hcs_$chname_file (db_path, create_relation_name, create_relation_name, relation.name, code);
		if code ^= 0
		then call error (code, "Renaming relation file from " || rtrim (create_relation_name) || " to " || relation.name);
		end; 
	     end;                      /* file_model and relation good */

/* Since we renamed the new to the old, we can get rid of the new names. */
/* We also replaced the original file_model with the new_one. */
	call rmdb_relmgr_entries.delete_relation (db_path, create_relation_name, (0));
	call delete_$path (db_path, create_model_name, "101111"b, myname, (0));

/* Take the copy of the file_model out of the db_model */
	if relation.copy_file_model_ptr ^= null
          then do;
	     do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= rel (copy_file_model_ptr));
		last_file_info_ptr = fi_ptr;
		end;

	     last_file_info_ptr -&gt; file_info.fwd_ptr = copy_file_model_ptr -&gt; file_info.fwd_ptr;
	     free relation.copy_file_model_ptr -&gt; file_info in (dbm_area);
	     end;
	
	if (code ^= 0)
	then if ^delete_object_info.inhibit_errors
	     then call error (code, error_message);
	     else ;				/* ignore the error */
	else if save_code = 0
		
/* Now we have to update the crossreference file records for all attributes that
   were deleted in this relation. */
	     then do r_index = 1 to relation.attribute_count;
		if relation.attribute (r_index).flags.delete
		then do;
		     attribute_name = unmake_name (relation.attribute_names (r_index));
		     call mdbm_util_$xref_dereference (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, relation.name,
			reference_count, error_message, code);
		     if (code ^= 0) &amp; ^(delete_object_info.inhibit_errors)
		     then call error (code, error_message);

		     end;
		end;				/* do relation_index */
		
	return;
     end switch_names;
%page;
/*DESCRIPTION
  This function searches the attribute list of the current relation and returns
  true if all the attributes are marked for deletion. */
all_attributes_are_deleted:
     proc returns (bit (1) aligned);

dcl  attribute_idx fixed bin;

	do attribute_idx = 1 to relation.attribute_count;
	     if ^relation.attribute (attribute_idx).flags.delete
	     then return ("0"b);
	     end;					/* do relation_index */

	return ("1"b);
     end all_attributes_are_deleted;


delete_relation_information:
     proc;

/* Unlink the file_info structure. */
	save_ptr, previous_ptr = null;
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while ((save_ptr = null) &amp; (rel (fi_ptr) ^= NULL_OFFSET));
	     if file_info.file_name = relation.name
	     then save_ptr = fi_ptr;
	     else previous_ptr = fi_ptr;
	     end;					/* do fi_ptr */

	if save_ptr ^= null
	then do;
	     if previous_ptr = null
	     then db_model.file_ptr = save_ptr -&gt; file_info.fwd_ptr;
	     else previous_ptr -&gt; file_info.fwd_ptr = save_ptr -&gt; file_info.fwd_ptr;

	     free save_ptr -&gt; file_info in (dbm_area);

	     call mdbm_util_$xref_delete_record (local_iocb, RELATION_KEY_HEAD, relation.name, error_message, (0));
	     end;

/* Now delete the relation and relation.m files. */
	call delete_file (relation.name);
	call delete_file (rtrim (relation.name) || ".m");

	db_model.num_blk_files = db_model.num_blk_files - 1;
	db_model.num_rels = db_model.num_rels - 1;

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, relation.name, RMDB_DEL_REL_OP, "", (""), (0));
	return;

delete_file:
     proc (file_name);

dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  file_name char (*) parameter;
dcl  fs_util_$delentry_file entry (char (*), char (*), fixed bin (35));

	call fs_util_$delentry_file (db_path, file_name, code);
	if code = error_table_$unsupported_operation
	then call delete_$path (db_path, file_name, "101111"b, myname, code);

	if (code ^= 0) &amp; (^delete_object_info.inhibit_errors)
	then call error (code, "Deleting " || file_name);

	return;
     end delete_file;

     end delete_relation_information;

%page;
%include access_mode_values;
%include acl_structures;
%include area_info;
%include copy_flags;
%include copy_options;
%include mdbm_db_model;
%include mdbm_file_model;
%include mrds_rmdb_ctl;
%include query_info;
%include rmdb_crossref_info;
%include rmdb_delete_object_info;
%include rmdb_history_entry;
%include status_structures;
%page;
dcl  addr builtin;
dcl  1 ai like area_info aligned;
dcl  any_other condition;
dcl  attribute_idx fixed bin;
dcl  attribute_list_idx fixed bin;
dcl  attribute_name char (32);
dcl  based_char8 char (8) based;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  command_query_ entry () options (variable);
dcl  db_path char (168);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35));
dcl  divide builtin;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$unsupported_operation fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  fixed builtin;
dcl  fs_util_$copy entry (ptr, fixed bin(35));
dcl  fs_util_$get_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35));
dcl  fs_util_$list_acl entry (char(*), char(*), char(*), ptr, ptr, fixed bin(35));
dcl  fs_util_$replace_acl entry (char(*), char(*), ptr, bit(1), fixed bin(35));
dcl  fs_util_$set_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35));
dcl  hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl  Idelete_object_info_ptr ptr parameter;
dcl  index builtin;
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  last_unreferenced_attribute_ptr ptr;
dcl  length builtin;
dcl  local_iocb ptr;
dcl  make_consistent_msg char (500);
dcl  mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry options (variable);
dcl  mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_delete_record entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mdbm_util_$xref_dereference entry (ptr, char (*), char (*), char (*), fixed bin (21), char (*), fixed bin (35));
dcl  mrds_error_$no_primary_key fixed bin (35) ext static;
dcl  mrds_error_$no_unref_attr fixed bin (35) ext static;
dcl  myname char (32) int static options (constant) init ("rmdb_delete_attribute");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  previous_ptr ptr;
dcl  (ptr, pointer) builtin;
dcl  QUERY_MSG char (256) int static options (constant)
	init ("Answering yes will cause the specified attribute to be deleted from the
currently readied MRDS database.");
dcl  quit condition;
dcl  quit_occurred bit (1) aligned;
dcl  reference_count fixed bin (21);
dcl  rel builtin;
dcl  relation_good_count fixed bin;
dcl  relation_index fixed bin;
dcl  relation_name char (32);
dcl  release_area_ entry (ptr);
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
dcl  rmdb_copy_relation entry (ptr, char (*), char (*), ptr, ptr, char (*), fixed bin (35));
dcl  rmdb_delete_all$attributes entry (ptr, char (*), fixed bin (35));
dcl  rmdb_relations_used$attributes entry (ptr, ptr, ptr, ptr, ptr, ptr, char (*), fixed bin (35));
dcl  rtrim builtin;
dcl  save_code fixed bin (35);
dcl  save_ptr ptr;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  unspec builtin;
dcl  UNSPEC bit (2) aligned int static options (constant) init ("00"b);
dcl  user_area area based (user_area_ptr);
dcl  user_area_ptr ptr;

     end rmdb_delete_attribute;
�



		    rmdb_delete_domain.pl1          12/07/87  1328.9rew 12/07/87  1320.5      353880



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

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

/*DESCRIPTION
  This subroutine deletes one or more domains from a MRDS database. Each of the
  domains is examined, and a list of relations to be operated upon is created.
  This is so that if more than one referenced domain is being deleted, each
  relation is only reformatted once. If a domain is unreferenced, it is simply
  removed from the db_model linked list. If it is referenced, the attributes
  defined upon the domains must be deleted, and the relations that contain those
  attribute must be reformatted.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
  2) change(86-10-30,Blair), approve(86-10-30,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     Re-arrange the quit handler so that we only hold quits during the time we
     are cleaning up - rename the relations, delete old model, update history
     and xref files.  Everywhere else, once the model is marked inconsistent,
     the salvager will do our cleanup if necessary so we don't need to worry
     about the user typing something which would make the model and relations
     inconsistent.
  3) change(87-11-03,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis),
     install(87-12-07,MR12.2-1008):
     Initialize mstxn_txn_id so that we don't get caught trying to abort a txn
     that doesn't exist during cleanup.  This happens if there is garbage in
     the field and dm is not available.
                                                   END HISTORY COMMENTS */

rmdb_delete_domain:
     proc (Irmdb_ctl_ptr, Idelete_object_info_ptr, Oerror_message, Ocode);

	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	delete_object_info_ptr = Idelete_object_info_ptr;

	last_unreferenced_attribute_ptr, user_area_ptr = null;
	
	if delete_object_info.version ^= delete_object_info_version_1
	then call error (error_table_$unimplemented_version,
		"Version " || delete_object_info.version || " for delete_object_info structure.");

	db_path = rmdb_ctl.absolute_db_path;		/* Create the xref file if not already created. */
	if rmdb_ctl.crossref_file_info.iocb_ptr = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, db_path, rmdb_ctl.db_model_ptr,
		rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     end;

	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;

	mstxn_txn_id = "0"b;
	on cleanup call cleaner;

	dbm_ptr = rmdb_ctl.db_model_ptr;

	if delete_object_info.all
	then call rmdb_delete_all$domains (rmdb_ctl_ptr, error_message, code);
	else do;

/* Create a non-freeing, non-zeroing extensible area to allocate structures in.
   When we return and finish using these structures, we will simply throw away
   the area. */
	     call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, user_area_ptr, code);
	     if code ^= 0
	     then call error (code, "Unable to get a temp segment in the temp dir.");

	     unspec (ai) = "0"b;
	     ai.version = area_info_version_1;
	     ai.extend = "1"b;
	     ai.dont_free = "1"b;
	     ai.no_freeing = "1"b;
	     ai.owner = myname;
	     ai.size = sys_info$max_seg_size;
	     ai.areap = user_area_ptr;

	     call define_area_ (addr (ai), code);
	     if code ^= 0
	     then call error (code, "Defining a user area.");

	     domain_list_ptr, attribute_list_ptr, relation_list_ptr = null;
	     if delete_object_info.unreferenced
	     then call make_unreferenced_domain_delete_list;
	     else do;
		call rmdb_relations_used$domains (rmdb_ctl_ptr, delete_object_info_ptr, user_area_ptr,
		     domain_list_ptr, attribute_list_ptr, relation_list_ptr, error_message, code);
		if code ^= 0
		then call error (code, error_message);

		if ^delete_object_info.force
		then do;
		     unspec (query_info) = "0"b;
		     query_info.version = query_info_version_6;
		     query_info.yes_or_no_sw = "1"b;
		     query_info.suppress_name_sw = "1"b;
		     query_info.question_iocbp = delete_object_info.check_iocb_ptr;
		     query_info.answer_iocbp = delete_object_info.query_iocb_ptr;
		     query_info.explanation_ptr = addr (QUERY_MSG);
		     query_info.explanation_len = length (QUERY_MSG);
		     end;

		call print_information;

		if (delete_object_info.long = UNSPEC &amp; delete_object_info.check)
		then do;
		     code = 0;
		     call error (code, error_message);
		     end;
		end;

/* Make sure we won't be creating a relation with no primary key. */
	     call check_for_deletion_of_primary_key;

	      make_consistent_msg = "";
		
	     call mdbm_util_$inconsistent_set (dbm_ptr, "delete_domain", "Deleting domains", rtrim (make_consistent_msg));


/* Invalidate the resultant. */
	     if ^delete_object_info.unreferenced
	     then do;
		rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";

		last_unreferenced_attribute_ptr = null;
		relation_good_count, save_code = 0;

		do relation_index = 1 to relation_list.count;
		     relation_ptr = relation_list.relation_ptr (relation_index);
		     relation_good_count = relation_good_count + 1;
		     call process_single_relation;
		     if code ^= 0
		     then do;
			save_code = code;
			goto cleanup_directory;
			end;                               /* do code ^= 0 */
		     end;                                    /* do relation_index */
		end;                                         /* do referenced objects */

/* If we get here, we have copied all the relations, so now we need to clean
   up by deleting the copies of the file model and the old relations.       */

cleanup_directory:	

/* The real work starts here - hold quits till we're done */

	     quit_occurred = "0"b;			/* BEGIN CRITICAL CODE */
	     on quit quit_occurred = "1"b;  

	     do relation_index = 1 to relation_good_count;
		     relation_ptr = relation_list.relation_ptr (relation_index);
		     fm_ptr = relation.file_model_ptr;
		     call transaction_in_progress;
		     if mstxn_transactions_needed
		     then do;
			on cleanup
			     begin;
			     call mstxn_cleanup;
			     call cleaner;
			     end;
			on any_other call mstxn_any_other;
%include mrds_start_transaction;
                              if mstxn_code ^= 0
			then call error (mstxn_code, "Could not start a transaction.");
			end;
		     call switch_names;
		     if mstxn_transactions_needed
		     then do;
			mftxn_code = 0;
%include mrds_finish_transaction;
                              end;			         /* end mstxn_transactions_needed */
		     
		     end;                               /* do relation_index */
		 

/* Continue after cleaning up the directory and the model... */
	     if save_code ^= 0 
	     then do;
		call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
		     rmdb_ctl.crossref_file_info.name, (""), (0));
		call error (save_code, error_message);
		end;

	     call unlink_deleted_domains;
	     call mdbm_util_$inconsistent_reset (dbm_ptr);
	     call delete_xref_records;

/* Now we're done cleaning up xref and model and history is written */
	     revert quit; 
	     if quit_occurred
	     then signal quit; 

	     code = 0;
	     end;                                        /* end ^delete_object_info.all */

	call error (code, error_message);
%page;
/*DESCRIPTION
  Error handler and cleanup handler. This is the only way to exit these
  subroutines.
*/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	if code = 0
	then Oerror_message = "";
	else Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;

RETURN_TO_CALLER:
	call cleaner;
	return;

cleaner:
     proc;

	if user_area_ptr ^= null
	then do;
	     call release_area_ (user_area_ptr);
	     call mdbm_util_$free_temp_segment (myname, user_area_ptr, (0));
	     end;

	if mstxn_txn_id ^= "0"b
	then do;
	     call transaction_manager_$abort_txn (mstxn_txn_id, code);
	     if code ^= 0
	     then call transaction_manager_$abandon_txn (mstxn_txn_id, (0));
	     end;

	return;
     end cleaner;

restore_significant_data:
     proc;
	return;
     end restore_significant_data;

should_rollback:
     proc returns (bit (1) aligned);
	return ("0"b);
     end should_rollback;
%page;
/*DESCRIPTION
  This internal subroutine displays the crossreference information that we
  have previously gathered. It then queries (if necessary) to see if we are
  allowed to delete each domain. If any domain deletion is cancelled, we have
  to recalculate the list of attributes deleted in each relation. */

print_information:
     proc;

dcl  cancel_domain bit (domain_list.count);		/* 1 ::= we don't really want to delete this one */
dcl  first_cancel_domain fixed bin;			/* idx of first of deleted domains cancelled */
dcl  printed_names (2) char (32);
dcl  relations_printed bit (relation_list.count);		/* 1 ::= we already printed the name of this relation */
dcl  relations_printed_count fixed bin;			/* number of relation names printed */
dcl  relations_to_be_printed bit (1) aligned;		/* indicates there is at least one relation name to be printed */

	cancel_domain = "0"b;
	first_cancel_domain = 0;

	do domain_list_idx = 1 to domain_list.count;
	     relations_to_be_printed = "0"b;
	     attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx);
	     domain_name = unmake_name (domain_list.name (domain_list_idx));
	     if delete_object_info.check
	     then do;
	     if attribute_list_ptr = null
	     then call ioa_$ioa_switch (delete_object_info.check_iocb_ptr, "^/Domain ""^a"" is unreferenced.",
		     domain_name);
	     else do;
		do attribute_list_idx = 1 to attribute_list.count;
		     attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
		     attribute_name = unmake_name (attribute_list.name (attribute_list_idx));
		     if attribute_list_idx = 1
		     then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr,
			     "^/Domain ""^a"" is used in attribute^[s^] ""^a""", domain_name,
			     (attribute_list.count &gt; 1), attribute_name);
		     else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, "^[ and^;,^] ""^a""",
			     (attribute_list.count = attribute_list_idx), attribute_name);

		     if attribute_ptr ^= null
		     then relations_to_be_printed = "1"b;

		     end;				/* do attribute_list_idx */
		if relations_to_be_printed
		then do;
		     relations_printed = "0"b;
		     relations_printed_count = 0;
		     do attribute_list_idx = 1 to attribute_list.count;
			attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
			if attribute_ptr ^= null
			then do attribute_idx = 1 to attribute.count;
				relation_index = attribute.relation_idx (attribute_idx);
				if ^substr (relations_printed, relation_index, 1)
				then do;
				     substr (relations_printed, relation_index, 1) = "1"b;
				     relation_name = unmake_name (relation_list.name (relation_index));
				     relations_printed_count = relations_printed_count + 1;
				     if relations_printed_count &lt; 3
				     then printed_names (relations_printed_count) = relation_name;
				     else do;
					call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr,
					     "^[ which ^[is^;are^] referenced in relations^;^s,^] ""^a""",
					     (relations_printed_count = 3), (attribute_list.count = 1),
					     printed_names (1));
					printed_names (1) = printed_names (2);
					printed_names (2) = relation_name;
					end;
				     end;
				end;		/* do attribute_idx */
			end;			/* do attribute_list_idx */
		     if relations_printed_count &gt; 0
		     then if relations_printed_count &lt; 3
			then call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr,
				"^[ which ^[is^;are^] referenced in relation ""^a""^; which ^[is^;are^] referenced in relations ""^a"" and ""^a""",
				(relations_printed_count = 1), (attribute_list.count = 1), printed_names (1),
				printed_names (2));
			else call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ", ""^a"" and ""^a""",
				printed_names (1), printed_names (2));
		     end;				/* relations_to_be_printed */

		call ioa_$ioa_switch_nnl (delete_object_info.check_iocb_ptr, ".^/");
		end;
	     end;                                         /* delete_object_info.check = TRUE */
	
	     if (delete_object_info.check &amp; (delete_object_info.long = UNSPEC)) then;
	     else if ^delete_object_info.force
	     then if ^query ()
		then do;
		     substr (cancel_domain, domain_list_idx, 1) = "1"b;
		     if first_cancel_domain = 0
		     then first_cancel_domain = domain_list_idx;
		     end;

	     end;					/* do domain_list_idx */

	if first_cancel_domain ^= 0
	then call recalculate_attributes_deleted;

	return;

query:
     proc returns (bit (1) aligned);

	call command_query_ (addr (query_info), answer, delete_object_info.request_name,
	     "     Do you wish to delete the domain ^a ?", rtrim(domain_name));
	if answer = "no"
	then return ("0"b);
	else return ("1"b);

     end query;
%page;
/*DESCRIPTION
  Take the list of canceled domain deletions in the cancel_domain bit string
  and process it by marking all attributes in each indicated domain in each
  relation to be deleted. This subroutine must be internal to print_information
  so we can access the cancel_domain string. */

recalculate_attributes_deleted:
     proc;

dcl  have_domains_to_process bit (1) aligned;
dcl  position fixed bin;
dcl  search_name char (33);

/* First mark all attributes in all referenced relations undeleted. */
	do relation_index = 1 to relation_list.count;
	     relation_ptr = relation_list.relation_ptr (relation_index);
	     unspec (relation.attribute (*).delete) = "0"b;
	     end;					/* do relation_index */

	do domain_list_idx = 1 to first_cancel_domain - 1;
	     domain_list.name (domain_list_idx) = "";
	     end;					/* do domain_list_idx */

/* Now walk through the domain list -&gt; attributes, marking each attribute in the
   relation structures deleted or not. */
	have_domains_to_process = "0"b;
	do domain_list_idx = first_cancel_domain to domain_list.count;
	     if substr (cancel_domain, domain_list_idx, 1)
	     then domain_list.name (domain_list_idx) = "";
	     else do;
		have_domains_to_process = "1"b;
		attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx);
		do attribute_list_idx = 1 to attribute_list.count;
		     attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
		     if attribute_ptr ^= null
		     then do;			/* the attribute was referenced in at least a single relation */
			search_name = attribute_list.name (attribute_list_idx);
			do attribute_idx = 1 to attribute.count;
			     relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx));
			     position = index (relation_attribute_names, search_name);
			     if position ^= 0
			     then do;		/* found the place, mark the attribute to be deleted */
				position = divide (position, 33, 17, 0) + 1;
				relation.attribute (position).flags.delete = "1"b;
				end;
			     end;			/* do attribute_idx */
			end;
		     end;				/* do attribute_list_idx */
		end;
	     end;					/* do domain_list_ptr */

	if ^have_domains_to_process
	then call error (0, "");			/* nothing to do, return to caller */
	return;

     end recalculate_attributes_deleted;

     end print_information;
%page;
make_unreferenced_domain_delete_list:
     proc;

/* Allocate the new domain_list structure to be the number of domains
   defined in size. Unless all domains are unreferenced, some of the entries
   will not be used. Remember to adjust the refer extent of the structure. */
	domain_list_count = db_model.num_domains;
	allocate domain_list in (user_area) set (domain_list_ptr);
	domain_list.count = 0;

/* Run through all domains defined in the model. */
	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
	     while (rel (di_ptr) ^= NULL_OFFSET);

	     if domain_info.unreferenced
	     then do;				/* found a candidate */
		domain_list.count = domain_list.count + 1;
		domain_list.name (domain_list.count) = make_name ((domain_info.name));
		end;
	     end;					/* do di_ptr */
	domain_list.attribute_list_ptr (*) = null;

	if domain_list.count = 0
	then if delete_object_info.inhibit_errors
	     then call error (0, "");
	     else call error (mrds_error_$no_unref_domain, "");

	return;
     end make_unreferenced_domain_delete_list;

make_name:
     proc (input_name) returns (char (33));

dcl  input_name char (*) parameter;

	return (OBJECT_HEAD || input_name);
     end make_name;

unmake_name:
     proc (input_name) returns (char (32));

dcl  input_name char (*) parameter;

	return (substr (input_name, 2, 32));
     end unmake_name;

/*DESCRIPTION
  This subroutine ensures that no transaction is in progress, and sets a flag
  bit for use later. */

transaction_in_progress:
     proc;

	if db_model.db_type_flags.transactions_needed
	then do;
	     mstxn_transactions_needed = "1"b;
	     call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
	     if mstxn_code = 0
	     then do;
		mstxn_txn_id = "0"b;
		call error (error_table_$action_not_performed,
		     "A transaction is in progress. Commit or abort the transaction and try the operation again.");
		end;
	     end;
	else mstxn_transactions_needed = "0"b;

	return;
     end transaction_in_progress;
%page;
check_for_deletion_of_primary_key:
     proc;

dcl attr_idx fixed bin;
dcl deletion_attributes char (500);
dcl no_primary_key bit (1) aligned;

          deletion_attributes = "";
	no_primary_key = "1"b;
	do domain_list_idx = 1 to domain_list.count;
	     attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx);
	     domain_name = unmake_name (domain_list.name (domain_list_idx));
	     do attribute_list_idx = 1 to attribute_list.count;
		attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
		if attribute_ptr ^= null then do attr_idx = 1 to attribute.count;
		     relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attr_idx));
		     do attribute_idx = 1 to relation.attribute_count;
			if relation.attribute(attribute_idx).flags.part_of_key 
			     &amp; relation.attribute_names (attribute_idx) = attribute_list.name (attribute_list_idx)
			     then do;
			     no_primary_key = "0"b;
			     relation.attribute(attribute_idx).flags.to_be_deleted = "1"b;
			     end;
			end;
		     end;
		end;
	     end;
	if ^no_primary_key 
	then do relation_index = 1 to relation_list.count while (^no_primary_key);
	     relation_ptr = relation_list.relation_ptr(relation_index);
	     do attribute_idx = 1 to relation.attribute_count while (^no_primary_key);
		if relation.attribute(attribute_idx).flags.part_of_key 
		then if ^relation.attribute(attribute_idx).flags.to_be_deleted
		     then no_primary_key = "1"b;
		     else do;
			attribute_name = unmake_name (relation.attribute_names (attribute_idx));
			relation.attribute(attribute_idx).flags.to_be_deleted = "0"b;
			deletion_attributes = rtrim(deletion_attributes) || " " || rtrim(attribute_name);
			end;
		end;
	     if ^no_primary_key 
	     then do;
		code = mrds_error_$no_primary_key;
		call error (code, "Deletion of the domain " || rtrim(domain_name) || " would result in no primary key in relation "  || rtrim(relation.name) || ".");
		end;
	end;
	end check_for_deletion_of_primary_key;
%page;
/*DESCRIPTION
  This subroutine either deletes all information pertaining to a relation (if
  all domains are deleted) or reformats it according to the list of deleted
  domains. */

process_single_relation:
     proc;

     
	if all_attributes_are_deleted ()
	then call delete_relation_information;
	else call rmdb_copy_relation (dbm_ptr, db_path, rmdb_ctl.temp_dir_path, addr (rmdb_ctl.relmgr_entries),
		relation_ptr, error_message, code);
	if code ^= 0
	then do;
	     if code = mrds_error_$no_primary_key
	     then	call mdbm_util_$inconsistent_reset (dbm_ptr);
	     if delete_object_info.inhibit_errors | code = dm_error_$key_duplication
	     then goto skip_relation;
	     else call error (code, error_message);
	     end;
skip_relation:
	return;
%page;
all_attributes_are_deleted:
     proc returns (bit (1) aligned);

dcl  attribute_idx fixed bin;

	do attribute_idx = 1 to relation.attribute_count;
	     if ^relation.attribute (attribute_idx).flags.delete
	     then return ("0"b);
	     end;					/* do relation_index */

	return ("1"b);
     end all_attributes_are_deleted;


delete_relation_information:
     proc;

/* Unlink the file_info structure. */
	save_ptr, previous_ptr = null;
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while ((save_ptr = null) &amp; (rel (fi_ptr) ^= NULL_OFFSET));
	     if file_info.file_name = relation.name
	     then save_ptr = fi_ptr;
	     else previous_ptr = fi_ptr;
	     end;					/* do fi_ptr */

	if save_ptr ^= null
	then do;
	     if previous_ptr = null
	     then db_model.file_ptr = save_ptr -&gt; file_info.fwd_ptr;
	     else previous_ptr -&gt; file_info.fwd_ptr = save_ptr -&gt; file_info.fwd_ptr;

	     free save_ptr -&gt; file_info in (dbm_area);

	     call mdbm_util_$xref_delete_record (local_iocb, RELATION_KEY_HEAD, relation.name, error_message, (0));
	     end;

/* Now delete the relation and relation.m files. */
	call delete_file (relation.name);
	call delete_file (rtrim (relation.name) || ".m");

	db_model.num_blk_files = db_model.num_blk_files - 1;
	db_model.num_rels = db_model.num_rels - 1;

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, relation.name, RMDB_DEL_REL_OP, "", (""), (0));
	return;

delete_file:
     proc (file_name);

dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  error_table_$unsupported_operation fixed bin (35) ext static;
dcl  file_name char (*) parameter;
dcl  fs_util_$delentry_file entry (char (*), char (*), fixed bin (35));

	call fs_util_$delentry_file (db_path, file_name, code);
	if code = error_table_$unsupported_operation
	then call delete_$path (db_path, file_name, "101111"b, myname, code);

	if (code ^= 0) &amp; (^delete_object_info.inhibit_errors)
	then call error (code, "Deleting " || file_name);

	return;
     end delete_file;

     end delete_relation_information;

     end process_single_relation;
%page;
/* DESCRIPTION
*  This module was brought over from rmdb_copy_relation since we can't really 
*  clean up before we have finished with ALL the relations.  It performs 
*  several steps;  initiate the copy of the file_model (.k), get the name of
*  the associated relation, copy contents of new file_model to the old one,
*  move the data from the old file to the new one, delete the old relation,
*  rename the new relation to the old name (or physically copy to old name if
*  dm file), remove the copy of the file_info from the db_model and free the
*  space.  Finally, we must update the xref file to show that the relation is
*  no longer in the attribute key record. */
	 

switch_names:
     proc;

dcl  1 local_status_branch like status_branch;
dcl  create_model_name char (32);
dcl  create_relation_name char (32);
dcl  data_acl_ptr ptr;
dcl  index builtin;
dcl  move_string char (move_string_length) based;
dcl  move_string_length fixed bin (35);
dcl  new_model_bit_count fixed bin (24);
dcl  new_file_model_ptr ptr;
dcl  last_file_info_ptr ptr;
dcl  1 co aligned like copy_options;
dcl  cvds bit (1) aligned;
dcl  ivds bit (1) aligned;
dcl  to_char fixed bin;

          create_model_name = rtrim (relation.name) || ".k";
	status_area_ptr = user_area_ptr;
	status_ptr = addr (local_status_branch);
	call hcs_$status_ (db_path, create_model_name, 0, status_ptr, status_area_ptr, code);
	to_char = index(status_entry_names (1), ".m");
	to_char = to_char -1;
	create_relation_name = rtrim(substr(status_entry_names (1), 1, to_char));
          call initiate_file_ (db_path, create_model_name, RW_ACCESS, new_file_model_ptr, new_model_bit_count, code);
	if code ^= 0
          then call error (code, "While initiating the new_file_model for relation " || relation.name);
	rmdb_relmgr_entries_ptr = addr (rmdb_ctl.relmgr_entries);

/* Move the contents of the new relation.m to old relation.m. */
	if (file_model.file_model_copy_good &amp; file_model.relation_copy_good &amp; save_code = 0)
	then do;
	     move_string_length = divide (new_model_bit_count, 9, 35, 0);
	     fm_ptr -&gt; move_string = new_file_model_ptr -&gt; move_string;

/* Move the contents of the data relation. First we must get the attributes of
   the old data file (ACL, mode switches) and move them to the new data file. */
	     data_acl_ptr = null;
	     call fs_util_$list_acl (db_path, relation.name, GENERAL_ACL_VERSION_1, user_area_ptr, data_acl_ptr, code);
	     if code ^= 0
	     then call error (code, "Getting the ACL to relation " || relation.name);

	     call fs_util_$replace_acl (db_path, create_relation_name, data_acl_ptr, "1"b, code);
	     if code ^= 0
	     then call error (code, "Setting the ACL on relation " || create_relation_name);

	     cvds, ivds = "0"b;
	     call fs_util_$get_switch (db_path, relation.name, "complete_volume_dump", cvds, (0));
	     call fs_util_$get_switch (db_path, relation.name, "incremental_volume_dump", ivds, (0));

               call fs_util_$set_switch (db_path, create_relation_name, "complete_volume_dump", cvds, (0));
	     call fs_util_$set_switch (db_path, create_relation_name, "incremental_volume_dump", ivds, (0));

/* Now get rid of the old data file. */
	     call rmdb_relmgr_entries.delete_relation (db_path, relation.name, code);
	     if code ^= 0
	     then call error (code, "Deleting relation " || relation.name);

/* If we are dealing with DM files, we need to physically copy the relation
   file. If not, then we can simply rename the new one to the old name. */
	     if mstxn_transactions_needed
	     then do;
		co.version = COPY_OPTIONS_VERSION_1;
		co.caller_name = myname;
		co.source_dir, co.target_dir = db_path;
		co.source_name = create_relation_name;
		co.target_name = relation.name;

		unspec (co.flags) = "0"b;
		unspec (co.copy_items) = "0"b;
		
		call fs_util_$copy (addr (co), code);
		if code ^= 0
		then call error (code, "Copying the new data file onto the old data file for relation " || relation.name);
		end;
	     else do; 
		call hcs_$chname_file (db_path, create_relation_name, create_relation_name, relation.name, code);
		if code ^= 0
		then call error (code, "Renaming relation file from " || rtrim (create_relation_name) || " to " || relation.name);
		end;
	     end;                      /* file_model and relation good */
/* Since we renamed the new to the old, we can get rid of the new names. */
/* We also replaced the original file_model with the new_one. */
	call rmdb_relmgr_entries.delete_relation (db_path, create_relation_name, (0));

	call delete_$path (db_path, create_model_name, "101111"b, myname, (0));
/* Take the copy of the file_model out of the db_model */
	if relation.copy_file_model_ptr ^= null
	then do;
	     do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= rel (copy_file_model_ptr));
		last_file_info_ptr = fi_ptr;
		end;
	     
	     last_file_info_ptr -&gt; file_info.fwd_ptr = copy_file_model_ptr -&gt; file_info.fwd_ptr;
	     free relation.copy_file_model_ptr -&gt; file_info in (dbm_area);
	     end;

	if (code ^= 0)
	then if ^delete_object_info.inhibit_errors
	     then call error (code, error_message);
	     else ;				/* ignore the error */
	else if save_code = 0
	then call modify_xref;
	return;
%page;
modify_xref:
     proc;

dcl index fixed bin;

/* Now we have to update the crossreference file records for all attributes and
   domains that were updated in this relation. */

	do index = 1 to relation.attribute_count;
	     if relation.attribute (index).flags.delete
	     then do;
		attribute_name = unmake_name (relation.attribute_names (index));
		call mdbm_util_$xref_dereference (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, relation.name,
		     reference_count, error_message, code);
		if code ^= 0
		then if delete_object_info.inhibit_errors
		     then goto finish_relation;

		di_ptr = ptr (dbm_ptr, relation.attribute(index).domain_info_ptr);
		if reference_count = 0 &amp; attribute_name ^= domain_info.name
		then do;				/* attribute became unreferenced */

/* Find the last unreferenced_attribute structure in the db_model. */
		     if last_unreferenced_attribute_ptr = null
		     then do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
			     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread)
			     while (rel (ua_ptr) ^= NULL_OFFSET);
			     last_unreferenced_attribute_ptr = ua_ptr;
			     end;			/* do ua_ptr */

/* Make a new unreferenced_attribute structure and populate it. */
		     allocate unreferenced_attribute in (dbm_area) set (ua_ptr);
		     unreferenced_attribute.name = attribute_name;
		     unreferenced_attribute.domain_ptr = relation.attribute (index).domain_info_ptr;
		     unreferenced_attribute.fwd_thread = NULL_OFFSET;
		     unreferenced_attribute.unused (*) = NULL_OFFSET;

/* Add it on the end of the linked list. */
		     if last_unreferenced_attribute_ptr = null
		     then db_model.unreferenced_attribute_ptr = rel (ua_ptr);
		     else last_unreferenced_attribute_ptr -&gt; unreferenced_attribute.fwd_thread = rel (ua_ptr);

		     last_unreferenced_attribute_ptr = ua_ptr;
		     end;
		end;
	     end;					/* do index */
finish_relation:
         	return;
     end modify_xref;
     end switch_names;
%page;
/*DESCRIPTION
  Delete the crossreference records for all deleted domains. */

delete_xref_records:
     proc;

	do domain_list_idx = 1 to domain_list.count;
	     if domain_list.name (domain_list_idx) ^= ""
	     then do;
		domain_name = unmake_name (domain_list.name (domain_list_idx));
		call mdbm_util_$xref_delete_record (local_iocb, DOMAIN_KEY_HEAD, domain_name, error_message, code);
		if code ^= 0
		then if code ^= error_table_$no_record
		     then call error (code, error_message);

/* An artifact of a domain is that there is an attribute crossreference record
   for each domain also, as a domain can also be used as an attribute without
   explicitly creating the attribute. We must also delete this record from the
   crossreference file. */
		call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, domain_name, error_message, code);
		if code ^= 0
		then if code ^= error_table_$no_record
		     then call error (code, error_message);

/* we got rid of the "generated" attribute, now get rid of any others */
		attribute_list_ptr = domain_list.attribute_list_ptr(domain_list_idx); 
		if attribute_list_ptr ^= null 	
		then do attribute_list_idx = 1 to attribute_list.count;	
		     attribute_name = unmake_name(attribute_list.name(attribute_list_idx));
		     call mdbm_util_$xref_delete_record (local_iocb, ATTRIBUTE_KEY_HEAD, attribute_name, error_message, code);
		     if code ^= 0
		     then if code ^= error_table_$no_record
			then call error (code, error_message);
		     end;                               /* do attribute_list_idx */
		end;				/* do domain_list_idx */
	     end;

	return;
     end delete_xref_records;
%page;
/*DESCRIPTION
  Unlink the domain_info structures for the deleted domains in the db_model.
  Add a history entry for each deleted domain. */

unlink_deleted_domains:
     proc;

	do domain_list_idx = 1 to domain_list.count;
	     if domain_list.name (domain_list_idx) ^= ""
	     then do;
		domain_name = unmake_name (domain_list.name (domain_list_idx));

/* Since we just made all the attributes based on this domain unreferenced
   in the model, we need to unlink all the attributes on the attribute_list
   from the unreferenced attribute chain and free the ua structures. Skip
   the list entry that has the same name as the domain name, because the
   generated attribute has no structures in the model.                     */

		attribute_list_ptr = domain_list.attribute_list_ptr (domain_list_idx);
		if attribute_list_ptr ^= null
		then do attribute_list_idx = 1 to attribute_list.count;
		     if attribute_list.name (attribute_list_idx) ^= domain_list.name (domain_list_idx)
		     then do;		/* all but the generated one */
			previous_ptr, save_ptr = null;
			attribute_name = unmake_name (attribute_list.name (attribute_list_idx));
			do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
			     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread)
			     while ((save_ptr = null) &amp; (rel (ua_ptr) ^= NULL_OFFSET));
			     if unreferenced_attribute.name = attribute_name
			     then save_ptr = ua_ptr;
			     else previous_ptr = ua_ptr;
			     end;		/* do ua_ptr */

			if save_ptr ^= null
			then do;
			     if previous_ptr = null
			     then db_model.unreferenced_attribute_ptr =
				     save_ptr -&gt; unreferenced_attribute.fwd_thread;
			     else previous_ptr -&gt; unreferenced_attribute.fwd_thread =
				     save_ptr -&gt; unreferenced_attribute.fwd_thread;

			     free save_ptr -&gt; unreferenced_attribute in (dbm_area);

			     call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, attribute_name,
				RMDB_DEL_ATTR_OP, "", (""), (0));
			     end;
			end;
		end;			/* do attribute_list_idx */

/* Now that we have gotten rid of all the unreferenced attributes based upon
   this domain, we can get rid of the domain_info structure. */
		previous_ptr, save_ptr = null;
		do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
		     while ((save_ptr = null) &amp; (rel (di_ptr) ^= NULL_OFFSET));
		     if domain_info.name = domain_name
		     then save_ptr = di_ptr;
		     else previous_ptr = di_ptr;
		     end;				/* do di_ptr */

		if save_ptr ^= null
		then do;
		     if previous_ptr = null
		     then db_model.domain_ptr = save_ptr -&gt; domain_info.fwd_thread;
		     else previous_ptr -&gt; domain_info.fwd_thread = save_ptr -&gt; domain_info.fwd_thread;

		     free save_ptr -&gt; domain_info in (dbm_area);
		     db_model.num_domains = db_model.num_domains - 1;

		     call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, domain_name, RMDB_DEL_DMN_OP, "", (""),
			(0));

		     end;

		end;
	     end;					/* do domain_list_idx */

	return;
     end unlink_deleted_domains;
%page;
%include access_mode_values;
%include acl_structures;
%include area_info;
%include copy_flags;
%include copy_options;
%include mdbm_db_model;
%include mdbm_file_model;
%include mrds_rmdb_ctl;
%include query_info;
%include rmdb_delete_object_info;
%include rmdb_crossref_info;
%include rmdb_history_entry;
%include status_structures;
%page;
dcl  addr builtin;
dcl  1 ai like area_info aligned;
dcl  answer char (3);
dcl  any_other condition;
dcl  attribute_idx fixed bin;
dcl  attribute_list_idx fixed bin;
dcl  attribute_name char (32);
dcl  based_char8 char (8) based;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  command_query_ entry () options (variable);
dcl  db_path char (168);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35));
dcl  divide builtin;
dcl  domain_list_idx fixed bin;
dcl  domain_name char (32);
dcl  dm_error_$key_duplication fixed bin (35) ext static;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  fixed builtin;
dcl  fs_util_$copy entry (ptr, fixed bin(35));
dcl  fs_util_$get_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35));
dcl  fs_util_$list_acl entry (char(*), char(*), char(*), ptr, ptr, fixed bin(35));
dcl  fs_util_$replace_acl entry (char(*), char(*), ptr, bit(1), fixed bin(35));
dcl  fs_util_$set_switch entry (char(*), char(*), char(*), bit(1) aligned, fixed bin(35));
dcl  hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl  Idelete_object_info_ptr ptr parameter;
dcl  index builtin;
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  last_unreferenced_attribute_ptr ptr;
dcl  length builtin;
dcl  local_iocb ptr;
dcl  make_consistent_msg char (500);
dcl  mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
dcl  mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_delete_record entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mdbm_util_$xref_dereference entry (ptr, char (*), char (*), char (*), fixed bin (21), char (*), fixed bin (35));
dcl  mdbm_util_$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
dcl  mrds_error_$no_primary_key fixed bin (35) ext static;
dcl  mrds_error_$no_unref_domain fixed bin (35) ext static;
dcl  myname char (32) int static options (constant) init ("rmdb_delete_domain");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  previous_ptr ptr;
dcl  (ptr, pointer) builtin;
dcl  QUERY_MSG char (110) int static options (constant)
	init ("Answering yes will cause the specified domain to be deleted from the currently
readied MRDS database.");
dcl  quit condition;
dcl  quit_occurred bit (1) aligned;
dcl  reference_count fixed bin (21);
dcl  rel builtin;
dcl  relation_good_count fixed bin (21);
dcl  relation_index fixed bin;
dcl  relation_name char (32);
dcl  release_area_ entry (ptr);
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
dcl  rmdb_copy_relation entry (ptr, char (*), char (*), ptr, ptr, char (*), fixed bin (35));
dcl  rmdb_delete_all$domains entry (ptr, char (*), fixed bin (35));
dcl  rmdb_relations_used$domains entry (ptr, ptr, ptr, ptr, ptr, ptr, char (*), fixed bin (35));
dcl  rtrim builtin;
dcl  save_code fixed bin (35);
dcl  save_ptr ptr;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  unspec builtin;
dcl  UNSPEC bit (2) aligned int static options (constant) init ("00"b);
dcl  user_area area based (user_area_ptr);
dcl  user_area_ptr ptr;

     end rmdb_delete_domain;




		    rmdb_delete_index.pl1           10/23/86  1025.2rew 10/23/86  1007.9      166158



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

/****^  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-06 by Thanh
     Nguyen. (see mrds #136)
  2) change(86-10-21,Blair), approve(86-10-21,PBF7311), audit(86-10-23,Dupuis),
     install(86-10-23,MR12.0-1199):
     If the code from relmgr_entries.delete_index indicates that the index
     doesn't exist, reset the code so that we can continue and delete the index
     entry from the model.  This might happen if a create_index got rolled
     back, but the model wasn't updated to reflect the rollback.
                                                   END HISTORY COMMENTS */

rmdb_delete_index: proc (rdi_rmdb_ctl_ptr, rdi_db_abs_path, rdi_db_model_ptr, rdi_rel_name, rdi_attr_name, rdi_brief_flag,
	rdi_error_message, rdi_code);

/*
                          BEGIN_DESCRIPTION
   This module will change an indexed attribute in a relation into a
   non-indexed attribute.

   This process involves both updating the structures in  the  model
   and deleting the old indices.

   An  attempt  has  been  made   to   make   data   model   updates
   uninterruptable by the user. To do this any quits signaled by the
   user are delayed until the updates are complete.

   It is not possible to recreate the deleted indices in  the  event
   that  the  cleanup condition is signaled. Instead the database is
   marked as inconsistent before the model is  updated  and  is  not
   marked as consistent until the last tuple has been un-indexed.
                          END_DESCRIPTION
   NOTE:
         Naming convention: because of the number of  internal  routines
         and the need for descriptive 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.
   
         In order to reduce the complexity of this module, none  of  the
         internal  routines  have  an error code parameter. Instead they
         set a global error code declared in the main routine, call  the
         clean_up  routine,  and  perform  a non-local goto to leave the
         module.
   
   Known Bugs:

   Other Problems:




                          HISTORY
   82-05-20 Davids: Written

   82-05-26 Davids: added rdi_db_model_ptr to the input parameters
                    and removed code that initiated it.

   82-06-10 Lackey: Changed RMDB_DEL_OP to RMDB_DEL_IDX_OP

   82-06-23 Davids: changed all references of force to brief to
                    reflect the control arg's name change.


   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.  

   82-09-15  D. Woodka : Modified for DMS conversion. Replaced 
   call to iox_$attach with a call to rmdb_relmgr_entries.open,
   and calls to iox_$control (order delete_key) with a call to
   rmdb_relmgr_entries.delete_index.

   83-01-10 Davids: Modified to correct the sense of an if statement
   that was causing relmgr_entries.delete_index not to be called.
   Also added code dealing with transactions.

   83-01-17 Davids: Code to report an error with finishing a transaction
   and to correctly handle errors occuring in the clean_up procedure.

   83-01-20 Davids: Removed declared but unused variables.

   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-05-24 Davids: Added code to set the version of the saved resultant to
   RESTRUCT so that the saved resultant will not be used for an opening.
*/

/* PARAMETERS */

	dcl     rdi_db_abs_path	 char (168);	/* (input) absolute path to the database directory */
	dcl     rdi_db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     rdi_rel_name	 char (*);	/* (input) name of the relation to be restructured */
	dcl     rdi_attr_name	 char (*);	/* (input) name of the attribute to be un-indexed */
	dcl     rdi_brief_flag	 bit (1);		/* (input) true ==&gt; caller used brief ctl_arg */
	dcl     rdi_error_message	 char (500);	/* (output) text of message in the event of an error */
	dcl     rdi_code		 fixed bin (35);	/* (output) standard error code */

/* AUTOMATIC */

	dcl     rdi_attr_ptr	 ptr;		/* pointer to attr_info structure */
	dcl     rdi_file_model_ptr	 ptr;		/* pointer to the file model that contains the relation */
	dcl     rdi_index_id	 bit (36) aligned;	/* actual bits that identify which attr an index refers to */
	dcl     rdi_nsecs		 fixed bin;	/* number of secondary indices
						   in the relation being restructured */
	dcl     rdi_number_of_varying_attrs fixed bin;	/* number of varying attrs in the relation being indexed */
	dcl     rdi_quit_signaled	 bit (1);		/* true if the break key was hit */
	dcl     rdi_rel_id		 bit (36) aligned;	/* bits that identify the relation */
	dcl     rdi_rel_opening_id	 bit (36) aligned;	/* relation opening identifier */
	dcl     rdi_rel_ptr		 ptr;		/* pointer to the rel_info structure */
	dcl     rdi_rmdb_ctl_ptr	 ptr;
	dcl     01 rdi_seek_head_info,		/* used in iox_$seek_head */
		02 relation_type	 fixed bin init (0),/* equality */
		02 n		 fixed bin init (3),/* 3 characters */
		02 search_key	 char (256) init ("");

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     pointer		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;

/* BASED */

	dcl     rdi_based_char8	 char (8) based;	/* overlay on the saved_res_version value */

/* CONDITIONS */

	dcl     any_other		 condition;
	dcl     cleanup		 condition;
	dcl     quit		 condition;

/* ENTRIES */

	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     ioa_$rs		 entry () options (variable);
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
	dcl     rmdb_add_rmdb_history	 entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));

/* EXTERNAL STATIC */

	dcl     dm_error_$collection_not_found fixed bin(35) ext static;
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;

/* INCLUDES */
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include rmdb_history_entry;
%page;
%include mrds_rmdb_ctl;


/*
   Initialize variables which may be referenced before they are  set
   somewhere else, i.e. they are referenced in the cleanup handler
*/


	rdi_code = 0;
	rdi_error_message = "";
	rdi_quit_signaled = "0"b;
	rdi_rel_opening_id = "0"b;
	rmdb_ctl_ptr = rdi_rmdb_ctl_ptr;
	mstxn_txn_id = "0"b;
	mstxn_transactions_needed = "0"b;

/*
   If the database needs transactions and one is already in progress stop right now.
*/
	if rdi_db_model_ptr -&gt; db_model.db_type_flags.transactions_needed
	then do;
		mstxn_transactions_needed = "1"b;
		call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
		if mstxn_code ^= dm_error_$no_current_transaction
		then do;
			rdi_code = error_table_$action_not_performed;
			rdi_error_message = "Indexes may not be deleted while a transaction is in proggress, " ||
			     "commit or abort the current transaction and try again.";
			goto exit_rmdb_delete_index;
		     end;
	     end;

/*
   Get pointers to the relation's file model, and extract  from  the
   model the rel_id, index_id, and the rel_ptr and attr_ptr.
*/

	call initiate_models (rdi_db_abs_path, rdi_rel_name, rdi_file_model_ptr);

	call get_relation_data (rdi_file_model_ptr, rdi_rel_ptr, rdi_rel_id, rdi_number_of_varying_attrs);

	call get_attribute_data (rdi_file_model_ptr, rdi_rel_ptr, rdi_rel_name, rdi_attr_name,
	     rdi_attr_ptr, rdi_index_id, rdi_nsecs);




	on cleanup call mstxn_cleanup;

	on any_other call mstxn_any_other;

%include mrds_start_transaction;

	if mstxn_code ^= 0
	then do;
		rdi_code = mstxn_code;
		rdi_error_message = "Could not start a transaction";
		goto exit_rmdb_delete_index;
	     end;

/*
   Mark the database inconsistent, delay quit  handling  to  prevent
   the database from being partially marked.
*/

	on quit rdi_quit_signaled = "1"b;
	rmdb_ctl_ptr -&gt; rmdb_ctl.saved_res_version_ptr -&gt; rdi_based_char8 = "RESTRUCT";
	call mdbm_util_$inconsistent_set (rdi_db_model_ptr, "delete_index",
	     "Deleting the index " || rtrim (rdi_attr_name) || " from relation " || rtrim (rdi_rel_name),
	     "delete_index " || rtrim (rdi_rel_name) || " " || rtrim (rdi_attr_name) || " -brief");
	revert quit;
	if rdi_quit_signaled
	then do;
		rdi_quit_signaled = "0"b;
		signal quit;
	     end;

	on cleanup begin;

		call mstxn_cleanup;
		call clean_up (""b, "1"b);
	     end;

/*
   Do the actual index deletion.

   quit handlers  are  not  needed  since  vfile  assures  that  any
   operation started is completed.
*/

	call rmdb_ctl.relmgr_entries.open (rdi_db_abs_path, rdi_rel_name, rdi_rel_opening_id, rdi_code);
	if rdi_code ^= 0 then do;
		rdi_error_message = "Error while opening the relation";
		call restore_significant_data;
		goto mftxn_exit;
	     end;

	call rmdb_ctl.relmgr_entries.delete_index (rdi_rel_opening_id, rdi_index_id, rdi_code);

/* no index but still need to clean up the model */
	if rdi_code = dm_error_$collection_not_found 
          then rdi_code = 0;

	mftxn_code = rdi_code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then do;
		rdi_error_message = "Could not finish the transaction";
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_delete_index;
	     end;

	if rdi_code ^= 0 then do;
		rdi_error_message = "Error while deleting the index";
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_delete_index;
	     end;

/*
   Update the model to reflect  that  the  attribute  is  no  longer
   indexed and mark the database as consistent.
*/
	on quit rdi_quit_signaled = "1"b;
	call update_model (rdi_db_model_ptr, rdi_rel_ptr, rdi_nsecs, rdi_attr_ptr);
	call mdbm_util_$inconsistent_reset (rdi_db_model_ptr);
	revert quit;
	if rdi_quit_signaled
	then do;
		rdi_quit_signaled = "0"b;
		signal quit;
	     end;

	call clean_up ("1"b, "0"b);

exit_rmdb_delete_index:

	return;

should_rollback: proc () returns (bit (1));
	return ("0"b);
     end should_rollback;





restore_significant_data: proc;

	dcl     rsd_code		 fixed bin (35);


	rdi_error_message = rtrim (rdi_error_message) || " Backout has occured.";

	if rdi_rel_opening_id ^= "0"b
	then call rmdb_ctl.relmgr_entries.close (rdi_rel_opening_id, rsd_code);
	rdi_rel_opening_id = "0"b;

	return;

     end restore_significant_data;

initiate_models: proc (im_db_abs_path, im_rel_name, im_file_model_ptr);

/*
   This routine initiates a pointer to the file_model  segment  that
   contains the relation model. If the file model cannot be found it
   indicates that the data base does not contain the relation.
*/

/* PARAMETERS */

	dcl     im_db_abs_path	 char (168);	/* (input) absolute path to the database directory */
	dcl     im_rel_name		 char (*);	/* (input) name of the relation to be restructured */
	dcl     im_file_model_ptr	 ptr;		/* (output) pointer to the file model
						   .        that contains the relation */


	call hcs_$initiate (im_db_abs_path, rtrim (im_rel_name) || ".m", "", 0, 0, im_file_model_ptr, rdi_code);
	if im_file_model_ptr = null ()
	then do;
		call ioa_$rs ("^/The relation ^a does not exist in the data base.",
		     rdi_error_message, length (rdi_error_message), im_rel_name);
		goto exit_rmdb_delete_index;
	     end;
	else rdi_code = 0;

	return;

     end initiate_models;

get_relation_data: proc (grd_file_model_ptr, grd_rel_ptr, grd_rel_id, grd_number_of_varying_attrs);

/*
   This routine extracts information from the rel_info structure for
   the relation that is to be restructured.
*/

/* PARAMETERS */

	dcl     grd_file_model_ptr	 ptr;		/* (input) pointer to the file model that contains the relation */
	dcl     grd_rel_ptr		 ptr;		/* (output) pointer to the rel_info structure */
	dcl     grd_rel_id		 bit (36) aligned;	/* (output) bits that identify the relation */
	dcl     grd_number_of_varying_attrs fixed bin;	/* (output) number of varying attrs in
						   .        the relation being indexed */

	grd_rel_ptr = pointer (grd_file_model_ptr, grd_file_model_ptr -&gt; file_model.rel_ptr);

	grd_rel_id = grd_rel_ptr -&gt; rel_info.id;

	grd_number_of_varying_attrs = grd_rel_ptr -&gt; rel_info.nvar_atts;

	return;

     end get_relation_data;

get_attribute_data: proc (gad_file_model_ptr, gad_rel_ptr, gad_rel_name,
	gad_attr_name, gad_attr_ptr, gad_index_id, gad_nsecs);

/*
   This routine gets the information about  the  attribute  that  is
   needed, i.e. its index_id and a pointer to its info structure. It
   also counts the number of indexed attributes in the relation.
*/

/* PARAMETERS */

	dcl     gad_file_model_ptr	 ptr;		/* (input) pointer to the file model that contains the relation */
	dcl     gad_rel_ptr		 ptr;		/* (input) pointer to the rel_info structure */
	dcl     gad_rel_name	 char (*);	/* (input) name of the relation to be restructured */
	dcl     gad_attr_name	 char (*);	/* (input) name of the attribute to be un-indexed */
	dcl     gad_attr_ptr	 ptr;		/* (output) pointer to attr_info structure */
	dcl     gad_index_id	 bit (36) aligned;	/* (output) actual bits that identify
						   .        which attr an index refers to */
	dcl     gad_nsecs		 fixed bin;	/* (output) number of secondary indices
						   .        in the relation being restructured */

/* AUTOMATIC */

	dcl     gad_i		 fixed bin;	/* loop index */
	dcl     gad_local_attr_ptr	 ptr;		/* pointer to attr_info structure */

	gad_attr_ptr = null ();
	gad_nsecs = 0;

	gad_local_attr_ptr = pointer (gad_file_model_ptr, gad_rel_ptr -&gt; rel_info.attr_ptr);
	do gad_i = 1 to gad_rel_ptr -&gt; rel_info.num_attr;
	     if gad_local_attr_ptr -&gt; attr_info.name = gad_attr_name
	     then gad_attr_ptr = gad_local_attr_ptr;

	     if gad_local_attr_ptr -&gt; attr_info.index_attr
	     then gad_nsecs = gad_nsecs + 1;

	     gad_local_attr_ptr = pointer (gad_file_model_ptr, gad_local_attr_ptr -&gt; attr_info.fwd_thread);
	end;

	if gad_attr_ptr = null ()
	then do;
		rdi_code = error_table_$action_not_performed;
		call ioa_$rs ("^/Relation ^a does not contain an attribute named ^a",
		     rdi_error_message, length (rdi_error_message), gad_rel_name, gad_attr_name);
		goto exit_rmdb_delete_index;
	     end;

	if ^gad_attr_ptr -&gt; attr_info.index_attr
	then do;
		if rdi_brief_flag
		then goto exit_rmdb_delete_index;
		else do;
			rdi_code = error_table_$action_not_performed;
			call ioa_$rs ("^/Attribute ^a in relation ^a is not a secondary index",
			     rdi_error_message, length (rdi_error_message), gad_attr_name, gad_rel_name);
			goto exit_rmdb_delete_index;
		     end;
	     end;

	gad_index_id = gad_attr_ptr -&gt; attr_info.index_id;

	return;

     end get_attribute_data;

update_model: proc (um_db_model_ptr, um_rel_ptr, um_nsecs, um_attr_ptr);

/*
   This procedure  updates  the  data  model  to  reflect  that  the
   attribute  is  no  longer indexed, and if the last index is being
   deleted that the relation is no longer indexed.
*/

/* PARAMETERS */

	dcl     um_db_model_ptr	 ptr;		/* (input) pointer to the database model */
	dcl     um_rel_ptr		 ptr;		/* (input) pointer to the rel_info structure */
	dcl     um_nsecs		 fixed bin;	/* (input) number of secondary indices
						   .       in the relation being restructured */
	dcl     um_attr_ptr		 ptr;		/* (input) pointer to attr_info structure */


	if um_nsecs = 1
	then um_rel_ptr -&gt; rel_info.indexed = "0"b;

	um_attr_ptr -&gt; attr_info.index_attr = "0"b;
	um_attr_ptr -&gt; attr_info.index_id = "0"b;

	call rmdb_add_rmdb_history (um_db_model_ptr, RMDB_REL_TYPE, (um_rel_ptr -&gt; rel_info.name),
	     RMDB_DEL_IDX_OP, (um_attr_ptr -&gt; attr_info.name), rdi_error_message, rdi_code);
	if rdi_code ^= 0
	then do;
		call clean_up ("0"b, "1"b);
		goto exit_rmdb_delete_index;
	     end;

	return;

     end update_model;

clean_up: proc (cu_set_code, cu_leave_db_inconsistent);

/*
   This procedure is called both during normal and error termination
   and in the event that the cleanup condition is signaled.

*/


/* PARAMETERS */

	dcl     cu_set_code		 bit (1);		/* (input) true ==&gt; if error occurs during cleanup, global error
						   .       code will be set to error */
	dcl     cu_leave_db_inconsistent bit (1);	/* (input) true ==&gt; the dba will not be queried if indexing is
						   .       to continue and the message giving directions for
						   .       how to make the db consistent will be concatinated
						   .       to the returned error message */

/* AUTOMATIC */

	dcl     cu_code		 fixed bin (35);	/* internal error code */



	if cu_leave_db_inconsistent
	then rdi_error_message = rtrim (rdi_error_message) ||
		"^/The data base is being left in an inconsistent state," ||
		"^/to make the database consistent use the delete_index request" ||
		"^/to finish deleting the partially deleted index.";

	if rdi_rel_opening_id ^= "0"b then
	     call rmdb_ctl.relmgr_entries.close (rdi_rel_opening_id, cu_code);
	if cu_set_code
	then do;
		if cu_code ^= 0
		then do;
			rdi_code = cu_code;
			if rdi_code = 0
			then rdi_error_message = "^/The relation could not be closed.";
			else rdi_error_message = rtrim (rdi_error_message) ||
				"^/The relation could not be closed.";
		     end;
	     end;
	else do;
		if cu_code ^= 0
		then rdi_error_message = rtrim (rdi_error_message) ||
			"^/The relation could not be closed.";
	     end;

	return;

     end clean_up;

     end rmdb_delete_index;
��



		    rmdb_delete_relation.pl1        12/09/86  1247.6rew 12/09/86  1235.2      134280



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

/****^  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-06 by Thanh
     Nguyen. (see mrds #136)
  2) change(86-04-03,Spitzer), approve(86-04-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Add updating the crossreference file.
  3) change(86-12-03,Blair), approve(86-12-03,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     If we're executing the delete as a cleanup operation and the rel_name is
     not in the model and there is no xref-file, we don't have anything to
     unlink.
                                                   END HISTORY COMMENTS */

rmdb_delete_relation: proc (I_rmdb_ctl_ptr, I_rmdb_delete_rel_info_ptr, O_err_msg, O_err_code);

/*                      BEGIN_DESCRIPTION

   This  module implements the rmdb delete relation work. It unlinks
   any  knowledge  of the  relation  from the db_model,  deletes the
   file_model (rel_name.m) and deletes the rel_data file (rel_name).

   This procedure contains two entry points:
         rmdb_delete_relation$rmdb_delete_relation
         rmdb_delete_relation$cleanup

   The only difference is that cleanup entry point does NOT set the
   inconsistent undo string.

   		      END_DESCRIPTION
*/

/* HISTORY
   82-04-29  Written by R. Lackey

   82-07-01  Roger Lackey :  Modified the calls to  mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   82-09-14 D. Woodka : Modified for DMS conversion. The call to delete_$path
   to delete the relation's MSF was changed to a call to rmdb_relmgr_entries.
   delete_relation. The cleanup_intercept handler was removed. 
   The pointer rmdb_ctl_ptr is now passed in as an argument in order to pass
   the relation_manager entry points.

   83-02-09 Mike Kubicar : Added transaction processing include files.

   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-05-24 Davids: Added code to reset the saved_res_version so the saved
   resultant will not get incorrectly used.
*/

/*       PARAMETERS       */
	dcl     I_rmdb_ctl_ptr	 ptr parameter;	/* Pointer to rmdb_ctl structure */
	dcl     I_rmdb_delete_rel_info_ptr ptr parameter; /* Pointer rmdb_delete_rel_info structure */
	dcl     O_err_code		 fixed bin (35) parameter; /* Error code */
	dcl     O_err_msg		 char (*) parameter;/* Error message test */

/* main entry point */

	cleanup_entry_point = "0"b;
	goto common;


%page;
/* Cleanup entry point does not set undo string in inconsistence */

cleanup: entry (I_rmdb_ctl_ptr, I_rmdb_delete_rel_info_ptr, O_err_msg, O_err_code);

	cleanup_entry_point = "1"b;
	goto common;


%page;
common:

	rmdb_delete_rel_info_ptr = I_rmdb_delete_rel_info_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;
	mstxn_txn_id = "0"b;
	if rmdb_delete_rel_info.version ^= RMDB_DELETE_REL_INFO_VERSION_1 then
	     call error (error_table_$unimplemented_version,
		"For rmdb_delete_rel_info.version");

	if rmdb_delete_rel_info.db_model_ptr -&gt; db_model.db_type_flags.transactions_needed then do; /* Transactions needed, it's a protected dm file */
		mstxn_transactions_needed = "1"b;
		call transaction_manager_$get_current_txn_id (mstxn_txn_id, mstxn_code);
		if mstxn_code = 0 then do;
			mstxn_txn_id = "0"b;
			call error (error_table_$action_not_performed,
			     "Relations may not be deleted while a transaction " ||
			     "is in progress.  Commit or abort the transaction " ||
			     "and try again.");
		     end;
	     end;
	else mstxn_transactions_needed = "0"b;
	mstxn_txn_id = "0"b;

	db_path = rmdb_delete_rel_info.absolute_db_path;
	dbm_ptr = rmdb_delete_rel_info.db_model_ptr;
	rel_name = rtrim (rmdb_delete_rel_info.relation_name);
	O_err_msg = "";
	O_err_code = 0;

	if db_path = "" then call error (mrds_error_$no_db_path, "");

	exists_in_db_model = "0"b;			/* Don't know yet */
	brief = rmdb_delete_rel_info.brief;

	rmdb_ctl_ptr -&gt; rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";

/* Critical code to unlink relation from db_model
   QUITs will be intercepted and held until the unlink critical code is completed
*/

	quit_intercept_flag = "0"b;

	on quit quit_intercept_flag = "1"b;		/* hold off any QUITs til finished updating db_model */



	call unlink_relation (exists_in_db_model);	/* Internal procedure */

	if exists_in_db_model
	then do;
	     call terminate_file_ (fm_ptr, 0, TERM_FILE_DELETE, code);
	     if code ^= 0 then do;

		if code = error_table_$noentry then code = 0; /* File model not there */
		else call error (code, rtrim (db_path) || "&gt;" || rel_name || ".m");
		end;
	     end;

/*  delete the relation */

	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, "Could not start a transaction while deleting relation " || rtrim (rel_name) || ".");
	call rmdb_ctl.relmgr_entries.delete_relation (db_path, rel_name, code);
	if code ^= 0 then do;
		if code = error_table_$noentry then code = 0; /* Relation data file not there */
		else call error (code, rtrim (db_path) || "&gt;" || rel_name);
	     end;

	call mdbm_util_$inconsistent_reset (dbm_ptr);	/* Make db consistent */

/* If not cleanup_entrypoint then add the history entry to the db_model that we deleted it */

	if ^cleanup_entry_point then
	     call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rel_name), RMDB_DEL_REL_OP, "", long_err_msg, code);

	revert quit;

	if quit_intercept_flag then signal quit;	/* Now signal the quit that was intercepted */

	if ^exists_in_db_model &amp; ^brief then call error (mrds_error_$no_model_rel, "^/" || rel_name);

exit:
	if O_err_code = mrds_error_$no_model_rel	/* Don't abort just for this */
	then mftxn_code = 0;
	else mftxn_code = O_err_code;
%include mrds_finish_transaction;
	if mftxn_code ^= 0 then do;
		O_err_code = mftxn_code;
		O_err_msg = "Could not finish a transaction while deleting relation " || rtrim (rel_name) || ".";
	     end;
	return;
%page;
/*  * * * * * * * * * *    unlink_relation   * * * * * * * * * * * *  *      */

unlink_relation: proc (exists);

	dcl     exists		 bit (1) parameter;
	dcl     last_ua_ptr		 ptr;
	dcl     record_buffer	 bit (72);

	prev_fi_ptr = null;			/* Indicating db_model.file_ptr */

/* Look for rel_name in file_info linked list */

	exists = "0"b;

	if db_model.file_ptr ^= NULL_OFFSET
	then do fi_ptr = ptr (dbm_ptr, db_model.file_ptr)
	     repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while (^exists &amp; rel (fi_ptr) ^= NULL_OFFSET);

	     if file_info.file_name = rel_name then do;	/* Found the one were looking for */
		     exists = "1"b;
		     saved_fi_ptr = fi_ptr;		/* Pointer to one to be unlinked */
		end;
	     else prev_fi_ptr = fi_ptr;

	end;

	if ^exists then goto not_in_model;		/* Relation was not linked into db_model */

	next_fi_ptr_offset = saved_fi_ptr -&gt; file_info.fwd_ptr;

	if ^cleanup_entry_point then call mdbm_util_$inconsistent_set (dbm_ptr, "delete_relation",
		"Deleting relation " || rel_name, "delete_relation " || rel_name || " -brief");

/* Indicate in all the attributes within this relation that they aren't
   referenced within this relation. If any of the attributes becomes
   unreferenced, create an unreferenced_attribute structure and link it into
   the list in db_model. */

	if rmdb_ctl.crossref_file_info.iocb_ptr = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path,
		dbm_ptr, rmdb_ctl.crossref_file_info.name, rmdb_ctl.crossref_file_info.iocb_ptr,
		long_err_msg, code);
	     if code ^= 0 then call error (code, long_err_msg);
	     end;
not_in_model:
	xref_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr;
	if xref_iocb_ptr = null then return;

	file_model_name = rtrim (rel_name) || ".m";
	call initiate_file_ (db_path, file_model_name, R_ACCESS, fm_ptr, (0), code);
	if code ^= 0 then
	     if brief then do;
		exists = "0"b;
		return;
		end;
	     else call error (code, "Initiating " || file_model_name);

	last_ua_ptr = null;
	ri_ptr = ptr (fm_ptr, rel_ptr);

	do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
		  repeat ptr (fm_ptr, attr_info.fwd_thread)
		  while (rel (ai_ptr) ^= NULL_OFFSET);
	     call mdbm_util_$xref_dereference (xref_iocb_ptr, ATTRIBUTE_KEY_HEAD,
		(attr_info.name), rel_name, reference_count, long_err_msg, code);
	     if code ^= 0 then call error (code, long_err_msg);

	     if reference_count = 0 then do;
		last_ua_ptr = null;
		do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
			  repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread)
			  while (rel (ua_ptr) ^= NULL_OFFSET);
		          last_ua_ptr = ua_ptr;
		     end;				/* do last_ua_ptr */

/* Check to see if the domain name and attribute name are the same. If so, then
   this is a generated attribute and should not be added to the unreferenced
   attribute list. */
		di_ptr = ptr (dbm_ptr, attr_info.domain_ptr);
		if domain_info.name = attr_info.name
		then do;

/* This is a generated attribute. Check the domain reference count. If it is 1,
   then the domain becomes unreferenced. */
		     crossref_info_record_ptr = addr (record_buffer);
		     call mdbm_util_$xref_find_record (xref_iocb_ptr, DOMAIN_KEY_HEAD,
			(domain_info.name), crossref_info_record_ptr, 8, long_err_msg, code);
		     if code ^= 0 then call error (code, long_err_msg);

		     if crossref_info_record.count = 1 /* 1 for the generated attribute */
		     then domain_info.unreferenced = "1"b;
		     end;
		else do;				/* it's a real attribute */
		     allocate unreferenced_attribute in (dbm_area) set (ua_ptr);

		     unreferenced_attribute.name = attr_info.name;
		     unreferenced_attribute.domain_ptr = attr_info.domain_ptr;
		     unreferenced_attribute.unused (*) = NULL_OFFSET;
		     unreferenced_attribute.fwd_thread = NULL_OFFSET;

/* Link it on the end of the list */
		     if last_ua_ptr = null
		     then db_model.unreferenced_attribute_ptr = rel (ua_ptr);
		     else last_ua_ptr -&gt; unreferenced_attribute.fwd_thread = rel (ua_ptr);
		     end;
		end;
	     end;					/* do ai_ptr */

/* Unlink the file_info structure in db_model */

	if ^exists 
	then do;
	     saved_fi_ptr = ptr (dbm_ptr, file_model.fi_ptr);
	     free saved_fi_ptr -&gt; file_info;
	     exists = "1"b;
	     return;
	     end;

	if prev_fi_ptr = null then /* Incase it was first in  list */
	     db_model.file_ptr = next_fi_ptr_offset;

	else prev_fi_ptr -&gt; file_info.fwd_ptr = next_fi_ptr_offset; /* Link around current file_info structure */

	db_model.num_unblk_files = db_model.num_unblk_files - 1; /* Just unlinked */
	db_model.num_rels = db_model.num_rels - 1;

	if ^brief &amp; code ^= 0 then call error (code, long_err_msg); /* Error code from rmdb_add_rmdb_history */

	call mdbm_util_$xref_delete_record (xref_iocb_ptr, RELATION_KEY_HEAD,  rel_name, long_err_msg, code);
	if (code ^= 0) &amp; (code ^= error_table_$no_record) &amp; (^brief)
	then call error (code, long_err_msg);

	free saved_fi_ptr -&gt; file_info;		/* Free unlinked file_info structure */

	call adjust_bit_count_ ((db_path), "db_model", "1"b, bcnt, code);

     end unlink_relation;
%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);
     end should_rollback;
%page;
/*  * * * * * * * * * * * * * *      error     * * * * * * * * * * * * * *   */



error: proc (err_code, err_message);

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


	O_err_code = err_code;
	O_err_msg = err_message;
	goto exit;

     end error;
%page;
%include access_mode_values;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mrds_rmdb_ctl;
%page;
%include rmdb_crossref_info;
%page;
%include rmdb_delete_rel_info;
%page;
%include rmdb_history_entry;
%page;
%include terminate_file;
%page;
	dcl     addr		 builtin;
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     any_other		 condition;
	dcl     based_char8		 char (8) based;
	dcl     bcnt		 fixed bin (35);
	dcl     cleanup		 condition;
	dcl     cleanup_entry_point	 bit (1);
	dcl     code		 fixed bin (35);
	dcl     db_path		 char (168);
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$no_record fixed bin(35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     exists_in_db_model	 bit (1);
	dcl     file_model_name	 char (32);
	dcl     fixed		 builtin;
	dcl     initiate_file_	 entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl     long_err_msg	 char (500);
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
	dcl     mdbm_util_$xref_build	 entry (char(*), char(*), ptr, char(*), ptr, char(*), fixed bin(35));
	dcl     mdbm_util_$xref_delete_record entry (ptr, char(*), char(*), char(*), fixed bin(35));
	dcl     mdbm_util_$xref_dereference entry (ptr, char(*), char(*), char(*), fixed bin (21), char(*), fixed bin(35));
	dcl     mdbm_util_$xref_find_record entry (ptr, char(*), char(*), ptr, fixed bin(21), char(*), fixed bin(35));
	dcl     mrds_error_$no_db_path fixed bin (35) ext static;
	dcl     mrds_error_$no_model_rel fixed bin (35) ext static;
	dcl     next_fi_ptr_offset	 bit (18);
	dcl     null		 builtin;
	dcl     NULL_OFFSET		 int static bit (18) unal init ((18)"1"b) options (constant);
	dcl     prev_fi_ptr		 ptr;
	dcl     ptr		 builtin;
	dcl     quit		 condition;
	dcl     quit_intercept_flag	 bit (1);
	dcl     reference_count	 fixed bin (21);
	dcl     rel		 builtin;
	dcl     rel_name		 char (32);
	dcl     rmdb_add_rmdb_history	 entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
	dcl     rtrim		 builtin;
	dcl     saved_fi_ptr	 ptr;
	dcl     sys_info$max_seg_size	 fixed bin(35) ext static;
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     xref_iocb_ptr	 ptr;

     end rmdb_delete_relation;




		    rmdb_execute_undo.pl1           10/23/86  1025.2rew 10/23/86  1008.0       61362



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

rmdb_execute_undo:
execute_undo:
	proc (sci_ptr, request_name, db_path, db_model_ptr, incon_name, undo_request);


/****^  HISTORY COMMENTS:
  1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     added call to rmdb_salvage_db.
  2) change(86-10-21,Blair), approve(86-10-21,PBF7311), audit(86-10-23,Dupuis),
     install(86-10-23,MR12.0-1199):
     Add the entry name execute_undo so that display_mrds_dm can call this
     program through mrds_rst_ to clean things up when the user is trying to
     display the model.
                                                   END HISTORY COMMENTS */


/*
   .                        BEGIN_DESCRIPTION
   This routine will query the user to find  out  if  he  wants  the
   undo_request  to  be  executed.  If  the  answer  is yes the undo
   request is executed and  if  the  execution  was  ok  the  module
   returns  to  its  caller.  If the execution fails the database is
   freed, if it cannot be freed the subsystem  is  aborted.  If  the
   user  indicates that the undo request should not be executed then
   the database is just freed, if it cannot be freed  the  subsystem
   is  aborted.  If  the  execution of the undo request fails or the
   user does not request its execution but the  database  was  freed
   then  the ssu request line is aborted. Note that if the subsystem
   or request line is aborted this module will  not  return  to  its
   caller.  A  message  indicating  that the database has been freed
   will be printed on the users terminal.

   This module should  only  be  called  if  the  currently  readied
   database is inconsistent.
   .                        END_DESCRIPTION

   Known Bugs:
   .    1) ssu_$execute_string does not return if the execution fails

   Other Problems:

   .                        HISTORY
   82-05-26 Davids: Written

   82-06-23 Davids: removed call to get_shortest_path and declared
   .                some explicitly declared builtins.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.
*/

/* PARAMETERS */

	dcl     sci_ptr		 ptr;		/* (input) just passing through */
	dcl     request_name	 char (32);	/* (input) request being executed */
	dcl     db_path		 char (168);	/* (input) absolute path of the readied database */
	dcl     db_model_ptr	 ptr;		/* (input) pointer to the db_model seg of the readied database */
	dcl     incon_name		 char (32);	/* (input) request name that caused the db to be inconsistent */
	dcl     undo_request	 char (100);	/* (input) request that will make the db consistent */

/* AUTOMATIC */

	dcl     code		 fixed bin (35);	/* standard error code */
	dcl     explanation		 char (300);	/* explanatory text to the query */
          dcl     question               char (300);        /* initial query to user */
	dcl     answer		 char (3) varying;	/* user's answer to the query (yes | no) */

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     iox_$user_input	 ptr ext static;
	dcl     iox_$user_output	 ptr ext static;

/* ENTRIES */

	dcl     command_query_	 entry () options (variable);
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     rmdb_salvage_db	 entry (char (*));
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$abort_subsystem	 entry () options (variable);
	dcl     ssu_$execute_string	 entry (ptr, char (*), fixed bin (35));
          dcl     ssu_et_$null_request_line fixed bin(35) ext static;

/* BUILTINS */

	dcl     addr		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     rtrim		 builtin;

/* INCLUDES */
%page;
%include query_info;

          if undo_request = "" 
	then explanation = "^/The database is inconsistent because the operation:" ||
	     "^/^-^a^s^/was interrupted.  The database must be made consistent" ||
	     "^/in order to perform additional restructuring requests. " ||
	     "^/^/Do you wish to continue ?";
	else explanation = "^/The database is inconsistent because the operation:" ||
	     "^/^-^a^s^/was interrupted. In order to undo the effects of this" ||
	     "^/the request ""^a"" must be executed." ||
	     "^/Until the database is made consistent it may not be restructured." ||
	     "^/^/Do you wish to run the request ?";
	query_info.version = query_info_version_5;
	query_info.switches.yes_or_no_sw = "1"b;
	query_info.switches.suppress_name_sw = "0"b;
	query_info.switches.cp_escape_control = "00"b;
	query_info.switches.suppress_spacing = "0"b;
	query_info.switches.padding = "0"b;
	query_info.status_code = 0;
	query_info.query_code = 0;
	query_info.question_iocbp = iox_$user_output;
	query_info.answer_iocbp = iox_$user_input;
	query_info.repeat_time = 0;
	query_info.explanation_ptr = addr (explanation);
	query_info.explanation_len = length (rtrim (explanation));
	if undo_request = ""
	then question = "^/The database ^s^a is inconsistent. " ||
	     "^/In order to ready or restructure the database it must first be made consistent." ||
	     "^/^/Do you wish to continue ?";
	else question = "^/The database ^s^a is inconsistent. " ||
	     "^/In order to ready or restructure the database the following " ||
	     "^/request which will make the database consistent must be run:" ||
	     "^/^-^a^/Do you wish to run it ?";
	call command_query_ (addr (query_info), answer, request_name, rtrim(question),
	     incon_name, db_path, undo_request);

	if answer = "yes"
	then do;
	          call rmdb_salvage_db (db_path);

		call ssu_$execute_string (sci_ptr, rtrim (undo_request), code);
		if (code ^= 0 &amp; code ^= ssu_et_$null_request_line)
		then do;
			call ssu_$execute_string (sci_ptr, "free_db", code);
			if code ^= 0
			then call ssu_$abort_subsystem (sci_ptr, code,
				"Execution of the undo request failed and the db could not be freed.");
			call ssu_$abort_line (sci_ptr, code,
			     "Execution of the undo request failed, the database has been freed");
		     end;
		else call mdbm_util_$inconsistent_reset (db_model_ptr);
	     end;
	else do;
		call ssu_$execute_string (sci_ptr, "free_db", code);
		if code ^= 0
		then call ssu_$abort_subsystem (sci_ptr, code, "Could not free the database");
		call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		     "^/The database is inconsistent and therefore may not be restructured, it has been freed.");
	     end;

     end rmdb_execute_undo;



��



		    rmdb_free_db.pl1                04/18/85  1454.7r w 04/18/85  0909.5       25623



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
rmdb_free_db: proc (absolute_db_path, saved_res_version_ptr, error_message, code);

/*
   .		       BEGIN_DESCRIPTION
   This  procedure  calls  mu_quiesce  to  unquiesce  the   db   and
   create_copy_res  to  create  an  updated  version  of  the  saved
   resultant. It is a separate   routine  instead  of  part  of  the
   close_db_request  so  that  there is a subroutine level interface
   independent of the subsystem.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-03-23 Davids: Written

   82-05-26 Davids: changed   to   be   compatable   with   the  new
   .                mdbm_util_$quiesce_free calling sequence.

   82-06-23 Davids: removed declared but unused builtins

   82-07-01 Roger Lackey : Changed mu_quiesce$ to mdbm_util_$quisce_ for 
   binding.

   83-05-24 Davids: Added the saved_res_version_ptr parameter. Also
   it now checks the saved_res_version and if its not what it is
   suppose to be it creates a new saved res.
   
/* PARAMETERS */

	dcl     absolute_db_path	 char (168);	/* (input) data base path */
	dcl     saved_res_version_ptr	 ptr;		/* (input) pointer to the saved_res_version */
	dcl     error_message	 char (500);	/* (output) text of error message in case of problems */
	dcl     code		 fixed bin (35);	/* (output) standard error code */

/* BASED */

	dcl     based_char8		 char (8) based;	/* overlay for saved_res_version */

/* ENTRIES */

	dcl     dsl_$create_res_copy	 entry options (variable);
	dcl     ioa_$rs		 entry () options (variable);
	dcl     mdbm_util_$quiesce_free entry (char (168), fixed bin (35));

/* EXTERNAL STATIC */

	dcl     mrds_data_$saved_res_version char (8) external static;

/* BUILTINS */

	dcl     length		 builtin;

/*
   Initialize the output parameters
*/

	code = 0;
	error_message = "";




/*
   Create an upto date saved resultant and unquiesce the data base
*/
	if saved_res_version_ptr -&gt; based_char8 ^= mrds_data_$saved_res_version
	then do;
		call dsl_$create_res_copy (absolute_db_path, code);
		if code ^= 0
		then do;
			call ioa_$rs ("Could not create a resultant copy for the database ^a, database not freed",
			     error_message, length (error_message), absolute_db_path);
			goto exit_rmdb_free_db;
		     end;
	     end;

	call mdbm_util_$quiesce_free (absolute_db_path, code);
	if code ^= 0
	then call ioa_$rs ("The database ^a cannot be unquiesced", error_message, length (error_message), absolute_db_path);


exit_rmdb_free_db:
	return;

     end rmdb_free_db;
�



		    rmdb_init_file_model.pl1        10/16/86  1551.9r w 10/16/86  1143.8       25254



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


rmdb_init_file_model: proc (I_dbm_ptr, I_fm_ptr, O_err_msg, O_err_code);

/*                 BEGIN_DESCRIPTION
   This procedure provided a pointer to the segment to be used as the file_model
   initializes the file_model structure and the associated rel_info structure. 
                   END_DESCRIPTION  
*/

/* HISTORY
82-06-01 Create by Roger Lackey 
*/

	dcl     I_dbm_ptr		 pointer parameter; /* Pointer to db_model */
	dcl     I_fm_ptr		 pointer parameter; /* Pointer to based of file_model seg */
	dcl     O_err_msg		 char (*) parameter;/* Text of returned error message */
	dcl     O_err_code		 fixed bin (35) parameter; /* Error code */

	O_err_msg = "";
	O_err_code = 0;
	dbm_ptr = I_dbm_ptr;
	fm_ptr = I_fm_ptr;

/* Derive  file_name from fm_ptr (file_model segment pointer)  */

	call hcs_$fs_get_path_name (fm_ptr, dir, ldn, file_name, code);
	if code ^= 0 then do;
		O_err_msg = "Getting file_model_pathname ";
		O_err_code = code;
		return;
	     end;

	rel_name = before (file_name, ".m");		/* Rel_name is file name without the  .m suffix */
%page;
	like_file_model = init_file_model;		/* initialize all but file_model area */
	file_model.fm_area = empty ();		/* initialize file_model area */

	file_model.changer_ptr = db_model.changer_ptr;

	call load_rel_info;

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

load_rel_info: procedure ();

/* routine to allocate and initialize the rel_info structure for
   the current relation in this file, using the file model area,
   and updating the file_model and global file element as necessary */


	allocate rel_info in (fm_area) set (ri_ptr);

	file_model.rel_ptr = rel (ri_ptr);

/* initialize relation detailed information */

	rel_info = init_rel_info;			/* copy template */
	rel_info.name = rel_name;
	rel_info.changer_ptr = db_model.changer_ptr;

     end load_rel_info;
%page;
	dcl     addr		 builtin;
	dcl     before		 builtin;
	dcl     code		 fixed bin (35);
	dcl     dir		 char (168);
	dcl     empty		 builtin;
	dcl     file_name		 char (32);
	dcl     fixed		 builtin;
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     ldn		 fixed bin;
	dcl     rel		 builtin;
	dcl     rel_name		 char (32);
	dcl     sys_info$max_seg_size	 fixed bin (35) external; /* system constant */
%page;
%include mdbm_file_model;
%page;
%include mdbm_file_model_init;
%page;
%include mdbm_db_model;

     end rmdb_init_file_model;
��



		    rmdb_ready_db.pl1               08/01/88  1435.5r w 08/01/88  1315.0      116496



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

rmdb_ready_db: proc (db_path, quiesce_wait_time, entries_str_ptr, absolute_db_path,
	db_model_ptr, saved_res_version_ptr, error_message, code);


/****^  HISTORY COMMENTS:
  1) change(86-01-28,Spitzer), approve(86-01-28,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     add initialization for relmgr_entries.(put_tuple get_tuples_by_spec).
  2) change(86-08-21,Blair), approve(86-08-21,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Back out the entry points get_tuples_by_spec and put_tuples as they
     haven't been sufficiently tested to be reliable.  Put in get_tuple_id and
     get_tuple_by_id.
                                                   END HISTORY COMMENTS */


/*
   .		       BEGIN_DESCRIPTION
   This module quiesces a data base in  preparation  for  its  being
   restructured  and  checks  to  be  sure that the data base can be
   restructured by the caller. It also returns  to  the  caller  the
   absolute  path of the data base and a pointer to the db_model for
   the database and a pointer the the version of the saved res.

   The restrictions are:
   .   only a data base may be restructured - the  path  cannot
   .      refer to a submodel.
   .   only a version 4 or latter data base may be restructured
   .   the caller must be a DBA for the data base
   .		       END_DESCRIPTION

   Known Bugs:
   Other Problems:

   .                       HISTORY
   82-03-22 Davids: Written

   82-05-25 Davids: added code to initiate a pointer to the db_model
   .                segment and return it to the caller.

   82-05-26 Davids: changed   to   be	compatable   with   the  new
   .                mu_quiesce$quiesce_quiet calling sequence.

   82-05-26 Roger Lackey: changed mrds_dsl_get_version$get_path_info to
                   dsl_$get_path_info for binding
                      and
                  mu_quiesce$quiesce_quiet to mdbm_util_$quiesce_quiet

   82-08-20 Davids: added entries_str_ptr to the parameter list, included 
                    the rmdb_relmgr_entries and mdbm_db_model include files
                    and added code to set the values of the relmgr entries
                    to the correct relation_manager based on the database type.

   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-05-24 Davids: Added code to initiate the saved rdbi segment and return
   a pointer to the saved_res_version element.

   83-10-04 Benjamin: Changed hcs_$initiate calls to initiate_file_.

   84-10-23 Benjamin: Changed to not abort when mu_quiesce returns 
   mrds_error_$my_quiesced_db.
*/

/* PARAMETERS */

	dcl     db_path		 char (168);	/* (input) data base path reative or absolute */
	dcl     quiesce_wait_time	 fixed bin;	/* (input) length of time to wait before giving
						   up tring to quiesce the data base */
	dcl     entries_str_ptr	 ptr;		/* (input) pointer to the relmgr_entries structure whose
                                                               elements will be set by this procedure */
	dcl     absolute_db_path	 char (168);	/* (output) absoulte path of the data base */
	dcl     db_model_ptr	 ptr;		/* (output) pointer to the db_model segment of the database */
	dcl     saved_res_version_ptr	 ptr;		/* (output) pointer the saved_res_version element
                                                               of the saved rdbi segment */
	dcl     error_message	 char (500);	/* (output) text of error message in case of problems */
	dcl     code		 fixed bin (35);	/* (output) standard error code */

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) external static;
	dcl     error_table_$no_dir	 fixed bin (35) ext static;
	dcl     mrds_error_$my_quiesced_db fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* ENTRIES */

	dcl     vfile_relmgr_$close	 entry (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_$create_MRDS_relation entry (char (*), char (*), ptr,
				 ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$destroy_index entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$destroy_relation_by_path entry (char (*), char (*), fixed bin (35));
	dcl     vfile_relmgr_$open	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin(35));
	dcl     vfile_relmgr_$create_cursor entry (bit(36) aligned, ptr, ptr, fixed bin(35));
          dcl     vfile_relmgr_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35));
	     
	dcl     relation_manager_$close entry (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_$create_relation entry (char (*), char (*), ptr,
				 ptr, bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$destroy_index entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$destroy_relation_by_path entry (char (*), char (*), fixed bin (35));
	dcl     relation_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$put_tuple entry (ptr, ptr, bit (36) aligned, fixed bin(35));
	dcl     relation_manager_$create_cursor entry (bit(36) aligned, ptr, ptr, fixed bin(35));
          dcl     relation_manager_$get_tuple_id entry (ptr, ptr, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$get_tuple_by_id entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35));

	dcl     ioa_$rs		 entry () options (variable);
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24),
				 fixed bin (35));
	dcl     mdbm_util_$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     dsl_$get_path_info	 entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     dsl_$create_res_copy	 entry options (variable);
	dcl     mdbm_util_$quiesce_quiet entry (char (168), fixed bin, fixed bin (35));

/* INTERNAL AUTOMATIC */

	dcl     area		 area (500);	/* local working area for structures to be allocated in */
	dcl     bit_count		 fixed bin (24);	/* required in calls to initiate_file_ */
	dcl     local_db_model_ptr	 ptr;		/* local copy of the pointer to the db_model seg */
	dcl     saved_rdbi_ptr	 ptr;		/* pointer the the rm_db_info structure in the rdbi segment */


/* BUILTINS */

	dcl     addr		 builtin;
	dcl     empty		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     null		 builtin;
	dcl     rel		 builtin;
	dcl     rtrim		 builtin;

/* INCLUDE FILES */
%page;
%include mrds_authorization;
%page;
%include mrds_path_info;
%page;
%include rmdb_relmgr_entries;
%page;
%include mdbm_db_model;
%page;
%include mdbm_rm_db_info;
%page;
%include access_mode_values;

/*
   Initialize the output parameters
*/

	absolute_db_path = "";
	db_model_ptr = null ();
	code = 0;
	error_message = "";



/*
   use the pointer declared in with rmdb_relmgr_entries
*/

	rmdb_relmgr_entries_ptr = entries_str_ptr;





/*
   Determine if the input path refers to a  data  base  model  or  a
   submodel.  If a submodel return an error. Also determine the data
   bases's version of its version  3  or  earlier  return  an  error
   (restructuring  can  not  be  supported  by  models  eariler than
   version 4).
*/


	call dsl_$get_path_info (db_path, addr (area),
	     mrds_path_info_structure_version, mrds_path_info_ptr, code);
	if code ^= 0
	then do;
		call ioa_$rs ("Could not get database path info for ^a", error_message, length (error_message), db_path);
		goto exit_rmdb_ready_db;
	     end;

	if mrds_path_info.type.submodel
	then do;
		code = error_table_$action_not_performed;
		error_message = "Submodels may not be restructured";
		goto exit_rmdb_ready_db;
	     end;

	if mrds_path_info.mrds_version &lt;= 3
	then do;
		code = error_table_$action_not_performed;
		error_message = "Version 3 and eariler data bases may not be restructured";
		goto exit_rmdb_ready_db;
	     end;

/*
   Determine the authorization of the caller, if he  is  not  a  DBA
   return an error.
*/


	call mdbm_util_$get_user_class ((mrds_path_info.absolute_path), addr (area),
	     mrds_authorization_structure_version, mrds_authorization_ptr, code);
	if code ^= 0
	then do;
		call ioa_$rs ("Unable to determine if you are a DBA for ^a", error_message,
		     length (error_message), mrds_path_info.absolute_path);
		goto exit_rmdb_ready_db;
	     end;

	if ^mrds_authorization.administrator
	then do;
		code = error_table_$action_not_performed;
		error_message = "Only a data base's DBA may restructure the data base";
		goto exit_rmdb_ready_db;
	     end;





/*
   initiate a pointer to the db_model segment  of  the  database  so
   that it is available for the other requests. the output parameter
   will be set after the database is quiesced.
*/

	local_db_model_ptr = null ();
	call initiate_file_ ((mrds_path_info.absolute_path), "db_model", RW_ACCESS, local_db_model_ptr, bit_count, code);
	if local_db_model_ptr = null ()
	then do;
		error_message = "Could not initiate the db_model segment";
		goto exit_rmdb_ready_db;
	     end;


/*
   Get a pointer to the saved_res_version value. If there is no saved
   resultant - create one
*/

	call initiate_file_ (rtrim (mrds_path_info.absolute_path) || "&gt;resultant_segs.dir",
	     "rdbi", RW_ACCESS, saved_rdbi_ptr, bit_count, code);
	if code = error_table_$no_dir
	then do;					/* create the saved resultant */
		call dsl_$create_res_copy (mrds_path_info.absolute_path, code);
		if code ^= 0
		then do;
			error_message = "Could not create and save a copy of the resultant.";
			goto exit_rmdb_ready_db;
		     end;
		call initiate_file_ (rtrim (mrds_path_info.absolute_path) || "&gt;resultant_segs.dir",
		     "rdbi", RW_ACCESS, saved_rdbi_ptr, bit_count, code);
	     end;
	if saved_rdbi_ptr = null ()
	then do;
		error_message = "Could not initiate the saved resultant segment rdbi.";
		goto exit_rmdb_ready_db;
	     end;
	saved_res_version_ptr = addr (saved_rdbi_ptr -&gt; rm_db_info.saved_res_version);

/*
   Quiesce  the  database.
*/

	call mdbm_util_$quiesce_quiet ((mrds_path_info.absolute_path), quiesce_wait_time, code);
	if code ^= 0 &amp; code ^= mrds_error_$my_quiesced_db
	then do;
		error_message = "The data base could not be quiesced.";
		goto exit_rmdb_ready_db;
	     end;




/*
   Setup the relation_manager entries that correspond with the
   type of database being opened.
*/

	if local_db_model_ptr -&gt; db_model.db_type_flags.vfile_type
	then do;
		rmdb_relmgr_entries.create_relation = vfile_relmgr_$create_MRDS_relation;
		rmdb_relmgr_entries.delete_relation = vfile_relmgr_$destroy_relation_by_path;
		rmdb_relmgr_entries.open = vfile_relmgr_$open;
		rmdb_relmgr_entries.close = vfile_relmgr_$close;
		rmdb_relmgr_entries.create_index = vfile_relmgr_$create_index;
		rmdb_relmgr_entries.delete_index = vfile_relmgr_$destroy_index;
		rmdb_relmgr_entries.put_tuple = vfile_relmgr_$put_tuple;
		rmdb_relmgr_entries.create_cursor = vfile_relmgr_$create_cursor;
		rmdb_relmgr_entries.get_tuple_id = vfile_relmgr_$get_tuple_id;
		rmdb_relmgr_entries.get_tuple_by_id = vfile_relmgr_$get_tuple_by_id;
	     end;
	else do;					/* dm_file database */
		rmdb_relmgr_entries.create_relation = relation_manager_$create_relation;
		rmdb_relmgr_entries.delete_relation = relation_manager_$destroy_relation_by_path;
		rmdb_relmgr_entries.open = relation_manager_$open;
		rmdb_relmgr_entries.close = relation_manager_$close;
		rmdb_relmgr_entries.create_index = relation_manager_$create_index;
		rmdb_relmgr_entries.delete_index = relation_manager_$destroy_index;
		rmdb_relmgr_entries.put_tuple = relation_manager_$put_tuple;
		rmdb_relmgr_entries.create_cursor = relation_manager_$create_cursor;
		rmdb_relmgr_entries.get_tuple_id = relation_manager_$get_tuple_id;
		rmdb_relmgr_entries.get_tuple_by_id = relation_manager_$get_tuple_by_id;
	     end;





/*
   Since  everything  worked  ok   we   can   set   the   value   of
   absolute_db_path and the db_model_ptr.
*/


	absolute_db_path = mrds_path_info.absolute_path;
	db_model_ptr = local_db_model_ptr;




exit_rmdb_ready_db:
	return;

     end rmdb_ready_db;




		    rmdb_relations_used.pl1         10/16/86  1532.8rew 10/16/86  1531.2      132255



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

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

/*DESCRIPTION
  Given a list of objects to delete (domains or attributes, depending upon
  which entry point into this subroutine is used), this subroutine creates
  a list of relations that are used along with a per-relation list of attributes
  to be deleted in that relation. This list is then used in another subroutine
  to create a new copy of those relations without the specified attributes.
  The information to prepare these lists comes from the temporary crossreference
  vfile.
*/

/****^  HISTORY COMMENTS:
  1) change(86-01-14,Spitzer), approve(86-01-14,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

rmdb_relations_used:
     proc;

	return;					/* not an entry point */

rmdb_relations_used$domains:
     entry (Irmdb_ctl_ptr, Idelete_object_info_ptr, Iarea_ptr, Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr,
	Oerror_message, Ocode);

	domain_entry = "1"b;
	goto COMMON;

rmdb_relations_used$attributes:
     entry (Irmdb_ctl_ptr, Idelete_object_info_ptr, Iarea_ptr, Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr,
	Oerror_message, Ocode);

	domain_entry = "0"b;
	goto COMMON;

COMMON:						/* copy input variables */
	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	delete_object_info_ptr = Idelete_object_info_ptr;
	user_area_ptr = Iarea_ptr;

/* initialize output variables */
	Odomain_list_ptr, Oattribute_list_ptr, Orelation_list_ptr = null;
	Oerror_message = "";
	Ocode = 0;

	temp_ptrs (*) = null;
	max_seg_size = sys_info$max_seg_size * 4;
	db_path = rmdb_ctl.absolute_db_path;
	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;

	on cleanup call cleaner;

	call mdbm_util_$get_temp_segments_path (rmdb_ctl.temp_dir_path, myname, temp_ptrs, code);
	if code ^= 0
	then do;
	     error_message = "Cannot get a temp segment in " || rtrim(rmdb_ctl.temp_dir_path) || ".";
	     call error (code, error_message);
	     end;
	
/* use the 1st temp segment for reading records from the crossref file */
	crossref_info_record_ptr = temp_ptrs (1);

/* Since we are now going to allocate lots of structures in the user area, set
   up an area condition so we can return some intelligent error message if we
   overflow it. */
	on area call error (error_table_$area_too_small, "Input user area.");

	if domain_entry
	then do;					/* create and fill the domain_list structure */
	     domain_list_count = delete_object_info.count;
	     allocate domain_list in (user_area) set (domain_list_ptr);

	     do domain_idx = 1 to domain_list_count;

/* Get the domain record from the crossreference file */
		call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, delete_object_info.name (domain_idx),
		     crossref_info_record_ptr, max_seg_size, error_message, code);
		if code ^= 0
		then if code = error_table_$no_record
		     then call error (mrds_error_$no_model_dom, delete_object_info.name (domain_idx));
		     else call error (code, error_message);

/* It's there, fill in the domain_list entry */
		domain_list.name (domain_idx) = make_name (delete_object_info.name (domain_idx));

/* Create this domain's corresponding attribute_list structure (the list of
   attributes that are used by this domain). If the domain is unreferenced,
   this ptr will be set to null. */
		if crossref_info_record.count = 0
		then attribute_list_ptr = null;
		else do;
		     attribute_list_count = crossref_info_record.count;
		     allocate attribute_list in (user_area) set (attribute_list_ptr);

/* Fill in the attribute_list structure for this domain. This will contain the
   list of attributes used within a single specific domain. */
		     do attribute_list_idx = 1 to attribute_list_count;
			attribute_list.name (attribute_list_idx) =
			     make_name (crossref_info_record.object (attribute_list_idx));
			end;			/* do attribute_list_idx */
		     end;

		domain_list.attribute_list_ptr (domain_idx) = attribute_list_ptr;
		end;				/* do domain_idx */
	     end;					/* if domain_entry */
	else do;					/* must have entered through the attribute EP */

/* Indicate there is no domain_list structure when entered through the domain
   entry point. */
	     domain_list_ptr = null;

/* Create the attribute_list structure. */
	     attribute_list_count = delete_object_info.count;
	     allocate attribute_list in (user_area) set (attribute_list_ptr);

/* Populate the attribute_list structure with the objects from the
   delete_object_info structure. */
	     do attribute_list_idx = 1 to attribute_list_count;
		attribute_list.name (attribute_list_idx) = make_name (delete_object_info.name (attribute_list_idx));
		attribute_list.attribute_ptr (attribute_list_idx) = null;
		end;				/* do attribute_list_idx */
	     end;

/* Process the attribute_list structure, producing the list of relations used
   in all the specified attributes. The list of unique relations is built upon
   a temp segment and then copied into an allocated structure, as we don't know
   a priori how many relations there will be. */
	relation_list_ptr = temp_ptrs (2);
	if domain_entry
	then do domain_idx = 1 to domain_list.count;
		attribute_list_ptr = domain_list.attribute_list_ptr (domain_idx);
		call get_relation_names;
		end;				/* do domain_idx */
	else call get_relation_names;

/* Create the relation_list structure that is to be returned to the caller. */
	relation_list_count = relation_list.count;
	allocate relation_list in (user_area) set (relation_list_ptr);

/* Copy the contents of the temp_ptrs (2) -&gt; relation_list.name into
   relation_list_ptr -&gt; relation_list.name. */
	relation_list_ptr -&gt; relation_list.name = temp_ptrs (2) -&gt; relation_list.name;

/* Now process the relation_list structure. We have to initiate the relation.m
   segments and create a relation structure for each referenced relation. Note
   that we don't have to terminate the segments because we will 1) leave the
   pointer to it in the relation structure, and 2) we will shortly delete the
   segment anyway. */

	do relation_idx = 1 to relation_list.count;
	     relation_model_name = rtrim (unmake_name (relation_list.name (relation_idx))) || ".m";
	     call initiate_file_ (db_path, relation_model_name, RW_ACCESS, fm_ptr, (0), code);
	     if code ^= 0
	     then call error (code, "Initiating " || pathname_ (db_path, relation_model_name));

/* Get attribute count of this relation from the relation_info structure in the
   file_model. */
	     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
	     relation_attribute_count = rel_info.num_attr;

/* Create and populate the relation structure for this relation. */
	     allocate relation in (user_area) set (relation_ptr);
	     relation.name = unmake_name (relation_list.name (relation_idx));
	     relation.file_model_ptr = fm_ptr;

	     relation_list.relation_ptr (relation_idx) = relation_ptr;

/* Fill in the list of attributes in this relation. */
	     ai_ptr = ptr (fm_ptr, rel_info.attr_ptr);
	     do attribute_idx = 1 to relation_attribute_count;
		unspec (relation.attribute (attribute_idx).flags) = "0"b;
		relation.attribute.attribute_info_ptr (attribute_idx) = ai_ptr;
		relation.attribute.domain_info_ptr (attribute_idx) = attr_info.domain_ptr;
		relation.attribute_names (attribute_idx) = make_name ((attr_info.name));
		relation.attribute.flags.part_of_key (attribute_idx) = attr_info.key_attr;
		ai_ptr = ptr (fm_ptr, attr_info.fwd_thread);
		end;				/* do attribute_idx */
	     end;					/* relation_idx */

/* Finally, we need to turn on the delete flag for each attribute in each
   referenced relation that is to be deleted. */
	if domain_entry
	then do domain_idx = 1 to domain_list.count;
		attribute_list_ptr = domain_list.attribute_list_ptr (domain_idx);
		call mark_deleted_attributes;
		end;				/* do domain_idx */
	else call mark_deleted_attributes;

/* Return the pointers to the structures we have just generated. */
	Orelation_list_ptr = relation_list_ptr;
	Oattribute_list_ptr = attribute_list_ptr;
	Odomain_list_ptr = domain_list_ptr;

	call error (0, "");
%page;
make_name:
     proc (input_name) returns (char (33));

dcl  input_name char (*) parameter;

	return (OBJECT_HEAD || input_name);
     end make_name;

unmake_name:
     proc (input_name) returns (char (32));

dcl  input_name char (33) parameter;

	return (substr (input_name, 2, 32));
     end unmake_name;
%page;
/* Process the current attribute_list structure: retrieve the attribute
   crossreference record for each attribute (this contains the list of relations
   that the attribute is used within). Search the relation_list structure for
   each relation. If it is not found, add the relation to the end of the
   relation_list. Then place the index of that relation in the attribute
   structure. */

get_relation_names:
     proc;

dcl  attribute_name char (32);
dcl  search_name char (33);
dcl  position fixed bin;

	do attribute_list_idx = 1 to attribute_list.count;
	     attribute_name =unmake_name (attribute_list.name (attribute_list_idx));
	     call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD,
		attribute_name, crossref_info_record_ptr, max_seg_size,
		error_message, code);
	     if code ^= 0
	     then if code = error_table_$no_record
		then call error (mrds_error_$no_model_attr, attribute_name);
		else call error (code, error_message);

	     if crossref_info_record.count = 0
	     then attribute_list.attribute_ptr (attribute_list_idx) = null;
	     else do;

/* Create the attribute structure. */
		attribute_count = crossref_info_record.count;
		allocate attribute in (user_area) set (attribute_ptr);

/* Each relation in the current crossref_info_record contains the attribute that
   we are processing now. Place the index of each referenced relation (in the
   relation_list structure) in the attribute structure. */
		do attribute_idx = 1 to attribute_count;
		     search_name = substr (crossref_info_record_objects, 1 + (33 * (attribute_idx - 1)), 33);
		     position = index (relation_list_names, search_name);

		     if position = 0
		     then do;			/* add it on the end */
			position, relation_list.count = relation_list.count + 1;
			relation_list.name (position) = search_name;
			end;
		     else position = divide (position, 33, 17, 0) + 1;

		     attribute.relation_idx (attribute_idx) = position;

		     end;				/* do attribute_idx */

		attribute_list.attribute_ptr (attribute_list_idx) = attribute_ptr;
		end;

	     attribute_list.domain_info_ptr (attribute_list_idx) = crossref_info_record.offset;
	     end;					/* do attribute_list_idx */

	return;
     end get_relation_names;
%page;
/*DESCRIPTION
  Take the list pointed to by the current attribute_list_ptr, processing it
  by marking all attributes in the referenced relation to be deleted. */

mark_deleted_attributes:
     proc;

dcl  position fixed bin;
dcl  search_name char (33);

	do attribute_list_idx = 1 to attribute_list.count;
	     attribute_ptr = attribute_list.attribute_ptr (attribute_list_idx);
	     if attribute_ptr ^= null
	     then do;				/* the attribute was referenced in at least a single relation */
		search_name = attribute_list.name (attribute_list_idx);
		do attribute_idx = 1 to attribute.count;
		     relation_ptr = relation_list.relation_ptr (attribute.relation_idx (attribute_idx));
		     position = index (relation_attribute_names, search_name);
		     if position ^= 0
		     then do;			/* found the place, mark the attribute to be deleted */
			position = divide (position, 33, 17, 0) + 1;
			relation.attribute (position).flags.delete = "1"b;
			end;
		     end;				/* do attribute_idx */
		end;
	     end;					/* do attribute_list_idx */

	return;
     end mark_deleted_attributes;
%page;
/*DESCRIPTION
  Error handler and cleanup handler. This is the only way to exit these
  subroutines.
*/

error:
     proc (code, msg);

dcl  code fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = code;
	Oerror_message = msg;
	goto RETURN_TO_CALLER;
     end error;

RETURN_TO_CALLER:
	call cleaner;
	return;

cleaner:
     proc;

dcl  cleaner_code fixed bin (35);

	if temp_ptrs (1) ^= null
	then call mdbm_util_$free_temp_segments (myname, temp_ptrs, cleaner_code);

	return;
     end cleaner;
%page;
%include access_mode_values;
%include mdbm_db_model;
%include mdbm_file_model;
%include mrds_rmdb_ctl;
%include rmdb_crossref_info;
%include rmdb_delete_object_info;
%page;
dcl  addr builtin;
dcl  area condition;
dcl  attribute_idx fixed bin;
dcl  attribute_list_idx fixed bin;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  divide builtin;
dcl  db_path char (168);
dcl  domain_entry bit (1) aligned;
dcl  domain_idx fixed bin;
dcl  error_message char (500);
dcl  error_table_$area_too_small fixed bin (35) ext static;
dcl  error_table_$no_record fixed bin(35) ext static;
dcl fixed builtin;
dcl  Iarea_ptr ptr parameter;
dcl  Idelete_object_info_ptr ptr parameter;
dcl  index builtin;
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  local_iocb ptr;				/* -&gt; IOCB for crossref file */
dcl  max_seg_size fixed bin (21);
dcl  mrds_error_$no_model_attr fixed bin(35) ext static;
dcl  mrds_error_$no_model_dom fixed bin(35) ext static;
dcl  myname char (32) int static options (constant) init ("rmdb");
dcl  null builtin;
dcl  Oattribute_list_ptr ptr parameter;
dcl  Ocode fixed bin (35) parameter;
dcl  Odomain_list_ptr ptr parameter;
dcl  Oerror_message char (*) parameter;
dcl  Orelation_list_ptr ptr parameter;
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  ptr builtin;
dcl  rel builtin;
dcl  relation_idx fixed bin;
dcl  relation_model_name char (32);
dcl  mdbm_util_$get_temp_segments_path entry (char (*), char (*), (*) ptr, fixed bin (35));
dcl  mdbm_util_$free_temp_segments entry (char (*), (*) ptr, fixed bin (35));
dcl  mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  rtrim builtin;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  temp_ptrs (2) ptr;
dcl  unspec builtin;
dcl  user_area area based (user_area_ptr);
dcl  user_area_ptr ptr;

     end rmdb_relations_used;
�



		    rmdb_rename.pl1                 10/16/86  1532.8rew 10/16/86  1531.2      258426



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

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

/*DESCRIPTION
  This subroutine implements renaming of domains, attributes and relation.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

rmdb_rename:
     proc (Irmdb_ctl_ptr, Irename_object_info_ptr, Oerror_message, Ocode);

	rmdb_ctl_ptr = Irmdb_ctl_ptr;
	rename_object_info_ptr = Irename_object_info_ptr;
	local_iocb = rmdb_ctl.crossref_file_info.iocb_ptr;
	dbm_ptr = rmdb_ctl.db_model_ptr;

	if rename_object_info.version ^= rename_object_info_version_1
	then call error (error_table_$unimplemented_version,
		"Version " || rename_object_info.version || " for the rename_object_info structure.");

	if /* case */ rename_object_info.type = RENAME_ATTRIBUTE
	then do;
	     rename_entry = rename_attribute;
	     key_head = ATTRIBUTE_KEY_HEAD;
	     end;
	else if rename_object_info.type = RENAME_DOMAIN
	then do;
	     rename_entry = rename_domain;
	     key_head = DOMAIN_KEY_HEAD;
	     end;
	else if rename_object_info.type = RENAME_RELATION
	then do;
	     rename_entry = rename_relation;
	     key_head = RELATION_KEY_HEAD;
	     end;
	else call error (mrds_error_$internal_error,
		"Rename operation of type " || ltrim (char (rename_object_info.type)));

	if local_iocb = null
	then do;
	     call mdbm_util_$xref_build (rmdb_ctl.temp_dir_path, rmdb_ctl.absolute_db_path, dbm_ptr,
		rmdb_ctl.crossref_file_info.name, local_iocb, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     rmdb_ctl.crossref_file_info.iocb_ptr = local_iocb;
	     end;

	max_seg_size = sys_info$max_seg_size * 4;

	tempp, fm_ptr = null;
	on cleanup call cleaner;

/* Verify all of the input arguments. See that all the from names are there and
   all the to names aren't. */
	do loop = 1 to rename_object_info.count;
	     call mdbm_util_$xref_find_record (local_iocb, rtrim (key_head), rename_object_info.from (loop), null, 0,
		error_message, code);
	     if code ^= 0
	     then if code = error_table_$no_record
		then do;
		     if rename_object_info.type = RENAME_ATTRIBUTE
		     then code = mrds_error_$no_model_attr;
		     else if rename_object_info.type = RENAME_DOMAIN
			then code = mrds_error_$no_model_dom;
			else code = mrds_error_$no_model_rel;
		     call error (code, rename_object_info.from (loop));
		     end;
		else call error (code, error_message);

	     call mdbm_util_$xref_find_record (local_iocb, rtrim (key_head), rename_object_info.to (loop), null, 0,
		error_message, code);
	     if code = 0
	     then do;
		if rename_object_info.type = RENAME_ATTRIBUTE
		then code = mrds_error_$attr_already_exists;
		else if rename_object_info.type = RENAME_DOMAIN
		     then code = mrds_error_$domain_already_defined;
		     else code = mrds_error_$dup_rel;
		call error (code, rename_object_info.to (loop));
		end;
	     else if code ^= error_table_$no_record
		then call error (code, error_message);
	     end;					/* do loop */

	call mdbm_util_$get_temp_segment_path (rmdb_ctl.temp_dir_path, myname, tempp, code);
	if code ^= 0
	then call error (code, "Unable to get temp segments.");

/* Actually rename the suckers now. */
	do loop = 1 to rename_object_info.count;
	     call rename_entry (rename_object_info.from (loop), rename_object_info.to (loop));
	     end;					/* do loop */

	call cleaner;
	call error (0, "");

RETURN_TO_CALLER:
	return;

cleaner:
     proc;

	if tempp ^= null
	then call mdbm_util_$free_temp_segment (myname, tempp, (0));
	if fm_ptr ^= null
	then call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
	return;
     end cleaner;

error:
     proc (cd, msg);

dcl  cd fixed bin (35) parameter;
dcl  msg char (*) parameter;

	Ocode = cd;
	if Ocode = 0
	then Oerror_message = "";
	else Oerror_message = msg;

	call cleaner;
	goto RETURN_TO_CALLER;

     end error;
%page;
/*DESCRIPTION
  This implements renaming a single attribute. Note that quits are trapped
  during critical code. Steps Are:
  - if the attribute is unreferenced rename the attribute in db_model
  - otherwise
    - mark the db and resultant inconsistent.
    - get the attribute xref record.
    - for each relation in the xref
      - initiate the file_model
      - find the attribute within the file_model
      - rename the attribute within the file_model
      - rename the attribute within the referenced domain xref record
    - mark the db consistent
  - rename the attribute xref record.
  - add a history entry
*/

rename_attribute:
     proc (ra_from, ra_to);

dcl  ra_attribute_xref_ptr ptr;
dcl  ra_from char (*) parameter;
dcl  ra_loop fixed bin;
dcl  ra_relation_name char (32);
dcl  ra_to char (*) parameter;
dcl  ra_unreferenced_domain bit (1) aligned;

	ra_unreferenced_domain = "0"b;
	goto RENAME_ATTRIBUTE_COMMON;

rename_attribute$unreferenced_domain:
     entry (ra_from, ra_to);

	ra_unreferenced_domain = "1"b;
	goto RENAME_ATTRIBUTE_COMMON;

RENAME_ATTRIBUTE_COMMON:

	ra_attribute_xref_ptr = tempp;

/* Get the attribute crossreference record */
	call mdbm_util_$xref_find_record (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_attribute_xref_ptr, max_seg_size,
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

/* BEGIN CRITICAL CODE */
	quit_occurred = FALSE;
	on quit quit_occurred = TRUE; 

/* disallow renaming of generated attributes */
	di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -&gt; crossref_info_record.offset);
	if domain_info.name = ra_from
	then call error (error_table_$unsupported_operation, 
	     "Attempt to rename a generated attribute: " || ra_from);

	if ra_attribute_xref_ptr -&gt; crossref_info_record.count = 0
	then if ra_unreferenced_domain		/* unreferenced attribute */
	     then do;				/* this is the generated attribute */
		call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to, ra_attribute_xref_ptr, error_message, code);
		if code ^= 0
		then call error (code, error_message);
		di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -&gt; crossref_info_record.offset);
		call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from,
		     ra_to, error_message, code);
		if code ^= 0
		then call error (code, error_message);
		end;
	     else do;
		continue = TRUE;
		do ua_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr)
		     repeat ptr (dbm_ptr, unreferenced_attribute.fwd_thread) while (rel (ua_ptr) ^= NULL_OFFSET &amp; continue);
		     if unreferenced_attribute.name = ra_from
		     then do;
			unreferenced_attribute.name = ra_to;
			continue = FALSE;
			di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -&gt; crossref_info_record.offset);
			call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from,
			     ra_to, error_message, code);
			if code ^= 0
			then call error (code, error_message);
			call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to, 
			     null(), error_message, code);
			if code ^= 0
			then call error (code, error_message);
			end;
		     end;				/* do ua_ptr */
		end;
	else do;					/* referenced attribute */

/* Mark database inconsistent */
	     rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";
	     if ra_unreferenced_domain
	     then call mdbm_util_$inconsistent_set (dbm_ptr, "rename_domain",
		     "Renaming domain " || rtrim (ra_from) || " to " || rtrim (ra_to),
		     "undo_rename " || rtrim (ra_to) || " " || rtrim (ra_from));
	     else call mdbm_util_$inconsistent_set (dbm_ptr, "rename_attribute",
		     "Renaming attribute " || rtrim (ra_from) || " to " || rtrim (ra_to),
		     "undo_rename " || rtrim (ra_to) || " " || rtrim (ra_from));

	     fm_ptr = null;
	     on cleanup call cleaner;

/* Do for all relations this attribute is referenced in */
	     do ra_loop = 1 to ra_attribute_xref_ptr -&gt; crossref_info_record.count;

/* Try to open the file_model */
		ra_relation_name = rtrim (ra_attribute_xref_ptr -&gt; crossref_info_record.object (ra_loop)) || ".m";
		call initiate_file_ (rmdb_ctl.absolute_db_path, ra_relation_name, RW_ACCESS, fm_ptr, (0), code);
		if code ^= 0
		then call error (code, "Initiating relation " || ra_relation_name);

/* rename the attr_info name in the file_model */
		ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
		continue = TRUE;
		do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread)
		     while (rel (ai_ptr) ^= NULL_OFFSET &amp; continue);
		     if attr_info.name = ra_from
		     then do;
			attr_info.name = ra_to;
			continue = FALSE;
			end;
		     end;				/* do ai_ptr */

		call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
		end;				/* do ra_loop */

/* Modify the attribute name in the domain reference record */
		di_ptr = ptr (dbm_ptr, ra_attribute_xref_ptr -&gt; crossref_info_record.offset);
		call mdbm_util_$xref_modify_reference_name (local_iocb, DOMAIN_KEY_HEAD, (domain_info.name), ra_from,
		     ra_to, error_message, code);
		if code ^= 0
		then call error (code, error_message);

/* Modify the name on the attribute crossreference record */
	     call mdbm_util_$xref_modify_record_name (local_iocb, ATTRIBUTE_KEY_HEAD, ra_from, ra_to,
		ra_attribute_xref_ptr, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);

	     call mdbm_util_$inconsistent_reset (dbm_ptr);
	     end;

/* Add history entry */

	if ^ra_unreferenced_domain
	then call rmdb_add_rmdb_history (dbm_ptr, RMDB_ATTR_TYPE, (ra_from), RMDB_RN_ATTR_OP, (ra_to), (""), (0));

/* END CRITICAL CODE */
	revert quit;
	if quit_occurred
	then signal quit;

	return;
     end rename_attribute;
%page;
/*DESCRIPTION
 This implements renaming a single domain. Note that quits are trapped during
   critical code. Steps are:
   - rename domain_info in db_model
   - get the domain xref record
   - if the domain is referenced
     - for each attribute in the domain xref record 
       - change the domain name in each attribute xref record
   - change the name on the domain xref record
   - add a history entry
*/

rename_domain:
     proc (rd_from, rd_to);

dcl  rd_domain_xref_ptr ptr;
dcl  rd_from char (*) parameter;
dcl  rd_loop fixed bin;
dcl  rd_to char (*) parameter;

	rd_domain_xref_ptr = tempp;

/* BEGIN CRITICAL CODE */

	quit_occurred = FALSE;
	on quit quit_occurred = TRUE;

/* Get the domain xref record. */
	call mdbm_util_$xref_find_record (local_iocb, DOMAIN_KEY_HEAD, rd_from, rd_domain_xref_ptr, max_seg_size,
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

/* Get a pointer to the domain_info structure in the db_model */
	di_ptr = ptr (dbm_ptr, rd_domain_xref_ptr -&gt; crossref_info_record.offset);
	if domain_info.name ^= rd_from
	then call error (mrds_error_$internal_error, "Domain " || rtrim (domain_info.name) || " should be " || rd_from);

/* Make sure the new domain name isn't an attribute based on this domain */
	continue = TRUE;
	do rd_loop = 1 to rd_domain_xref_ptr -&gt; crossref_info_record.count 
	     while (continue);
	     if rd_domain_xref_ptr -&gt; crossref_info_record.object (rd_loop) = rd_to
	     then continue = FALSE;
	     end;
	if ^continue
	then call error (error_table_$unsupported_operation, 
	     "The new domain name has already been used for an attribute based on this domain: " || rd_to);

/* Make sure the new domain name hasn't been used for an attribute already. */
	call mdbm_util_$xref_find_record (local_iocb, rtrim (ATTRIBUTE_KEY_HEAD), rd_to, null, 0, error_message, code);
	if code = 0
	then call error (error_table_$unsupported_operation,
	     "The new domain name has already been used for an attribute in the database: " || rd_to);

/* Change the name in domain_info */
	domain_info.name = rd_to;

/* Rename the domain xref record key. */
	call mdbm_util_$xref_modify_record_name (local_iocb, DOMAIN_KEY_HEAD, rd_from, rd_to, rd_domain_xref_ptr,
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

/* Rename the generated attribute record for this domain, along with all
   relation referenced for this generated attribute. */
	call rename_attribute$unreferenced_domain (rd_from, rd_to);

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_DOMAIN_TYPE, (rd_from), RMDB_RN_DMN_OP, (rd_to), (""), (0));

/* END CRITICAL CODE */
	revert quit; 
	if quit_occurred
	then signal quit;				/* finally signal it */

	return;
     end rename_domain;
%page;
/*DESCRIPTION
  This implements renaming a single relation. Note that quits are disabled 
  during critical code. Steps are:
  - mark db and resultant inconsistent
  - rename file_info in db_model
  - if the relation is a vfile
    - rename the relation file
  -otherwise
    - copy the relation to the new named relation using copy_
    - delete the original relation
  - rename the file_model segment
  - add a history entry
  - mark the db consistent
*/

rename_relation:
     proc (rr_from, rr_to);

dcl  rr_from char (*) parameter;
dcl  rr_from_model_name char (32);
dcl  rr_relation_xref_ptr ptr;
dcl  rr_to char (*) parameter;
dcl  rr_to_model_name char (32);

	rr_relation_xref_ptr = tempp;

/* BEGIN CRITICAL CODE */
	quit_occurred = FALSE;
	on quit quit_occurred = TRUE;

	call mdbm_util_$xref_find_record (local_iocb, RELATION_KEY_HEAD, rr_from, rr_relation_xref_ptr, max_seg_size,
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

	fi_ptr = ptr (dbm_ptr, rr_relation_xref_ptr -&gt; crossref_info_record.offset);
	if file_info.file_name ^= rr_from
	then call error (mrds_error_$internal_error,
		"Relation " || rtrim (file_info.file_name) || " should be " || rr_from);

	rr_from_model_name = rtrim (rr_from) || ".m";

	fm_ptr = null;
	on cleanup call cleaner;
	call initiate_file_ (rmdb_ctl.absolute_db_path, rr_from_model_name, RW_ACCESS, fm_ptr, (0), code);
	if code ^= 0
	then call error (code, "Initiating file_model for relation " || rr_from);

	rmdb_ctl.saved_res_version_ptr -&gt; based_char8 = "RESTRUCT";
	call mdbm_util_$inconsistent_set (dbm_ptr, "rename_relation",
	     "Renaming relation " || rtrim (rr_from) || " to " || rr_to,
	     "undo_rename " || rtrim (rr_to) || " " || rtrim (rr_from));

	file_info.file_name = rr_to;
	ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
	rel_info.name = rr_to;

	if db_model.db_type_flags.vfile_type
	then call fs_util_$chname_file (rmdb_ctl.absolute_db_path, rr_from, rr_from, rr_to, code);
	else do;
	     copy_options_ptr = addr (local_copy_options);
	     copy_options.version = COPY_OPTIONS_VERSION_1;
	     copy_options.caller_name = myname;
	     copy_options.source_dir, copy_options.target_dir = rmdb_ctl.absolute_db_path;
	     copy_options.source_name = rr_from;
	     copy_options.target_name = rr_to;

	     unspec (copy_options.flags) = "0"b;
	     copy_options.flags.no_name_dup = TRUE;
	     copy_options.flags.force = TRUE;
	     copy_options.flags.delete = TRUE;
	     copy_options.flags.mbz = "0"b;

	     unspec (copy_options.copy_items) = "0"b;
	     copy_options.copy_items.acl = TRUE;
	     copy_options.copy_items.ring_brackets = FALSE;
	     copy_options.copy_items.dumper_switches = FALSE;
	     copy_options.copy_items.mbz = "0"b;

	     file_model.relation_copy_good = FALSE;
	     call fs_util_$copy (copy_options_ptr, code);

/* Do this delete because file_manager_ has a bug: it doesn't get around to
   abiding by the flags. When/if DM is fixed the next group of statements may
   be removed. */
	     if code = 0
	     then do;
		acl_ptr = null;
		call fs_util_$list_acl (copy_options.source_dir, copy_options.source_name, GENERAL_ACL_VERSION_1,
		     addr (my_area), acl_ptr, code);
		if code ^= 0
		then call error (code, "Getting acl to relation " || copy_options.source_name);

		call fs_util_$replace_acl (copy_options.source_dir, copy_options.target_name, acl_ptr, "0"b, code);
		if code ^= 0
		then call error (code, "Setting acl on relation " || copy_options.target_name);

		file_model.relation_copy_good = TRUE;

		call fs_util_$delentry_file (copy_options.source_dir, copy_options.source_name, code);
		if code ^= 0
		then call error (code, "Deleting the old relation " || copy_options.source_name);
		end;
	     end;

	if code ^= 0
	then call error (code, "Renaming relation " || rtrim (rr_from) || " to " || rr_to);

	do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
	            repeat ptr (fm_ptr, attr_info.fwd_thread)
	            while (rel (ai_ptr) ^= NULL_OFFSET);
	     call mdbm_util_$xref_modify_reference_name (local_iocb, ATTRIBUTE_KEY_HEAD, (attr_info.name), rr_from, rr_to, error_message, code);
	     if code ^= 0
	     then call error (code, error_message);
	     end;

	call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, code);
	if code ^= 0
	then call error (code, "Terminating file_model for relation " || rr_from);

	rr_to_model_name = rtrim (rr_to) || ".m";

	call fs_util_$chname_file (rmdb_ctl.absolute_db_path, rr_from_model_name, rr_from_model_name, rr_to_model_name,
	     code);
	if code ^= 0
	then call error (code, "Renaming relation " || rtrim (rr_from_model_name) || " to " || rr_to_model_name);

	call mdbm_util_$xref_modify_record_name (local_iocb, RELATION_KEY_HEAD, rr_from, rr_to, rr_relation_xref_ptr,
	     error_message, code);
	if code ^= 0
	then call error (code, error_message);

	call rmdb_add_rmdb_history (dbm_ptr, RMDB_REL_TYPE, (rr_from), RMDB_RN_REL_OP, (rr_to), (""), (0));

	call mdbm_util_$inconsistent_reset (dbm_ptr);

/* END CRITICAL CODE */
	revert quit;
	if quit_occurred
	then signal quit;

	return;
     end rename_relation;
%page;
/*DESCRIPTION
  This entry point attempts to undo the actions of the rename requests.
  These can only be run when the database is marked inconsistent, and
  attempt to recover all the information possible. They don't report any
  errors that may be caused by items missing, mis-named, etc as these could
  result from a system or process interruption during a rename request. Note
  that we don't have to update the crossreference file in the [pd], as we are
  operating in an environment that hasn't created it yet. Also note that if
  there is an interruption during the undo process, it may be restarted the next
  time the specified database is touched. Certain operations may be retried,
  however, if they don't complete this request will continue on trying to undo
  the entire operation. The database inconsistent switch doesn't get reset until
  the entire undo operation succeeds.
*/

rmdb_rename$undo_rename:
     entry (Isci_ptr, Iinfo_ptr);

	call initialize;
	if operation = "rename_domain"
	then call undo_domain;
	else if operation = "rename_attribute"
	     then call undo_attribute;
	     else if operation = "rename_relation"
		then call undo_relation;

	call mdbm_util_$inconsistent_reset (dbm_ptr);
	return;

undo_domain:
     proc;

	continue = TRUE;

/* do for all domains in the database */
	do di_ptr = ptr (dbm_ptr, db_model.domain_ptr) repeat ptr (dbm_ptr, domain_info.fwd_thread)
	     while (rel (di_ptr) ^= NULL_OFFSET &amp; continue);
	     if domain_info.name = from_name
	     then do;
		continue = FALSE;
		domain_info.name = to_name;
		end;
	     end;

	return;
     end undo_domain;
%page;
undo_relation:
     proc;

	continue = TRUE;

/* do for all relations in the database */
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while (rel (fi_ptr) ^= NULL_OFFSET &amp; continue);
	     if file_info.file_name = from_name
	     then do;
		file_info.file_name = substr (to_name, 1, length (file_info.file_name));
		continue = FALSE;
		end;
	     end;

	tempp, fm_ptr = null;
	on cleanup call cleaner;

	call initiate_file_ (rmdb_ctl.absolute_db_path, to_name, RW_ACCESS, fm_ptr, (0), code);
	if code ^= 0
	then if code ^= error_table_$noentry
	     then goto RETURN_TO_CALLER;
	     else do;
		call initiate_file_ (rmdb_ctl.absolute_db_path, from_name, RW_ACCESS, fm_ptr, (0), code);
		if code ^= 0
		then goto RETURN_TO_CALLER;
		call fs_util_$chname_file (rmdb_ctl.absolute_db_path, from_name, from_name, to_name, code);
		end;

	ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
	rel_info.name = to_name;

	if db_model.db_type_flags.vfile_type
	then call fs_util_$chname_file (rmdb_ctl.absolute_db_path, from_name, from_name, to_name, (0));
	else if file_model.relation_copy_good
	     then do;
		copy_options_ptr = addr (local_copy_options);
		copy_options.version = COPY_OPTIONS_VERSION_1;
		copy_options.caller_name = "undo_rename";
		copy_options.source_dir, copy_options.target_dir = rmdb_ctl.absolute_db_path;
		copy_options.source_name = from_name;
		copy_options.target_name = to_name;

		unspec (copy_options.flags) = "0"b;
		copy_options.flags.no_name_dup = TRUE;
		copy_options.flags.force = TRUE;
		copy_options.flags.delete = TRUE;
		copy_options.flags.mbz = "0"b;

		unspec (copy_options.copy_items) = "0"b;
		copy_options.copy_items.acl = TRUE;
		copy_options.copy_items.ring_brackets = FALSE;
		copy_options.copy_items.dumper_switches = FALSE;
		copy_options.copy_items.mbz = "0"b;

		call fs_util_$copy (copy_options_ptr, code);

/* Do this delete because file_manager_ has a bug: it doesn't get around to
        abiding by the flags. When/if DM is fixed the next group of statements may
        be removed. */
		if code = 0
		then do;
		     acl_ptr = null;
		     call fs_util_$list_acl (copy_options.source_dir, copy_options.source_name, GENERAL_ACL_VERSION_1,
			addr (my_area), acl_ptr, code);
		     if code = 0
		     then do;
			call fs_util_$replace_acl (copy_options.source_dir, copy_options.target_name, acl_ptr, "0"b,
			     code);
			if code = 0
			then call fs_util_$delentry_file (copy_options.source_dir, copy_options.source_name, (0));
			end;
		     end;

		file_model.relation_copy_good = FALSE;
		end;
	     else call fs_util_$delentry_file (rmdb_ctl.absolute_db_path, from_name, (0));

	call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
	fm_ptr = null;
	return;
     end undo_relation;
%page;
undo_attribute:
     proc;

	continue = TRUE;

/* do for all unreferenced attributes in the db model */
	do ai_ptr = ptr (dbm_ptr, db_model.unreferenced_attribute_ptr) repeat ptr (dbm_ptr, attr_info.fwd_thread)
	     while (rel (ai_ptr) ^= NULL_OFFSET &amp; continue);
	     if attr_info.name = from_name
	     then do;
		attr_info.name = to_name;
		continue = FALSE;
		end;
	     end;					/* do ai_ptr */

	if continue
	then do;					/* the attribute is referenced somewhere */
	     fm_ptr, tempp = null;
	     on cleanup call cleaner;

/* Do for all relations in the database */
	     do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
		while (rel (fi_ptr) ^= NULL_OFFSET);
		call initiate_file_ (rmdb_ctl.absolute_db_path, (file_info.file_name), R_ACCESS, fm_ptr, (0), code);
		if code = 0
		then do;
		     continue = TRUE;
		     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);

/* Do for all attribute within a single relation */
		     do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr) repeat ptr (fm_ptr, attr_info.fwd_thread)
			while (rel (ai_ptr) ^= NULL_OFFSET &amp; continue);
			if attr_info.name = from_name
			then do;
			     attr_info.name = to_name;
			     continue = FALSE;
			     end;
			end;			/* do ai_ptr */
		     call terminate_file_ (fm_ptr, 0, TERM_FILE_TERM, (0));
		     fm_ptr = null;
		     end;
		end;				/* do fi_ptr */
	     end;

	return;
     end undo_attribute;
%page;
initialize:
     proc ();

dcl  i_nargs fixed bin;

	sci_ptr = Isci_ptr;
	rmdb_ctl_ptr = Iinfo_ptr;
	dbm_ptr = rmdb_ctl.db_model_ptr;
	if dbm_ptr = null
	then goto RETURN_TO_CALLER;			/* no database opened yet */

	call mdbm_util_$inconsistent_get_info (dbm_ptr, incon_value, operation, (""), (""));
	if ^incon_value
	then call ssu_$abort_line (sci_ptr, 0, "This request can only be called when making the database consistent.");

	call ssu_$arg_count (sci_ptr, i_nargs);
	if i_nargs ^= 2
	then goto RETURN_TO_CALLER;

	call ssu_$arg_ptr (sci_ptr, 1, argp, argl);
	from_name = arg;
	call ssu_$arg_ptr (sci_ptr, 2, argp, argl);
	to_name = arg;

	return;
     end initialize;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include copy_flags;
%page;
%include copy_options;
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mrds_rmdb_ctl;
%page;
%include rmdb_crossref_info;
%page;
%include rmdb_history_entry;
%page;
%include rmdb_rename_object_info;
%page;
%include terminate_file;
%page;
dcl  addr builtin;
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  based_char8 char (8) based;
dcl  char builtin;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  continue bit (1) aligned;
dcl  empty builtin;
dcl  error_message char (500);
dcl  error_table_$no_record fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$unsupported_operation fixed bin (35) ext static;
dcl  FALSE bit (1) aligned int static options (constant) init ("0"b);
dcl  fixed builtin;
dcl  from_name char (32);
dcl  fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  fs_util_$copy entry (ptr, fixed bin (35));
dcl  fs_util_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl  fs_util_$list_acl entry (char (*), char (*), char (*), ptr, ptr, fixed bin (35));
dcl  fs_util_$replace_acl entry (char (*), char (*), ptr, bit (1), fixed bin (35));
dcl  Iinfo_ptr ptr parameter;
dcl  incon_value bit (1);
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  Irename_object_info_ptr ptr parameter;
dcl  Irmdb_ctl_ptr ptr parameter;
dcl  Isci_ptr ptr parameter;
dcl  key_head char (32);
dcl  length builtin;
dcl  1 local_copy_options aligned like copy_options;
dcl  local_iocb ptr;
dcl  loop fixed bin;
dcl  ltrim builtin;
dcl  max_seg_size fixed bin (21);
dcl  mdbm_util_$get_temp_segment_path entry (char (*), char (*), ptr, fixed bin (35));
dcl  mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
dcl  mdbm_util_$inconsistent_reset entry (ptr);
dcl  mdbm_util_$inconsistent_set entry (ptr, char (*), char (*), char (*));
dcl  mdbm_util_$free_temp_segment entry (char (*), ptr, fixed bin (35));
dcl  mrds_error_$attr_already_exists fixed bin (35) ext static;
dcl  mrds_error_$domain_already_defined fixed bin (35) ext static;
dcl  mrds_error_$dup_rel fixed bin (35) ext static;
dcl  mrds_error_$internal_error fixed bin (35) ext static;
dcl  mrds_error_$no_model_attr fixed bin (35) ext static;
dcl  mrds_error_$no_model_dom fixed bin (35) ext static;
dcl  mrds_error_$no_model_rel fixed bin (35) ext static;
dcl  my_area area;
dcl  myname char (32) int static options (constant) init ("rmdb_rename");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) aligned int static options (constant) init ((18)"1"b);
dcl  Ocode fixed bin (35) parameter;
dcl  Oerror_message char (*) parameter;
dcl  operation char (32);
dcl  ptr builtin;
dcl  quit condition;
dcl  quit_occurred bit (1) aligned;
dcl  rel builtin;
dcl  rename_entry entry variable internal entry (char (*), char (*));
dcl  rmdb_add_rmdb_history entry (ptr, fixed bin, char (32), fixed bin, char (32), char (500), fixed bin (35));
dcl  mdbm_util_$xref_build entry (char (*), char (*), ptr, char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_find_record entry (ptr, char (*), char (*), ptr, fixed bin (21), char (*), fixed bin (35));
dcl  mdbm_util_$xref_modify_record_name entry (ptr, char (*), char (*), char (*), ptr, char (*), fixed bin (35));
dcl  mdbm_util_$xref_modify_reference_name entry (ptr, char (*), char (*), char (*), char (*), char (*), fixed bin (35));
dcl  rtrim builtin;
dcl  sci_ptr ptr;
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  tempp ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  to_name char (32);
dcl  TRUE bit (1) aligned int static options (constant) init ("1"b);
dcl  unspec builtin;

     end rmdb_rename;
��



		    rmdb_rq_create_attribute.pl1    10/16/86  1541.4rew 10/16/86  1541.5       55782



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

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

/*DESCRIPTION
  This routine parses command arguments for the create_attribute rmdb
  request.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     written.
                                                   END HISTORY COMMENTS */

rmdb_rq_create_attribute:
     proc (Isci_ptr, Iinfo_ptr);

/* Initialize values */

	sci_ptr = Isci_ptr;
	rmdb_ctl_ptr = Iinfo_ptr;

/* Determine the number of arguments. There must be an even number. */

	call ssu_$arg_count (sci_ptr, nargs);
	if (nargs = 0) | (mod (nargs, 2) ^= 0)
	then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args,
		"^/Usage:^/^-^a attribute1 domain1 {...attributeN domainN}", myname);

/* Create the structure that contains the attributes to create */

	create_attr_info_count = mod (nargs, 2);
	allocate create_attr_info in (my_area) set (create_attr_info_ptr);

/* Check to see if we have an open database */

	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database.");

/* Check to see if the database is consistent. If not, we must make it
consistent before we can create new attributes. Note that if for some reason
the database is not made consistent rmdb_execute_undo will not return, it
will either cause a request line or subsystem abort.*/

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, "create_attribute", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr,
		incon_name, undo_request);

/* Fill in our structure */

	create_attr_info.version = create_attr_info_version_1;
	create_attr_info.count = divide (nargs, 2, 17, 0);
	attribute_index = 1;

	do loop = 1 to nargs by 2;
	     call ssu_$arg_ptr (sci_ptr, loop, argp, argl);

	     if argl &gt; 32
	     then call ssu_$abort_line (sci_ptr, error_table_$bigarg,
		     "^/The maximum length of attribute names is 32 characters. ^a", arg);
	     if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0
	     then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg);
	     if search (substr (arg, 1, 1), "_-0123456789") ^= 0
	     then call ssu_$abort_line (sci_ptr, mrds_error_$inv_attr_name_first_char, "^a", arg);

	     create_attr_info.attribute (attribute_index).name = arg;

	     call ssu_$arg_ptr (sci_ptr, loop + 1, argp, argl);
	     if argl &gt; 32
	     then call ssu_$abort_line (sci_ptr, error_table_$bigarg,
		     "^/The maximum length of domain names is 32 characters. ^a", arg);
	     if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0
	     then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg);
	     if search (substr (arg, 1, 1), "_-0123456789") ^= 0
	     then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg);

	     create_attr_info.attribute (attribute_index).domain = arg;

	     attribute_index = attribute_index + 1;
	     end;					/* do loop */

/* Check for duplicate attributes to create */

	do loop = 1 to create_attr_info.count-1;
	     do inner_loop = loop + 1 to create_attr_info.count;
		if create_attr_info.attribute (loop).name = create_attr_info.attribute (inner_loop).name
		then call ssu_$abort_line (sci_ptr, mrds_error_$attr_already_exists, "^a", create_attr_info.attribute (inner_loop).name);
		end;				/* do inner_loop */
	     end;					/* do loop */

/* Do the actual attribute creation */

	call rmdb_create_attribute (rmdb_ctl_ptr, create_attr_info_ptr, error_message, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", error_message);

	return;
%page;
%include mrds_rmdb_ctl;
%include rmdb_create_attr_info;
%page;
dcl  arg char (argl) based (argp);			/* command line argument */
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  attribute_index fixed bin;			/* loop index */
dcl  code fixed bin (35);
dcl  divide builtin;
dcl  empty builtin;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$bigarg fixed bin (35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;
dcl  incon_name char (32);				/* name of the request that caused the db to become inconsistent */
dcl  incon_value bit (1);				/* true ::= the db is inconsistent */
dcl  Iinfo_ptr ptr;
dcl  inner_loop fixed bin (17);			/* loop index */
dcl  Isci_ptr ptr;
dcl  loop fixed bin;				/* loop index */
dcl  mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
dcl  mod builtin;
dcl  mrds_data_$valid_rel_and_attr_name_chars char (128) ext static;
dcl  mrds_error_$attr_already_exists fixed bin(35) ext static;
dcl  mrds_error_$bad_ident fixed bin(35) ext static;
dcl  mrds_error_$inv_attr_name_first_char fixed bin(35) ext static;
dcl  mrds_error_$inv_domain_name_first_char fixed bin(35) ext static;
dcl  my_area area;					/* small area to allocate in */
dcl  myname char (32) int static options (constant) init ("create_attribute");
dcl  nargs fixed bin;
dcl  rmdb_create_attribute entry (ptr, ptr, char (*), fixed bin (35));
dcl  rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100));
dcl  sci_ptr ptr;
dcl  search builtin;
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  substr builtin;
dcl  undo_request char (100);				/* rmdb request that will cause the db to become consistent */
dcl  unused2 char (200);				/* output from mdbm_util_$inconsistent_get_info */
dcl  verify builtin;

     end rmdb_rq_create_attribute;
��



		    rmdb_rq_create_domain.pl1       10/16/86  1534.3rew 10/16/86  1143.7       94158



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

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

/* BEGIN_DESCRIPTION

   This routine parses command arguments for the create_domain rmdb
   request.

   END_DESCRIPTION */

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     written
                                                   END HISTORY COMMENTS */

rmdb_rq_create_domain:
     proc (I_sci_ptr, I_rmdb_ctl_ptr);

	sci_ptr = I_sci_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;

/* Determine the number of arguments. There must be an even number. */

	call ssu_$arg_count (sci_ptr, nargs);
	if (nargs = 0) | (mod (nargs, 2) ^= 0)
	then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args,
		"^/Usage:^/^-^a domain_name data_type {-control_args}", myname);

/* Check to see if we have an open database. */

	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database.");

/* Check to see if the database is consistent. If not, we must make it
consistent before we can create new attributes. Note that if for some reason
the database is not made consistent rmdb_execute_undo will not return. It
will either cause a request line or subsystem abort. */

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, myname, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name,
		undo_request);

/* Create the structure that contains the info about the domain. */

	create_domain_info_count = 1;
	allocate create_domain_info in (my_area) set (create_domain_info_ptr);

/* Fill in our structure. */

	create_domain_info.version = create_domain_info_version_1;
	create_domain_info.domain (1).check_proc_path, create_domain_info.domain (1).decode_proc_path,
	     create_domain_info.domain (1).encode_proc_path = " ";

/* The first arg must be the domain name. */

	call ssu_$arg_ptr (sci_ptr, 1, argp, argl);
	if argl &gt; 32
	then call ssu_$abort_line (sci_ptr, mrds_error_$long_ident, "^a", arg);
	if argl &lt; 1
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The domain name cannot be a null value. ^a", arg);
	if verify (arg, mrds_data_$valid_id_chars) ^= 0
	then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg);
	if search (substr (arg, 1, 1), "-_") ^= 0
	then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg);
	create_domain_info.domain (1).name = arg;

/* The second arg must be the domain type */

	call ssu_$arg_ptr (sci_ptr, 2, argp, argl);
	if argl &lt; 1
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The domain type cannot be a null value. ^a", arg);

/* Establish a cleanup handler. */

	Pseg = null;
	on cleanup call tidy_up;

	call translator_temp_$get_segment ((myname), Pseg, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"Unable to allocate space in the process for a descriptor.");

	the_descriptor = "0"b;
	call rmdb_create_descriptor (arg, Pseg, addr (the_descriptor), code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
		"A valid descriptor could not be produced from the supplied data type declaration. ^a", arg);

	create_domain_info.domain (1).descriptor, create_domain_info.domain (1).decode_declare_data_descriptor =
	     the_descriptor;

/* Initialize for the control argument loop */

	args_used = 2;
	check_proc_exists, decode_dcl_exists, decode_proc_exists, encode_proc_exists = "0"b;

/* Now get the control arguments if there are any. */

	do while (args_used &lt; nargs);

	     call ssu_$arg_ptr (sci_ptr, args_used + 1, argp, argl);
	     if /* case */ index (arg, "-") = 1
	     then if (arg = "-check_procedure") | (arg = "-check_proc")
		then do;
		     call common_to_all_args (check_proc_exists, "check_proc");
		     create_domain_info.domain (1).check_proc_path = pathname_ (I_dirname, I_entryname);
		     end;
		else if (arg = "-encode_procedure") | (arg = "-encode_proc")
		then do;
		     call common_to_all_args (encode_proc_exists, "encode_proc");
		     create_domain_info.domain (1).encode_proc_path = pathname_ (I_dirname, I_entryname);
		     end;
		else if arg = "-decode_procedure" | arg = "-decode_proc"
		then do;
		     call common_to_all_args (decode_proc_exists, "decode_proc");
		     create_domain_info.domain (1).decode_proc_path = pathname_ (I_dirname, I_entryname);
		     end;
		else if (arg = "-decode_dcl") | (arg = "-decode_declare")
		then do;
		     call common_to_all_args (decode_dcl_exists, "decode_dcl");
		     call rmdb_create_descriptor (arg, Pseg, addr (the_descriptor), code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code,
			     "^/A valid descriptor could not be produced from the supplied data type. ^a", arg);

		     create_domain_info.domain (1).decode_declare_data_descriptor = the_descriptor;
		     end;

		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
						/* invalid control arg */

	     else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);
						/* not a control arg */
	     end;					/* args_used = nargs */

/* Now we have all the args, so check for completeness and consistency */

	if (decode_proc_exists &amp; ^decode_dcl_exists)
	then create_domain_info.domain (1).decode_declare_data_descriptor = create_domain_info.domain (1).descriptor;

	if (decode_dcl_exists &amp; ^decode_proc_exists)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^/A -decode_declare type has been specified, but there was no decode_procedure specified.");

	call rmdb_create_domain (rmdb_ctl_ptr, create_domain_info_ptr, error_message, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", error_message);

	call tidy_up;
	return;

%page;
/* * * * * * * * * * * * *  tidy_up * * * * * * * * * * * * * * * * * * * * * */

tidy_up:
     proc;

	if Pseg ^= null
	then call translator_temp_$release_all_segments (Pseg, code);
     end tidy_up;

%page;
/* * * * * * * * * * * * *  common_to_all_args  * * * * * * * * * * * * * * * */

common_to_all_args:
     proc (already_exists, which_arg);

dcl  already_exists bit (1) aligned;
dcl  which_arg char (*) parameter;

	if already_exists
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"^/The ^a control argument was previously specified.", which_arg);

	args_used = args_used + 1;
	if args_used = nargs
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^/A ^a argument is required following the -^a control argument.", which_arg, which_arg);

	call ssu_$arg_ptr (sci_ptr, args_used + 1, argp, argl);
	args_used = args_used + 1;
	if (argl &lt; 1) | (index (arg, "-") = 1)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^/A ^a argument is required following the -^a control argument.", which_arg, which_arg);
	if (arg ^= "-decode_dcl") | (arg ^= "-decode_declare")
	then do;
	     call expand_pathname_ (arg, I_dirname, I_entryname, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a", arg);
	     if (length (rtrim (I_entryname)) &gt; 32) &amp; (index (I_entryname, "$") = 0)
	     then call ssu_$abort_line (sci_ptr, error_table_$entlong, "^a", arg);
	     end;

	already_exists = "1"b;
	return;
     end common_to_all_args;
%page;
%include mrds_rmdb_ctl;
%include rmdb_create_domain_info;
%page;
dcl  addr builtin;
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  args_used fixed bin;
dcl  check_proc_exists bit (1) aligned;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  decode_dcl_exists bit (1) aligned;
dcl  decode_proc_exists bit (1) aligned;
dcl  empty builtin;
dcl  encode_proc_exists bit (1) aligned;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin(35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$entlong fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;
dcl  incon_name char (32);				/* name of the request that caused the db to become inconsistent */
dcl  incon_value bit (1);				/* true ::= the db is inconsistent */
dcl  I_dirname char (168);
dcl  I_entryname char (65);
dcl  I_rmdb_ctl_ptr ptr;
dcl  I_sci_ptr ptr;
dcl  index builtin;
dcl  length builtin;
dcl  mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
dcl  mod builtin;
dcl  mrds_data_$valid_id_chars char (128) varying ext static;
dcl  mrds_error_$bad_ident fixed bin (35) ext static;
dcl  mrds_error_$long_ident fixed bin (35) ext static;
dcl  mrds_error_$inv_domain_name_first_char fixed bin (35) ext static;
dcl  my_area area;
dcl  myname char (32) int static options (constant) init ("create_domain");
dcl  nargs fixed bin;
dcl  null builtin;
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  Pseg ptr;
dcl  rtrim builtin;
dcl  rmdb_create_descriptor entry (char (*), ptr, ptr, fixed bin (35));
dcl  rmdb_create_domain entry (ptr, ptr, char (*), fixed bin (35));
dcl  rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100));
dcl  sci_ptr ptr;
dcl  search builtin;
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  substr builtin;
dcl  the_descriptor bit (36) aligned;
dcl  translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin (35));
dcl  undo_request char (100);				/* rmdb request that will cause the db to become consistent */
dcl  unused2 char (200);				/* output from mdbm_util_$inconsistent_get_info */
dcl  verify builtin;

     end rmdb_rq_create_domain;
��



		    rmdb_rq_create_index.pl1        10/16/86  1551.9r w 10/16/86  1144.2       52443



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
rmdb_rq_create_index: proc (sci_ptr, info_ptr);

/*
   .                       BEGIN_DESCRIPTION
   This  procedure  implements  the  create_index  request  of   the
   restructure_mrds_db  subsystem.  It  verifies  that  the  correct
   number of arguments have been supplied and that a data  base  has
   been  readied  for  restructuring.  It  does  not verify that the
   arguments supplied are actually a relation and attribute  in  the
   database,  that  is left to the rmdb_create_index procedure which
   is called to do the actual index creation.

   It also checks to be sure that the database is consistent. If the
   database  is  marked  as  inconsistent it will query the user for
   execution of the undo request. If the request is ok the  database
   will  be  consistent  so the index creation will be done, else it
   won't be.
   .                       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-03-31 Davids: Written

   82-05-26 Davids: added code to check consistency of db  and  call
   .                rmdb_execute_undo its inconsistent. Also changed
   .                calling sequence of rmdb_create_index to include
   .                the db_model_ptr.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

*/

/* PARAMETERS */

	dcl     sci_ptr		 ptr;		/* (input) pointer to the subsystem control info structure */
						/*         need to be able to pass it to the ssu routines */
	dcl     info_ptr		 ptr;		/* (input) pointer to the rmdb_ctl structure which is */
						/*         read only */

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) external static;
	dcl     error_table_$badcall	 fixed bin (35) external static;

/* ENTRIES */

	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     ssu_$abort_line	 entry options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     rmdb_create_index	 entry (ptr, char (168), ptr, char (*), char (*), char (500), fixed bin (35));
	dcl     rmdb_execute_undo	 entry (ptr, char (32), char (168), ptr, char (32), char (100));

/* INTERNAL AUTOMATIC */

	dcl     attr_name_len	 fixed bin (21);	/* length of the attribute name argument */
	dcl     attr_name_ptr	 ptr;		/* pointer to the attribute name argument */
	dcl     code		 fixed bin (35);	/* standard error code */
	dcl     error_message	 char (500);	/* error message returned from rmdb_create_index */
	dcl     incon_name		 char (32);	/* name of the request that caused
                                                              the database to be inconsistent */
	dcl     incon_value		 bit (1);		/* true ==&gt; the database is inconsistent */
	dcl     nargs		 fixed bin;	/* number of arguments the request was called with */
	dcl     rel_name_len	 fixed bin (21);	/* length of the relation name argument */
	dcl     rel_name_ptr	 ptr;		/* pointer to the relation name argument */
	dcl     undo_request	 char (100);	/* rmdb request that will cause the db to become consistent */
	dcl     unused2		 char (200);	/* output from mdbm_util_$inconsistent_get_info */

/* BASED */

	dcl     attr_name		 char (attr_name_len) based (attr_name_ptr); /* name of attribute to be indexed */
	dcl     rel_name		 char (rel_name_len) based (rel_name_ptr); /* name of relation which
                                                                                      contains the attribute */

/* INCLUDES */
%page;
%include mrds_rmdb_ctl;

/*
   Assign initial values
*/

	rmdb_ctl_ptr = info_ptr;





/*
   Determine the number of arguments that this  request  was  called
   with.  Two  arguments  are  required  the  relation  name and the
   attribute name.

   If two arguments are not supplied issue an error. Note that abort
   line does not return.
*/

	call ssu_$arg_count (sci_ptr, nargs);
	if nargs ^= 2
	then call ssu_$abort_line (sci_ptr, error_table_$badcall,
		"^/Usage:^/^-create_index relation_name attribute_name^/");





/*
   If the absolute_db_path element of the rmdb_ctl structure is null
   it   means   that   no   data   base  is  currently  readied  for
   restructuring. This is an error.
*/

	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database");

/*
   If the database is inconsistent it must be made consistent before
   the index can be created.  Note  that  if  for  some  reason  the
   database is not made consistent rmdb_execute_undo will not return
   it will either cause a request line or subsystem abort.
*/

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, "create_index", rmdb_ctl.absolute_db_path,
		rmdb_ctl.db_model_ptr, incon_name, undo_request);




/*
   Get the relation name and attribute name arguments.
*/

	call ssu_$arg_ptr (sci_ptr, 1, rel_name_ptr, rel_name_len);
	call ssu_$arg_ptr (sci_ptr, 2, attr_name_ptr, attr_name_len);





/*
   Do the actual index creation
*/

	call rmdb_create_index (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rel_name, attr_name,
	     error_message, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, error_message);






	return;


     end rmdb_rq_create_index;
�



		    rmdb_rq_create_relation.pl1     12/09/86  1247.6rew 12/09/86  1237.8      175869



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



/****^  HISTORY COMMENTS:
  1) change(86-06-16,Blair), approve(86-06-16,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Initialize all the attributes we have room for. Previously the extent was
     set to zero and initialization wasn't happening.
  2) change(86-10-28,Blair), approve(86-10-28,PBF7311), audit(86-11-26,Dupuis),
     install(86-12-09,MR12.0-1237):
     Move the initializing of rmdb_create_rel_info.num_attrs out of the
     attr_list_handler so that it doesn't get wiped out if we have any indices
     to create.
                                                   END HISTORY COMMENTS */


rmdb_rq_create_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr);

/* .		    BEGIN_DESCRIPTION

   This procedure is called from the the rmdb ssu routine

   Its purpose is to process the create_relation request arguments

   Syntax for this request is

   .     relation_name { &lt;rel_attr_list&gt; }
   .                   { -index  &lt;index_attr_list&gt; | -ix  &lt;index_attr_list&gt; }
   .                   { -sel_exp  | -se "mrds_temp_rel_type_selection_exp" }

   rel_attr_list ::=  attr_name_1 attr_name_2 .... attr_name_n

   index_attr_list ::=  rmdb_ix_attr_name_m .... rmdb_ix_attr_name_k

   mrds_temp_rel_type_selection_exp ::= temp_rel like selection expression

   The  rel_attr_list  and  -sel_exp  are exclusive arguments.  The
   attributes  that  are  to  make up the relation primary key must
   have   an   astrisk  appended  to  the  attribute  name  in  the
   rel_attr_list.   The -index maybe used with either and specifies
   which  attributes  are  to  be secondary indices.  The attribute
   names  that appear in the index_attr_list must be defined in the
   rel_attr_list or by the selection_expression.

   Currently only attributes that already exist in the data_model can be used
   to define new relations.

   .		         END_DESCRIPTION

%page;
   HISTORY:
   82-03-11 Written by R. Lackey

   82-06-09 R. Harvey: Stripped out code to handle parentheses.

   82-06-28 Roger Lackey : corrected loop control and check for * on end of 
   attribute name.  other minor changes pointer out in team review.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   83-02-07  Mike Kubicar : Changed calling sequence of rmdb_create_relation
   so that it includes a bit which says whether the routine was called from
   request level.  This is necessary since that routine must know whether to
   start transactions and that should only be done from request level.

*/
%page;

/* rmdb_rq_create_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr) */

	dcl     I_rmdb_ctl_ptr	 pointer parameter /* Pointer to restructuring control */;
	dcl     I_sci_ptr		 pointer parameter /* ssu info ptr */;

	sci_ptr = I_sci_ptr;			/* For quicker ref */
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;		/* Pointer to rmdb control structure */

	selection_exp_exists = "0"b;			/* On = -sel_exp was found */
	rel_attr_list_exists = "0"b;			/* On = relation attr list was found */
	index_attr_list_exists = "0"b;		/* On = index attr_list was found */
	rmdb_create_rel_info_ptr = null;		/* Not allocated yet */
	rmdb_ix_attrs_ptr = null;			/* Not allocated yet */
	rmdb_sel_val_info_ptr = null;			/* Not allocated yet */

	if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then
	     call ssu_$abort_line (sci_ptr, error_table_$unimplemented_version, "rmdb_create_rel_info.incl.pl1");

	if rmdb_ctl.absolute_db_path = "" then
	     call error (error_table_$action_not_performed,
		"^/There is no currently readied data base.");

	on cleanup call tidy_up;			/* Establish a cleanup handler for this procedure */

	call ssu_$arg_count (sci_ptr, nargs);		/* Get number of arguments supplied to me */

	if nargs &lt; 2 then /* Must have rel_name and at least one attribute
						   or -selection_expression */
	     call error (error_table_$wrong_no_of_args, USAGE); /* Tell um how to use it */

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, /* See if db is inconsistent */
	     incon_flag, incon_name, unused, undo_request);

	if incon_flag then /* DB is inconsisten */
	     call rmdb_execute_undo (sci_ptr,
		"create_relation", rmdb_ctl.absolute_db_path,
		rmdb_ctl.db_model_ptr, incon_name, undo_request);

	call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); /* First arg must be rel name */

	args_used = 1;

	if arg_len &gt; 30				/* Relation names can only be 30 chars long
						   because the relation model name must have a ".m" suffix */
	then call error (mrds_error_$rel_name_too_long, arg);

	if arg_len &lt; 1 then call error (mrds_error_$no_rel_name, "^/Relation name was expected for first argument.");

	else rel_name = arg;			/* Got a good rel_name */

%page;
	do while (args_used &lt; nargs);			/* Process supplied arguments */

	     call ssu_$arg_ptr (sci_ptr, args_used + 1, arg_ptr, arg_len); /* Get next argument */

	     if substr (arg, 1, 1) = "-" then do;	/* Control arg check */

		     if arg = "-ix" | arg = "-index" then do; /* Index attr list should follow */

			     args_used = args_used + 1; /* Just used -index */

			     if index_attr_list_exists then
				call error (error_table_$inconsistent,
				     "^/The -index argument was previously specified.");
			     if args_used &lt; nargs then do;
				     rmdb_ix_attrs_alloc = mrds_data_$max_attributes;
				     allocate rmdb_ix_attrs in (wa) set (rmdb_ix_attrs_ptr);
				     rmdb_ix_attrs.version = RMDB_IX_ATTRS_VERSION_1;
				     rmdb_ix_attrs.relation_name = rel_name;
				     rmdb_ix_attrs.num_used = 0;

				     call attr_list_handler (args_used, INDEX_ATTR_LIST);
				end;

			     else call error (mrds_error_$no_inds,
				     "^/An index attribute list is required following the -index control argument.");

			     index_attr_list_exists = "1"b;
			end; 	                    /* if arg = "-index" then do */

		     else if arg = "-se" | arg = "-sel_exp" then do; /* Selection expression should follow */

			     args_used = args_used + 1;

			     if selection_exp_exists then
				call error (error_table_$inconsistent,
				     "^/The -sel_exp argument was previously specified.");

			     if rel_attr_list_exists then
				call error (error_table_$inconsistent,
				     "^/A relation attribute list cannot be used with the control argument: " || arg);

			     if args_used &lt; nargs then
				call select_exp_handler (args_used);

			     else do;

				     call error (mrds_error_$no_sel_exp,
					"^/A selection expression is required following the -sel_exp control argument.");
				end;

			end;			/* if arg = "-se" */

		     else call error (error_table_$badopt, arg); /*  Bad control arg */

		end;				/* End control arg check */

	     else do;				/* Not a control arg */

		     if args_used = 1 then do;	/* If first argument following rel_name
						   assume it is the relation attribute list */


/*       Allocate and init rmdb_create_rel_info  structure     */

			     rmdb_create_rel_info_alloc = mrds_data_$max_attributes; /* Set max number of attrs
						   in rmdb_create_rel_info */

			     allocate rmdb_create_rel_info in (wa) /* wa is rmdb_ctl.work_area) */
				set (rmdb_create_rel_info_ptr);

			     rmdb_create_rel_info.version = RMDB_CREATE_REL_INFO_VERSION_1;
			     rmdb_create_rel_info.db_path = rmdb_ctl.absolute_db_path;
			     rmdb_create_rel_info.db_model_ptr = rmdb_ctl.db_model_ptr;
			     rmdb_create_rel_info.temp_directory_path = rmdb_ctl.temp_dir_path;
			     rmdb_create_rel_info.relation_name = rel_name;
			     rmdb_create_rel_info.num_attrs = rmdb_create_rel_info_alloc; /* we'll figure out how many actual in a minute */
			     do z = 1 to rmdb_create_rel_info_alloc;
				rmdb_create_rel_info.attrs (*).primary_key = "0"b; /* Turn off all primary_key flags */
				rmdb_create_rel_info.attrs (*).indexed = "0"b; /* Turn off all indexed flags */
			     end;

			     rmdb_create_rel_info.num_attrs = 0;
			     call attr_list_handler (args_used, REL_ATTR_LIST); /* Process attribute list */

			end;			/* Must be rel_attr_list */

		     else call error (error_table_$bad_subr_arg, arg || USAGE);

		end;

	end /* Get rest of arguments */;

	if ^selection_exp_exists then do;		/* Creation was already done for us */

		if rmdb_create_rel_info_ptr = null then
		     call error (mrds_error_$no_rel_attr, "^/" || rel_name);

		if rmdb_create_rel_info.num_attrs &lt; 1 then
		     call error (mrds_error_$no_rel_attr, rmdb_create_rel_info.relation_name);

		if index_attr_list_exists then call index_attr_mark; /* Mark those attrs that are to be indexed */

		call rmdb_create_relation (rmdb_ctl_ptr, rmdb_create_rel_info_ptr, "1"b /* Called at request level */, err_msg, code);
		if code ^= 0 then call error (code, err_msg);

	     end;

	call tidy_up;				/* Free rmdb_create_rel_info structure */

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

attr_list_handler: proc (ag_used, list_type_indicator);	/* Processor for both rel and index attribute list */

	dcl     ag_used		 fixed bin parameter /* (INPUT/OUTPUT) Number of arguments used so far  */;
	dcl     list_type_indicator	 fixed bin parameter /* (INPUT) 1 = relation attr list
						   2 = index attr list */;

/* This internal procedure processes the input string

   attr_1 attr_2 .. .. .. attr_n

   It isolates each attribute in an attribute list for both relation atr_list
   and index attr_list.
*/

	first = "1"b;
	attrs_done = "0"b;
%page;
	do while (ag_used &lt; nargs &amp; ^attrs_done);

	     call ssu_$arg_ptr (sci_ptr, ag_used + 1, arg_ptr, arg_len); /* Get next argument */

	     if substr (arg, 1, 1) = "-" then /* argument is a control arg */
		attrs_done = "1"b;


	     else do;				/* Not a control argument */

		     ag_used = ag_used + 1;		/* Bump number of arguments used */

		     attr_name = arg;

		     if length (attr_name) &lt; 1 then call error (mrds_error_$bad_attr_name,
			     "^/Null attribute name.");

		     if list_type_indicator = REL_ATTR_LIST then do;

			     call relation_attr_add;

			end;
		     else do;			/* Were working on an inde attr list */

			     if length (attr_name) &gt; 32 then call error (mrds_error_$rst_name_too_long,
				     "^/Attribute name is longer then 32 characters: " || attr_name);
			     rmdb_ix_attrs.num_used = rmdb_ix_attrs.num_used + 1;
			     rmdb_ix_attrs.an (rmdb_ix_attrs.num_used) = attr_name;

			end;

		     first = "0"b;			/* First token already processed */
		end;				/* END not a contol arg */
	end /* END do while (ag_used &lt;= nargs | ^attrs_done) */;

     end attr_list_handler;
%page;
/*  * * * * * * * * * * * *   relation_attr_add   * * * * * * * * * * * * * */


relation_attr_add: proc;


	if rmdb_create_rel_info.num_attrs &gt;= mrds_data_$max_attributes then
	     call error (mrds_error_$max_attributes, "");

	rmdb_create_rel_info.num_attrs = rmdb_create_rel_info.num_attrs + 1; /* Got another one */



	if index (reverse (attr_name), "*") = 1 then do;	/* If last char is * it is a primary attribute */

		j = length (attr_name) - 1;		/* Length attr - * */

		attr_name = substr (attr_name, 1, j);	/* Remove the * from name */

		if j &lt; 1 then call error (mrds_error_$bad_attr_name, "*");

		rmdb_create_rel_info.attrs (rmdb_create_rel_info.num_attrs).primary_key = "1"b;

	     end;

	if length (attr_name) &gt; 32 then call error (mrds_error_$rst_name_too_long,
		"^/Attribute name is longer then 32 characters: " || attr_name);

	rmdb_create_rel_info.attrs (rmdb_create_rel_info.num_attrs).name = attr_name;

	rel_attr_list_exists = "1"b;			/* Remember we had a rel_attr_list */

     end relation_attr_add;
%page;
/*  * * * * * * * * * * * *   index_attr_mark   * * * * * * * * * * * * * * */


index_attr_mark: proc;

	do k = 1 to rmdb_ix_attrs.num_used;		/* All indexed attrs */

	     attr_name = rmdb_ix_attrs.an (k);

	     found = "0"b;

	     do j = 1 to rmdb_create_rel_info.num_attrs while (^found); /* Search for name in list */

		if attr_name = rmdb_create_rel_info.attrs (j).name then do;

			if rmdb_create_rel_info.attrs (j).indexed = "1"b then
			     call error (mrds_error_$previously_defined_index, (attr_name));

			rmdb_create_rel_info.attrs (j).indexed = "1"b; /* Mark as indexed */
			found = "1"b;
		     end;

	     end;

	     if ^found then call error (mrds_error_$undef_attr,
		     "^/" || attr_name);

	end;					/* END All indexed attrs */

     end index_attr_mark;
%page;
/*  * * * * * * * * * * * *   select_exp_handler   * * * * * * * * * * * * * */

select_exp_handler: proc (args_used_count);

	dcl     args_used_count	 fixed bin parameter;

	selection_exp_exists = "1"b;

	call ssu_$arg_ptr (sci_ptr, args_used_count + 1, sel_exp_ptr, sel_exp_len); /* Get selection expression */
	args_used_count = args_used_count + 1;

/* Check any other args for control argument (they are not allowed following the selection exp) */

	do z = args_used_count + 1 to nargs;

	     call ssu_$arg_ptr (sci_ptr, z, arg_ptr, arg_len); /* Get next arg */
	     if substr (arg, 1, 1) = "-" then call
		     error (error_table_$bad_arg, "^/" || arg ||
		     "^/No control arguments are allowed after the select expression.");
	end;
%page;
/* rmdb_sel_val_info is required by rmdb_create_and_pop_rel even if no sel_vals are provided */

	allocate rmdb_sel_val_info in (wa) set (rmdb_sel_val_info_ptr);
	rmdb_sel_val_info.version = RMDB_SEL_VAL_INFO_VERSION_1;
	rmdb_sel_val_info.sv_num = 0;
	rmdb_sel_val_info.data_list_ptr = null;
	rmdb_sel_val_info.desc_list_ptr = null;

	if nargs &gt; args_used_count then do;		/* Must have provided some sel_values */

		call ssu_$arg_list_ptr (sci_ptr, al_ptr); /* Get the argument list */
		rmdb_sel_val_info.data_list_ptr =
		     addr (al_ptr -&gt; arg_list.arg_ptrs (args_used_count + 1)); /* Pointer list of data pointers */
		rmdb_sel_val_info.desc_list_ptr =
		     addr (al_ptr -&gt; arg_list.desc_ptrs (args_used_count + 1)); /* Pointer to list of
						   select_value descriptors */
		rmdb_sel_val_info.sv_num = nargs - args_used_count;
	     end;

	if rmdb_ix_attrs_ptr = null then do;		/*  If no -index was supplied */
		rmdb_ix_attrs_alloc = 0;		/* Got to have this
						   to pass rel_name to rmdb_create_and_pop_rel */
		allocate rmdb_ix_attrs in (wa) set (rmdb_ix_attrs_ptr);
		rmdb_ix_attrs.version = RMDB_IX_ATTRS_VERSION_1;
		rmdb_ix_attrs.relation_name = rel_name;
		rmdb_ix_attrs.num_used = 0;
	     end;

	call rmdb_create_and_pop_rel (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path,
	     rmdb_ctl.temp_dir_path, sel_exp, rmdb_sel_val_info_ptr,
	     rmdb_ix_attrs_ptr, err_msg, code);
	if code ^= 0 then do;

		added_args = "";
		do z = args_used_count + 1 to nargs;

		     call ssu_$arg_ptr (sci_ptr, z, arg_ptr, arg_len); /* Get next arg */
		     added_args = added_args || " " || arg;
		end;

		err_msg = rtrim (err_msg) || added_args;

		call error (code, err_msg);
	     end;					/* END if code ^= 0 */

	args_used_count = nargs;			/* So we won't look for any more arguments */

     end select_exp_handler;
%page;
/*  * * * * * * * * * * * *       error       * * * * * * * * * * * * * */

error: proc (err_code, err_message);			/* Error procedure for rmdb_create_relation.pl1 */

	dcl     err_code		 fixed bin (35) parameter;
	dcl     err_message		 char (*) parameter;
	dcl     ssu_$abort_line	 entry () options (variable);

	call tidy_up;

	call ssu_$abort_line (sci_ptr, err_code, err_message);

     end error;











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

tidy_up: proc;

	if rmdb_create_rel_info_ptr ^= null then
	     free rmdb_create_rel_info;

	if rmdb_ix_attrs_ptr ^= null then free rmdb_ix_attrs;

	if rmdb_sel_val_info_ptr ^= null then free rmdb_sel_val_info;

     end tidy_up;
%page;
	dcl     added_args		 char (100) varying;
	dcl     addr		 builtin;
	dcl     al_ptr		 ptr;
	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     args_used		 fixed bin;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     attrs_done		 bit (1);
	dcl     attr_name		 char (64) varying;
	dcl     cleanup		 condition;
	dcl     code		 fixed bin (35);
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$bad_subr_arg fixed bin (35) ext static;
	dcl     error_table_$inconsistent fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext static;
	dcl     err_msg		 char (256);
	dcl     first		 bit (1);
	dcl     found		 bit (1);
	dcl     incon_flag		 bit (1);
	dcl     incon_name		 char (32);
	dcl     index		 builtin;
	dcl     INDEX_ATTR_LIST	 fixed bin int static options (constant) init (2);
	dcl     index_attr_list_exists bit (1);
	dcl     j			 fixed bin;
	dcl     k			 fixed bin;
	dcl     length		 builtin;
	dcl     mrds_data_$max_attributes fixed bin (35) init (256);
	dcl     mrds_error_$bad_attr_name fixed bin (35) ext static;
	dcl     mrds_error_$max_attributes fixed bin (35) ext static;
	dcl     mrds_error_$no_inds	 fixed bin (35) ext static;
	dcl     mrds_error_$no_rel_attr fixed bin (35) ext static;
	dcl     mrds_error_$no_rel_name fixed bin (35) ext static;
	dcl     mrds_error_$no_sel_exp fixed bin (35) ext static;
	dcl     mrds_error_$previously_defined_index fixed bin (35) ext static;
	dcl     mrds_error_$rel_name_too_long fixed bin (35) ext static;
	dcl     mrds_error_$rst_name_too_long fixed bin (35) ext static;
	dcl     mrds_error_$undef_attr fixed bin (35) ext static;
	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     nargs		 fixed bin;
	dcl     null		 builtin;
	dcl     REL_ATTR_LIST	 fixed bin int static options (constant) init (1);
	dcl     rel_attr_list_exists	 bit (1);
	dcl     rel_name		 char (32) varying;
	dcl     reverse		 builtin;
	dcl     rmdb_create_and_pop_rel entry (ptr, char (*), char (*), char (*), ptr, ptr, char (*), fixed bin (35));
	dcl     rmdb_create_relation	 entry (ptr, ptr, bit (1), char (*), fixed bin (35));
	dcl     rmdb_execute_undo	 entry (ptr, char (32), char (168), ptr, char (32), char (100));
	dcl     rtrim		 builtin;
	dcl     sci_ptr		 ptr;
	dcl     selection_exp_exists	 bit (1);
	dcl     sel_exp		 char (sel_exp_len) based (sel_exp_ptr);
	dcl     sel_exp_len		 fixed bin (21);
	dcl     sel_exp_ptr		 ptr;
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_list_ptr	 entry (ptr, ptr);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     substr		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     undo_request	 char (100);
	dcl     unused		 char (32);
	dcl     USAGE		 char (120) int static options (constant) init ("^/Usage: create_relation  relation_name {attribute_list}^/^7x{-index attribute_list}  {-sel_exp  SEL_EXP}");
	dcl     wa		 area (sys_info$max_seg_size) based (rmdb_ctl.work_area_ptr);
	dcl     z			 fixed bin;

%page;
%include mrds_rmdb_ctl;
%page;
%include rmdb_create_rel_info;
%page;
%include arg_list;

     end rmdb_rq_create_relation;
���



		    rmdb_rq_delete_index.pl1        10/16/86  1551.9r w 10/16/86  1144.3       88623



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
rmdb_rq_delete_index: proc (sci_ptr, info_ptr);

/*
   .                       BEGIN_DESCRIPTION
   This  procedure  implements  the  delete_index  request  of   the
   restructure_mrds_db  subsystem.  It  verifies  that  the  correct
   number of arguments have been supplied and that a data  base  has
   been  readied  for  restructuring.  It  does  not verify that the
   arguments supplied are actually a relation and attribute  in  the
   database,  that  is left to the rmdb_delete_index procedure which
   is called to do the actual index deletion.

   If the database is inconsistent rmdb_execute_undo  is  called  to
   query the user and execute the request.
   .                       END_DESCRIPTION
   
   .                       BEGIN_INFO
   .05/20/82  delete_index, dli
   .
   .Syntax:  dli relation_name  attribute_name {-control_args}
   .
   .
   .Function:  Removes  the  secondary  index  for  the  attribute  in  the
   .              relation.
   .
   .
   .Arguments:
   .
   .relation_name
   .   Name of the relation to be restructured.
   .
   .attribute_name
   .   Name of the attribute whose secondary  index  is  to  be  deleted.
   .
   .
   .Control Arguments:
   .
   .brief, fc
   .   Will suppress error reporting if the  attribute  is  not  already  a
   .   secondary index.
   .
   .long, lg
   .   Will report an error if the attribute is  not  already  a  secondary
   .   index
   .
   .
   .Notes:
   .
   .   This request may be run only against a consistent database.  If  the
   .   database  is  inconsistent  the  user  will  be queried to see if he
   .   wishes to execute the "undo request", this  request  will  make  the
   .   database  consistent.  After  the undo request has been executed the
   .   requested index will be deleted. If the undo request fails the  user
   .   will  be  returned  to  rmdb  request  level - the index will not be
   .   deleted, in addition the database will be freed.
   .                       END_INFO
   
   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-05-17 Davids: Written

   82-05-26 Davids: Added call to rmdb_execute_undo for inconsistent
   .                database and added rmdb_ctl.db_model.ptr to  the
   .                calling sequence of rmdb_delete_index.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.
*/

/* PARAMETERS */

	dcl     sci_ptr		 ptr;		/* (input) pointer to the subsystem control info structure */
						/*         need to be able to pass it to the ssu routines */
	dcl     info_ptr		 ptr;		/* (input) pointer to the rmdb_ctl structure which is */
						/*         read only */

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) external static;
	dcl     error_table_$badcall	 fixed bin (35) external static;

/* ENTRIES */

	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     mdbm_util_$inconsistent_reset entry (ptr);
	dcl     ssu_$abort_line	 entry options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$print_message	 entry () options (variable);
	dcl     rmdb_delete_index	 entry (ptr, char (168), ptr, char (*), char (*), bit (1), char (500), fixed bin (35));
	dcl     rmdb_execute_undo	 entry (ptr, char (32), char (168), ptr, char (32), char (100));

/* INTERNAL AUTOMATIC */

	dcl     attr_name_len	 fixed bin (21);	/* length of the attribute name argument */
	dcl     attr_name_ptr	 ptr;		/* pointer to the attribute name argument */

	dcl     code		 fixed bin (35);	/* standard error code */

	dcl     ctl_arg_error	 bit (1);		/* true ==&gt; at least one of the control arguments was in error */
	dcl     ctl_arg_len		 fixed bin (21);	/* length of a control argument */
	dcl     ctl_arg_ptr		 ptr;		/* pointer to a control argument */

	dcl     error_message	 char (500);	/* error message returned from rmdb_delete_index */

	dcl     brief_flag		 bit (1);		/* true ==&gt; last control arg had value of -fc or -brief */

	dcl     i			 fixed bin;	/* loop counter for control argument processing */

	dcl     incon_value		 bit (1);		/* true ==&gt; database is inconsistent */
	dcl     incon_name		 char (32);	/* name of request that caused the db to become inconsistent */

	dcl     nargs		 fixed bin;	/* number of arguments the request was called with */

	dcl     rel_name_len	 fixed bin (21);	/* length of the relation name argument */
	dcl     rel_name_ptr	 ptr;		/* pointer to the relation name argument */

	dcl     rest_of_undo_request	 char (100);	/* copy of undo request with request, rel, attr names removed */

	dcl     this_is_the_undo_request bit (1);	/* true ==&gt; the user typed in the undo request */

	dcl     undo_attr_name	 char (32) varying; /* name of the attribute in the undo request */
	dcl     undo_rel_name	 char (32) varying; /* name of the relation in the undo request */
	dcl     undo_request	 char (100);	/* rmdb request that will make the db consistent again */
	dcl     undo_request_name	 char (32) varying; /* name of the undo request */

	dcl     unused1		 char (200);	/* unused output parameter from mdbm_util_$inconsistent_get_info */

/* BASED */

	dcl     attr_name		 char (attr_name_len) based (attr_name_ptr); /* name of attribute to be indexed */
	dcl     ctl_arg		 char (ctl_arg_len) based (ctl_arg_ptr); /* control argument */
	dcl     rel_name		 char (rel_name_len) based (rel_name_ptr); /* name of relation which contains the attribute */

/* BUILTINS */

	dcl     after		 builtin;
	dcl     before		 builtin;

/* INCLUDES */
%page;
%include mrds_rmdb_ctl;

/*
   Assign initial values
*/

	rmdb_ctl_ptr = info_ptr;
	brief_flag = "0"b;
	ctl_arg_error = "0"b;
	this_is_the_undo_request = "0"b;




/*
   Determine the number of arguments that this  request  was  called
   with.  At least two  arguments  are  required,  the  relation  name and the
   attribute name there may also be any number of control arguments
   which may be either brief or long.

   If at least two arguments are not supplied issue an  error.  Note
   that abort line does not return.
*/

	call ssu_$arg_count (sci_ptr, nargs);
	if nargs &lt; 2
	then call ssu_$abort_line (sci_ptr, error_table_$badcall,
		"^/Usage:^/^-delete_index relation_name attribute_name {-brief | -long}^/");





/*
   If the absolute_db_path element of the rmdb_ctl structure is null
   it   means   that   no   data   base  is  currently  readied  for
   restructuring. This is an error.
*/

	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database");

/*
   Get the relation and attribute name  arguments  and  the  control
   arguments.  All control arguments will be looked at, any that are
   in error will be reported. If an incorrect control arg  is  found
   then  the  request will be aborted (along with any other requests
   on the command line) after all the control  arguments  have  been
   looked at.
*/

	call ssu_$arg_ptr (sci_ptr, 1, rel_name_ptr, rel_name_len);
	call ssu_$arg_ptr (sci_ptr, 2, attr_name_ptr, attr_name_len);

	do i = 3 to nargs;
	     call ssu_$arg_ptr (sci_ptr, i, ctl_arg_ptr, ctl_arg_len);
	     if ctl_arg = "-brief" | ctl_arg = "-bf"
	     then brief_flag = "1"b;
	     else
		if ctl_arg = "-long" | ctl_arg = "-lg"
	     then brief_flag = "0"b;
	     else do;
		     ctl_arg_error = "1"b;
		     call ssu_$print_message (sci_ptr, error_table_$badcall,
			"^/Argument ^i (^a) is not a legal control argument^/",
			i, ctl_arg);
		end;
	end;

	if ctl_arg_error
	then call ssu_$abort_line (sci_ptr, 0);

/*
   If the database is inconsistent then only the undo request may be
   executed. Since it is possible that the user typed  in  the  undo
   request himself it must be parsed and compared with what the user
   typed in. If the two are different rmdb_execute_undo is called to
   query the user and execute the request. If the user typed in  the
   request himself it will be executed and then the database will be
   marked as consistent. Note that if rmdb_execute_undo returns then
   the database is consistent and the index deletion can take place.
*/

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused1, undo_request);
	if incon_value
	then do;
		undo_request_name = before (undo_request, " ");
		rest_of_undo_request = after (undo_request, " ");
		undo_rel_name = before (rest_of_undo_request, " ");
		rest_of_undo_request = after (rest_of_undo_request, " ");
		undo_attr_name = before (rest_of_undo_request, " ");
		if undo_request_name = "delete_index" &amp;
		     undo_rel_name = rel_name &amp;
		     undo_attr_name = attr_name
		then this_is_the_undo_request = "1"b;
		else call rmdb_execute_undo (sci_ptr, "delete_index", rmdb_ctl.absolute_db_path,
			rmdb_ctl.db_model_ptr, incon_name, undo_request);
	     end;





/*
   Do the actual index creation
*/

	call rmdb_delete_index (rmdb_ctl_ptr, rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rel_name, attr_name, brief_flag,
	     error_message, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, error_message);









/*
   If we are executing the undo request directly the  database  must
   now be marked as consistent.
*/

	if this_is_the_undo_request
	then call mdbm_util_$inconsistent_reset (rmdb_ctl.db_model_ptr);






	return;


     end rmdb_rq_delete_index;
�



		    rmdb_rq_delete_object.pl1       12/07/87  1328.9rew 12/07/87  1321.0       83106



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

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

/*DESCRIPTION
  This routine is the argument processor for the rmdb delete_attribute and
  delete_domain requests. After processing the arguments and building the delete
  structure, it calls rmdb_delete_(domain attribute) to actually do all the work.
*/

/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written
  2) change(87-09-30,Blair), approve(87-11-03,MCR7792), audit(87-11-30,Dupuis),
     install(87-12-07,MR12.2-1008):
     Correct the request name placed in the inconsistent_message structure so
     it will accurately reflect the request being made consistent.
                                                   END HISTORY COMMENTS */

rmdb_rq_delete_object:
     proc;

	return;					/* not an entry point */

rmdb_rq_delete_object$domain:
	entry (Isci_ptr, Iinfo_ptr);

	domain_entry = "1"b;
	goto COMMON;

rmdb_rq_delete_object$attribute:
	entry (Isci_ptr, Iinfo_ptr);

	domain_entry = "0"b;
	goto COMMON;

COMMON:
	sci_ptr = Isci_ptr;
	rmdb_ctl_ptr = Iinfo_ptr;

/* Determine if we have an open database. */
	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database.");

	call ssu_$arg_count (sci_ptr, nargs);

/* Count all the non-control arguments (this is the list of names) */
	begin;

dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  arglengths (nargs) fixed bin (21);
dcl  argp ptr;
dcl  argptrs (nargs) ptr;

	     delete_object_info_count = 0;
	     do loop = 1 to nargs;
		call ssu_$arg_ptr (sci_ptr, loop, argp, argl);
		if index (arg, "-") ^= 1
		then delete_object_info_count = delete_object_info_count + 1;
		argptrs (loop) = argp;
		arglengths (loop) = argl;
		end;				/* do loop */

	     allocate delete_object_info in (my_area) set (delete_object_info_ptr);
	     unspec (delete_object_info) = "0"b;
	     delete_object_info.version = delete_object_info_version_1;

	     delete_object_info.count = 0;
	     do loop = 1 to nargs;
		argp = argptrs (loop);
		argl = arglengths (loop);
		if /* case */ index (arg, "-") = 1
		then if /* case */ arg = "-a" | arg = "-all"
		     then delete_object_info.all = TRUE;
		     else if arg = "-bf" | arg = "-brief"
		     then delete_object_info.long = SHORT;
		     else if arg = "-ck" | arg = "-check"
		     then delete_object_info.check = TRUE;
		     else if arg = "-fc" | arg = "-force"
		     then delete_object_info.force = TRUE;
		     else if arg = "-ihe" | arg = "-inhibit_error"
		     then delete_object_info.inhibit_errors = TRUE;
		     else if arg = "-lg" | arg = "-long"
		     then delete_object_info.long = LONG;
		     else if arg = "-nfc" | arg = "-no_force"
		     then delete_object_info.force = FALSE;
		     else if arg = "-nihe" | arg = "-no_inhibit_error"
		     then delete_object_info.inhibit_errors = FALSE;
		     else if arg = "-unref" | arg = "-unreferenced"
		     then delete_object_info.unreferenced = TRUE;
		     else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);
		else do;
		     if argl &gt; length (delete_object_info.name (1))
		     then call ssu_$abort_line (sci_ptr, mrds_error_$rst_name_too_long, "^a", arg);

		     if argl &lt; 1
		     then call ssu_$abort_line (sci_ptr, 0, "The ^[domain^;attribute^] name cannot be the null string.");
		     if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0
		     then call ssu_$abort_line (sci_ptr, mrds_error_$bad_ident, "^a", arg);
		     if domain_entry
		     then if search (substr (arg, 1, 1), "_-") ^= 0
			then call ssu_$abort_line (sci_ptr, mrds_error_$inv_domain_name_first_char, "^a", arg);
			else ;
		     else if search (substr (arg, 1, 1), "_-0123456789") ^= 0
			then call ssu_$abort_line (sci_ptr, mrds_error_$inv_attr_name_first_char, "^a", arg);

		     delete_object_info.count = delete_object_info.count + 1;
		     delete_object_info.name (delete_object_info.count) = arg;
		     end;
		end;				/* do loop */

	end;					/* begin */

	if (delete_object_info.all | delete_object_info.unreferenced) &amp; delete_object_info.count ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all or -unref and a list of ^[domains^;attributes^].", domain_entry);

	if delete_object_info.check &amp; delete_object_info.all
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all and -check");

	if (delete_object_info.long = LONG) &amp; delete_object_info.all
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all and -long");

	if (delete_object_info.long = LONG) &amp; delete_object_info.unreferenced
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-unref and -long");

	if delete_object_info.check &amp; delete_object_info.unreferenced
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-unreferenced and -check");

	if (delete_object_info.check &amp; (delete_object_info.long ^= UNSPEC))
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-check and -brief or -long");

	if delete_object_info.long = SHORT
          then delete_object_info.check = FALSE;

	if delete_object_info.long = LONG
	then delete_object_info.check = TRUE;

	if ^delete_object_info.all &amp; ^delete_object_info.unreferenced &amp; delete_object_info.count = 0
	then call ssu_$abort_line (sci_ptr, 0, "No deletion arguments found.^/A list of ^[domain^;attribute^] names, -unreferenced or -all must be given.",
	     domain_entry);

/* Make sure that we don't need to cleanup from a previous operation. */
	if domain_entry
	then delete_object_info.request_name = "rmdb (delete_domain)";
	else delete_object_info.request_name = "rmdb (delete_attribute)";

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, rtrim (delete_object_info.request_name), rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr,
		incon_name, undo_request);


	delete_object_info.check_iocb_ptr = iox_$user_output;
	delete_object_info.query_iocb_ptr = iox_$user_input;

	if domain_entry
	then call rmdb_delete_domain (rmdb_ctl_ptr, delete_object_info_ptr, error_message, code);
	else call rmdb_delete_attribute (rmdb_ctl_ptr, delete_object_info_ptr, error_message, code);
	if code ^= 0 &amp; ^delete_object_info.inhibit_errors
	then call ssu_$abort_line (sci_ptr, code, "^a", error_message);

	return;
%page;
%include mrds_rmdb_ctl;
%include rmdb_delete_object_info;
%page;
dcl  code fixed bin (35);
dcl  domain_entry bit (1) aligned;
dcl  empty builtin;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin(35) ext static;
dcl  FALSE bit (1) aligned int static options (constant) init ("0"b);
dcl  Iinfo_ptr ptr parameter;
dcl  incon_name  char (32);				/* name of the request that caused the db to become inconsistent */
dcl  incon_value bit (1);				/* true ::= the db is inconsistent */
dcl  index builtin;
dcl  iox_$user_input ptr ext static;
dcl  iox_$user_output ptr ext static;
dcl  Isci_ptr ptr parameter;
dcl  length builtin;
dcl  LONG bit (2) aligned int static options (constant) init ("10"b);
dcl  loop fixed bin;
dcl  mdbm_util_$inconsistent_get_info entry options(variable);
dcl  mrds_data_$valid_rel_and_attr_name_chars char (128) ext static;
dcl  mrds_error_$bad_ident fixed bin(35) ext static;
dcl  mrds_error_$inv_attr_name_first_char fixed bin(35) ext static;
dcl  mrds_error_$inv_domain_name_first_char fixed bin(35) ext static;
dcl  mrds_error_$rst_name_too_long fixed bin (35) ext static;
dcl  my_area area;
dcl  nargs fixed bin;
dcl  rmdb_delete_attribute entry (ptr, ptr, char (*), fixed bin (35));
dcl  rmdb_delete_domain entry (ptr, ptr, char(*), fixed bin(35));
dcl  rmdb_execute_undo entry (ptr, char(32), char(168), ptr, char(32), char(100));
dcl  rtrim builtin;
dcl  sci_ptr ptr;
dcl  search builtin;
dcl  SHORT bit (2) aligned int static options (constant) init ("01"b);
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  substr builtin;
dcl  TRUE bit (1) aligned int static options (constant) init ("1"b);
dcl  UNSPEC bit (2) aligned int static options (constant) init ("00"b);
dcl  undo_request  char (100);				/* rmdb request that will cause the db to become consistent */
dcl  unused2 char (200);				/* output from mdbm_util_$inconsistent_get_info */
dcl  unspec builtin;
dcl  verify builtin;

     end rmdb_rq_delete_object;
��



		    rmdb_rq_delete_relation.pl1     10/16/86  1551.9rew 10/16/86  1143.3       66069



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




/****^  HISTORY COMMENTS:
  1) change(86-07-24,Blair), approve(86-07-24,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Allow a null undo_request as an argument for rmdb_execute_undo.
                                                   END HISTORY COMMENTS */


rmdb_rq_delete_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr);

/* .                    BEGIN_DESCRIPTION

   This procedure is called from the rmdb ssu_ routine

   Its purpose is to process the delete_relation rmdb request arguments

   Syntax for this request is :
   .     delete_relation rel_name {-brief}  {-long}

   .		     END_DESCRIPTION
*/
/* HISTORY
   82-04-30 Written by Roger Lackey

   82-06-25 Roger Lackey : changed force to brief and remove -no_force

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.
*/

%page;
/* rmdb_rq_delete_relation: proc (I_sci_ptr, I_rmdb_ctl_ptr); */

/*        Parameters      */

	dcl     I_sci_ptr		 ptr parameter;	/*  Pointer to ssu info */
	dcl     I_rmdb_ctl_ptr	 ptr parameter;	/* Pointer to restructuring control */

	sci_ptr = I_sci_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;
	rmdb_delete_rel_info_ptr = null;

	if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then
	     call error (error_table_$unimplemented_version, "rmdb_create_rel_info.incl.pl1");

	on cleanup call tidy_up;			/* Establish a cleanup handler for this procedure */

	if rmdb_ctl.absolute_db_path = " " then
	     call error (error_table_$action_not_performed,
		"^/There is no currently readied data base.");

	call ssu_$arg_count (sci_ptr, nargs);		/* Get number of arguments supplied to me */

	if nargs &lt; 1 then call error (error_table_$wrong_no_of_args,
		"^/Usage: delete_relation rel_name  {-brief}  {-long}");

	call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); /* First arg must be rel_name */

	if arg_len &gt; 30				/* Relation names can only be 30 chars long
						   because the relation model name must have a ".m" suffix */
	then call error (mrds_error_$rel_name_too_long, arg);
	if arg_len &lt; 1 then call error (mrds_error_$no_rel_name, "^/Relation name was expected for first argument.");

	n = verify (arg, mrds_data_$valid_rel_and_attr_name_chars);
	if n ^= 0 then call error (mrds_error_$bad_rel_name, arg ||
		"^/First bad character is: " || substr (arg, n, 1));


	if substr (arg, 1, 1) = "_" then
	     call error (mrds_error_$bad_rel_name, arg ||
		"^/Relation names cannot begin with an underscore.");

	allocate rmdb_delete_rel_info in (wa) set (rmdb_delete_rel_info_ptr);

	rmdb_delete_rel_info.version = RMDB_DELETE_REL_INFO_VERSION_1;
	rmdb_delete_rel_info.absolute_db_path = rmdb_ctl.absolute_db_path;
	rmdb_delete_rel_info.db_model_ptr = rmdb_ctl.db_model_ptr;
	rmdb_delete_rel_info.relation_name = arg;
	rmdb_delete_rel_info.brief = "0"b;
%page;
/* Process rest of arguments */

	do i = 2 to nargs;

	     call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len); /* Get next arg */

	     if substr (arg, 1, 1) = "-" then do;	/* Look for control args */

		     if arg = "-brief" | arg = "-bf" | arg = "-brief." then
			rmdb_delete_rel_info.brief = "1"b;

		     else if arg = "-lg" | arg = "-long" then
			rmdb_delete_rel_info.brief = "0"b;

		     else call error (error_table_$badopt, arg); /*  Bad control arg */
		end;

	     else call error (error_table_$bad_arg, arg);

	end;					/* END nargs &gt; 1 */

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, /* See if db is inconsistent */
	     incon_flag, incon_name, unused, undo_request);

	if incon_flag then do;			/* DB is inconsisten */
	     if undo_request = ""
	     then call rmdb_execute_undo (sci_ptr, "delete_relation",
		rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name, undo_request);
	     else do;
		undo_rq_name = before (undo_request, BLANK);
		rest = after (undo_request, undo_rq_name);
		i = verify (rest, BLANK);
		rest = substr (rest, i);		/* Remove leading blanks */
		undo_rel_name = before (rest, BLANK);

		if ^(undo_rq_name = "delete_relation" &amp; /* If not delete_rel with same relation name then */
		     undo_rel_name = rmdb_delete_rel_info.relation_name) then
		     call rmdb_execute_undo (sci_ptr,
			"delete_relation", rmdb_ctl.absolute_db_path,
			rmdb_ctl.db_model_ptr, incon_name, undo_request);
		end;
	     end;


	call rmdb_delete_relation (rmdb_ctl_ptr, rmdb_delete_rel_info_ptr, err_msg, code);
	if code ^= 0 then call error (code, err_msg);

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

error: proc (err_code, err_message);			/* Error procedure for rmdb_create_relation.pl1 */

	dcl     err_code		 fixed bin (35);
	dcl     err_message		 char (*);
	dcl     ssu_$abort_line	 entry () options (variable);

	call tidy_up;

	call ssu_$abort_line (sci_ptr, err_code, err_message);

     end error;











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

tidy_up: proc;

	if rmdb_delete_rel_info_ptr ^= null
	then free rmdb_delete_rel_info;

     end tidy_up;
%page;
	dcl     after		 builtin;
	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     before		 builtin;
	dcl     BLANK		 char (1) int static options (constant) init (" ");
	dcl     cleanup		 condition;
	dcl     code		 fixed bin (35);
	dcl     error_table_$action_not_performed fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext static;
	dcl     err_msg		 char (256);
	dcl     i			 fixed bin;
	dcl     incon_flag		 bit (1);
	dcl     incon_name		 char (32);
	dcl     mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext;
	dcl     mrds_error_$bad_rel_name fixed bin (35) ext static;
	dcl     mrds_error_$no_rel_name fixed bin (35) ext static;
	dcl     mrds_error_$rel_name_too_long fixed bin (35) ext static;
	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     n			 fixed bin;
	dcl     nargs		 fixed bin;
	dcl     null		 builtin;
	dcl     rest		 char (100) varying;
	dcl     rmdb_delete_relation	 entry (ptr, ptr, char (*), fixed bin (35));
	dcl     rmdb_execute_undo	 entry (ptr, char (32), char (168), ptr, char (32), char (100));
	dcl     sci_ptr		 ptr;
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     substr		 builtin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     undo_rel_name	 char (32);
	dcl     undo_request	 char (100);
	dcl     undo_rq_name	 char (32) varying;
	dcl     unused		 char (32);
	dcl     verify		 builtin;
	dcl     wa		 area (sys_info$max_seg_size) based (rmdb_ctl.work_area_ptr);

%page;
%include mrds_rmdb_ctl;
%page;
%include rmdb_delete_rel_info;

     end rmdb_rq_delete_relation;
���



		    rmdb_rq_dot.pl1                 10/16/86  1551.9r w 10/16/86  1144.3       15435



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
rmdb_rq_dot: proc (sci_ptr, info_ptr);

/*
   .		       BEGIN_DESCRIPTION
   This   routine   displays   the   current    version    of    the
   restructure_mrds_db subsystem and the data base currently readied
   for restructuring in response to the "." request.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-03-29 Davids: Written

   82-04-08 Davids: changed the name of  the  subsystem  that  is
   .                printed  from  restructure_mrds_db to rmdb to
   .                a name change that was made a while back.

   82-06-22 Davids: removed call to get_shortest_path_

   83-05-25 Davids: Added dcl for rtrim
*/

/* PARAMETERS */

	dcl     sci_ptr		 ptr;		/* (input) pointer to the subsystem control info structure */
						/* need to be able to pass it to the ssu entries */
	dcl     info_ptr		 ptr;		/* (input) pointer to the rmdb_ctl structure which is both */
						/* read and written */

/* BUILTINS */

	dcl     rtrim		 builtin;

/* ENTRIES */

	dcl     ioa_		 entry options (variable);

/* INCLUDES */
%page;
%include mrds_rmdb_ctl;

	rmdb_ctl_ptr = info_ptr;


	if rmdb_ctl.absolute_db_path = ""
	then call ioa_ ("rmdb: ^a^-No database is currently readied.", rmdb_ctl.rmdb_version);
	else call ioa_ ("rmdb: ^a^-^a", rmdb_ctl.rmdb_version, rtrim (rmdb_ctl.absolute_db_path));

	return;

     end rmdb_rq_dot;
�



		    rmdb_rq_free_db.pl1             10/16/86  1551.9rew 10/16/86  1143.3       37359



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

rmdb_rq_free_db: proc (sci_ptr, info_ptr);


/****^  HISTORY COMMENTS:
  1) change(85-12-04,Spitzer), approve(85-12-04,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     If we have a xreference file, destroy it. Terminate the model properly.
                                                   END HISTORY COMMENTS */


/*
   .		       BEGIN_DESCRIPTION
   This  routine  implements  the  relesae_db  request  within   the
   restructure_mrds_db  subsystem.  It  checks  to  be sure that the
   request has been called with 0 arguments and that a database  has
   already been readied so that it makes sense to try to release it.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:






   .                       HISTORY
   82-03-29 Davids: Written

   82-05-25 Davids: modified to set rmdb_ctl.db_model_ptr to null at
   .                the same time that the absolute_db_path  is  set
   .                to "".

   83-05-24 Davids: Changed the argument list to rmdb_free_db to include
   a pointer to the saved_res_version.
*/

   /* PARAMETERS */
	dcl     sci_ptr		 ptr;		/* (input) pointer to the subsystem control info structure */
						/*         need to be able to pass it to the ssu routines */
	dcl     info_ptr		 ptr;		/* (input) pointer to the rmdb_ctl structure which is both */
						/*         read and written. */

/* EXTERNAL STATIC */

	dcl     error_table_$action_not_performed fixed bin (35) external static;
	dcl     error_table_$badcall	 fixed bin (35) external static;

/* ENTRIES */

	dcl     mdbm_util_$xref_destroy entry (ptr, char(*), char(*), char(*), fixed bin(35));
	dcl     rmdb_free_db	 entry (char (168), ptr, char (500), fixed bin (35));
	dcl     ssu_$abort_line	 entry options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));

/* INTERNAL AUTOMATIC */

	dcl     code		 fixed bin (35);	/* standard error code */
	dcl     error_message	 char (500);	/* error message returned from rmdb_free_db */
	dcl     nargs		 fixed bin;	/* number of arguments the request was called with */

/* BUILTINS */

	dcl     null		 builtin;

/* INCLUDES */
%page;
%include mrds_rmdb_ctl;
%include terminate_file;
%page;
/*
   Init the value of the rmdb_ctl pointer
*/

	rmdb_ctl_ptr = info_ptr;





/*
   Get the number of arguments that the request was called with - if
   its not 0 its an error.

   Note that ssu_$abort_line does not return.
*/

	call ssu_$arg_count (sci_ptr, nargs);
	if nargs ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$badcall,
		"^/The free_db (fdb) request is called without any arguments");





/*
   If the absolute_db_path element of the rmdb_ctl structure is null
   it  means  that  no  database  is  currently readied - this is an
   error.
*/

	if rmdb_ctl.absolute_db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$action_not_performed,
		"^/There is no currently readied database to be freed");

/*
   the only errors that are now possible will occur within the  call
   to rmdb_free_db.
*/

	call rmdb_free_db (rmdb_ctl.absolute_db_path, rmdb_ctl.saved_res_version_ptr, error_message, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, error_message);


/*
   Get rid of the xreference file.
*/

	if rmdb_ctl.crossref_file_info.iocb_ptr ^= null
	then call mdbm_util_$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr, rmdb_ctl.temp_dir_path,
	     rmdb_ctl.crossref_file_info.name, (""), (0));


/*
   By changing rmdb_ctl.absolute_db_path  to  ""  we  indicate  that
   there is no currently readied db.
*/

	rmdb_ctl.absolute_db_path = "";

	if rmdb_ctl.db_model_ptr ^= null
	then call terminate_file_ (rmdb_ctl.db_model_ptr, 0, TERM_FILE_TERM, (0));

	return;

     end rmdb_rq_free_db;
�



		    rmdb_rq_ready_db.pl1            09/26/88  1255.5rew 09/26/88  1248.2      131310



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

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

rmdb_rq_ready_db:
     proc (sci_ptr, info_ptr);


/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     added the database creation code.
  2) change(88-01-11,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Re_arrange some code so that the pathname of the database isn't expanded
     until after we try to fill in the mrds_pathname_info structure so that we
     can use search paths to locate the database.  Only if the database doesn't
     exist do we try to create one in the working_dir.
  3) change(88-09-20,Dupuis), approve(88-09-20,MCR7995), audit(88-09-20,Blair),
     install(88-09-26,MR12.2-1119):
     Changed error_table_bad_arg to error_table_$badopt (phx20666).
                                                   END HISTORY COMMENTS */


/*
   .		       BEGIN_DESCRIPTION
   This  routines  implements  that  ready_db  request  within   the
   restructure_mrds_db  subsystem.  It  processes  and  checks  that
   arguments  associated  with  the  request  and  then  calls   the
   rmdb_ready_db  routine  which actually does the work or ready-ing
   the db for restructuring.

   If the database does not exist, the user will be queried to create
   it. If the answer is yes, the database is created with no existing
   domains, attribute, or domains, and the database is quiesced.

   In the event that the readied database is marked inconsistent  it
   will  query  the  user  for execution of the undo request.
   .		       END_DESCRIPTION

   Known Bugs:

   Other Problems:

   .                       HISTORY
   82-03-29 Davids: Written

   82-04-08 Davids: Changed the error messages for "a database is
   .                alreadied readied" and "could not  ready  the
   .                database" so that they are formated better.

   82-04-30 Davids: Added code to check the  consistency  of  the
   .                database and to execute the undo request.

   82-05-25 Davids: changed to have rmdb_ctl.db_model_ptr in calling
   .                sequence to rmdb_ready_db.

   82-05-26 Davids: changed to call rmdb_execute_undo if the database
   .                is inconsistent.

   82-06-07 Davids: changed to check size condition if user inputs a
   .                quiesce_wait_time  that  is  to  large.  Also to
   .                recognize a negative wait  time  so  as  not  to
   .                treat  it  like  a control argument. And changed
   .                changed   the   default   wait   time   to   use
   .                mrds_data_$quiesce_wait  (= 0)  instead  of  the
   .                constant 10.

   82-06-25 Davids: removed    call    to   get_shortest_path_   and
   .                reformated some lines to prevent wrap-around

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   .                        mdbm_util_$inconsistent_* for binding.

   82-08-20 Davids: modified the call to rmdb_ready_db to include
   .                addr (rmdb_ctl.relmgr_entries).

   83-05-24 Davids: Modified the parameter list of rmdb_ready_db to include the
   saved_res_version_ptr argument.

   84-10-23 Benjamin: When returning from rmdb_ready_db, if code is 
   mrds_error_$my_quiesced_db, will not abort, but rather set a flag that says
   that rmdb did not quiesce the database.
*/

/* PARAMETERS */

dcl  sci_ptr ptr;					/* (input) pointer to the subsystem control infor structure */
						/*         need to be able to pass it to the ssu entries */
dcl  info_ptr ptr;					/* (input) pointer the rmdb_ctl structure which is both */
						/*         read and written */

/* EXTERNAL STATIC */

dcl  error_table_$badopt fixed bin (35) external static;
dcl  error_table_$bad_conversion fixed bin (35) external static;
dcl  error_table_$noarg fixed bin (35) external static;
dcl  mrds_data_$quiesce_wait fixed bin (35) external static;
dcl  mrds_error_$my_quiesced_db fixed bin (35) ext static;
dcl  mrds_error_$no_database fixed bin (35) ext static;

/* ENTRIES */

dcl  command_query_$yes_no entry () options (variable);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  rmdb_create_db entry (char (*), char (*), char (*), char (*), ptr, char (*), fixed bin (35));
dcl  rmdb_execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100));
dcl  rmdb_ready_db entry (char (168), fixed bin, ptr, char (168), ptr, ptr, char (500), fixed bin (35));
dcl  ssu_$abort_line entry options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));

/* INTERNAL AUTOMATIC */

dcl  arg_len fixed bin (21);				/* length of an argument */
dcl  arg_ptr ptr;					/* pointer to an argument */
dcl  code fixed bin (35);				/* standard error code */
dcl  db_dir char (168);				/* expanded directory of db */
dcl  db_name char (32);				/* db name + suffix */
dcl  db_path char (168);				/* database path supplied as an argument */
dcl  error_message char (500);			/* error message returned from rmdb_ready_db */
dcl  force_sw bit (1);				/* true if -force was specified */
dcl  i fixed bin;					/* loop index */
dcl  incon_name char (32);				/* name of module that marked db as inconsistent */
dcl  incon_value bit (1);				/* true ==&gt; db is inconsistent */
dcl  nargs fixed bin;				/* number of arguments the request was called with */
dcl  quiesce_wait_time fixed bin;			/* how many seconds the caller is willing to wait to
						   try to quiesce the database */
dcl  quiesce_wait_time_supplied bit (1);		/* true if a wait time has been supllied as an argument */
dcl  relation_type char (32);				/* file type command line argument */
dcl  relation_modes char (256);			/* mode command line argument */
dcl  undo_request char (100);				/* rmdb request that will make the db consistent again */
dcl  unused1 char (200);				/* unused output parameter from mdbm_util_$inconsistent_get_info */

/* BUILTINS */

dcl  addr builtin;
dcl  index builtin;
dcl  verify builtin;

/* BASED */

dcl  arg char (arg_len) based (arg_ptr);		/* an argument */

/* CONDITIONS */

dcl  size condition;

/* CONSTANTS */

dcl  DATA_MANAGEMENT_FILE char (32) int static options (constant) init ("data_management_file");
dcl  OFF bit (1) internal static options (constant) init ("0"b);
dcl  ON bit (1) internal static options (constant) init ("1"b);
dcl  VFILE char (32) int static options (constant) init ("vfile");

/* INCLUDES */
%page;
%include mrds_rmdb_ctl;

/*
   Assign initial values
*/

	rmdb_ctl_ptr = info_ptr;

	db_path = "";
	relation_type = "";
	relation_modes = "";
	quiesce_wait_time_supplied = OFF;

	force_sw = OFF;

/*
   If the absolute_db_path is not null it indicates that a  database
   is  currently  in the readied state. The caller cannot request to
   ready a  database  while  one  is  still  readied.  The  call  to
   ssu_$abort_line  does  not  return,  it  causes  the  rest of the
   request line to be aborted and returns control to the listener.
*/

	if rmdb_ctl.absolute_db_path ^= ""
	then call ssu_$abort_line (sci_ptr, 0,
		"^/The database ^a^/^-is already readied, only 1 database may be readied at a time."
		|| "^/^-Type ""free_db"" to free the currently readied database.", rmdb_ctl.absolute_db_path);

/*
   The ready_db request takes two control args, -pathname (-pn)  and
   -quiesce_wait_time  (-qwt).  These  arguments  may  appear in any
   order and any number of times with the last value being  the  one
   used.  If  the first argument is not a control arg, i.e. does not
   begin with a "-" it is assumed to be the database path.
*/

	call ssu_$arg_count (sci_ptr, nargs);

	i = 1;
	do while (i &lt;= nargs);
	     call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len);

	     if /* case */ index (arg, "-") = 1
	     then if /* case */ arg = "-fc" | arg = "-force"
		then force_sw = "1"b;
		else if arg = "-nfc" | arg = "-no_force"
		then force_sw = "0"b;
		else if arg = "-pn" | arg = "-pathname"
		then do;
		     if i = nargs
		     then
missing_path:
			call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "^/The -pathname (-pn) control arg was given but no pathname was supplied");
		     call ssu_$arg_ptr (sci_ptr, i + 1, arg_ptr, arg_len);
		     if index (arg, "-") = 1
		     then goto missing_path;
		     db_path = arg;
		     i=i+1;
		     end;
		else if arg = "-qwt" | arg = "-quiesce_wait_time"
		then do;
		     if i = nargs
		     then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "^/The -quiesce_wait_time (-qwt) control arg was given but no quiesce wait time was supplied.");
		     call ssu_$arg_ptr (sci_ptr, i + 1, arg_ptr, arg_len);
		     if verify (arg, "-0123456789") ^= 0
		     then goto bad_conversion;

		     quiesce_wait_time_supplied = ON;
		     on size
			begin;
			     call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				"^/The size of the quiesce wait time ^a is larger "
				|| "than the maximum of 131071.", arg);
			end;
(size):
		     quiesce_wait_time = cv_dec_check_ (arg, code);
		     revert size;
		     if code ^= 0
		     then
bad_conversion:	          call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			     "^/Could not convert ^a into an integer representing the quiesce wait-time.", arg);
		     if quiesce_wait_time &lt; 0
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			     "^/The quiesce wait time ^a is negative, wait times must be &gt;= 0.", arg);
		     i=i+1;
		     end;
		else if arg = "-rt" | arg = "-relation_type"
		then do;
		     if i = nargs
		     then
missing_type:		call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/The -relation_type (-rt) control argument was given but no relation type was supplied.");
		     call ssu_$arg_ptr (sci_ptr, i+1, arg_ptr, arg_len);
		     if index (arg, "-") = 1
		     then goto missing_type;
		     relation_type = arg;
		     i = i+1;
		     if i ^= nargs
		     then do;
			call ssu_$arg_ptr (sci_ptr, i+1, arg_ptr, arg_len);
			if index (arg, "-") ^= 1
			then do;
			     relation_modes = arg;
			     i = i + 1;
			     end;
			end;
		     end;
		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Argument ^i (^a) is unrecognized", i,
			arg);
	     else if db_path = ""
		then db_path = arg;
	          else call ssu_$abort_line (sci_ptr, 0, "Duplicate argument.^/A database_path has already been given. ^a",
		     arg);
	     i = i + 1;
	     end;					/* do while */

/*
   If the database path has not been supplied as an argument its  an
   error
*/

	if db_path = ""
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^/The database path is required and has not been supplied");

/*
   If a quiesce_wait_time has not been supplied assume the  default
   value.
*/

	if ^quiesce_wait_time_supplied
	then quiesce_wait_time = mrds_data_$quiesce_wait;

/* Check validity of the relation type. If no relation type specified, default
   to vfile types */

	if relation_type = ""
	then relation_type = VFILE;
	else if relation_type = "dmf"
	     then relation_type = DATA_MANAGEMENT_FILE;
	     else if ^(relation_type = VFILE | relation_type = DATA_MANAGEMENT_FILE)
		then call ssu_$abort_line (sci_ptr, 0, "Invalid relation_type supplied. ^a^/^-Valid types are: ^a, ^a",
		relation_type, VFILE, DATA_MANAGEMENT_FILE);

/*
   Make the call that will prepare the database for restructuring.
*/

	rmdb_ctl.flags.database_readied_by_rmdb = ON;

	call rmdb_ready_db (db_path, quiesce_wait_time, addr (rmdb_ctl.relmgr_entries), rmdb_ctl.absolute_db_path,
	     rmdb_ctl.db_model_ptr, rmdb_ctl.saved_res_version_ptr, error_message, code);
	if code = mrds_error_$my_quiesced_db
	then rmdb_ctl.flags.database_readied_by_rmdb = OFF;
	else if code = mrds_error_$no_database
	     then do;
		call expand_pathname_$add_suffix (db_path, "db", db_dir, db_name, code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "^a", db_path);
		db_path = pathname_ (db_dir, db_name);

		if ^force_sw
		then do;
		     call command_query_$yes_no (force_sw, mrds_error_$no_database, "restructure_mrds_db (ready_db)",
			"Answering yes will create an empty MRDS database.", "^/Do you wish to create ^a?",
			db_path);
		     if ^force_sw
		     then call ssu_$abort_line (sci_ptr, 0);
		     end;
		call rmdb_create_db (db_path, relation_type, relation_modes, rmdb_ctl.absolute_db_path,
		     rmdb_ctl.db_model_ptr, error_message, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^/The database ^a^/could not be created.^/^-^a", db_path,
			error_message);

		call rmdb_ready_db (db_path, quiesce_wait_time, addr (rmdb_ctl.relmgr_entries),
		     rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, rmdb_ctl.saved_res_version_ptr, error_message,
		     code);

		end;
	     else if code ^= 0
		then call ssu_$abort_line (sci_ptr, code,
			"^/The database ^a^/^-could not be readied for restructuring^/^-^a", db_path, error_message)
			;

/*
   If the database is inconsistent it must be made consistent before
   the user can be told that it has been readied. Note at this point
   the database is really readied. rmdb_execute_undo will query  the
   user  about  running the undo request. If the user chooses not to
   run the undo request or the undo request fails  the  database  is
   freed and then the request line is aborted. If the database can't
   be freed the subsystem is aborted.
*/

	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused1, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, "ready_db", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr, incon_name,
		undo_request);


	return;

     end rmdb_rq_ready_db;
��



		    rmdb_rq_rename.pl1              12/09/86  1247.6rew 12/09/86  1235.4       58149



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

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

/*DESCRIPTION
  This set of routines parses the command line for the rename_(attribute
  domain relation) requests of the restructure_mrds_db subsystem.
*/


/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     written.
  2) change(86-12-05,Blair), approve(86-12-05,PBF7311), audit(86-12-05,Dupuis),
     install(86-12-09,MR12.0-1237):
     Null out the request info_structure ptr so that tidy_up works properly.
                                                   END HISTORY COMMENTS */

rmdb_rq_rename:
     proc;

	return;

rmdb_rq_rename$attribute:
     entry (Isci_ptr, Iinfo_ptr);

	type = RENAME_ATTRIBUTE;
	goto START;

rmdb_rq_rename$domain:
     entry (Isci_ptr, Iinfo_ptr);

	type = RENAME_DOMAIN;
	goto START;

rmdb_rq_rename$relation:
     entry (Isci_ptr, Iinfo_ptr);

	type = RENAME_RELATION;
	goto START;

START:
	sci_ptr = Isci_ptr;
	rmdb_ctl_ptr = Iinfo_ptr;
          rename_object_info_ptr = null;
	
	on cleanup call tidy_up;
/* Get number of arguments, must be an even number. */
	call ssu_$arg_count (sci_ptr, nargs);
	if nargs = 0 | (mod (nargs, 2) = 1)
	then
USAGE:
	     call error (error_table_$wrong_no_of_args, "^/Usage: " || myname (type) || " from1 to1 {...fromN toN}");

	rename_object_info_count = divide (nargs, 2, 17, 0);
	allocate rename_object_info in (my_area) set (rename_object_info_ptr);
	rename_object_info.version = rename_object_info_version_1;
	rename_object_info.type = type;

	idx = 1;
	do loop = 1 to nargs;
	     call ssu_$arg_ptr (sci_ptr, loop, argp, argl);

	     if argl = 0
	     then goto USAGE;

	     if argl &gt; 30 &amp; type = RENAME_RELATION
	     then call error (mrds_error_$rel_name_too_long, arg);
	     if argl &gt; 32
	     then call error (mrds_error_$long_ident, arg);

	     if verify (arg, mrds_data_$valid_rel_and_attr_name_chars) ^= 0
	     then do;
		if type = RENAME_RELATION
		then code = mrds_error_$bad_rel_name;
		else if type = RENAME_ATTRIBUTE
		     then code = mrds_error_$bad_attr_name;
		     else code = mrds_error_$bad_ident;
		call error (code, arg);
		end;
	     if search (substr (arg, 1, 1), "-_") ^= 0
	     then do;
		if type = RENAME_RELATION
		then code = mrds_error_$inv_rel_name_first_char;
		else if type = RENAME_ATTRIBUTE
		     then code = mrds_error_$inv_attr_name_first_char;
		     else code = mrds_error_$inv_domain_name_first_char;
		call error (code, arg);
		end;

	     if mod (loop, 2) = 1
	     then rename_object_info.from (idx) = arg;
	     else do;
		rename_object_info.to (idx) = arg;
		idx = idx + 1;
		end;

	     end;					/* do loop */

/* Make sure we have an open database. */
	if rmdb_ctl.absolute_db_path = ""
	then call error (error_table_$action_not_performed,
		"^/There is no currently readied database.");

/* Determine whether or not we need to clean up from a previous operation. */
	call mdbm_util_$inconsistent_get_info (rmdb_ctl.db_model_ptr, incon_value, incon_name, unused2, undo_request);
	if incon_value
	then call rmdb_execute_undo (sci_ptr, "create_attribute", rmdb_ctl.absolute_db_path, rmdb_ctl.db_model_ptr,
		incon_name, undo_request);

	call rmdb_rename (rmdb_ctl_ptr, rename_object_info_ptr, error_message, code);
	if code ^= 0
	then call error (code, error_message);

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

error: proc (err_code, err_message);			/* Error procedure for rmdb_rename.pl1 */

	dcl     err_code		 fixed bin (35) parameter;
	dcl     err_message		 char (*) parameter;
	dcl     ssu_$abort_line	 entry () options (variable);

	call tidy_up;

	call ssu_$abort_line (sci_ptr, err_code, err_message);

     end error;

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

tidy_up: proc;

	if rename_object_info_ptr ^= null then
	     free rename_object_info;

     end tidy_up;
%page;
%include mrds_rmdb_ctl;
%include rmdb_rename_object_info;
%page;
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  code fixed bin (35);
dcl  cleanup condition;
dcl  divide builtin;
dcl  empty builtin;
dcl  error_message char (500);
dcl  error_table_$action_not_performed fixed bin(35) ext static;
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;
dcl  idx fixed bin;
dcl  Iinfo_ptr ptr parameter;
dcl  Isci_ptr ptr parameter;
dcl  incon_name  char (32);				/* name of the request that caused the db to become inconsistent */
dcl  incon_value bit (1);				/* true ::= the db is inconsistent */
dcl  loop fixed bin;
dcl  mdbm_util_$inconsistent_get_info entry options(variable);
dcl  mod builtin;
dcl  mrds_data_$valid_rel_and_attr_name_chars char (128) varying ext static;
dcl  mrds_error_$bad_attr_name fixed bin (35) ext static;
dcl  mrds_error_$bad_ident fixed bin (35) ext static;
dcl  mrds_error_$bad_rel_name fixed bin (35) ext static;
dcl  mrds_error_$inv_attr_name_first_char fixed bin (35) ext static;
dcl  mrds_error_$inv_domain_name_first_char fixed bin (35) ext static;
dcl  mrds_error_$inv_rel_name_first_char fixed bin (35) ext static;
dcl  mrds_error_$long_ident fixed bin (35) ext static;
dcl  mrds_error_$rel_name_too_long fixed bin (35) ext static;
dcl  my_area area;
dcl  myname (3) char (32) int static options (constant) init ("rename_attribute", "rename_domain", "rename_relation");
dcl  nargs fixed bin;
dcl  null builtin;
dcl  rmdb_execute_undo entry (ptr, char(32), char(168), ptr, char(32), char(100));
dcl  rmdb_rename entry (ptr, ptr, char (*), fixed bin (35));
dcl  sci_ptr ptr;
dcl  search builtin;
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (ptr, fixed bin);
dcl  ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
dcl  substr builtin;
dcl  type fixed bin (17);
dcl  undo_request  char (100);				/* rmdb request that will cause the db to become consistent */
dcl  unused2 char (200);				/* output from mdbm_util_$inconsistent_get_info */
dcl  verify builtin;

     end rmdb_rq_rename;
���



		    rmdb_rq_tb_.alm                 11/05/86  1615.9r w 11/04/86  1038.5       32634



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

" Request definitions for the restructure_mrds_db subsystem


" HISTORY COMMENTS:
"  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
"     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
"     Add create_(attribute domain), rename_(attribute domain),
"     delete_(attribute domain), undo_rename requests
"                                                      END HISTORY COMMENTS


"			HISTORY
" 82-03-10 Davids written
"
" 82-06-22 Davids: combined and alphabetized the ssu and rmdb
"                  requests into 1 list
"
" 82-07-02 Roger Lackey : changed rmdb_rq_dm to call mdbm_util_$rmdb_rq_dmdm 
"  for binding
"
" 82-08-11 Paul Benjamin: changed display_mrds_dm to display_data_model with
"                         short names of ddm and dmdm.
"
" 83-10-04 Paul Benjamin: removed all standard ssu_ requests in favor of the 
"		      in favor of adding the standard request table.
"

	name rmdb_rq_tb_

	include ssu_request_macros

	begin_table rmdb_rq_tb_
"
	request	.,
		 rmdb_rq_dot$rmdb_rq_dot,
		 (),
		 (Print current status.),
		 flags.allow_command

	request	apply,
		 ssu_requests_$apply_request_util,
		 (ap),
		 ,
		 flags.unimplemented+flags.dont_summarize+flags.dont_list

	request	create_attribute,
		 rmdb_rq_create_attribute$rmdb_rq_create_attribute,
		 (cra),
		 (Creates a new attribute.),
		 flags.allow_command

	request	create_domain,
		 rmdb_rq_create_domain$rmdb_rq_create_domain,
		 (crd),
		 (Creates a new domain.),
		 flags.allow_command

	request	create_index,
		 rmdb_rq_create_index$rmdb_rq_create_index,
		 (cri),
		 (Creates a new index into a relation.),
		 flags.allow_command

	request	create_relation,
		 rmdb_rq_create_relation$rmdb_rq_create_relation,
		 (crr),
		 (Creates a new relation.),
		 flags.allow_command

	request	delete_attribute,
		 rmdb_rq_delete_object$attribute,
		 (dla),
		 (Deletes one or more attributes.),
		 flags.allow_command

	request	delete_domain,
		 rmdb_rq_delete_object$domain,
		 (dld),
		 (Deletes one or more domains.),
		 flags.allow_command

	request	delete_index,
		 rmdb_rq_delete_index$rmdb_rq_delete_index,
		 (dli),
		 (Deletes an index.),
		 flags.allow_command

	request	delete_relation,
		 rmdb_rq_delete_relation$rmdb_rq_delete_relation,
		 (dlr),
		 (Deletes a relation.),
		 flags.allow_command

	request	display_data_model,
		 mdbm_util_$rmdb_rq_dmdm,
		 (ddm,dmdm),
		 (Displays data model info.),
		 flags.allow_command

	request	free_db,
		 rmdb_rq_free_db$rmdb_rq_free_db,
		 (fdb),
		 (Frees a database that has previously been readied for restructuring.),
		 flags.allow_command

	request	ready_db,
		 rmdb_rq_ready_db$rmdb_rq_ready_db,
		 (rdb),
		 (Readies a database for restructuring.),
		 flags.allow_command

	request	rename_attribute,
		 rmdb_rq_rename$attribute,
		 (rna),
		 (Replaces the name of an attribute with another name.),
		 flags.allow_command

	request	rename_domain,
		 rmdb_rq_rename$domain,
		 (rnd),
		 (Replaces the name of a domain with another name.),
		 flags.allow_command

	request	rename_relation,
		 rmdb_rq_rename$relation,
		 (rnr),
		 (Replaces the name of a relation with another name.),
		 flags.allow_command

	request	undo_rename,
		rmdb_rename$undo_rename,
		(),
		(),
		flags.allow_command+flags.dont_summarize+flags.dont_list
		
	end_table rmdb_rq_tb_

	end
��



		    rmdb_salvage_db.pl1             12/09/86  1247.6rew 12/09/86  1236.5       46935



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

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

/*DESCRIPTION
  This routine attempts to clean up after certain rmdb requests. It is only
  called by the undo operation (when the database in marked inconsistent)
  after the operation is undone. The purpose is to delete all the files
  (relation.m or relation MSF/DMF) that have unique names. These strangely
  named files are created by operations that cause the relation to be copied.
*/

/****^  HISTORY COMMENTS:
  1) change(86-01-27,Spitzer), approve(86-01-27,MCR7311),
     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
     written
  2) change(86-11-03,Blair), approve(86-11-03,PBF7311), audit(86-12-01,Dupuis),
     install(86-12-09,MR12.0-1237):
     Take out the code that lets you roll the files forward when a new relation
     has been created from the old during a delete or rename.  We don't have
     enough information to update the model properly even if the relations are
     good, so we always have to roll back.
                                                   END HISTORY COMMENTS */

rmdb_salvage_db:
     proc (Idb_path);

	db_path = Idb_path;
	system_areap, status_area_ptr = get_system_free_area_ ();

	star_names_ptr, star_entry_ptr = null;
	dbm_ptr = null;

	status_ptr = addr (sb);
	status_branch.names_relp = "0"b;

	on cleanup call cleaner;

	call initiate_file_ (db_path, "db_model", RW_ACCESS, dbm_ptr, (0), code);
	if code ^= 0
	then return;

	last_fi_ptr = null;
	done = "0"b;
	do fi_ptr = ptr (dbm_ptr, db_model.file_ptr) repeat ptr (dbm_ptr, file_info.fwd_ptr)
	     while ((rel (fi_ptr) ^= NULL_OFFSET) &amp; (^done));
	     if substr (file_info.file_name, 1, 1) = "!"
	     then done = "1"b;
	     else last_fi_ptr = fi_ptr;
	     end;					/* do fi_ptr */

	if last_fi_ptr = null
	then db_model.file_ptr = NULL_OFFSET;
	else last_fi_ptr -&gt; file_info.fwd_ptr = NULL_OFFSET;

	call hcs_$star_ (db_path, "!*.m", star_ALL_ENTRIES, system_areap, star_entry_count, star_entry_ptr,
	     star_names_ptr, code);
	if code ^= 0
	then return;

	do loop = 1 to star_entry_count;
	     call process_file (loop);
	     end;					/* do loop */

	free star_names in (system_area);
	star_names_ptr = null;

	free star_entries in (system_area);
	star_entry_ptr = null;

	return;
%page;
process_file:
     proc (star_idx);

dcl  model_name char (32);
dcl  relation_name char (32);
dcl  star_idx fixed bin parameter;

	model_name = star_names (star_entries (star_idx).nindex);
	relation_name = before (model_name, ".");
	
/*  Delete the uniquely named files. */
	call delete_file (relation_name);
	call delete_file (model_name);

	return;
%page;
delete_file:
     proc (file_name);

dcl  delete_$path entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  error_table_$unsupported_operation fixed bin (35) ext static;
dcl  file_name char (*) parameter;
dcl  fs_util_$delentry_file entry (char (*), char (*), fixed bin (35));

	call fs_util_$delentry_file (db_path, file_name, code);
	if code = error_table_$unsupported_operation
	then call delete_$path (db_path, file_name, "101111"b, myname, code);

	return;
     end delete_file;

     end process_file;
%page;
cleaner:
     proc;

dcl  p ptr;

	if star_names_ptr ^= null
	then free star_names in (system_area);
	if star_entry_ptr ^= null
	then free star_entries in (system_area);
	if status_branch.names_relp ^= "0"b
	then free status_entry_names in (system_area);

	do p = dbm_ptr;
	     if p ^= null
	     then call terminate_file_ (dbm_ptr, (0), TERM_FILE_TERM, (0));
	     end;

	return;
     end cleaner;
%page;
%include access_mode_values;
%page;
%include mdbm_db_model;
%page;
%include star_structures;
%page;
%include status_structures;
%page;
%include terminate_file;
%page;
dcl  addr builtin;
dcl  before builtin;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  db_path char (168);
dcl  done bit (1) aligned;
dcl  fixed builtin;
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  Idb_path char (*) parameter;			/* absolute pathname of the database */
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  last_fi_ptr ptr;
dcl  loop fixed bin;
dcl  myname char (32) int static options (constant) init ("rmdb_salvage_db");
dcl  null builtin;
dcl  NULL_OFFSET bit (18) unaligned int static options (constant) init ((18)"1"b);
dcl  pointer builtin;
dcl  ptr builtin;
dcl  rel builtin;
dcl  1 sb aligned like status_branch;
dcl  substr builtin;
dcl  sum builtin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  system_area area based (system_areap);
dcl  system_areap ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));

     end rmdb_salvage_db;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

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


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

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

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
</pre></body></html>