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 > 1 then call error (error_table_$too_many_args, "Usage: create_mrds_db$set_dm_file_db_type {mode_string}"); if arg_num > 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 || ">"; 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) || ">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 >= 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 -> 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 -> 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 & 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 > 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 > 0 & 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_ ()) || ">" || 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) || ">" || 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)), ">")); temp_dir_directory = before (rsc.temp_dir, ">" || 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 => use ".db" suffix on db path */ declare allow_new_features bit (1) init ("0"b) int static; /* on => 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 => 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 => 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 => 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 |[add_rmdb_history] entry execute_undo execute_undo: tra |[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 => 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 -> 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 => 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 (this may be ignored) the attribute may not be defined in the model define, cmdb: the attribute name may be the (this may be ignored) the domain name may be the (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 -> rsc.directive_ptr; stmt_ptr = rsc_ptr -> 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 > 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 => attr not found, don't add to sublist */ else do; dom_gl_ptr = node_ptr -> 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 -> 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 -> gl.item_info_ptr; /* set domain_info ptr for attr */ gl.inferior_assigned = ON; dom_gl_ptr -> 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 -> 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 -> 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 => 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 -> gl.name, """ given on line", gl_ptr -> gl.parse_info_ptr -> 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) || ">" || 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) || ">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 => 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) || ">" || 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 -> model_seg.struct_offset = NULL_OFFSET; model_seg_ptr -> 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 (this may be ignored) the domain may not be defined in the model define, cmdb: the domain name may be the (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 (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 > 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) || ">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 > 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 -> domain_info.fwd_thread ^= NULL_OFFSET); last_di_ptr = pointer (dbm_ptr, last_di_ptr -> domain_info.fwd_thread); end; end; last_di_ptr -> 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 > 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 -> path_entry.path = path; path_entry_ptr -> 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 <= 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 < 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 < 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 => 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 -> 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 (this may be ignored) the file may not be defined in the database define, cmdb: the file name may be the (this may be ignored) one of the relation names may be the (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 -> rsc.stmt_ptr; directive_ptr = rsc_ptr -> 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 > 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" & 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 -> node.data;/* get relation global element pointer */ relation_ptr = rel_gl_ptr -> gl.parse_info_ptr; /* get relation declaration */ /* check that this relation is not already in some file */ if ^rel_gl_ptr -> 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 -> gl.other_info_ptr -> 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 -> gl.superior_assigned = ON; /* file present for this relation */ rel_gl_ptr -> gl.file_info_ptr = fi_ptr; /* set file info/model in relation global element */ rel_gl_ptr -> gl.file_model_ptr = fm_ptr; rel_gl_ptr -> 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 -> gl.inferior_assigned | ^rel_gl_ptr -> 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) || ">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) || ">" || 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 > 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 -> file_info.fwd_ptr ^= NULL_OFFSET); last_fi_ptr = pointer (dbm_ptr, last_fi_ptr -> file_info.fwd_ptr); end; end; last_fi_ptr -> 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 -> 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 -> 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 -> 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 -> gl.other_info_ptr; /* get attribute's domain info pointer */ dom_sl_ptr = attr_gl_ptr -> 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 -> 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 -> gl.name, """ in relation """, rel_gl_ptr -> gl.name, """."); call mrds_rst_error (rsc_ptr, 2 /* severity */, mrds_error_$rst_model_limit, (message)); end; /* update global list entries */ rel_sl_ptr -> 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 -> sl.item_info_ptr = ri_ptr; /* set rel_info in attr's rel sublist element */ attr_sl_ptr -> 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 -> 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 > mrds_data_$max_attributes & ^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 -> gl.name, """ in relation """, rel_gl_ptr -> 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 => 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 -> attr_info.defn_order >= 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 -> 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 -> 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 => current order is in list */ declare found bit (1); /* on => exit loop, else keep looking */ declare order_was_obtained bit (1); /* on => 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 -> node.data; /* get rel sublist pointer */ attr_gl_ptr = rel_sl_ptr -> sl.global_list_ptr; /* get global attr pointer */ call list_search (relation.name, attr_gl_ptr -> gl.item_sub_list_ptr, attr_sl_ptr, ATTR_SL); attribute_ptr = rel_sl_ptr -> 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 => 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 -> 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 => 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 -> 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 -> gl.other_info_ptr = di_ptr; /* set domain_info in attr global element */ rel_sl_ptr -> 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 -> 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 & (file_id_space + tuple_id_space <= 34)) | (^blocked_check & (file_id_space + vfile_component_space <= 17)) then do ; /* last space usage within limits, try to get another bit for the file_id_space to occupy * / if file_id_space < 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 > 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 <= 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 => 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 => 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 => 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 => 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 => 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; /* > 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 > 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 < 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 => 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 & 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 (this may be ignored) one of the attribute names may be the (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 > 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 -> node.data; /* Set the relation global element pointer */ ri_ptr = rel_gl_ptr -> 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 -> gl.other_info_ptr; /* get rel's file gl ptr */ if file_gl_ptr -> gl.parse_info_ptr = null () then do; /* not from source => 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 -> gl.affected = ON; /* file where relation resides is affected */ rel_gl_ptr -> 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 -> 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 -> node.data; /* Attribute sub_list entry pointer */ ai_ptr = attr_sl_ptr -> 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 > 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 -> sl.global_list_ptr; attr_gl_ptr -> 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 > 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 -> 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 -> 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 <= 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 < lbound (case, 1) | struct_type > 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 < lbound (var_case, 1) | struct_type > hbound (var_case, 1) then call bad_struct_type (); else if struct_size < 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 -> 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 -> 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 -> 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 => input, off => 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 => 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 => free, off => 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 >= -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 >= 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 < 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 < 0 then an = -n; else an = +n; if (an = test_symbol) then do; next_state = DPDA.v2 (i); goto got_symbol; end; if (an > 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 < 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 > 0) then do; /* if marked symbol was in table, use it */ next_state = DPDA.v2 (m); goto got_symbol; end; if nil_flag & nil > 0 then do; /* If skip recovery has just occurred and there is a nil symbol transition take the transition and back up to the nil symbol in the lookahead stack. */ next_state = DPDA.v2 (nil); la_get = mod (la_get - 2, -lbound (lex_stack, 1)) + 1; la_ct = la_ct + 1; test_symbol = nil_sym; go to got_symbol; end; line_number = lex_stack (-la_use).line; if token_cnt > 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 < 0) then do; /* is this a look-ahead state? */ db_data.type = "LK01"; db_look = la_need; db_data.data = geterm (test_symbol, 0); /* display only terminal "name" on look-ahead */ db_data.flag = " "; end; else do; db_data.data = getermc (test_symbol, la_get); /* display terminal "name" and data, if available */ end; call ioa_$ioa_switch_nnl (iox_$user_output, "^a^/", string (db_data)); end; current_state = next_state; if (current_state < 0) then do; /* Transition is a look-ahead state. */ current_state = -current_state; end; else do; if (ls_top >= hbound (lex_stack, 1)) then 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 > 0) then do; if rsc_ptr -> rsc.severity_high >= 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 >= 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 <= 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 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 symbol defined by the -recover control if used. The 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: ::= | ! ::= | ! ::= a ; ! ::= r ; | r ; ! ::= b ; ! ::= s ; | 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 ; 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 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: ::= ! then the generated from skip recovery will allow the to be correctly parsed, reducing the number of useless error messages by quite a bit, usually. These rules can help parse thru misplaced statements during error recovery, but will never accept these statements under normal circumstances. The semantics on these 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) <= 0) then return ("0"b); /* no skip table */ error_mark = 0; current_table = 1; recov_msg = "Unuseable "; recov_msg = recov_msg || geterm (test_symbol, la_get); recov_msg = recov_msg || " on line "; dec4 = lex_stack (-la_get).line; recov_msg = recov_msg || ltrim (dec4); recov_msg = recov_msg || ", Skipped to "; nil_sym = skip_v1 (2); /* SKIP table */ c = 1; do while (c ^= 0); if (la_ct < 1) then do; /* if look-ahead stack is empty, get a symbol */ call mrds_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 > 0) then if (lex_stack (-ids).symlen > 0) then do; temp = temp || """"; temp = temp || substr (lex_stack (-ids).symptr -> c_str, 1, min (50, lex_stack (-ids).symlen)); temp = temp || """"; return (temp); end; if (idx = 0) then temp = end_of_input_msg; else temp = substr (string (TC), TL.fc (idx), TL.ln (idx)); return (temp); getermc: entry (idx, ids) returns (char (100) var); if (idx = 0) then temp = end_of_input_msg; else temp = substr (string (TC), TL.fc (idx), TL.ln (idx)); temp = temp || " "; goto get_rest; end; %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 < 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 < 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) > 0 then nil_sym = skip_v1 (2); /* SKIP table */ else nil_sym = -1; la_next = mod (la_use, -lbound (lex_stack, 1)) + 1; next_symbol = lex_stack (-la_next).symbol; dcl string builtin; string (sws) = "0"b; transit = -1; combinations = 0; depth = 0; if debug_sw then call dump_la; do i = current_table + 1 to current_table + DPDA.v2 (current_table) while (combinations < 2); alt_symbol = abs (DPDA.v1 (i)); if alt_symbol = nil_sym then go to try_again; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^4i ^4a ^i ^a^/", current_state, DDop (sign (DPDA.v2 (i))), alt_symbol, geterm (alt_symbol, 0)); string (cycle) = "0"b; if combinations < 2 then 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 <= 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 < 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 >= 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 < 2); if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= s)) | (DPDA.v1 (i) = s) then do; if debug_sw then call ioa_$ioa_switch_nnl (iox_$user_output, "#^vx(^i)^i^/", depth, rep, s); if (combinations = 0) then do; combinations = 1; transit = alt_symbol; if (rep = 1) then RBNf = "10"b; else RBNf = "01"b; end; else combinations = 2; end; end; end; if (next_symbol = alt_symbol) then do; if (combinations = 0) then do; CNf = "1"b; do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st); if ((DPDA.v1 (i) < 0) & (-DPDA.v1 (i) <= test_symbol)) | DPDA.v1 (i) = test_symbol then RBNf = "10"b; end; transit = alt_symbol; combinations = 1; end; else combinations = 2; end; done: depth = depth - 5; do i = 1 to ps_top; parse_stack (i) = parse_stack2 (i); end; return; end; else do; if la_use2 = la_use /* la_use points to the bad input symbol. */ then s = alt_symbol; /* We are considering an alternate symbol. */ else s = lex_stack (-la_use2).symbol; marked = 0; do i = cur_st + 1 to cur_st + DPDA.v2 (cur_st) while (abs (DPDA.v1 (i)) <= s); if abs (DPDA.v1 (i)) = s then go to found; else if DPDA.v1 (i) < 0 then marked = i; end; if marked ^= 0 then i = marked; else go to done; found: ns = DPDA.v2 (i); if ns >= 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 >= 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 > 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 " equ LN1,*-DPDA-ST1-1 " " STATE 3 equ ST3,*-DPDA zero NSRD,LN3 zero 0,-ST582 "EOI zero 14,-ST580 " zero 15,-ST582 " zero 16,-ST582 " equ LN3,*-DPDA-ST3-1 " " STATE 8 equ ST8,*-DPDA zero STRD,LN8 zero 4,ST50 " zero -12,ST54 " 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 " equ LN13,*-DPDA-ST13-1 " " STATE 15 equ ST15,*-DPDA zero NSRD,LN15 zero 0,-ST598 "EOI zero 15,-ST596 " zero 16,-ST598 " equ LN15,*-DPDA-ST15-1 " " STATE 19 equ ST19,*-DPDA zero STRD,LN19 zero 4,ST81 " zero -12,ST85 " 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 " equ LN26,*-DPDA-ST26-1 " " STATE 28 equ ST28,*-DPDA zero STRD,LN28 zero 1,ST135 " zero 17,ST137 " zero 18,ST141 " zero 19,ST145 " zero 20,ST149 " zero 21,ST153 " zero 22,ST157 " zero 23,ST161 " zero 24,ST163 " zero 25,ST172 " zero 26,ST181 " zero 27,ST184 " zero 28,ST187 " zero 29,ST194 " 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 " zero 4,ST200 " 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 " equ LN62,*-DPDA-ST62-1 " " STATE 65 equ ST65,*-DPDA zero STRD,LN65 zero 4,ST226 " zero -12,ST230 " 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 " 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 " zero 4,ST240 " 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 " 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 " zero 3,-ST619 " zero 4,-ST619 " zero 6,-ST619 " zero 17,-ST608 " zero 18,-ST608 " zero 19,-ST608 " zero 20,-ST608 " zero 21,-ST608 " zero 22,-ST608 " zero 23,-ST608 " zero 28,-ST608 " zero 29,-ST608 " 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 " zero 4,-ST625 " zero 6,-ST623 " equ LN131,*-DPDA-ST131-1 " " STATE 135 equ ST135,*-DPDA zero STRD,LN135 zero 11,ST293 " 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 " equ LN161,*-DPDA-ST161-1 " " STATE 163 equ ST163,*-DPDA zero NSRD,LN163 zero 1,-ST629 " zero 3,-ST635 " zero 4,-ST635 " zero 6,-ST635 " zero 26,-ST629 " zero 27,-ST629 " zero 28,-ST629 " zero 29,-ST629 " equ LN163,*-DPDA-ST163-1 " " STATE 172 equ ST172,*-DPDA zero NSRD,LN172 zero 1,-ST639 " zero 3,-ST640 " zero 4,-ST640 " zero 6,-ST640 " zero 26,-ST639 " zero 27,-ST639 " zero 28,-ST639 " zero 29,-ST639 " equ LN172,*-DPDA-ST172-1 " " STATE 181 equ ST181,*-DPDA zero STRD,LN181 zero 24,ST350 " zero 25,ST359 " equ LN181,*-DPDA-ST181-1 " " STATE 184 equ ST184,*-DPDA zero STRD,LN184 zero 24,ST368 " zero 25,ST377 " 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 " 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 " zero -12,ST403 " 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 " equ LN215,*-DPDA-ST215-1 " " STATE 217 equ ST217,*-DPDA zero STRD,LN217 zero 1,ST411 " 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 " zero 4,ST415 " 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 " 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 " zero 4,-ST646 " zero 6,-ST644 " 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 " zero 31,ST433 " zero 32,ST435 " zero 33,ST437 " equ LN288,*-DPDA-ST288-1 " " STATE 293 equ ST293,*-DPDA zero STRD,LN293 zero 2,ST441 " zero 3,ST446 " 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 " zero 3,-ST651 " zero 4,-ST651 " zero 6,-ST651 " zero 26,-ST650 " zero 27,-ST650 " zero 28,-ST650 " zero 29,-ST650 " 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 " 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 " zero 3,-ST656 " zero 4,-ST656 " zero 6,-ST656 " zero 26,-ST655 " zero 27,-ST655 " zero 28,-ST655 " zero 29,-ST655 " equ LN350,*-DPDA-ST350-1 " " STATE 359 equ ST359,*-DPDA zero NSRD,LN359 zero 1,-ST660 " zero 3,-ST661 " zero 4,-ST661 " zero 6,-ST661 " zero 26,-ST660 " zero 27,-ST660 " zero 28,-ST660 " zero 29,-ST660 " equ LN359,*-DPDA-ST359-1 " " STATE 368 equ ST368,*-DPDA zero NSRD,LN368 zero 1,-ST665 " zero 3,-ST666 " zero 4,-ST666 " zero 6,-ST666 " zero 26,-ST665 " zero 27,-ST665 " zero 28,-ST665 " zero 29,-ST665 " equ LN368,*-DPDA-ST368-1 " " STATE 377 equ ST377,*-DPDA zero NSRD,LN377 zero 1,-ST670 " zero 3,-ST671 " zero 4,-ST671 " zero 6,-ST671 " zero 26,-ST670 " zero 27,-ST670 " zero 28,-ST670 " zero 29,-ST670 " 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 " 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 " zero 4,ST476 " 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 " equ LN411,*-DPDA-ST411-1 " " STATE 413 equ ST413,*-DPDA zero STRD,LN413 zero -12,ST230 " 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 " equ LN431,*-DPDA-ST431-1 " " STATE 433 equ ST433,*-DPDA zero STRD,LN433 zero 9,ST500 " equ LN433,*-DPDA-ST433-1 " " STATE 435 equ ST435,*-DPDA zero STRD,LN435 zero 9,ST505 " 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 " zero 8,-ST675 " zero 11,-ST678 " 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 " 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 " equ LN472,*-DPDA-ST472-1 " " STATE 474 equ ST474,*-DPDA zero STRD,LN474 zero -12,ST403 " 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 " zero -12,ST487 " equ LN484,*-DPDA-ST484-1 " " STATE 487 equ ST487,*-DPDA zero NSRD,LN487 zero 2,-ST684 " zero 7,-ST682 " zero -12,-ST684 " 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 " zero 4,-ST690 " zero 6,-ST690 " zero 10,-ST688 " equ LN495,*-DPDA-ST495-1 " " STATE 500 equ ST500,*-DPDA zero NSRD,LN500 zero 3,-ST696 " zero 4,-ST696 " zero 6,-ST696 " zero 10,-ST694 " equ LN500,*-DPDA-ST500-1 " " STATE 505 equ ST505,*-DPDA zero NSRD,LN505 zero 3,-ST702 " zero 4,-ST702 " zero 6,-ST702 " zero 10,-ST700 " equ LN505,*-DPDA-ST505-1 " " STATE 510 equ ST510,*-DPDA zero STRD,LN510 zero 11,ST565 " 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 " zero -12,ST572 " 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 " 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 " 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 " 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 " 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 " zero 17,ST137 " zero 18,ST141 " zero 19,ST145 " zero 20,ST149 " zero 21,ST153 " zero 22,ST157 " zero 23,ST161 " zero 28,ST187 " zero 29,ST194 " 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 " 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 " zero 26,ST338 " zero 27,ST342 " zero 28,ST187 " zero 29,ST194 " 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 " 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 " zero 8,ST520 " 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 " 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 " 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 " 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 " 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 => 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 < 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 > 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 > 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) & (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) > 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 & ^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 & ^mode_bits.protection_on then call error (error_table_$bad_mode_value, "Rollback cannot be specified without protection."); if mode_bits.concurrency_on & ^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) < 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 => 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 (this may be ignored) the relation may not be defined in the database define, cmdb: the relation name may be the (this may be ignored) one of the attribute names may be the (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 -> rsc.stmt_ptr; directive_ptr = rsc_ptr -> 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 > 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 => relation not found, so don't add sublists */ else do; attr_gl_ptr = node_ptr -> node.data; /* get attribute global element pointer */ if attr_gl_ptr -> gl.item_info_ptr = null () then ; /* check for assigned domain for this attribute */ else if attr_gl_ptr -> gl.item_info_ptr -> sl.new_other_info_ptr = null () then ; else do; /* get attr's domain global element pointer */ dom_gl_ptr = attr_gl_ptr -> gl.item_info_ptr -> sl.new_other_info_ptr; dom_gl_ptr -> 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 -> 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 -> 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 -> gl.item_info_ptr; /* attribute info pointer */ sl.parse_info_ptr = attribute_ptr; /* attr parse structure */ sl.old_other_info_ptr = attr_gl_ptr -> gl.other_info_ptr; /* domain info ptr */ sl.new_other_info_ptr = attr_gl_ptr -> 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 => 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 <= 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 < lbound (case, 1) | struct_type > 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> sl in (sublist_area); else allocate sl set (struct_ptr) in (sublist_area); goto return_label; case (22): if FREE then free struct_ptr -> 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 -> 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 -> 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 < lbound (var_case, 1) | struct_type > hbound (var_case, 1) then call bad_struct_code (); else if struct_size < 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 -> 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 -> 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 => input, off => 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 => free structure, off => 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. ">" 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 ">" */ temp_line_number = line_number; good_char = "0"b; do while (^good_char); if char_type ^= WHITE_SPACE & 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 = ">" 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 "">"" 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 -> 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 -> 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 = "/" & 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 ^= "*" & 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 ^= "/" & 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 ">" 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 & char_type ^= NL & char_type ^= A_PATH_ENTRY & char_type ^= EOF & char ^= "," & 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 > seg_len then ; else do; /* find end of next line */ line_ptr = addr (char_string (pos)); line_length = index (substr (line_ptr -> 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 -> 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 -> source, 1, line_length); call iox_$put_chars (static_rsc_ptr -> 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 <= 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 & pos <= 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 <= 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) & high > low); if token > 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 => previous error message issued */ dcl stringsize condition; /* target too small for string */ dcl good_char bit (1); /* on => character is not white space or new line char */ dcl mantissa_end bit (1); /* end of mantissa flag */ dcl radix_found bit (1); /* on => 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 => token has been found */ dcl comment_end bit (1); /* on => 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 => a comment was found and skipped */ dcl number_found bit (1); /* off => "." 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 => 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 -mark -order -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 >udd>LIS>Wardd>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: >udd>LIS>Wardd>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: >udd>LIS>Wardd>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>LIS>Wardd>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 >udd>LIS>Wardd>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 >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_parse_table ted -abort >udd>LIS>Wardd>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: & indent the lrk source & ted -abort >udd>LIS>Wardd>lrk|ind mrds_rst_parse.lrk & & generate the lrk tables from mrds_rst_parse.lrk source bnf & with control arguments inside that source output is the & mrds_rst_parse object table for the parser the source & mrds_rst_semantics.pl1, and the intermediate lrk results & mrds_rst_parse.result and several mrds_rst_parse.lrk.* segs & with a listing of mrds_rst_parseg.list & >udd>LIS>Wardd>lrk mrds_rst_parse & & generate the keyword sorted list include file from the & mrds_rst_keywords.syn source and the lrk output & mrds_rst_parse.result the output produced is & mrds_rst_keywords.incl.pl1 & >udd>LIS>Wardd>kwsl mrds_rst_parse mrds_rst_keywords mrds_rst_keywords & & generate the error skip table include the source is & mrds_rst_parse.result, output is mrds_rst_skip_table.incl.pl1 & >udd>LIS>Wardd>msd mrds_rst_parse mrds_rst_skip_table & & generate the terminal symbols include file the source is & mrds_rst_parse.result, output is mrds_rst_terminals.incl.pl1 & ted -abort >udd>LIS>Wardd>lrk|hal_dcl mrds_rst_parse mrds_rst_terminals & & build the ascii to decimal transliteration include file input & is mrds_rst_translate.mad, output is & mrds_rst_translate.incl.pl1 & ted -abort >udd>LIS>Wardd>Wardd|mad mrds_rst_translate.mad & & put include file headers/trailer comments in this adds the & BEGIN INCLUDE FILE.... and END INCLUDE FILE comments & ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_parse_table ted -abort >udd>LIS>Wardd>Wardd|incl_cmt mrds_rst_skip_table & & compile parser, scanner, and semantics PL1 routines & pl1 mrds_rst_semantics pl1 mrds_rst_parse pl1 mrds_rst_scanner & & get rid of lrk generated segments no longer needed they were & used as intermediate results by lrk and it's tools & 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 control to LRK input file in order to be able to un-reserve keywords for CMDB. Also changed and rules to avoid 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 -> 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 -> rsc.stmt_ptr = stmt_ptr; do i = 1 by 1 to hbound (stmt_ptr -> 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 -> rsc.temp_dir) || ">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 ************************************************************************** */ /* ::= ! */ 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; /* ::= ! */ rule_label (0002): /* null statement */ goto return_label; /* ::= ! */ 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; /* ::= ! */ rule_label (0004): /* start of attribute delete/define/redefine, set it active */ stmt (directive.type).attribute.active = ON; goto return_label; /* ::= ! */ rule_label (0005): /* start of relation delete/define/redefine, set it active */ stmt (directive.type).relation.active = ON; goto return_label; /* ::= ! */ 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 ***************************************************************** */ /* ::= | ! */ 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; /* ::= ! */ rule_label (0008): goto return_label; /* ::= ! */ rule_label (0009): goto return_label; /* ::= ! */ 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; /* ::= ! */ 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 -> domain.descriptor); goto return_label; /* ::= ! */ rule_label (0012): /* build descriptor for number, set packing, precision, scale, and type */ if aligned then descr_ptr -> descriptor.packed = OFF; else descr_ptr -> descriptor.packed = ON; call set_precision_and_scale (); call set_number_type (); goto return_label; /* ::= ! */ rule_label (0013): /* build descriptor for character string, set type, packed, and size */ call set_string_size_and_packing (); if nonvarying then descr_ptr -> descriptor.type = 21; else descr_ptr -> descriptor.type = 22; goto return_label; /* ::= ! */ rule_label (0014): /* build descriptor for bit string, set type, packed, and size */ call set_string_size_and_packing (); if nonvarying then descr_ptr -> descriptor.type = 19; else descr_ptr -> descriptor.type = 20; goto return_label; domain_initialize: procedure (); /* initialize the domain structure */ domain_list_ptr -> domain.name = get_name (stack_top, 32); domain_list_ptr -> domain.descriptor = OFF; domain_list_ptr -> domain.varying_avg_length = 0; domain_list_ptr -> domain.options = OFF; domain_list_ptr -> domain.pad = OFF; domain_list_ptr -> domain.check.flag = OFF; domain_list_ptr -> domain.check.pad = OFF; domain_list_ptr -> domain.check.stack_ptr = null (); domain_list_ptr -> domain.check.stack_size = 0; domain_list_ptr -> domain.check_proc.flag = OFF; domain_list_ptr -> domain.check_proc.pad = OFF; domain_list_ptr -> domain.check_proc.path = BLANK; domain_list_ptr -> domain.check_proc.entry = BLANK; domain_list_ptr -> domain.encode_proc.flag = OFF; domain_list_ptr -> domain.encode_proc.pad = OFF; domain_list_ptr -> domain.encode_proc.path = BLANK; domain_list_ptr -> domain.encode_proc.entry = BLANK; domain_list_ptr -> domain.decode_proc.flag = OFF; domain_list_ptr -> domain.decode_proc.pad = OFF; domain_list_ptr -> domain.decode_proc.path = BLANK; domain_list_ptr -> domain.decode_proc.entry = BLANK; domain_list_ptr -> domain.decode_dcl.flag = OFF; domain_list_ptr -> domain.decode_dcl.pad = OFF; domain_list_ptr -> domain.decode_dcl.descriptor = OFF; domain_list_ptr -> 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 -> descriptor.version = ON; descr_ptr -> 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 -> descriptor.type = 1; else descr_ptr -> descriptor.type = 2; else if short then descr_ptr -> descriptor.type = 3; else descr_ptr -> descriptor.type = 4; else if ^float then if short then descr_ptr -> descriptor.type = 5; else descr_ptr -> descriptor.type = 6; else if short then descr_ptr -> descriptor.type = 7; else descr_ptr -> descriptor.type = 8; else if real then if ^float then do; if aligned then descr_ptr -> descriptor.type = 9; else descr_ptr -> descriptor.type = 43; end; else do; if aligned then descr_ptr -> descriptor.type = 10; else descr_ptr -> descriptor.type = 44; end; else if ^float then do; if aligned then descr_ptr -> descriptor.type = 11; else descr_ptr -> descriptor.type = 45; end; else do; if aligned then descr_ptr -> descriptor.type = 12; else descr_ptr -> 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 >= 1 & saved_precision <= 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 -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >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 >= 1 & saved_precision <= 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 -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >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 >= 1 & saved_precision <= 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 -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has precision <1 or >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 -> arith_size.precision = saved_precision; /* set precision type as short or long */ if decimal then ; else if ^float then if saved_precision <= 35 then short = ON; else short = OFF; else if saved_precision <= 27 then short = ON; else short = OFF; /* check on the scale factor */ if ^(float & 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 -> domain.name, """ on line", domain_list_ptr -> 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 >= -128 & scale_factor <= 127 then ; else do; if scale_factor < 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 -> domain.name, """ on line", domain_list_ptr -> domain.line_num, "has a scale factor <-128 or >127, using """, scale_factor, """ instead."); call mrds_rst_error (static_rsc_ptr, 2 /* severity */, mrds_error_$rst_bad_declaration, (message)); end; descr_ptr -> 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 -> domain.name, """ on line", domain_list_ptr -> 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 -> descriptor.packed = OFF; else descr_ptr -> descriptor.packed = ON; descr_ptr -> 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 -> 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 -> domain.name, """ on line", domain_list_ptr -> 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 ***************************************** */ /* ::= ! */ rule_label (0015): goto return_label; /* ::= ! */ rule_label (0016): goto return_label; /* ::= ! */ rule_label (0017): goto return_label; /* ::= ! */ rule_label (0018): /* set real attribute */ if duplicate ("real or complex", addr (type_seen)) then ; else real = ON; goto return_label; /* ::= ! */ rule_label (0019): /* set complex attribute */ if duplicate ("real or complex", addr (type_seen)) then ; else real = OFF; goto return_label; /* ::= ! */ rule_label (0020): /* set fixed attribute */ if duplicate ("float or fixed", addr (representation_seen)) then ; else float = OFF; goto return_label; /* ::= ! */ rule_label (0021): /* set float attribute */ if duplicate ("float or fixed", addr (representation_seen)) then ; else float = ON; goto return_label; /* ::= ! */ rule_label (0022): /* set binary attribute */ if duplicate ("binary or decimal", addr (base_seen)) then ; else decimal = OFF; goto return_label; /* ::= ! */ rule_label (0023): /* set decimal attribute */ if duplicate ("binary or decimal", addr (base_seen)) then ; else decimal = ON; goto return_label; /* ::= ! */ rule_label (0024): goto return_label; /* ::= ! */ rule_label (0025): goto return_label; /* ::= ! */ rule_label (0026): /* set positive sign */ sign_flag = OFF; goto return_label; /* ::= ! */ rule_label (0027): /* set negative sign */ sign_flag = ON; goto return_label; /* ::= ! */ rule_label (0028): /* set sign positive */ sign_flag = OFF; goto return_label; /* ::= ! */ 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; /* ::= ! */ 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; /* ::= ! */ rule_label (0031): goto return_label; /* ::= ! */ rule_label (0032): /* set aligned attribute */ if duplicate ("aligned or unaligned", addr (alignment_seen)) then ; else aligned = ON; goto return_label; /* ::= ! */ 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 -> flag_overlay then do; /* attribute not yet seen, flag it as seen, return no duplication */ flag_ptr -> 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 -> domain.name, """ on line", domain_list_ptr -> 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 => 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 **************************************************************************** */ /* ::= ! */ rule_label (0034): goto return_label; /* ::= ! */ rule_label (0035): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ rule_label (0036): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = ON; goto return_label; /* ::= ! */ rule_label (0037): goto return_label; /* ::= ! */ rule_label (0038): goto return_label; /* ::= ! */ rule_label (0039): goto return_label; /* ::= ! */ rule_label (0040): goto return_label; /* ::= ! */ 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; /* ::= ! */ rule_label (0042): goto return_label; /* ::= ! */ rule_label (0043): /* set varying attribute */ if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ rule_label (0044): /* set nonvarying attribute */ if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = ON; goto return_label; /* ::= ! */ rule_label (0045): goto return_label; /* ::= ! */ rule_label (0046): if duplicate ("varying or nonvarying", addr (fixed_varying_seen)) then ; else nonvarying = OFF; goto return_label; /* ::= ! */ 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 <= 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 -> domain.name, """ on line", domain_list_ptr -> 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 -> domain.name, """ on line", domain_list_ptr -> 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 ***************************************************************** */ /* ::= ! */ rule_label (0048): /* set options present */ domain_list_ptr -> domain.options = ON; goto return_label; /* ::= ! */ rule_label (0049): /* set no options present */ domain_list_ptr -> domain.options = OFF; goto return_label; /* ::= ! */ rule_label (0050): goto return_label; /* ::= ! */ rule_label (0051): goto return_label; /* ::= ! */ rule_label (0052): goto return_label; /* ::= ! */ rule_label (0053): goto return_label; /* ::= ! */ rule_label (0054): goto return_label; /* ::= ! */ rule_label (0055): goto return_label; /* ***************************** decode declaration option ****************************** */ /* ::= ! */ 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 -> domain.decode_dcl.descriptor = saved_decode_descriptor; goto return_label; /* ::= ! */ 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 -> 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 -> domain.decode_dcl.descriptor; end; else do; domain_list_ptr -> 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 ************************************************** */ /* ::= ! */ rule_label (0058): /* set up check procedure path and entry names */ temp_index = stack_top - 1; call get_check_path_entry (); goto return_label; /* ::= ! */ rule_label (0059): /* set up check procedure pathname and missing entry name */ temp_index = stack_top; call get_check_path_entry (); goto return_label; /* ::= ! */ rule_label (0060): /* set up encode procedure path and entry names */ temp_index = stack_top - 1; call get_encode_path_entry (); goto return_label; /* ::= ! */ rule_label (0061): /* set up encode pathname and missing entryname */ temp_index = stack_top; call get_encode_path_entry (); goto return_label; /* ::= ! */ rule_label (0062): /* set up decode procedure path and entry names */ temp_index = stack_top - 1; call get_decode_path_entry (); goto return_label; /* ::= ! */ 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 -> domain.check_proc.flag = ON; domain_list_ptr -> domain.check_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.check_proc.entry = get_entry (domain_list_ptr -> domain.check_proc.path); else domain_list_ptr -> 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 -> domain.encode_proc.flag = ON; domain_list_ptr -> domain.encode_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.encode_proc.entry = get_entry (domain_list_ptr -> domain.encode_proc.path); else domain_list_ptr -> 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 -> domain.decode_proc.flag = ON; domain_list_ptr -> domain.decode_proc.path = get_name (temp_index, 168); if temp_index = stack_top then domain_list_ptr -> domain.decode_proc.entry = get_entry (domain_list_ptr -> domain.decode_proc.path); else domain_list_ptr -> 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 -> lex_stack (stack_top).token_num ^= 0 & search (reverse (pathname), ">") ^= 0 then /* absolute pathname, extract the rightmost component */ entry_portion = substr (pathname, length (pathname) - search (reverse (pathname), ">") + 2); /* either dummy "" 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) <= 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 -> 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 ********************************************** */ /* ::= ! */ rule_label (0064): /* attribute declaration processing complete, set it inactive */ stmt (directive.type).attribute.active = OFF; goto return_label; /* ::= | ! */ rule_label (0065): goto return_label; /* ::= ! */ rule_label (0066): /* count the last attribute specification */ stmt (directive.type).attribute.number = stmt (directive.type).attribute.number + 1; goto return_label; /* ::= ! */ rule_label (0067): goto return_label; /* ::= ! */ 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 -> attribute_domain.attr = get_name (stack_top - 1, 32); attribute_list_ptr -> attribute_domain.dom = get_name (stack_top, 32); attribute_list_ptr -> attribute_domain.line_num = get_line_number (stack_top - 1); attribute_list_ptr -> attribute_domain.default = OFF; /* defined in source */ attribute_list_ptr -> 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 *********************************************** */ /* ::= ! */ 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; /* ::= | ! */ rule_label (0070): /* no relation statement, set it inactive */ stmt (directive.type).relation.active = OFF; goto return_label; /* ::= ! */ rule_label (0071): goto return_label; /* ::= ! */ rule_label (0072): goto return_label; /* ::= ! */ 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; /* ::= ! */ rule_label (0074): /* start relation list, get name from stack */ call get_relation_name (); goto return_label; /* ::= ! */ rule_label (0075): goto return_label; /* ::= ! */ rule_label (0076): goto return_label; /* ::= ! */ 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; /* ::= ! */ 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 -> relation.a_ptr; attribute_ptr -> attribute.pr_key = ON; attribute_ptr -> attribute.key_order = 1; call ioa_$rs ("^a^a^a ^d ^a^a^a", message, message_length, "Relation """, relation_list_ptr -> relation.name, """ on line", relation_list_ptr -> relation.line_num, "does not specify any key attributes, assuming """, attribute_ptr -> 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 -> relation.a_ptr = null (); relation_list_ptr -> relation.name = get_name (stack_top, 30); relation_list_ptr -> relation.max_tup = 0; relation_list_ptr -> relation.num_items = 0; relation_list_ptr -> relation.line_num = get_line_number (stack_top); relation_list_ptr -> 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 -> 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 -> 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 -> relation.num_items = relation_list_ptr -> relation.num_items + 1; saved_attr_ptr = attribute_ptr; end; end; /* ****************************************************** index specification processing ****************************************************** */ /* ::= ! */ rule_label (0079): /* index processing complete, set it inactive */ stmt (directive.type).index.active = OFF; goto return_label; /* ::= | ! */ rule_label (0080): /* set index statement inactive */ stmt (directive.type).index.active = OFF; goto return_label; /* ::= ! */ rule_label (0081): goto return_label; /* ::= ! */ rule_label (0082): goto return_label; /* ::= ! */ 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; /* ::= ! */ rule_label (0084): /* start a index definition list with the relation name */ call get_index_relation (); goto return_label; /* ::= ! */ rule_label (0085): /* add the last attribute to this index definition list */ call get_index_attribute (); goto return_label; /* ::= ! */ 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 -> rel_index.i_ptr = null (); index_list_ptr -> rel_index.rel_name = get_name (stack_top, 32); index_list_ptr -> rel_index.num_items = 0; index_list_ptr -> rel_index.unused = OFF; index_list_ptr -> 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 -> 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 -> item.next = item_ptr; index_list_ptr -> rel_index.num_items = index_list_ptr -> 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 -> children.child_ptr; end; /* run through linked list of names, checking for duplicates, until list end */ do while (item_ptr ^= null ()); if item_ptr -> item.name ^= name then /* not duplicate, set next list element for list type */ if list_type ^= CHILD then item_ptr = item_ptr -> item.next; else do; children_ptr = children_ptr -> children.next; if children_ptr = null () then item_ptr = null (); else item_ptr = children_ptr -> 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 => child relation, 9 => file relation, 10 => attribute */ declare name_duplicate bit (1); /* ON => 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 "" is used when a missing identifier has been detected and a dummy inserted for it. */ length = lex_stack_ptr -> lex_stack (stack_pos).symlen; name = substr (lex_stack_ptr -> lex_stack (stack_pos).symptr -> source, 1, length); token_pos = lex_stack_ptr -> lex_stack (stack_pos).token_num; /* check on the token size */ if length <= name_size then ; else do; length = name_size; lex_stack_ptr -> 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 -> 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 -> lex_stack (stack_pos).token_num ^= 0 then value = lex_stack_ptr -> lex_stack (stack_pos).val; else do; /* token_num = 0 means dummy "" on stack for missing number, use a fixup value and issue error message */ value = 1; lex_stack_ptr -> 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 <= 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 -> 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 -> 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 => 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 => 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); /* > op code */ declare LESS fixed bin internal static options (constant) init (4); /* < op code */ declare GREATER_EQUAL fixed bin internal static options (constant) init (5); /* >= op code */ declare LESS_EQUAL fixed bin internal static options (constant) init (6); /* <= op code */ declare AND fixed binary internal static options (constant) init (10); /* & 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; /* "" => 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 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 => varying average size declared */ declare size_seen bit (1) internal static; /* on => string size was declared */ declare decode_proc_seen bit (1) internal static; /* on => decode_proc option was declared */ declare encode_proc_seen bit (1) internal static; /* on => encode_proc option was declared */ declare check_seen bit (1) internal static; /* on => check or check_proc option declared */ declare type_seen bit (1) internal static; /* on => a type was declared */ declare representation_seen bit (1) internal static; /* on => representation was declared */ declare base_seen bit (1) internal static; /* on => base was declared */ declare precision_seen bit (1) internal static; /* on => precision was declared */ declare alignment_seen bit (1) internal static; /* on => alignment was declared */ declare fixed_varying_seen bit (1) internal static; /* on => fixed or varying was declared */ declare scale_seen bit (1) internal static; /* on => scale was declared */ declare decode_dcl_seen bit (1) internal static; /* on => 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 => decimal declared */ declare real bit (1) internal static; /* on => real declared */ declare (addrel, hbound, copy, length) builtin; declare (null, reverse, rtrim, substr) builtin; declare float bit (1) internal static; /* on => float declared */ declare aligned bit (1) internal static; /* on => aligned was declared */ declare nonvarying bit (1) internal static; /* on => nonvarying was declared */ declare temp_index fixed binary; /* storage for stack position of a token */ declare key_attribute bit (1); /* on => attribute is part of primary key */ declare short bit (1) internal static; /* on => 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 -> 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 -> node.right.thread then ; else call mrds_rst_tree_successor (root_ptr, node_ptr, successor_ptr, successor_parent_ptr, success); if node_ptr -> node.left.thread then ; else do; call mrds_rst_tree_predecessor (root_ptr, node_ptr, predecessor_ptr, predecessor_parent_ptr, success); if node_ptr -> node.right.thread then predecessor_ptr -> node.right.link = node_ptr -> node.right.link; else do; predecessor_ptr -> 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 -> node.right.thread then if ^node_ptr -> node.left.thread then successor_ptr = node_ptr -> node.left.link; else do; thread = "1"b; if parent_ptr ^= node_ptr -> node.left.link then successor_ptr = node_ptr -> node.left.link; else successor_ptr = node_ptr -> 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 -> node.left.link = node_ptr -> node.left.link; successor_ptr -> node.left.thread = node_ptr -> 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 -> node.right.thread then do; successor_parent_ptr -> node.left.thread = "1"b; successor_ptr -> node.right.thread = "0"b; end; else successor_parent_ptr -> node.left.link = successor_ptr -> node.right.link; successor_ptr -> node.right.link = node_ptr -> 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 -> node.left.link then do; parent_ptr -> node.left.link = successor_ptr; parent_ptr -> node.left.thread = thread; end; else do; parent_ptr -> node.right.link = successor_ptr; parent_ptr -> 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 -> node.key = key; node_ptr -> node.right.thread = "1"b; node_ptr -> node.left.thread = "1"b; node_ptr -> node.data = null (); node_ptr -> 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 -> node.right.link = root_ptr; root_ptr -> node.right.thread = "0"b; root_ptr -> node.left.link = root_ptr; root_ptr -> node.left.thread = "1"b; root_ptr -> node.data = null (); root_ptr -> 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 -> node.left.thread then ; else do; parent_ptr = root_ptr; root_ptr -> 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 > parent_ptr -> node.key then do; node_ptr -> node.right.link = parent_ptr -> node.right.link; node_ptr -> node.left.link = parent_ptr; parent_ptr -> node.right.link = node_ptr; parent_ptr -> node.right.thread = "0"b; end; else do; node_ptr -> node.left.link = parent_ptr -> node.left.link; node_ptr -> node.right.link = parent_ptr; parent_ptr -> node.left.link = node_ptr; parent_ptr -> 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 -> node.left.link; if node_ptr -> 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 -> node.right.thread); predecessor_parent_ptr = predecessor_ptr; predecessor_ptr = predecessor_ptr -> 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 -> node.left.link; thread = root_ptr -> 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 & ^success); /* Branch left for smaller or right for larger keys. If key matches, note success and remember pointers. */ if key > node_ptr -> node.key then do; thread = node_ptr -> node.right.thread; parent_ptr = node_ptr; node_ptr = node_ptr -> node.right.link; end; else if key < node_ptr -> node.key then do; thread = node_ptr -> node.left.thread; parent_ptr = node_ptr; node_ptr = node_ptr -> 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 -> node.right.link; if node_ptr -> 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 -> node.left.thread); successor_parent_ptr = successor_ptr; successor_ptr = successor_ptr -> 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 (>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 & 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 & ^(verify (arg, "-0123456789.") = 0 & 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 <= 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 < 0 then do; call com_err_ (error_table_$bad_conversion, PROC_NAME, "^/The quiesce wait time ^a is negative, wait times must be >= 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 & ^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>^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) || ">" || 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>^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 */ & 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 < 1 | type_of_object_restructured > RMDB_REL_TYPE then do; code = error_table_$action_not_performed; call ioa_$rs ("type of object restructured indicator <^i> 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 < 1 | operation > RMDB_RN_REL_OP then do; code = error_table_$action_not_performed; call ioa_$rs ("type of operation indicator <^i> 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 -> db_model.dbm_area); new_rmdb_history_entry_ptr -> rmdb_history_entry.user_id = get_group_id_ (); new_rmdb_history_entry_ptr -> rmdb_history_entry.date_time_restructured = clock; new_rmdb_history_entry_ptr -> rmdb_history_entry.type_of_object_restructured = type_of_object_restructured; new_rmdb_history_entry_ptr -> rmdb_history_entry.object_name = object_name; new_rmdb_history_entry_ptr -> rmdb_history_entry.operation = operation; new_rmdb_history_entry_ptr -> rmdb_history_entry.secondary_object_name = secondary_object_name; new_rmdb_history_entry_ptr -> 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 -> db_model.first_restructuring_history_offset = NULL_OFFSET then do; db_model_ptr -> db_model.first_restructuring_history_offset = rel (new_rmdb_history_entry_ptr); new_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_previous_entry = NULL_OFFSET; end; else do; last_rmdb_history_entry_ptr = pointer (db_model_ptr, db_model_ptr -> db_model.last_restructuring_history_offset); last_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_next_entry = rel (new_rmdb_history_entry_ptr); new_rmdb_history_entry_ptr -> rmdb_history_entry.offset_to_previous_entry = db_model_ptr -> db_model.last_restructuring_history_offset; end; db_model_ptr -> 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 -> 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 > 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 -> 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)) > 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)) > 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 -> 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 -> file_model.relation_copy_good = "1"b; new_file_model_ptr -> 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) -> 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 & element_id_list.number_of_elements > 0 then do loop = 1 repeat loop + 1 while (loop <= element_id_list.number_of_elements & 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 .k to .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 -> like_file_model = init_file_model; new_file_model_ptr -> file_model.fm_area = empty (); new_file_model_ptr -> file_model.changer_ptr = db_model.changer_ptr; allocate rel_info in (new_file_model_ptr -> file_model.fm_area) set (ri_ptr); new_file_model_ptr -> 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 -> file_info.file_name = create_relation_name; new_file_info_ptr -> file_info.file_id = "000000000000000000000000000000000001"b; new_file_info_ptr -> file_info.fwd_ptr = NULL_OFFSET; new_file_model_ptr -> 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 -> 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 -> 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 -> 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 -> unreferenced_attribute.name = create_attr_info.attribute (attribute_index).name; new_ua_ptr -> unreferenced_attribute.domain_ptr = crossref_info_record.offset; new_ua_ptr -> unreferenced_attribute.fwd_thread = NULL_OFFSET; /* Mark the domain in db_model referenced */ di_ptr = ptr (dbm_ptr, new_ua_ptr -> 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 -> 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 => 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 (*)