mtape_.alm 02/16/84 1306.5r w 02/16/84 1249.6 9270 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " Transfer vector for mtape_ " " Modification History: " " Created by J. A. Bush 07/10/83 name mtape_ macro transfer segdef &1 &1: getlp tra &2$&1 &end transfer mtape_attach,mtape_iox_ transfer allocate_buffers,mtape_io_ transfer flush_buffers,mtape_io_ transfer order,mtape_io_ transfer read_block,mtape_io_ transfer read_label,mtape_io_ transfer set_mode,mtape_io_ transfer stop_tape,mtape_io_ transfer write_block,mtape_io_ transfer write_label,mtape_io_ transfer demount,mtape_mount_cntl_ transfer mount,mtape_mount_cntl_ transfer volume_switch,mtape_mount_cntl_ transfer alloc,mtape_util_ transfer error,mtape_util_ transfer user_query,mtape_util_ transfer mtape_cv_apd,mtape_cv_apd end  mtape_check_status_.pl1 12/01/87 0801.0rew 11/30/87 1323.9 68778 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Added checks to return on write errors and reposition the tape on read errors. 2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. END HISTORY COMMENTS */ mtape_check_status_: proc (arg_mtdp, arg_code); /* format: style4 */ /* * This program performs certain "last ditch" exception recovery * functions for mtape_. In particular, automatic recovery from device * attention and power off are attempted from within this module. * * Modification History: * * Created by J. A. Bush 11/11/83 */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl 1 save_position like mtape_data.position aligned; /* CONSTANT DATA */ dcl DEV_ATT_MSG char (64) int static options (constant) init ("Attempting recovery from device attention condition."); dcl PWR_OFF_MSG char (64) int static options (constant) init ("Attempting recovery from power off condition."); /* EXTERNAL STATIC DATA */ dcl error_table_$device_attention fixed bin (35) ext static; dcl error_table_$device_parity fixed bin (35) ext static; dcl error_table_$unable_to_do_io fixed bin (35) ext static; dcl mtape_dev_attention_recovery condition; /* BUILTIN FUNCTIONS */ dcl null builtin; /* EXTERNAL ENTRIES */ dcl mtape_util_$error entry options (variable); dcl mtape_mount_cntl_$remount entry (ptr, fixed bin (35)); dcl mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); /* BASED VARIABLES */ dcl based_area area based (mtape_data.areap); %page; /* Beginning of mtape_check_status_ entry */ mtdp = arg_mtdp; /* copy args */ vs_ptr = mtape_data.vs_current; mpfmip = mtape_data.pfm_info_ptr; moip = mtape_data.open_info_ptr; /* save current file and block pos. */ save_position = mtape_data.position; /* allocate area to store status */ allocate ths in (based_area) set (ths_ptr); mtape_data.last_ur_status_ptr = ths_ptr; ths.version = THS_VERSION; call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "^/mtape_check_status_: error from tape_ioi_$hardware_status"); return; end; if ths.major = DEVICE_ATTENTION & (ths.minor = HANDLER_IN_STANDBY | ths.minor = NO_SUCH_HANDLER | ths.minor = HANDLER_CHECK) & arg_code ^= error_table_$device_parity then do; call MSG_OUT ("Unrecoverable error"); if ths.minor = HANDLER_CHECK then arg_code = error_table_$unable_to_do_io; else arg_code = error_table_$device_attention; end; else /* if apparent pwr off, see if recoverable recursion not allowed */ if ths.major = POWER_OFF then do; if mtape_vol_set.pwr_off_retry then do; call mtape_util_$error (mtdp, 0, "^/Recovery of PWR OFF status condition unsuccessful"); arg_code = error_table_$unable_to_do_io; end; else do; mtape_vol_set.pwr_off_retry = "1"b; arg_code = error_table_$device_attention; /* Tell user and operator about the error and that we are atempting recovery. */ call MSG_OUT ("Power off condition"); call mtape_util_$error (mtdp, 0, PWR_OFF_MSG); mtape_vol_set.demount_comment = PWR_OFF_MSG; call RECOVERY; /* attempt recovery */ arg_code = code; end; end; else if ths.major = DEVICE_ATTENTION & (mtape_open_info.open_mode = Sequential_input | mtape_open_info.open_mode = Stream_input) then do; if mtape_vol_set.dev_att_retry then do; call mtape_util_$error (mtdp, 0, "^/Recovery of DEV ATT status condition unsuccessful"); arg_code = error_table_$unable_to_do_io; end; else do; /* protect against recursion */ mtape_vol_set.dev_att_retry = "1"b; mtape_vol_set.demount_comment = DEV_ATT_MSG; /* Tell user and operator about the error and that we are attempting recovery. */ call MSG_OUT ("Device Attention condition"); call mtape_util_$error (mtdp, 0, DEV_ATT_MSG); call RECOVERY; /* attempt recovery */ arg_code = code; /* should not return here unless recovery unsuccessful */ end; end; else /* Report it, unless PFM wants it */ if ^mtape_pfm_info.extended_error_recovery then do; call MSG_OUT ("Unrecoverable error"); arg_code = error_table_$unable_to_do_io; end; free ths in (based_area); mtape_data.last_ur_status_ptr = null; return; %page; /* RECOVERY - subroutine to attempt recovery from dev attention/pwr off condition */ RECOVERY: proc; if mtape_vol_set.pwr_off_retry | save_position.phy_file < 3 then do; call mtape_mount_cntl_$remount (mtdp, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "^/Remount of volume ^a unsuccessful, while attempting error recovery", mtape_vol_set.volume_name); arg_code = code; /* return this error code */ return; end; mtape_vol_set.demount_comment = ""; /* Do file position if necessary */ if save_position.phy_file ^= 0 then do; call mtape_io_$order (mtdp, "fsf", save_position.phy_file, null, code); if code ^= 0 then return; end; /* Do block position if necessary */ if save_position.phy_block ^= 0 then do; call mtape_io_$order (mtdp, "fsr", save_position.phy_block, null, code); if code ^= 0 then return; end; end; else do; /* Move the tape back 2 and forward 2. The effect is to clean the fuzz off of the tape heads. DO NOT EVER REMOVE THIS CODE. */ code = 0; call mtape_io_$order (mtdp, "bsf", 2, null, code); if code ^= 0 then return; call mtape_io_$order (mtdp, "fsf", 2, null, code); if code ^= 0 then return; /* Do block position if necessary */ if save_position.phy_block ^= 0 then do; call mtape_io_$order (mtdp, "fsr", save_position.phy_block, null, code); if code ^= 0 then return; end; end; signal mtape_dev_attention_recovery; return; end RECOVERY; /* MSG_OUT - subroutine to output common formatted error message */ MSG_OUT: proc (preamble); dcl preamble char (*); /* display common msg format */ call mtape_util_$error (mtdp, arg_code, "^/^a detected on volume ^a, mounted on device ^a. Physical position: file # ^d, block # ^d. Hardware status: ""^a"".", preamble, mtape_vol_set.volume_name, mtape_vol_set.device_name, save_position.phy_file, save_position.phy_block + 1, ths.description); return; end MSG_OUT; %page; %include mtape_data; %page; %include mtape_vol_set; %page; %include mtape_err_stats; %page; %include mtape_constants; %page; %include mtape_pfm_info; %page; %include mtape_open_close_info; %page; %include iox_modes; %page; %include tape_ioi_dcls; %page; %include tape_ioi_hw_status; end mtape_check_status_;  mtape_control_.pl1 12/17/86 0925.7r w 12/17/86 0830.0 276624 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ mtape_control_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. * * Modification History: * * Created by J. A. Bush 10/05/82 * Modified by J. A. Bush 12/01/83 to update error statistics before * gathering information for volume_("" set_)status operations. */ /* ARGUMENT DATA */ dcl arg_iocbp ptr; /* Input IOCB Pointer */ dcl arg_order_name char (*); /* Input control order name */ dcl arg_info_ptr ptr; /* Input control order info pointer */ dcl arg_code fixed bin (35); /* Return error code */ /* AUTOMATIC DATA */ dcl iocbp ptr; /* Auto copy of IOCB pointer */ dcl order_name char (32); /* Auto copy of control order name */ dcl info_ptr ptr; /* Auto copy of control order info pointer */ dcl code fixed bin (35); dcl (cox, i) fixed bin; dcl open bit (1) aligned; dcl nvp ptr; dcl vol_string char (128); dcl short_info char (8) aligned; dcl long_info char (100) aligned; /* CONSTANT DATA */ dcl myname char (6) int static options (constant) init ("mtape_"); dcl ORDER_NAMES (16) char (19) int static options (constant) init ("change_module", "cmod", "file_set_status", "fsst", "file_status", "fst", "force_end_of_volume", "feov", "hardware_status", "hwst", "ring_in", "rin", "volume_set_status", "vsst", "volume_status", "vst"); /* EXTERNAL STATIC DATA */ dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_open fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, convert, hbound, lbound, ltrim, null, rtrim, size, substr, sum, unspec) builtin; /* EXTERNAL ENTRIES */ dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr); dcl mtape_util_$error entry options (variable); dcl mtape_util_$get_statistics entry (ptr, fixed bin (35)); dcl mtape_util_$init_pfm entry (ptr, fixed bin (35)); dcl mtape_mount_cntl_$demount entry (ptr, fixed bin (35)); dcl mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl iox_$propagate entry (ptr); /* BASED STORAGE */ dcl based_area area based (mtape_data.areap); dcl order_arg char (32) varying based (info_ptr); %page; /* control - entry to implement the iox_$control entry point */ control: entry (arg_iocbp, arg_order_name, arg_info_ptr, arg_code); iocbp = arg_iocbp -> iocb.actual_iocb_ptr; /* copy arguments */ mtdp = iocbp -> iocb.attach_data_ptr; /* get ptr to our data structure */ mtape_data.iocb_ptr = iocbp; /* save our IOCB ptr */ maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; code, arg_code = 0; /* Reset return code */ if arg_order_name = "io_call" then do; /* execute order on behalf of io_call? */ io_call_infop = arg_info_ptr; /* yes, set info ptr to io_call structure */ order_name = io_call_info.order_name; /* copy target order */ if io_call_info.nargs ^= 0 then /* if target order has args */ info_ptr = addr (io_call_info.args (1));/* point to first 1 */ else info_ptr = null; /* allocate any structures in my area */ end; else do; /* not called from io_call */ io_call_infop = null; /* null => not called from io_call */ order_name = arg_order_name; info_ptr = arg_info_ptr; end; /* First call the PFM and see if he wants to handle the control order */ call mtape_data.order (mtdp, order_name, info_ptr, io_call_infop, code); if code ^= error_table_$no_operation then /* he either did it or */ go to CONTROL_OP_END; /* got another error, return */ code = 0; /* give mtape_ proper a chance */ /* PFM passed the buck back to us, does it stop here? */ if iocbp -> iocb.open_descrip_ptr ^= null then /* is file open now? */ open = "1"b; /* yes, set flag */ else open = "0"b; /* no I/O switch is closed */ do cox = hbound (ORDER_NAMES, 1) to lbound (ORDER_NAMES, 1) by -1 /* find the right control order */ while (order_name ^= ORDER_NAMES (cox)); end; go to CONTROL_OP (cox); /* go process found control operation */ CONTROL_OP (0): /* unrecognized by mtape_ */ code = error_table_$no_operation; code = error_table_$no_operation; go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (1): /* "change_module" operation */ CONTROL_OP (2): /* "cmod" operation */ call CHECK_CLOSED; /* I/O switch must be closed */ if info_ptr ^= null then do; /* Non-null means to "push" a new PFM */ if mtape_data.saved_pfm_info_ptr = null then do; /* must allocate a structure */ allocate mtape_saved_pfm_info in (based_area) set (mspfmip); mtape_data.saved_pfm_info_ptr = mspfmip;/* save ptr */ mtape_saved_pfm_info.version = mtape_saved_pfm_info_version_1; /* and set version */ end; mtape_saved_pfm_info.pfm_name = mtape_attach_info.pfm_prefix; /* save the old PFM prefix */ mtape_saved_pfm_info.old_pfm_entries = mtape_data.pfm_required_entries; /* and PFM entries */ mtape_attach_info.pfm_prefix = order_arg; end; else do; /* Null info ptr, this is a "POP" request */ mspfmip = mtape_data.saved_pfm_info_ptr; /* get saved info */ mtape_attach_info.pfm_prefix = mtape_saved_pfm_info.pfm_name; end; call mtape_util_$init_pfm (mtdp, code); /* search for new PFM */ if code ^= 0 then do; /* if some error, restore other PFM */ mtape_data.pfm_required_entries = mtape_saved_pfm_info.old_pfm_entries; go to CONTROL_OP_END; end; free mtape_data.tlb -> mtape_label_record in (based_area); /* free up label buffer */ mtape_data.tlb = null; /* this causes PFM to go through initialzation properly */ call mtape_data.pfm_init (mtdp, code); /* init the new PFM */ if code ^= 0 then do; /* couldn't init it */ mtape_data.pfm_required_entries = mtape_saved_pfm_info.old_pfm_entries; go to CONTROL_OP_END; end; mtape_data.first_file = "0"b; /* reset for consistency checks */ go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (3): /* "file_set_status" operation */ CONTROL_OP (4): /* "fsst" operation */ call CHECK_VERSION (fsst_version_1); /* check version if user allocated structure */ if mtape_data.fi_head = null then do; /* never been opened */ code = error_table_$no_file; call mtape_util_$error (mtdp, code, "^/The file set has not been opened during this attachment"); go to CONTROL_OP_END; end; if info_ptr = null then do; /* we have to allocate the structure ourselves */ mtape_fsst_nfiles = 0; /* first we have to determine the # of files */ do fi_ptr = mtape_data.fi_head repeat mtape_file_info.next_fi_ptr while (fi_ptr ^= null); if mtape_file_info.section = 1 then /* only count whole files */ mtape_fsst_nfiles = mtape_fsst_nfiles + 1; /* increment number of files */ end; if mtape_fsst_nfiles = 0 then do; /* no files processed yet */ code = error_table_$no_file; /* set real error code later */ go to CONTROL_OP_END; end; allocate mtape_fsst in (based_area) set (fsst_ptr); /* allocate the structure */ mtape_fsst.version = fsst_version_1; /* set version number */ end; else fsst_ptr = info_ptr; /* otherwise use user structure */ mtape_fsst.file_set_id = mtape_data.fi_head -> mtape_file_info.file_set_id; /* set file set id */ mtape_fsst.file_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */ mtape_fsst_nfiles = 0; do fi_ptr = mtape_data.fi_head repeat mtape_file_info.next_fi_ptr while (fi_ptr ^= null); if mtape_file_info.section = 1 then do; /* only count whole files */ mtape_fsst_nfiles = mtape_fsst_nfiles + 1; /* increment number of files */ f_statp = addr (mtape_fsst.fs_stat (mtape_fsst_nfiles)); /* set file_status ptr */ call SET_FILE_STATUS; /* copy the file status for this file */ end; end; mtape_fsst.nfiles = mtape_fsst_nfiles; /* set number of files for refer extent */ if io_call_infop ^= null then do; /* if called from io_call, display the structure */ call io_call_info.report ("File Set Status for ""^a"" file set ""^a"", number of files - ^d.", Tape_volume_types (mtape_fsst.file_type), mtape_fsst.file_set_id, mtape_fsst.nfiles); do i = 1 to mtape_fsst.nfiles; /* iterate through each file */ f_statp = addr (mtape_fsst.fs_stat (i));/* set ptr to current structure */ call DISPLAY_FILE_STATUS; /* do the display for each file */ end; free mtape_fsst in (based_area); /* free the file status structure */ end; else if info_ptr = null then /* if the user let us allocate the structure */ arg_info_ptr = fsst_ptr; /* return pointer to allocated structure */ go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (5): /* "file_status" operation */ CONTROL_OP (6): /* "fst" operation */ call CHECK_VERSION (fst_version_1); /* check version if user allocated structure */ if mtape_data.fi_current = null then do; /* never been opened */ code = error_table_$no_file; call mtape_util_$error (mtdp, code, "^/The file set has not been opened during this attachment"); go to CONTROL_OP_END; end; if info_ptr = null then do; /* we have to allocate the structure ourselves */ allocate mtape_fst in (based_area) set (fst_ptr); /* allocate the structure */ mtape_fst.version = fst_version_1; /* set version number */ end; else fst_ptr = info_ptr; /* otherwise use user structure */ mtape_fst.file_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */ fi_ptr = mtape_data.fi_current; /* set up for current file */ f_statp = addr (mtape_fst.f_stat); /* set file_status ptr */ call SET_FILE_STATUS; /* copy the file status for this file */ if io_call_infop ^= null then do; /* if called from io_call, display the structure */ call io_call_info.report ("Status of current File for ""^a"" file set", Tape_volume_types (mtape_fst.file_type)); call DISPLAY_FILE_STATUS; /* do the display for each file */ free mtape_fst in (based_area); /* free the file status structure */ end; else if info_ptr = null then /* if the user let us allocate the structure */ arg_info_ptr = fst_ptr; /* return pointer to allocated structure */ go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (7): /* "force_end_of_volume" operation */ CONTROL_OP (8): /* "feov" operation */ if ^open | /* I/O switch must be open for output */ (open & mtape_open_info.open_mode ^= Sequential_output & mtape_open_info.open_mode ^= Stream_output) then do; code = error_table_$not_open; /* set an appropriate error code */ call mtape_util_$error (mtdp, code, "^/The ""^a"" control operation requires that the I/O switch be open for output", order_name); end; else do; mtape_data.force_end_of_volume = "1"b; /* simulate EOT marker */ mtape_data.arg_buf_ptr = null; /* set up to flush buffers */ mtape_data.arg_buf_len = 0; call mtape_data.write (mtdp, code); /* flush out buffers, and do volume switch */ end; go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (9): /* "hardware_status" operation */ CONTROL_OP (10): /* "hwst" operation */ call CHECK_VERSION (hwst_version_1); /* check version if user allocated structure */ if info_ptr = null then do; /* we have to allocate the structure ourselves */ allocate mtape_hardware_status in (based_area) set (hwst_ptr); /* allocate the structure */ mtape_hardware_status.version = hwst_version_1; /* set version number */ end; else hwst_ptr = info_ptr; /* otherwise use user structure */ call SET_HARDWARE_STATUS; /* copy the hardware status */ if io_call_infop ^= null then do; /* if called from io_call, display the structure */ call DISPLAY_HARDWARE_STATUS; /* display last hardware status */ free mtape_hardware_status in (based_area); /* free the file status structure */ end; else if info_ptr = null then /* if the user let us allocate the structure */ arg_info_ptr = hwst_ptr; /* return pointer to allocated structure */ go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (11): /* "ring_in" operation */ CONTROL_OP (12): /* "rin" operation */ call CHECK_CLOSED; /* I/O switch must be closed */ if ^mtape_attach_info.ring then do; /* if a ring already in, this is a NOP */ call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, size (mtape_data) * 4, mtape_data.cmtdp); mtape_data.cmtdp -> mtape_data = mtape_data; /* allocate and copy control structure */ mtdp, iocbp -> iocb.attach_data_ptr = mtape_data.cmtdp; /* use copy */ call iox_$propagate (iocbp); /* let iox_ know about iocb change */ nvp = mtape_data.vs_current; /* save current volume ptr */ do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null); if mtape_vol_set.mounted then do; /* if volume currently mounted... */ mtape_data.vs_current = vs_ptr; /* set current volume set ptr */ mtape_data.tioi_id = mtape_vol_set.tioi_id; /* just to be sure */ call mtape_io_$order (mtdp, "rwnw", 0, null, code); /* rewind volume */ call mtape_mount_cntl_$demount (mtdp, code); /* demount the volume */ end; end; code = 0; mtape_data.lab_bufp = null; /* avoid invalid ptrs */ mtape_data.tioi_id = "0"b; /* reset this constant */ mtape_data.vs_current = nvp; /* restore current volume ptr */ mtape_attach_info.ring = "1"b; /* and set the write ring flag */ end; go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (13): /* "volume_set_status" operation */ CONTROL_OP (14): /* "vsst" operation */ call CHECK_VERSION (vsst_version_1); /* check version if user allocated structure */ if info_ptr = null then do; /* we have to allocate the structure ourselves */ mtape_vsst_nvolumes = 0; /* vsrst we have to determine the # of volumes */ do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null); mtape_vsst_nvolumes = mtape_vsst_nvolumes + 1; /* increment number of volumes */ end; if mtape_vsst_nvolumes = 0 then do; /* no volumes processed yet */ code = error_table_$no_operation; /* set real error code later */ go to CONTROL_OP_END; end; allocate mtape_vsst in (based_area) set (vsst_ptr); /* allocate the structure */ mtape_vsst.version = vsst_version_1; /* set version number */ end; else vsst_ptr = info_ptr; /* otherwise use user structure */ mtape_vsst.volume_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */ mtape_vsst_nvolumes = 0; do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null); mtape_vsst_nvolumes = mtape_vsst_nvolumes + 1; /* increment number of volumes */ v_statp = addr (mtape_vsst.vs_stat (mtape_vsst_nvolumes)); /* set volume status ptr */ call SET_VOLUME_STATUS; /* copy the volume status for this volume */ end; mtape_vsst.nvolumes = mtape_vsst_nvolumes; /* set number of volumes for refer extent */ if io_call_infop ^= null then do; /* if called from io_call, display the structure */ call io_call_info.report ("Volume Set Status for ""^a"" volume set, number of volumes - ^d.", Tape_volume_types (mtape_vsst.volume_type), mtape_vsst.nvolumes); do i = 1 to mtape_vsst.nvolumes; /* iterate through each volume */ v_statp = addr (mtape_vsst.vs_stat (i));/* set ptr to current structure */ call DISPLAY_VOLUME_STATUS; /* do the display for each volume */ end; free mtape_vsst in (based_area); /* free the volume status structure */ end; else if info_ptr = null then /* if the user let us allocate the structure */ arg_info_ptr = vsst_ptr; /* return pointer to allocated structure */ go to CONTROL_OP_END; /* take common exit */ CONTROL_OP (15): /* "volume_status" operation */ CONTROL_OP (16): /* "vst" operation */ call CHECK_VERSION (vst_version_1); /* check version if user allocated structure */ if info_ptr = null then do; /* we have to allocate the structure ourselves */ allocate mtape_vst in (based_area) set (vst_ptr); /* allocate the structure */ mtape_vst.version = vst_version_1; /* set version number */ end; else vst_ptr = info_ptr; /* otherwise use user structure */ mtape_vst.volume_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */ vs_ptr = mtape_data.vs_current; /* set up for current volume */ v_statp = addr (mtape_vst.v_stat); /* set volume_status ptr */ call SET_VOLUME_STATUS; /* copy the volume status for this volume */ if io_call_infop ^= null then do; /* if called from io_call, display the structure */ call io_call_info.report ("Status of current Volume for ""^a"" volume set", Tape_volume_types (mtape_vst.volume_type)); call DISPLAY_VOLUME_STATUS; /* do the display for each volume */ free mtape_vst in (based_area); /* free the volume status structure */ end; else if info_ptr = null then /* if the user let us allocate the structure */ arg_info_ptr = vst_ptr; /* return pointer to allocated structure */ CONTROL_OP_END: arg_code = code; /* return error code */ return; %page; /* CHECK_VERSION - internal procedure to check the structure version number for user allocated structures */ CHECK_VERSION: proc (req_version); dcl req_version char (8); dcl 1 version_check based (info_ptr) aligned, /* generic structure to check version number */ 2 version char (8); if info_ptr ^= null then /* if user has allocated his own structure */ if version_check.version ^= req_version then do; /* but the version number is wrong */ code = error_table_$unimplemented_version; /* set appropriate error code */ go to CONTROL_OP_END; /* take non-local goto to error return */ end; end CHECK_VERSION; /* CHECK_CLOSED - internal procedure to verify that I/O switch is closed */ CHECK_CLOSED: proc; if open then do; /* can't be open */ code = error_table_$not_closed; call mtape_util_$error (mtdp, code, "^/The ""^a"" control operation requires that the I/O switch be closed.", order_name); go to CONTROL_OP_END; /* take non-local goto and return */ end; end CHECK_CLOSED; %page; /* DISPLAY_HARDWARE_STATUS - internal procedure to display hardware status for io_call */ DISPLAY_HARDWARE_STATUS: proc; call io_call_info.report ("^/Last reported hardware status; Description:^/^a", mtape_hardware_status.description); call io_call_info.report ("^/I/O Status Words:^-^12.3b ^12.3b", substr (mtape_hardware_status.iom_status, 1, 36), substr (mtape_hardware_status.iom_status, 37, 36)); call io_call_info.report ("List Pointer Words:^-^12.3b ^12.3b", substr (mtape_hardware_status.iom_lpw, 1, 36), substr (mtape_hardware_status.iom_lpw, 37, 36)); end DISPLAY_HARDWARE_STATUS; %page; /* DISPLAY_FILE_STATUS - internal procedure to display file status for each file */ DISPLAY_FILE_STATUS: proc; dcl i fixed bin; call io_call_info.report ("^/File Number:^-^d", file_status.file_seq); call io_call_info.report ("File Name:^-^a", file_status.file_id); call io_call_info.report ("File State:^-^[Never opened^;Not open^;Open^;Open with error^]", file_status.file_state + 1); if file_status.error_code ^= 0 then do; call convert_status_code_ (file_status.error_code, short_info, long_info); call io_call_info.report ("File Code:^-^w (^a)", file_status.error_code, long_info); end; vol_string = ""; /* clear out volume name string */ i = 0; do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (i < file_status.end_vol_index); i = i + 1; /* increment volume index */ if i >= file_status.begin_vol_index then do; /* at beginning volume of file? */ if mtape_vol_set.volume_id ^= "" then /* if volume id has been set */ vol_string = rtrim (vol_string) || " " || mtape_vol_set.volume_id; else vol_string = rtrim (vol_string) || " " || mtape_vol_set.volume_name; end; end; vol_string = ltrim (vol_string); /* trim off leading white space */ call io_call_info.report ("File Sections:^-^d", file_status.file_sections); call io_call_info.report ("On Volume^[s^]:^-^a", (file_status.file_sections > 1), vol_string); if file_status.generation > 0 then /* if a gereration number exists */ call io_call_info.report ("Generation:^-^d^[; Generation Version:^-^d^;^1s^]", file_status.generation, (file_status.gen_version > 0), file_status.gen_version); if file_status.creation ^= " 00000" then /* if creation date exists.. */ call io_call_info.report ("Creation Date:^-^a", CV_DATE (file_status.creation)); if file_status.expiration ^= " 00000" then /* if expiration date exists.. */ call io_call_info.report ("Expiration Date:^-^a", CV_DATE (file_status.expiration)); call io_call_info.report ("File Format:^-^a", file_status.file_format); call io_call_info.report ("Block Length:^-^d", file_status.block_len); call io_call_info.report ("Record Length:^-^d", file_status.reclen); call io_call_info.report ("Recording Mode:^-^a", file_status.recording_mode); if file_status.block_count ^= 0 then call io_call_info.report ("Block Count:^-^d", file_status.block_count); call io_call_info.report ("Read Errors:^-^d", file_status.read_errors); call io_call_info.report ("Write Errors:^-^d", file_status.write_errors); end DISPLAY_FILE_STATUS; %page; /* SET_FILE_STATUS - internal procedure to copy the file status for this file */ SET_FILE_STATUS: proc; dcl i fixed bin; unspec (file_status) = "0"b; /* clear the structure first */ file_status.file_id = mtape_file_info.file_id; /* set appropriate fields */ file_status.file_seq = mtape_file_info.seq_number; file_status.generation = mtape_file_info.generation; file_status.gen_version = mtape_file_info.gen_version; file_status.creation = mtape_file_info.creation_date; file_status.expiration = mtape_file_info.expiration_date; file_status.file_format = mtape_file_info.file_code; file_status.block_len = mtape_file_info.block_size; file_status.reclen = mtape_file_info.record_size; file_status.block_count = mtape_file_info.block_count; file_status.read_errors = mtape_file_info.read_errors; file_status.write_errors = mtape_file_info.write_errors; if mtape_file_info.conversion = MTAPE_CV_EBCDIC then /* set proper recording mode */ file_status.recording_mode = "EBCDIC"; else if mtape_file_info.conversion = MTAPE_CV_BCD then file_status.recording_mode = "BCD"; else if mtape_file_info.conversion = MTAPE_NO_CONVERSION & mtape_file_info.hdw_mode = MTAPE_HWM_NINE then file_status.recording_mode = "ASCII"; else if mtape_file_info.hdw_mode = MTAPE_HWM_BIN then file_status.recording_mode = "BINARY"; else file_status.recording_mode = "******"; i = 0; /* reset volume count */ do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (file_status.end_vol_index = 0); i = i + 1; /* increment volume index */ if vs_ptr = mtape_file_info.begin_vs_ptr then file_status.begin_vol_index = i; if file_status.begin_vol_index ^= 0 then file_status.file_sections = file_status.file_sections + 1; if vs_ptr = mtape_file_info.end_vs_ptr then file_status.end_vol_index = i; end; if mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE then file_status.file_state = 1; else if ^open then file_status.file_state = 1; else if mtape_data.error_lock ^= 0 then /* if an error lock exists.. */ file_status.file_state = 3; else file_status.file_state = 2; file_status.error_code = mtape_data.error_lock; end SET_FILE_STATUS; %page; /* DISPLAY_VOLUME_STATUS - internal procedure to display volume status for each volume */ DISPLAY_VOLUME_STATUS: proc; call io_call_info.report ("^/Volume Name:^-^a", volume_status.volume_name); call io_call_info.report ("Volume ID:^-^a", volume_status.volume_id); call io_call_info.report ("Mounted:^2-^[Yes^;No^]", volume_status.mounted); if volume_status.device_name ^= "" then call io_call_info.report ("On Device:^-^a", volume_status.device_name); call io_call_info.report ("Volume Sequence:^-^d", volume_status.volume_index); if volume_status.mounts > 0 then do; /* if volume has ever been mounted */ if volume_status.mounts > 1 | ^volume_status.mounted then do; /* if not currently mounted | > 1 mount */ call io_call_info.report ("Total Volume Error Statistics^[ Across ^d Volume Mounts^;^1s^]:^/", (volume_status.mounts > 1), volume_status.mounts); call REPORT_ERR_STATS (addr (volume_status.tot_error_stats)); end; if volume_status.mounted then do; /* if volume currently mounted */ call io_call_info.report ("Volume Error Statistics For Current Mount:^/"); call REPORT_ERR_STATS (addr (volume_status.rel_error_stats)); end; end; end DISPLAY_VOLUME_STATUS; %page; /* SET_VOLUME_STATUS - internal procedure to copy the volume status for this volume */ SET_VOLUME_STATUS: proc; volume_status.volume_name = mtape_vol_set.volume_name; /* copy volume info */ volume_status.volume_id = mtape_vol_set.volume_id; volume_status.mounted = mtape_vol_set.mounted; volume_status.volume_index = mtape_vol_set.volume_index; volume_status.device_name = mtape_vol_set.device_name; volume_status.mounts = mtape_vol_set.mounts; if open & mtape_data.tioi_id = mtape_vol_set.tioi_id then do; /* update error stats */ if mtape_open_info.open_mode = Sequential_output | mtape_open_info.open_mode = Stream_output then do; /* currently open for output */ mtape_data.arg_buf_ptr = null; /* set up to flush out buffers */ mtape_data.arg_buf_len = 0; call mtape_data.write (mtdp, code); /* flush out buffers */ end; call mtape_util_$get_statistics (mtdp, code);/* update error stats */ end; volume_status.tot_error_stats = mtape_vol_set.tot_error_stats; volume_status.rel_error_stats = mtape_vol_set.rel_error_stats; end SET_VOLUME_STATUS; /* REPORT_ERR_STATS - internal procedure to format error statistics for io_call */ REPORT_ERR_STATS: proc (esp); dcl esp ptr; dcl i fixed bin; es_ptr = esp; call io_call_info.report ("Operation^20tNumber Processed^40tErrors^/"); if mtape_err_stats.read.operations > 0 then /* Where any reads done? */ call io_call_info.report ("Read^20t^d^40t^d", mtape_err_stats.read.operations, mtape_err_stats.read.errors); if mtape_err_stats.write.operations > 0 then /* Where any writes done? */ call io_call_info.report ("Write^20t^d^40t^d", mtape_err_stats.write.operations, mtape_err_stats.write.errors); if mtape_err_stats.orders.operations > 0 then /* Where any orders done? */ call io_call_info.report ("Non-data Xfer Cmds^20t^d^40t^d", mtape_err_stats.orders.operations, mtape_err_stats.orders.errors); if sum (mtape_err_stats.successful_retry) > 0 then do; /* Do not display unless we have some */ call io_call_info.report ("^/Successful Read Error Recovery Stratagy^/"); call io_call_info.report ("IDCW Chn Cmd^20tSuccessful Recoverys^/"); do i = hbound (mtape_err_stats.successful_retry, 1); if mtape_err_stats.successful_retry (i) > 0 then /* only display case if retrys */ call io_call_info.report ("^5x3^d^20t^d", i, mtape_err_stats.successful_retry (i)); end; end; end REPORT_ERR_STATS; %page; /* SET_HARDWARE_STATUS - internal procedure to obtain last hardware status from tape_ioi_ and fill in mtape_hardware_status structure */ SET_HARDWARE_STATUS: proc; allocate ths in (based_area) set (ths_ptr); /* allocate tape_ioi_ status structure */ ths.version = THS_VERSION_1; /* set proper version number */ call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Error from tape_ioi_$hardware_status."); go to CONTROL_OP_END; end; mtape_hardware_status.description = ths.description; /* now fill in our structure */ mtape_hardware_status.iom_status = ths.iom; mtape_hardware_status.iom_lpw = ths.lpw; free ths in (based_area); /* free up tape_ioi_ structure */ end SET_HARDWARE_STATUS; %page; /* CV_DATE - function to convert julian date (yyddd) to month/day/year */ CV_DATE: proc (julian) returns (char (10) aligned); dcl julian char (6) aligned; /* date in form: " yyddd" */ dcl clock fixed bin (71), (month, day, year) fixed bin, (Cmonth, Cday, Cyear) pic "99", date_time char (10) aligned, code fixed bin (35); dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)), encode_clock_value_$offsets entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (71), fixed bin (35)); year = convert (year, substr (julian, 2, 2)); day = convert (day, substr (julian, 4, 3)); call encode_clock_value_$offsets (0, 0, day - 1, year - 1, 0, 0, 0, 0, 0, "gmt", clock, code); if code ^= 0 then return ("unknown"); call decode_clock_value_$date_time (clock, month, day, year, 0, 0, 0, 0, 0, "gmt", code); if code ^= 0 then return ("unknown"); Cmonth = month; Cday = day; Cyear = year - 1900; date_time = Cmonth || "/" || Cday || "/" || Cyear; return (date_time); end CV_DATE; %page; %include iocb; %page; %include mtape_data; %page; %include mtape_attach_info; %page; %include mtape_open_close_info; %page; %include mtape_file_info; %page; %include mtape_vol_set; %page; %include io_call_info; %page; %include rcp_volume_formats; %include mtape_saved_pfm_info; %page; %include mtape_file_status; %page; %include mtape_volume_status; %include mtape_err_stats; %page; %include mtape_hardware_status; %include iox_modes; %page; %include mtape_label_record; %page; %include mtape_constants; %page; %include tape_ioi_dcls; %page; %include tape_ioi_hw_status; end mtape_control_;  mtape_cv_apd.rd 03/17/86 1519.4r w 03/17/86 1430.1 436653 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* DESCRIPTION: This command takes an argument processing definition (APD) from a source file and translates the information specified by that source into a form readily useable by the argument processing routine process_arguments_. The result, called a print vector array, is stored into a value segment specified by the user. The information in the source file must be specified in the APD language whose grammar is described elsewhere. The syntax of the command is as follows: mtape_cv_apd {-source} path {{-target} path} {-control_arg} where -control_arg may be -replace or -no_replace and designates whether or not to replace the APD if it already exists in the target database. The source file must have the "mapd" suffix and the target file must be a value segment with the "value" suffix. The result print_vector_array contains print_vectors of the following composition: 1) Initial vector: definition order * command name * default linear form initial implied option explanation validate result validate result explanation 2) Option vector: definition order * command name * option * initial argument next implied option excluded option unexcluded option presence required /~* takes no value *~/ 3) Option name vector: definition order * command name * option * synonym * negative form /~* takes no value *~/ 4) Argument vector: definition order * command name * option * argument * next argument presence required /~* takes no value *~/ validation string default value negative value explanation * Required dimensions Note that this program does no validity or consistency checking of the info that the user feeds it. This should be added in the future. */ /* HISTORY: Written by S. Krupp, 03/01/83. Modified: 07/25/83 by Lindsey Spratt: Changed to put the definition in a value segment instead of a vector db. The default linear form is now stored separately in the value seg, rather than as part of the definition pva. 08/05/83 by S. Krupp: Changed name from cvapd to mtape_cv_apd. Changed source segment suffix from "cvapd" to "mapd". 08/26/83 by S. Krupp: Added the "Force_literal" and "Validate_explanation" statements. */ %page; /*++ INCLUDE NEXT_STMT \ INCLUDE ERROR \ BEGIN initial_definition / Program_name : / LEX(2) PUSH(initial_stmt_list) / program_name_stmt \ / / ERROR(2) NEXT_STMT / initial_stmt_list \ / / ERROR(3) / error_return \ initial_stmt_list / Explanation : / LEX(2) PUSH(initial_stmt_list) / explanation_stmt \ / Default_linear_form : / LEX(2) PUSH(initial_stmt_list) / default_linear_form_stmt \ / Initial_implied_option : / LEX(2) PUSH(initial_stmt_list) / initial_implied_option_stmt \ / Validate_result : / LEX(2) PUSH(initial_stmt_list) / validate_result_stmt \ / Validate_result_explanation : / LEX(2) PUSH(initial_stmt_list) / validate_result_explanation_stmt \ / / / end_or_opt \ / / ERROR(4) / error_return \ end_or_opt / End ; / NEXT_STMT / return \ / Option : / / option_definition \ / / ERROR(10) NEXT_STMT / initial_stmt_list \ option_definition / Option : / LEX(2) PUSH(per_option_stmt_list) / option_stmt \ per_option_stmt_list / Option_name : / LEX(2) PUSH(per_option_stmt_list) / option_name_stmt \ / First_argument : / LEX(2) PUSH(per_option_stmt_list) / first_argument_stmt \ / Antonym : / LEX(2) PUSH(per_option_stmt_list) / antonym_stmt \ / Explanation : / LEX(2) PUSH(per_option_stmt_list) / explanation_stmt \ / Exclude : / LEX(2) PUSH(per_option_stmt_list) / exclude_stmt \ / Unexclude : / LEX(2) PUSH(per_option_stmt_list) / unexclude_stmt \ / Presence : / LEX(2) PUSH(per_option_stmt_list) / presence_stmt \ / Next_implied_option : / LEX(2) PUSH(per_option_stmt_list) / next_implied_option_stmt \ / / / per_opt_end_or_opt_or_arg \ / / ERROR(4) / error_return \ per_opt_end_or_opt_or_arg / End ; / [if default_exclude_myself then call add_to_vector(option, EXCLUDED_OPTION)] NEXT_STMT / return \ / Option : / [if default_exclude_myself then call add_to_vector(option, EXCLUDED_OPTION)] / option_definition \ / Argument : / [if default_exclude_myself then call add_to_vector(option, EXCLUDED_OPTION)] / argument_definition \ / / ERROR(11) NEXT_STMT / per_option_stmt_list \ / / ERROR(4) / error_return \ argument_definition / Argument : / LEX(2) PUSH(per_argument_stmt_list) / argument_stmt \ per_argument_stmt_list / Validate : / LEX(2) PUSH(per_argument_stmt_list) / validate_stmt \ / Validate_explanation : / LEX(2) PUSH(per_argument_stmt_list) / validate_explanation_stmt \ / Default_value : / LEX(2) PUSH(per_argument_stmt_list) / default_value_stmt \ / Antonym_value : / LEX(2) PUSH(per_argument_stmt_list) / antonym_value_stmt \ / Presence : / LEX(2) PUSH(per_argument_stmt_list) / presence_stmt \ / Next_argument : / LEX(2) PUSH(per_argument_stmt_list) / next_argument_stmt \ / Explanation : / LEX(2) PUSH(per_argument_stmt_list) / explanation_stmt \ / Force_literal : / LEX(2) PUSH(per_argument_stmt_list) / force_literal_stmt \ / / / per_arg_end_or_opt_or_arg \ / / ERROR(4) / error_return \ per_arg_end_or_opt_or_arg / End ; / NEXT_STMT / return \ / Option : / / option_definition \ / Argument : / / argument_definition \ / / ERROR(13) NEXT_STMT / per_argument_stmt_list \ / / ERROR(4) / error_return \ cum_quoted_comma_list cum_quoted_comma_list_next / , / ERROR(12) NEXT_STMT / STACK_POP \ / ; / ERROR(12) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ / / append_to_str(token_value, expanded_token_len, expanded_token_ptr) LEX(1) / cum_quoted_comma_list_punc \ / / ERROR(12) NEXT_STMT / STACK_POP \ cum_quoted_comma_list_punc / , / LEX(1) / cum_quoted_comma_list_next \ / ; / [if list_dim = DEFAULT_LINEAR_FORM then call set_name (expanded_token, default_linear_form_length, default_linear_form_ptr); else call add_to_vector(expanded_token, list_dim); call reset_name(expanded_token_len, expanded_token_ptr)] NEXT_STMT / STACK_POP \ / / ERROR(12) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ comma_list comma_list_next / , / ERROR(12) NEXT_STMT / STACK_POP \ / ; / ERROR(12) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ / / add_to_vector(token_value, list_dim) LEX(1) / \ / , / LEX(1) / comma_list_next \ / ; / NEXT_STMT / STACK_POP \ / / ERROR(12) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ return / / ERROR(5) / RETURN \ / / / RETURN \ error_return / / / RETURN \ / / / RETURN \ stmts program_name_stmt / ; / [call set_name(token_value, command_name_len, command_name_ptr); call start_vector(INITIAL_VECTOR)] NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ explanation_stmt / / [list_dim = EXPLANATION] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ default_linear_form_stmt / / [list_dim = DEFAULT_LINEAR_FORM] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ initial_implied_option_stmt / ; / add_to_vector(token_value, INITIAL_IMPLIED_OPTION) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ option_stmt / ; / [call set_name(token_value, option_len, option_ptr); call reset_name(argument_len, argument_ptr); call start_vector(OPTION_VECTOR); default_exclude_myself = "1"b] NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ option_name_stmt / / [list_dim = SYNONYM] / comma_list \ / / ERROR(4) / error_return \ first_argument_stmt / ; / add_to_vector(token_value, INITIAL_ARGUMENT) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ antonym_stmt / / [list_dim = NEGATIVE_FORM] / comma_list \ / / ERROR(4) / error_return \ exclude_stmt / / [list_dim = EXCLUDED_OPTION] / comma_list \ / / ERROR(4) / error_return \ unexclude_stmt / / [list_dim = UNEXCLUDED_OPTION] / comma_list \ / / ERROR(4) / error_return \ presence_stmt / required ; / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT / STACK_POP \ / literal_required ; / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT / STACK_POP \ / optional ; / NEXT_STMT / STACK_POP \ / ; / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ next_implied_option_stmt / ; / add_to_vector(token_value, NEXT_IMPLIED_OPTION) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ argument_stmt / ; / [call set_name(token_value, argument_len, argument_ptr); call start_vector(ARGUMENT_VECTOR)] NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ validate_stmt / / [list_dim = VALIDATION_STRING] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ default_value_stmt / / [list_dim = DEFAULT_VALUE] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ antonym_value_stmt / / [list_dim = NEGATIVE_VALUE] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ next_argument_stmt / ; / add_to_vector(token_value, NEXT_ARGUMENT) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ validate_result_stmt / / [list_dim = VALIDATE_RESULT] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ validate_result_explanation_stmt / / [list_dim = VALIDATE_RESULT_EXPLANATION] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ validate_explanation_stmt / / [list_dim = VALIDATE_EXPLANATION] / cum_quoted_comma_list \ / / ERROR(4) / error_return \ force_literal_stmt / ; / add_to_vector("", FORCE_LITERAL) NEXT_STMT / STACK_POP \ / / ERROR(1) NEXT_STMT / STACK_POP \ / / ERROR(4) / error_return \ ++*/ %page; mtape_cv_apd: proc (); /* Automatic */ dcl answer char (3) var; dcl area_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl argument_len fixed bin (21); dcl argument_ptr ptr; dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl command_name_len fixed bin (21); dcl command_name_ptr ptr; dcl created_value_seg bit (1) aligned init ("0"b); dcl default_exclude_myself bit (1) aligned; dcl default_linear_form_length fixed bin (21) init (0); dcl default_linear_form_ptr ptr init (null); dcl default_linear_form_value_name char (128) varying init (""); dcl definition_exists bit (1) aligned init ("0"b); dcl definition_order pic "999"; dcl definition_string_length fixed bin (35) init (0); dcl definition_string_ptr ptr init (null); dcl dlf_var_length fixed bin(21); dcl dlf_var_ptr ptr; dcl definition_value_name char (128) varying init (""); dcl error_code_array (1) fixed bin (35); dcl expanded_token_len fixed bin (21); dcl expanded_token_ptr ptr; dcl i fixed bin; dcl list_dim fixed bin; dcl main_pv_num fixed bin; dcl main_pv_type fixed bin; dcl n_definition_order fixed bin; dcl nargs fixed bin; dcl option_len fixed bin (21); dcl option_ptr ptr; dcl Pfirst_stmt_desc ptr; dcl Pfirst_token_desc ptr; dcl replace bit (1) aligned; dcl sdname char (168); dcl seg_len fixed bin (21); dcl seg_ptr ptr; dcl sename char (32); dcl source_rpath_len fixed bin (21); dcl source_rpath_ptr ptr; dcl synonym_len fixed bin (21); dcl synonym_ptr ptr; dcl target_rpath_len fixed bin (21); dcl target_rpath_ptr ptr; dcl tdname char (168); dcl temp_seg_ptr ptr; dcl tename char (32); dcl value_defined (22) bit (1); /* *** True means that DIMENSIONS(i) in the current */ /* print_vector has a value. */ dcl value_seg_ptr ptr init (null); dcl 1 auto_area_info like area_info; dcl 1 auto_query_info like query_info; /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl argument char (argument_len) based (argument_ptr); dcl based_area area based (area_ptr); dcl command_name char (command_name_len) based (command_name_ptr); dcl default_linear_form_string char (default_linear_form_length) based (default_linear_form_ptr); dcl dlf_var char(dlf_var_length) var based(dlf_var_ptr); dcl expanded_token char (expanded_token_len) based (expanded_token_ptr); dcl option char (option_len) based (option_ptr); dcl source_rpath char (source_rpath_len) based (source_rpath_ptr); dcl synonym char (synonym_len) based (synonym_ptr); dcl target_rpath char (target_rpath_len) based (target_rpath_ptr); /* Builtin */ dcl (addr, after, dimension, divide, empty, length, null, reverse, rtrim, string, unspec) builtin; /* Entries */ dcl command_query_ entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl com_err_ entry () options (variable); dcl define_area_ entry (ptr, 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_wdir_ entry () returns (char (168)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var); dcl lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl term_$seg_ptr entry (ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl translator_temp_$get_next_segment entry (ptr, ptr, fixed bin (35)); dcl translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); dcl value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)); dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35)); dcl value_$set_data entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35)); dcl value_$delete_data entry (ptr, bit (36) aligned, char (*), fixed bin (35)); /* Static */ /* Things marked *** are all related to the dimensions contained in the print_vector_array. If the dimensions change, all of these things should be looked at for possible changes. */ dcl (COMMENT_CLOSE char (2) init ("*/"), COMMENT_OPEN char (2) init ("/*"), CVAPD_VERSION fixed bin init (1), FATAL_ERROR fixed bin init (3), FATAL_ERROR_MSG char (45) init ("Fatal error has occured. Translation failed."), FREE_OLD_PV_ARRAY bit (1) aligned init ("1"b), IGNORED_INPUT_LEN fixed bin (21) init (0), MAX_DIM_NAME_LEN fixed bin init (32), /* *** */ MAX_NUM_OF_ARGS fixed bin init (5), MIN_NUM_OF_ARGS fixed bin init (1), ME char (12) init ("mtape_cv_apd"), ME_UPPER char (12) init ("MTAPE_CV_APD"), N_INCREMENTAL_PV_SLOTS fixed bin init (10), N_INITIAL_PV_SLOTS fixed bin (35) init (10), N_PV_DIMS fixed bin init (22), /* *** */ NEW_VECTOR fixed bin init (-1), NO_COPY fixed bin (2) init (1), QUOTE_CLOSE char (1) init (""""), QUOTE_OPEN char (1) init (""""), SINIT bit (2) init ("10"b), SLEX bit (4) init ("1000"b), SOURCE_SUFFIX char (4) init ("mapd"), STMT_DELIM char (1) init (";"), STOP_ON_DUPLICATION bit (1) aligned init ("1"b), STOP_ON_ERROR bit (1) aligned init ("1"b), USAGE_MSG char (66) init ("Usage: mtape_cv_apd {-source} path {{-target} path} {-control_arg}"), VALUE_SUFFIX char (5) init ("value") ) internal static options (constant); dcl (INITIAL_VECTOR init (1), OPTION_VECTOR init (2), OPTION_NAME_VECTOR init (3), ARGUMENT_VECTOR init (4), BASIC_VECTOR init (5), NEGATIVE_FORM_VECTOR init (6) ) fixed bin internal static options (constant); dcl BYTES_PER_WORD init (4) fixed bin internal static options (constant); dcl CAN_HAVE_VALUE (22) bit (1) aligned /* *** */ init ((11) ("1"b), (1) ("0"b), (9) ("1"b), (1) ("0"b)) internal static options (constant); dcl CAN_HAVE_MULTIPLE_DEFINITIONS (22) bit (1) aligned /* *** */ init ((9) ("0"b), (3) ("1"b), (5) ("0"b), (3) ("1"b), (2) ("0"b)) internal static options (constant); dcl DIMENSIONS (22) char (32) var /* *** */ init ("definition order", /* 1 */ "command name", /* 2 */ "default linear form", /* 3 */ "initial implied option", /* 4 */ "explanation", /* 5 */ "option", /* 6 */ "initial argument", /* 7 */ "next implied option", /* 8 */ "presence required", /* 9 */ "excluded option", /* 10 */ "synonym", /* 11 */ "negative form", /* 12 */ "argument", /* 13 */ "next argument", /* 14 */ "validation string", /* 15 */ "default value", /* 16 */ "negative value", /* 17 */ "unexcluded option", /* 18 */ "validate result", /* 19 */ "validate result explanation", /* 20 */ "validate explanation", /* 21 */ "force literal" /* 22 */ ) internal static options (constant); dcl (DEFINITION_ORDER init (1), /* *** */ COMMAND_NAME init (2), DEFAULT_LINEAR_FORM init (3), INITIAL_IMPLIED_OPTION init (4), EXPLANATION init (5), OPTION init (6), INITIAL_ARGUMENT init (7), NEXT_IMPLIED_OPTION init (8), PRESENCE_REQUIRED init (9), EXCLUDED_OPTION init (10), SYNONYM init (11), NEGATIVE_FORM init (12), ARGUMENT init (13), NEXT_ARGUMENT init (14), VALIDATION_STRING init (15), DEFAULT_VALUE init (16), NEGATIVE_VALUE init (17), UNEXCLUDED_OPTION init (18), VALIDATE_RESULT init (19), VALIDATE_RESULT_EXPLANATION init (20), VALIDATE_EXPLANATION init (21), FORCE_LITERAL init (22) ) fixed bin internal static options (constant); dcl PERMANENT_VALUE init ("01"b) bit (36) aligned internal static options (constant); dcl PERMANENT_VALUE_SEG_TYPE init (0) fixed bin internal static options (constant); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl (error_table_$bad_arg, error_table_$empty_file, error_table_$noarg, error_table_$oldnamerr, error_table_$segknown, error_table_$wrong_no_of_args, error_table_$zero_length_seg ) fixed bin (35) ext static; dcl (lex_control_chars, lex_delims ) char (128) var init ("") int static; dcl (cleanup, size) condition; dcl BREAK_CHARS char (5) var init (":, ") internal static options (constant); /* ":", ",", SPACE, TAB, NL */ dcl IGNORED_BREAK_CHARS char (3) var init (" ") internal static options (constant); /* SPACE, TAB, NL */ dcl 1 error_control_table (13) int static options (constant) unaligned, 2 severity fixed bin (17) init ((4) (3), /* 1 - 3 */ 2, 4, 1, 4, 4, /* 4 - 8 */ (4) (3)), /* 9 - 13 */ 2 Soutput_stmt bit (1) init ((13) ("1"b)), 2 message char (256) var init ( "Error in statement.", /* 1 */ "Unrecognized statement. Looking for program_name statement.", /* 2 */ "Source file is empty.", /* 3 */ "Source file ends unexpectedly.", /* 4 */ "Text after end statement.", /* 5 */ "Could not append a print vector to the print vector array.", /* 6 */ "This value has already been defined. Ignoring value.", /* 7 */ "Could not append a dimension to a print vector.", /* 8 */ "Reference made to unknown vector type.", /* 9 */ "Unrecognized statement in initial statement list.", /* 10 */ "Unrecognized statement in option statement list.", /* 11 */ "Bad syntax in list.", /* 12 */ "Unrecognized statement in argument statement list."), /* 13 */ 2 brief_message char (256) var init ((13) ("")); %page; /* Include */ %include access_mode_values; %page; %include pa_value_names; %page; %include vu_print_vector_array; %page; %include vu_entry_dcls; %page; %include area_info; %page; %include terminate_file; %page; %include query_info; %page; /* Main Procedure */ call initialize_translator_values (); on cleanup call cleanup_trans (); call cu_$arg_count (nargs, code); if code ^= 0 then call abort (code, ""); if nargs = 0 then call abort (0, USAGE_MSG); if nargs < MIN_NUM_OF_ARGS | nargs > MAX_NUM_OF_ARGS then call abort (error_table_$wrong_no_of_args, ""); source_rpath_ptr, target_rpath_ptr = null; source_rpath_len, target_rpath_len = 0; replace = "0"b; i = 1; do while (i <= nargs); call get_arg (i, arg_ptr, arg_len); if arg = "-source" then call get_arg (i, source_rpath_ptr, source_rpath_len); else if arg = "-target" then call get_arg (i, target_rpath_ptr, target_rpath_len); else if arg = "-replace" | arg = "-rp" then replace = "1"b; else if arg = "-no_replace" | arg = "-nrp" then replace = "0"b; else if source_rpath_ptr = null then do; source_rpath_ptr = arg_ptr; source_rpath_len = arg_len; end; else if target_rpath_ptr = null then do; target_rpath_ptr = arg_ptr; target_rpath_len = arg_len; end; else call abort (error_table_$bad_arg, """" || arg || """"); end; if source_rpath_ptr = null then call abort (error_table_$noarg, "Source pathname."); call expand_pathname_$add_suffix (source_rpath, SOURCE_SUFFIX, sdname, sename, code); if code ^= 0 then call abort (code, """" || source_rpath || """"); if target_rpath_ptr ^= null then do; call expand_pathname_$add_suffix (target_rpath, VALUE_SUFFIX, tdname, tename, code); if code ^= 0 then call abort (code, """" || target_rpath || """"); end; else do; tdname = get_wdir_ (); call suffixed_name_$new_suffix (sename, SOURCE_SUFFIX, VALUE_SUFFIX, tename, code); if code ^= 0 then call abort (code, "Unable to convert the source entry name into a target value segment entry name."); end; call hcs_$initiate_count (sdname, sename, "", bit_count, NO_COPY, seg_ptr, code); if code = error_table_$segknown then code = 0; else if code ^= 0 then call abort (code, rtrim (sdname) || ">" || rtrim (sename)); seg_len = divide (bit_count + 8, 9, 21, 0); call ioa_ ("^a ^3.1f", ME_UPPER, CVAPD_VERSION); call translator_temp_$get_segment ((ME), temp_seg_ptr, code); if code ^= 0 then call abort (code, ""); call translator_temp_$get_next_segment (temp_seg_ptr, area_ptr, code); if code ^= 0 then call abort (code, ""); call translator_temp_$get_next_segment (area_ptr, definition_string_ptr, code); if code ^= 0 then call abort (code, ""); definition_string_length = sys_info$max_seg_size * 4; unspec (auto_area_info) = "0"b; auto_area_info.version = 1; auto_area_info.extend = "1"b; auto_area_info.zero_on_alloc = "1"b; auto_area_info.zero_on_free = "0"b; auto_area_info.dont_free = "0"b; auto_area_info.no_freeing = "0"b; auto_area_info.system = "1"b; auto_area_info.owner = ME; auto_area_info.size = sys_info$max_seg_size; auto_area_info.areap = area_ptr; call define_area_ (addr (auto_area_info), code); if code ^= 0 then call abort (code, ""); call vector_util_$init_print_vector_array (area_ptr, N_INITIAL_PV_SLOTS, N_PV_DIMS, MAX_DIM_NAME_LEN, print_vector_array_ptr, code); if code ^= 0 then call abort (code, ""); print_vector_array.dimension_table.name = DIMENSIONS; if lex_delims = "" then call lex_string_$init_lex_delims (QUOTE_OPEN, QUOTE_CLOSE, COMMENT_OPEN, COMMENT_CLOSE, STMT_DELIM, SINIT, BREAK_CHARS, IGNORED_BREAK_CHARS, lex_delims, lex_control_chars); call lex_string_$lex (seg_ptr, seg_len, IGNORED_INPUT_LEN, temp_seg_ptr, SLEX, QUOTE_OPEN, QUOTE_CLOSE, COMMENT_OPEN, COMMENT_CLOSE, STMT_DELIM, BREAK_CHARS, IGNORED_BREAK_CHARS, lex_delims, lex_control_chars, Pfirst_stmt_desc, Pfirst_token_desc, code); if code = error_table_$zero_length_seg then call abort (code, rtrim (sdname) || ">" || rtrim (sename)); else if code ^= 0 then do; code = 0; MERROR_SEVERITY = FATAL_ERROR; end; Pthis_token = Pfirst_token_desc; call SEMANTIC_ANALYSIS (); if MERROR_SEVERITY >= FATAL_ERROR then call abort (0, FATAL_ERROR_MSG); call initiate_file_$create (tdname, tename, RW_ACCESS, value_seg_ptr, created_value_seg, (0), code); if value_seg_ptr = null then call abort (code, rtrim (tdname) || ">" || rtrim (tename)); if created_value_seg then do; call value_$init_seg (value_seg_ptr, PERMANENT_VALUE_SEG_TYPE, null, 0, code); if code ^= 0 then call abort (code, rtrim (tdname) || ">" || rtrim (tename)); end; definition_value_name = DEFINITION_PREFIX || "." || command_name; default_linear_form_value_name = DEFAULT_LINEAR_FORM_PREFIX || "." || command_name; if ^replace then do; call value_$get_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), area_ptr, (null ()), (0), code); if code = 0 then definition_exists = "1"b; else if code = error_table_$oldnamerr then definition_exists = "0"b; else call abort (code, "Searching for " || command_name || " definition in value segment."); if definition_exists then do; call command_query_ (addr (auto_query_info), answer, ME, "A definition for ^a exists^/ in the value segment ^a>^a.^/Do you want to replace it?", command_name, tdname, tename); if answer = "no" | answer = "n" then call abort (0, "Definition not replaced."); else do; replace = "1"b; call com_err_ (0, ME, "Definition will be replaced."); end; end; end; if replace then do; call value_$delete_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), code); if code = error_table_$empty_file | code = error_table_$oldnamerr then call com_err_ ((0), ME, "No old definition of ^a in value segment. Adding definition.", command_name); else if code ^= 0 then call abort (code, "Cannot replace " || command_name || " definition in value segment."); call value_$delete_data (value_seg_ptr, PERMANENT_VALUE, (default_linear_form_value_name), code); if code = error_table_$empty_file | code = error_table_$oldnamerr then call com_err_ ((0), ME, "No old default linear form of ^a in value segment. Adding definition.", command_name); else if code ^= 0 then call abort (code, "Cannot replace " || command_name || " definition in value segment."); end; call vector_util_$cv_pva_to_string (print_vector_array_ptr, definition_string_ptr, definition_string_length, code); if code ^= 0 then call abort (code, ""); call value_$set_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), definition_string_ptr, divide (definition_string_length, BYTES_PER_WORD, 18, 0), (null ()), (null ()), (0), code); if code ^= 0 then call abort (code, ""); dlf_var_length = default_linear_form_length; allocate dlf_var in(based_area) set(dlf_var_ptr); dlf_var = default_linear_form_string; call value_$set_data (value_seg_ptr, PERMANENT_VALUE, (default_linear_form_value_name), dlf_var_ptr, divide(dlf_var_length + 3, BYTES_PER_WORD, 17, 0) + 1, (null ()), (null ()), (0), code); if code ^= 0 then call abort (code, ""); RETURN: call cleanup_trans (); return; ERROR_RETURN: return; %page; /* Translation and Utility Routines */ /* This subroutine adds the specified string (usually the current token) to a print vector in the print vector array we are building. The string becomes the value of the dimension specified by dim_num. If necessary, this subroutine adds a new print vector (in special cases) to accommodate the new dimension value (token). */ add_to_vector: proc (str, dim_num); /* Automatic */ dcl vector_num fixed bin; /* Parameter */ dcl dim_num fixed bin; dcl str char (*); if MERROR_SEVERITY >= FATAL_ERROR /* Quit if hopeless. */ then return; if value_defined (dim_num) & ^CAN_HAVE_MULTIPLE_DEFINITIONS (dim_num) then do; call ERROR (7); return; end; if (dim_num = EXCLUDED_OPTION | dim_num = UNEXCLUDED_OPTION) & str = option then default_exclude_myself = "0"b; /* Don't need default exclusion anymore. */ if dim_num = SYNONYM /* Special, we need a SYNONYM print vector. */ then do; call set_name (str, synonym_len, synonym_ptr); call append_vector (OPTION_NAME_VECTOR, vector_num, code); if code ^= 0 then do; call ERROR (6); return; end; end; else if dim_num = NEGATIVE_FORM /* Special, we need a NEGATIVE_FORM print vector. */ /* Really a SYNONYM vector plus NEGATIVE_FORM dim. */ then do; call set_name (str, synonym_len, synonym_ptr); call append_vector (NEGATIVE_FORM_VECTOR, vector_num, code); if code ^= 0 then do; call ERROR (6); return; end; end; else do; /* Nonspecial, try adding to current print vector. */ vector_num = main_pv_num; if value_defined (dim_num) & CAN_HAVE_MULTIPLE_DEFINITIONS (dim_num) then do; call append_vector (main_pv_type, vector_num, code); if code ^= 0 then do; call ERROR (6); return; end; end; if CAN_HAVE_VALUE (dim_num) then call add_dim (dim_num, str, vector_num, code); else call add_dim (dim_num, "", vector_num, code); if code ^= 0 then do; call ERROR (8); return; end; end; value_defined (dim_num) = "1"b; end add_to_vector; %page; /* Sets up a print vector with all the mandatory information for the specified vector type. Sets the current print vector to this one. */ start_vector: proc (vector_type); /* Parameter */ dcl vector_type fixed bin; /* Automatic */ dcl vector_num fixed bin; if MERROR_SEVERITY >= FATAL_ERROR then return; value_defined (*) = "0"b; call append_vector (vector_type, vector_num, code); if code ^= 0 then do; call ERROR (6); return; end; main_pv_num = vector_num; main_pv_type = vector_type; end start_vector; %page; /* This routine can be called to initialize different types of print vectors given the type wanted. The input information is vector type. The output information is the vector_num of the new vector. Before calling this procedure, the caller must make sure that all necessary information for that particular print vector has been set. For example, the OPTION print vector needs to have then command_name and option variables set. */ append_vector: proc (vector_type, vector_num, code); /* Parameter */ dcl code fixed bin (35); dcl vector_num fixed bin; dcl vector_type fixed bin; code = 0; n_definition_order = n_definition_order + 1; call set_definition_order (n_definition_order, definition_order); if vector_type = OPTION_VECTOR then do; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, NEW_VECTOR, DIMENSIONS (DEFINITION_ORDER), definition_order, DIMENSIONS (COMMAND_NAME), command_name, DIMENSIONS (OPTION), option, print_vector_array_ptr, code); if code ^= 0 then return; end; else if vector_type = ARGUMENT_VECTOR then do; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, NEW_VECTOR, DIMENSIONS (DEFINITION_ORDER), definition_order, DIMENSIONS (COMMAND_NAME), command_name, DIMENSIONS (OPTION), option, DIMENSIONS (ARGUMENT), argument, print_vector_array_ptr, code); if code ^= 0 then return; end; else if vector_type = INITIAL_VECTOR | vector_type = BASIC_VECTOR then do; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, NEW_VECTOR, DIMENSIONS (DEFINITION_ORDER), definition_order, DIMENSIONS (COMMAND_NAME), command_name, print_vector_array_ptr, code); if code ^= 0 then return; end; else if vector_type = OPTION_NAME_VECTOR then do; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, NEW_VECTOR, DIMENSIONS (DEFINITION_ORDER), definition_order, DIMENSIONS (COMMAND_NAME), command_name, DIMENSIONS (OPTION), option, DIMENSIONS (SYNONYM), synonym, print_vector_array_ptr, code); if code ^= 0 then return; end; else if vector_type = NEGATIVE_FORM_VECTOR then do; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, NEW_VECTOR, DIMENSIONS (DEFINITION_ORDER), definition_order, DIMENSIONS (COMMAND_NAME), command_name, DIMENSIONS (OPTION), option, DIMENSIONS (SYNONYM), synonym, DIMENSIONS (NEGATIVE_FORM), "", print_vector_array_ptr, code); if code ^= 0 then return; end; else do; code = error_table_$bad_arg; return; end; vector_num = print_vector_array.number_of_vectors; end append_vector; %page; /* This routine adds a dimension value to a specified print vector. If the print vector is specified by a -1, a new print vector is created to hold the dimension value. The number of the new print vector is returned in that case. */ add_dim: proc (dim_num, dim_value, vector_num, code); /* Parameter */ dcl code fixed bin (35); dcl dim_num fixed bin; dcl dim_value char (*); dcl vector_num fixed bin; call vector_util_$append_general_print_vector (area_ptr, N_INCREMENTAL_PV_SLOTS, FREE_OLD_PV_ARRAY, vector_num, DIMENSIONS (dim_num), dim_value, print_vector_array_ptr, code); end add_dim; %page; /* This routine sets the character representation of the definition order. */ (size): set_definition_order: proc (arg_n_definition_order, arg_definition_order); /* Parameter */ dcl arg_n_definition_order fixed bin; dcl arg_definition_order pic "999"; on size begin; call com_err_ (0, ME, "The size of your definition is too large." ); call abort (0, "It has caused the definition_order dimension to overflow."); end; arg_definition_order = arg_n_definition_order; end set_definition_order; %page; /* This routine is used to set information we must keep around (i.e., the command_name, option, argument variables). It sets the specified based variable to be the specified string (usually the current token). */ set_name: proc (arg_str, arg_name_len, arg_name_ptr); /* Based */ dcl name char (arg_name_len) based (arg_name_ptr); /* Parameter */ dcl arg_name_len fixed bin (21); dcl arg_name_ptr ptr; dcl arg_str char (*); if arg_name_ptr ^= null then free arg_name_ptr -> name; arg_name_len = length (arg_str); allocate name in (based_area) set (arg_name_ptr); name = arg_str; end set_name; %page; /* This routine "resets" a specified based character string variable by freeing it and setting the length to 0 and setting the ptr to null. */ reset_name: proc (arg_name_len, arg_name_ptr); /* Based */ dcl name char (arg_name_len) based (arg_name_ptr); /* Parameter */ dcl arg_name_len fixed bin (21); dcl arg_name_ptr ptr; if arg_name_ptr ^= null then free arg_name_ptr -> name; arg_name_len = 0; arg_name_ptr = null; end reset_name; %page; /* This routine initializes some global variables used by the translator. Some of these variables must be set immediately on invocation not only for the translator can clean up properly, but to start proper "running" values. */ initialize_translator_values: proc (); n_definition_order = 0; command_name_ptr, option_ptr, argument_ptr = null; command_name_len, option_len, argument_len = 0; synonym_ptr = null; synonym_len = 0; expanded_token_ptr = null; expanded_token_len = 0; seg_ptr = null; temp_seg_ptr, area_ptr = null; unspec (auto_query_info) = "0"b; auto_query_info.version = query_info_version_5; auto_query_info.yes_or_no_sw = "1"b; auto_query_info.question_iocbp = null; auto_query_info.answer_iocbp = null; auto_query_info.explanation_ptr = null; end initialize_translator_values; %page; /* Gets arg(arg_num) from the command's argument list. increments arg_num by 1. If an error happens getting the arg, we call abort directly, we don't return from here. */ get_arg: proc (arg_num, arg_ptr, arg_len); /* Parameter */ dcl arg_len fixed bin (21); dcl arg_num fixed bin; dcl arg_ptr ptr; /* Automatic */ dcl code fixed bin (35); call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); if code ^= 0 then call abort (code, ""); arg_num = arg_num + 1; end get_arg; %page; /* This routine cleans up the user environment after an invocation of the translator. */ cleanup_trans: proc (); if seg_ptr ^= null then call term_$seg_ptr (seg_ptr, code); if temp_seg_ptr ^= null then call translator_temp_$release_all_segments (temp_seg_ptr, code); if value_seg_ptr ^= null then call terminate_file_ (value_seg_ptr, (0), TERM_FILE_TERM, code); end cleanup_trans; %page; /* This routine prints an error message, cleans up the environment and then aborts the invocation of mtape_cv_apd. */ abort: proc (code, msg); /* Parameter */ dcl code fixed bin (35); dcl msg char (*); call com_err_ (code, ME, msg); call cleanup_trans (); goto ERROR_RETURN; end abort; %page; /* This routine takes a based character string variable, and appends the given string to it (reallocating the based variable for more storage if necessary). */ append_to_str: proc (str_to_append, str_len, str_ptr); /* Automatic */ dcl temp_str_len fixed bin (21); dcl temp_str_ptr ptr; /* Based */ dcl str char (str_len) based (str_ptr); dcl temp_str char (temp_str_len) based (temp_str_ptr); /* Parameter */ dcl str_len fixed bin (21); dcl str_ptr ptr; dcl str_to_append char (*); if str_ptr = null then do; str_len = length (str_to_append); allocate str in (based_area) set (str_ptr); str = str_to_append; return; end; temp_str_len = length (str_to_append) + str_len; allocate temp_str in (based_area) set (temp_str_ptr); temp_str = str || str_to_append; free str_ptr -> str; str_ptr = temp_str_ptr; str_len = temp_str_len; end append_to_str;  mtape_delete_defaults.pl1 04/10/85 0831.6r w 04/08/85 1129.0 76806 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */ mtape_delete_defaults: proc (); /* DESCRIPTION: This command deletes default arguments that have been set by the mtape_set_defaults command. It deletes the defaults associated with a particular tape processing operation and volume type. The default arguments are deleted from the value segment that the user specifies. */ /* HISTORY: Written 09/13/83 by S. Krupp. */ /* START OF DECLARATIONS */ /* Automatic */ dcl arg_list_ptr ptr; dcl code fixed bin(35); dcl db_entryname char(32); dcl db_dirname char(168); dcl db_full_pathname char(168) var; dcl db_rel_pathname char(168) var; dcl found_option bit(3); dcl idx fixed bin; dcl nargs fixed bin; dcl operation char(32) var; dcl program_name char(64) var; dcl result_ptr ptr; dcl value_seg_ptr ptr; dcl volume_type char(32) var; dcl 1 auto_area_info like area_info; /* Based */ dcl found_option_array(3) bit(1) unaligned based(addr(found_option)); /* Builtin */ dcl (addr, hbound, null, unspec) builtin; /* Condition */ dcl cleanup condition; /* Entries */ dcl com_err_ entry() options(variable); dcl cu_$arg_count entry(fixed bin, fixed bin(35)); dcl cu_$arg_list_ptr entry (ptr); dcl define_area_ entry (ptr, fixed bin(35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_$rsnnl entry() options(variable); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35)); dcl process_arguments_$get_option_value entry() options(variable); dcl release_area_ entry (ptr); dcl term_$seg_ptr entry (ptr, fixed bin(35)); dcl value_$delete_data entry(ptr, bit(36) aligned, char(*), fixed bin(35)); /* Static */ dcl (ARG_PROCESSING_MODE init(0), FIRST_ARG_TO_PROCESS init(1) ) fixed bin internal static options(constant); dcl (MYNAME init("mtape_delete_defaults"), PROGRAM_NAME_PREFIX init("mtape_") ) char(32) var internal static options(constant); dcl (OPERATION_OPTION_IDX init(1), VOLUME_TYPE_OPTION_IDX init(2), PATHNAME_OPTION_IDX init(3) ) fixed bin internal static options(constant); dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant); dcl VALUE_SUFFIX char(5) init("value") internal static options(constant); dcl (OPERATION_OPTION_NAME init("operation"), VOLUME_TYPE_OPTION_NAME init("volume_type"), PATHNAME_OPTION_NAME init("pathname") ) char(32) var internal static options(constant); dcl LONG_OPTION_REFNAME(3) char(32) var int static options(constant) init("operation", "-volume_type", "-pathname"); dcl (ATTACH_IDX init(1), OPEN_IDX init(2), CLOSE_IDX init(3), DETACH_IDX init(4) ) fixed bin internal static options(constant); dcl OPERATIONS(4) char(6) internal static options(constant) init("attach", "open", "close", "detach"); dcl VOLUME_TYPES(2) char(32) var internal static options(constant) init("ansi", "ibm"); dcl (error_table_$bad_arg, error_table_$noarg, error_table_$oldnamerr )fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Include */ %page; %include access_mode_values; %page; %include area_info; %page; %include pa_value_names; /* END OF DECLARATIONS */ %page; /* Main Procedure */ /* Initialize */ value_seg_ptr = null; unspec (auto_area_info) = "0"b; auto_area_info.version = area_info_version_1; auto_area_info.areap = null; auto_area_info.owner = MYNAME; auto_area_info.size = sys_info$max_seg_size; auto_area_info.zero_on_alloc = "1"b; auto_area_info.extend = "1"b; call cu_$arg_count(nargs, code); if code ^= 0 then call ABORT(code, "Could not get the argument count.", ""); if nargs = 0 then call ABORT(0, "Usage ""mtape_delete_defaults OPERATION {-control_args}""", ""); on cleanup call CLEANUP(); call define_area_(addr(auto_area_info), code); if code ^= 0 then call ABORT(code, "Unable to allocate a work area.", ""); /* Get mtape_delete_default's argument list. */ call cu_$arg_list_ptr(arg_list_ptr); /* Process mtape_delete_defaults's arguments. */ call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE, arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap, result_ptr, code); if code ^= 0 then call ABORT_SILENT(); /* Error msg already printed. */ /* Get information needed to locate the arguments that are the subject of the command line (i.e., the arguments that are the defaults for the specified tape processing operation and volume type). */ call process_arguments_$get_option_value(result_ptr, auto_area_info.areap, found_option, OPERATION_OPTION_NAME, operation, VOLUME_TYPE_OPTION_NAME, volume_type, PATHNAME_OPTION_NAME, db_rel_pathname); if ^found_option_array(OPERATION_OPTION_IDX) then call ABORT(error_table_$noarg, "Missing ""^a"" option.", (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX))); do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation); end; if idx > hbound(OPERATIONS, 1) then call ABORT(error_table_$bad_arg, "Unknown operation specified: ""^a"".", (operation)); if found_option_array(VOLUME_TYPE_OPTION_IDX) then do; do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type); end; if idx > hbound(VOLUME_TYPES, 1) then call ABORT(error_table_$bad_arg, "Unknown volume type specified: ""^a"".", (volume_type)); if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX) then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ || volume_type || """ with the ""^a"" operation.", (operation)); end; /* Build the program name from the specified tape processing operation and volume type. */ call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX, operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type); /* Now we locate the value segment and delete the default arguments if they are in there. */ call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code); if code ^= 0 then call ABORT(code, "^a", (db_rel_pathname)); db_full_pathname = pathname_(db_dirname, db_entryname); call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code); if code ^= 0 then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname)); call value_$delete_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX || "." || program_name, code); if code = error_table_$oldnamerr then call ABORT((0), "There are no corresponding default arguments^/in ^a.", (db_full_pathname)); else if code ^= 0 then call ABORT(code, "Unable to delete the default arguments from ^a.", (db_full_pathname)); call CLEANUP(); RETURN: return; %page; CLEANUP: proc(); if auto_area_info.areap ^= null then call release_area_(auto_area_info.areap); if value_seg_ptr ^= null then call term_$seg_ptr(value_seg_ptr, code); end CLEANUP; ABORT: proc (code, msg, msg_arg); /* Parameter */ dcl code fixed bin (35); dcl msg char (*); dcl msg_arg char (*); call com_err_ (code, MYNAME, msg, msg_arg); call CLEANUP(); goto RETURN; end ABORT; ABORT_SILENT: proc(); call CLEANUP(); goto RETURN; end ABORT_SILENT; end mtape_delete_defaults;  mtape_get_defaults.pl1 04/10/85 0831.6r w 04/08/85 1129.0 96129 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */ mtape_get_defaults: proc (); /* DESCRIPTION: This command prints out default arguments that have been set by the mtape_set_defaults command. It prints out the defaults associated with a particular tape processing operation and volume type. It can print out either the default linear form or the defaults from a specified value segment. The default linear form is the final set of defaults that apply after all of the applicable defaults have been gathered from the search list and processed. We don't have to worry about constructing the default linear form because there is an entry in the mtape_ argument processing routine that does this. */ /* HISTORY: Written 09/13/83 by S. Krupp. */ /* START OF DECLARATIONS */ /* Automatic */ dcl arg_list_ptr ptr; dcl based_varying_char_ptr ptr; dcl code fixed bin(35); dcl db_entryname char(32); dcl db_dirname char(168); dcl db_full_pathname char(168) var; dcl db_rel_pathname char(168) var; dcl default_linear_form char(4096) var; dcl definition_ptr ptr; dcl found_option bit(4); dcl idx fixed bin; dcl n_data_words fixed bin(18); dcl nargs fixed bin; dcl operation char(32) var; dcl program_name char(64) var; dcl result_ptr ptr; dcl use_search_list bit(1) aligned; dcl value_seg_ptr ptr; dcl volume_type char(32) var; dcl 1 auto_area_info like area_info; /* Based */ dcl based_varying_char char(sys_info$max_seg_size) var based(based_varying_char_ptr); dcl found_option_array(4) bit(1) unaligned based(addr(found_option)); /* Builtin */ dcl (addr, hbound, null, unspec) builtin; /* Condition */ dcl cleanup condition; /* Entries */ dcl com_err_ entry() options(variable); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_list_ptr entry (ptr); dcl define_area_ entry (ptr, fixed bin(35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_ entry() options(variable); dcl ioa_$rsnnl entry() options(variable); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35)); dcl process_arguments_$cv_result_to_linear_form entry(ptr, ptr, char(*) varying, fixed bin(35)); dcl process_arguments_$get_option_value entry() options(variable); dcl release_area_ entry (ptr); dcl term_$seg_ptr entry (ptr, fixed bin(35)); dcl value_$get_data entry (ptr, bit(36) aligned, char(*), ptr, ptr, fixed bin(18), fixed bin(35)); /* Static */ dcl (ARG_PROCESSING_MODE init(0), FIRST_ARG_TO_PROCESS init(1) ) fixed bin internal static options(constant); dcl (MYNAME init("mtape_get_defaults"), PROGRAM_NAME_PREFIX init("mtape_") ) char(32) var internal static options(constant); dcl (OPERATION_OPTION_IDX init(1), VOLUME_TYPE_OPTION_IDX init(2), PATHNAME_OPTION_IDX init(3), USE_SEARCH_LIST_OPTION_IDX init(4) ) fixed bin internal static options(constant); dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant); dcl VALUE_SUFFIX char(5) init("value") internal static options(constant); dcl (OPERATION_OPTION_NAME init("operation"), VOLUME_TYPE_OPTION_NAME init("volume_type"), PATHNAME_OPTION_NAME init("pathname"), USE_SEARCH_LIST_OPTION_NAME init("user_search_list") ) char(32) var internal static options(constant); dcl LONG_OPTION_REFNAME(4) char(32) var int static options(constant) init("operation", "-volume_type", "-pathname", "-use_search_list"); dcl (ATTACH_IDX init(1), OPEN_IDX init(2), CLOSE_IDX init(3), DETACH_IDX init(4) ) fixed bin internal static options(constant); dcl OPERATIONS(4) char(6) internal static options(constant) init("attach", "open", "close", "detach"); dcl VOLUME_TYPES(2) char(32) var internal static options(constant) init("ansi", "ibm"); dcl (error_table_$bad_arg, error_table_$noarg, error_table_$oldnamerr )fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Include */ %page; %include access_mode_values; %page; %include area_info; %page; %include pa_value_names; /* END OF DECLARATIONS */ %page; /* Main Procedure */ /* Initialize */ value_seg_ptr = null; unspec (auto_area_info) = "0"b; auto_area_info.version = area_info_version_1; auto_area_info.areap = null; auto_area_info.owner = MYNAME; auto_area_info.size = sys_info$max_seg_size; auto_area_info.zero_on_alloc = "1"b; auto_area_info.extend = "1"b; call cu_$arg_count(nargs, code); if code ^= 0 then call ABORT(code, "Could not get the argument count.", ""); if nargs = 0 then call ABORT(0, "Usage ""mtape_get_defaults OPERATION {-control_args}""", ""); on cleanup call CLEANUP(); call define_area_(addr(auto_area_info), code); if code ^= 0 then call ABORT(code, "Unable to allocate a work area.", ""); /* Get mtape_get_default's argument list. */ call cu_$arg_list_ptr(arg_list_ptr); /* Process mtape_get_defaults's arguments. */ call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE, arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap, result_ptr, code); if code ^= 0 then call ABORT_SILENT(); /* Error msg already printed. */ /* Get information needed to locate the arguments that are the subject of the command line (i.e., the arguments that are the defaults for the specified tape processing operation and volume type). */ call process_arguments_$get_option_value(result_ptr, auto_area_info.areap, found_option, OPERATION_OPTION_NAME, operation, VOLUME_TYPE_OPTION_NAME, volume_type, PATHNAME_OPTION_NAME, db_rel_pathname, USE_SEARCH_LIST_OPTION_NAME, use_search_list); if ^found_option_array(OPERATION_OPTION_IDX) then call ABORT(error_table_$noarg, "Missing ""^a"" option.", (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX))); do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation); end; if idx > hbound(OPERATIONS, 1) then call ABORT(error_table_$bad_arg, "Unknown operation specified: ""^a"".", (operation)); if found_option_array(VOLUME_TYPE_OPTION_IDX) then do; do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type); end; if idx > hbound(VOLUME_TYPES, 1) then call ABORT(error_table_$bad_arg, "Unknown volume type specified: ""^a"".", (volume_type)); if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX) then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ || volume_type || """ with the ""^a"" operation.", (operation)); end; /* Build the program name from the specified tape processing operation and volume type. */ call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX, operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type); /* Now we either search a value seg for defaults or we call the mtape_ argument processing routine to construct the default linear form. */ if found_option_array(PATHNAME_OPTION_IDX) then do; call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code); if code ^= 0 then call ABORT(code, "^a", (db_rel_pathname)); db_full_pathname = pathname_(db_dirname, db_entryname); call initiate_file_(db_dirname, db_entryname, R_ACCESS, value_seg_ptr, (0), code); if code ^= 0 then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname)); call value_$get_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX || "." || program_name, auto_area_info.areap, based_varying_char_ptr, n_data_words, code); if code = error_table_$oldnamerr then call ABORT((0), "There are no corresponding default arguments^/in ^a.", (db_full_pathname)); else if code ^= 0 then call ABORT(code, "Unable to get the default arguments from ^a.", (db_full_pathname)); end; else do; definition_ptr = null; call process_arguments_$argument_list((program_name), ARG_PROCESSING_MODE, null, (0), definition_ptr, auto_area_info.areap, result_ptr, code); if code ^= 0 then call ABORT_SILENT(); /* Error msg printed already. */ call process_arguments_$cv_result_to_linear_form(definition_ptr, result_ptr, default_linear_form, code); if code ^= 0 then call ABORT(code, "Unable to convert the result of processing to a default linear form.", ""); based_varying_char_ptr = addr(default_linear_form); end; call ioa_("^/Operation: ^a^[^/Volume type: ^a^;^]", operation, (found_option_array(VOLUME_TYPE_OPTION_IDX)), volume_type); if found_option_array(PATHNAME_OPTION_IDX) then call ioa_("Pathname: ^a^/Default arguments: ^a^/", db_full_pathname, based_varying_char); else call ioa_("Default linear form: ^a^/", based_varying_char); call CLEANUP(); RETURN: return; %page; CLEANUP: proc(); if auto_area_info.areap ^= null then call release_area_(auto_area_info.areap); if value_seg_ptr ^= null then call term_$seg_ptr(value_seg_ptr, code); end CLEANUP; ABORT: proc (code, msg, msg_arg); /* Parameter */ dcl code fixed bin (35); dcl msg char (*); dcl msg_arg char (*); call com_err_ (code, MYNAME, msg, msg_arg); call CLEANUP(); goto RETURN; end ABORT; ABORT_SILENT: proc(); call CLEANUP(); goto RETURN; end ABORT_SILENT; end mtape_get_defaults;  mtape_io_.pl1 10/10/88 1026.2rew 10/10/88 1025.0 353790 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Added cleanup handlers and code check returns. 2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. 3) change(88-06-28,Farley), approve(88-10-06,MCR7938), audit(88-10-06,Fawcett), install(88-10-10,MR12.2-1152): Modified buffer allocation to only allocate one I/O buffer when reading in large records (> 4096 words). Having more than one will allow tape_ioi_ to attempt chained I/O, which can result in a hardware channel error of "Incorrect DCW during list service".. END HISTORY COMMENTS */ mtape_io_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. * This module implements the physical tape interface for the Per-Format * modules. * * Modification History: * * Created by J. A. Bush 10/05/82 * Modified by J. A. Bush 12/01/83 for performance improvements */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_buf_size fixed bin (21); /* Requested length of users buffer */ dcl arg_order char (*); /* Control order mnemonic */ dcl arg_mode char (*); /* Mode mnemonic for set_mode entry */ dcl arg_index fixed bin; /* Mode index for set_mode entry */ dcl arg_repeat_cnt fixed bin; /* Control order repeat count */ dcl arg_infop ptr; /* Control order info pointer */ dcl arg_mode_ptr ptr; /* Mode info ptr for set_mode entry */ /* AUTOMATIC DATA */ dcl (infop, mode_ptr) ptr; dcl (label_len, act_length) fixed bin (21); dcl (code, scode, unr_code) fixed bin (35); dcl (oidx, rx, req_buffers, repeat_cnt, descrep_cnt, act_cnt, i, n_rdy_bufs, n_qed_bufs, alloc_tries) fixed bin; dcl spec_status bit (36) aligned; dcl order char (4); dcl 1 auto_ths like ths aligned; /* CONSTANT DATA */ dcl LC char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UC char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl HDW_MODE_STR (6) char (4) int static options (constant) init ("bin", "tap9", "bcd", "asc", "ebc", "a/e"); dcl WRITE_IO fixed bin int static options (constant) init (2); dcl BYTES_PER_DCW fixed bin int static options (constant) init (4 * 4096); dcl BYTES_PER_WORD fixed bin int static options (constant) init (4); dcl LENGTH_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b); dcl ALIGN_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b); dcl RECOVERY_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b); dcl WAIT_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b); dcl (WAIT init ("1"b), /* wait for order to complete */ NO_WAIT init ("0"b), /* do not wait for order to complete */ FORWARD init ("1"b), /* space files/blocks forward */ BACKWARD init ("0"b) /* space files/blocks backward */ ) bit (1) aligned int static options (constant); dcl order_mnemonics (0:22) char (4) static options (constant) init ("bsf", "bsr", "fsf", "fsr", "eof", "ers", "dse", "rew", "run", "lod", "rqs", "rss", "rqd", "rsd", "den", "per", "pro", "rsv", "rel", "rcr", "wcr", "rwnw", "runw"); dcl mode_mnemonics (0:6) char (8) static options (constant) init ("data", "length", "align", "recovery", "wait", "event", "cif"); /* EXTERNAL STATIC DATA */ dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$eov_on_write fixed bin (35) ext static; dcl error_table_$buffer_big fixed bin (35) ext static; dcl error_table_$device_not_active fixed bin (35) ext static; dcl error_table_$nine_mode_parity fixed bin (35) ext static; dcl error_table_$positioned_on_bot fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl mtape_dev_attention_recovery condition; dcl cleanup condition; /* BUILTIN FUNCTIONS */ dcl (addr, copy, divide, hbound, lbound, mod, null, translate) builtin; /* EXTERNAL ENTRIES */ dcl ascii_to_ebcdic_ entry (char (*), char (*)); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl ascii_to_bcd_ entry (char (*), bit (*)); dcl bcd_to_ascii_ entry (bit (*), char (*)); dcl mtape_util_$error entry options (variable); dcl mtape_mount_cntl_$mount entry (ptr, fixed bin (35)); dcl mtape_check_status_ entry (ptr, fixed bin (35)); /* BASED VARIABLES */ dcl based_label char (label_len) based (mtape_label_record.lab_ptr); dcl based_bits bit (label_len * 6) based; dcl based_area area based (mtape_data.areap); dcl blk_pad char (mtape_data.remain) based (addr (tape_blk (mtape_data.processed + 1))) unaligned; %page; /* read_block - entry to read the next block from the tape */ read_block: entry (arg_mtdp, arg_code); call SETUP; /* setup our enviornment */ call UNLOAD_LREC_CNT; /* Update block/lrec history */ on mtape_dev_attention_recovery begin; /* set up condition handler */ call tape_ioi_$read (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.length, rx, code); call CHECK_RX; /* go check result index */ if code = 0 then do; /* if no error.. */ call mtape_util_$error (mtdp, 0, "^[Device Attention^;Power Off^] recovery successful.", mtape_vol_set.dev_att_retry); mtape_vol_set.pwr_off_retry, mtape_vol_set.dev_att_retry = "0"b; /* reset flags */ end; go to continue_read; /* take non-local goto to get out of condition */ end; call tape_ioi_$read (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.length, rx, code); call CHECK_RX; /* go check result index */ continue_read: /* target of non-local goto */ if code = 0 then do; /* if no error.. */ if mtape_data.length > mtape_data.block_size then /* eliminate obvious padding */ mtape_data.length = mtape_data.block_size; mtape_data.position.phy_block = mtape_data.position.phy_block + 1; /* increment block number */ mtape_data.processed = mtape_data.buffer_offset; /* prime buffer variables */ mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); mtape_data.remain = mtape_data.length - mtape_data.processed; end; arg_code = code; /* return error code */ return; %page; /* write_block - entry to write the current block to tape */ write_block: entry (arg_mtdp, arg_code); call SETUP; /* setup our environment */ mtape_data.position.phy_block = mtape_data.position.phy_block + 1; /* increment block number */ call UNLOAD_LREC_CNT; /* save block/log record history */ if mtape_data.hdw_mode = MTAPE_HWM_BIN then do; /* if writing in binary, must pad mod 4 */ mtape_data.remain = mod (mtape_data.processed, BYTES_PER_WORD); if mtape_data.remain ^= 0 then do; /* Have to pad block? */ mtape_data.remain = BYTES_PER_WORD - mtape_data.remain; /* get bytes to add */ blk_pad = copy (mtape_data.padding_char, mtape_data.remain); /* yes, do it */ mtape_data.processed = mtape_data.processed + mtape_data.remain; end; end; if ^mtape_data.run then do; /* if no I/O currently queued */ mtape_data.buf_len (mtape_data.cur_buf_idx) = mtape_data.processed; /* copy length to be written */ mtape_data.cur_buf_idx = mtape_data.cur_buf_idx + 1; /* increment buffer index */ if mtape_data.cur_buf_idx > mtape_data.bufs_per_subset then do; /* its time to write the subset */ do i = lbound (mtape_data.buf_ptrs, 1) to mtape_data.bufs_per_subset; /* queue half of the buffers */ call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.buf_ptrs (i), mtape_data.buf_len (i), code); if code ^= 0 then do; /* error from queue_write */ call mtape_util_$error (mtdp, code, /* report it */ "Error from tape_ioi_$queue_write (^run) queuing buffer ^p, length ^d", mtape_data.buf_ptrs (i), mtape_data.buf_len (i)); go to write_block_return; /* return on error */ end; end; call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code); if code ^= 0 then do; /* error from list_buffers */ call mtape_util_$error (mtdp, code,/* report it */ "Error from tape_ioi_$list_buffers"); go to write_block_return; end; mtape_data.run = "1"b; /* We now have I/O going */ mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1); end; mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx); /* set for current buffer */ end; else do; /* buffers have been queued and are running */ call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.processed, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Error from tape_ioi_$queue_write (run mode), queueing buffer at ^p, length ^d", mtape_data.cur_buf_ptr, mtape_data.processed); go to write_block_return; end; call tape_ioi_$list_buffers (mtape_data.tioi_id, QUEUED_STATE, mtape_data.buf_ptrs, n_qed_bufs, code); if code ^= 0 then do; /* error from list_buffers */ call mtape_util_$error (mtdp, code, /* report it */ "Error from tape_ioi_$list_buffers (QUEUED_STATE)."); go to write_block_return; end; if n_qed_bufs < mtape_data.nbufs then do; /* all buffers not full? */ call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code); if code ^= 0 then do; /* error from list_buffers */ call mtape_util_$error (mtdp, code,/* report it */ "Error from tape_ioi_$list_buffers (READY_STATE)."); go to write_block_return; end; end; else do; /* all buffers full, check oldest */ /* Establish condition handler for recovery of DEV ATTENTION and PWR OFF statuses */ on mtape_dev_attention_recovery go to feov_target; /* take non-local goto to flush out buffers */ call tape_ioi_$check_write (mtape_data.tioi_id, mtape_data.buf_ptrs (1), rx, code); if rx ^= 0 then do; call CHECK_RX; go to write_block_return; end; end; mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (1); /* let user fill this one */ end; mtape_data.processed = mtape_data.buffer_offset; /* prime buffer variables */ mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); mtape_data.remain = mtape_data.buf_size - mtape_data.processed; if mtape_data.force_end_of_volume then /* if feov cntl op has been executed.. */ go to feov_target; /* take non-local goto to flush buffers entry */ write_block_return: arg_code = code; /* return error code */ return; %page; /* flush_buffers - entry to queue up and wait for all buffers to be written out */ flush_buffers: entry (arg_mtdp, arg_code); call SETUP; /* set up our environment */ if ^mtape_vol_set.volume_end then /* if we havn't reached end of volume yet, */ if mtape_data.nbufs > 0 then do; /* and we have allocated buffers */ on mtape_dev_attention_recovery go to feov_target; feov_target: /* target of non-local goto */ /* the recovery may fail so return here on nz code */ if code ^= 0 then go to flush_bufs_return; if mtape_data.cur_buf_idx > lbound (mtape_data.buf_ptrs, 1) then /* if we have un-queued buffers */ do i = lbound (mtape_data.buf_ptrs, 1) to mtape_data.cur_buf_idx - 1; /* do it now */ call tape_ioi_$queue_write (mtape_data.tioi_id, all_buf_ptrs (i), all_buf_lens (i), code); if code ^= 0 then do; /* error from queue_write */ call mtape_util_$error (mtdp, code, /* report it */ "Error from tape_ioi_$queue_write (flush) queuing buffer ^p, length ^d", all_buf_ptrs (i), all_buf_lens (i)); go to flush_bufs_return; /* return on error */ end; end; rx, code = 0; do while (code = 0 & rx = 0); /* do until no more buffers */ call tape_ioi_$check_write (mtape_data.tioi_id, null, rx, code); end; if code = error_table_$device_not_active then /* all I/O is finished */ code, rx = 0; else call CHECK_RX; /* otherwise check the error */ if code = 0 then do; /* if no error */ mtape_data.run = "0"b; /* I/O no longer in progress */ if mtape_data.phy_block = 0 then /* called to wrt blks after volume switch */ mtape_data.phy_block = mtape_data.cur_buf_idx - 1; /* set blocks written */ call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code); if code ^= 0 then do; /* error from list_buffers */ call mtape_util_$error (mtdp, code, /* report it */ "Error from tape_ioi_$list_buffers (flush)"); go to flush_bufs_return; end; mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1); /* reset buffer index */ mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (1); /* let user fill this one */ mtape_data.processed = mtape_data.buffer_offset; /* prime buffer variables */ mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); mtape_data.remain = mtape_data.buf_size - mtape_data.processed; if mtape_vol_set.pwr_off_retry | mtape_vol_set.dev_att_retry then do; call mtape_util_$error (mtdp, 0, "^[Device Attention^;Power Off^] recovery successful.", mtape_vol_set.dev_att_retry); mtape_vol_set.pwr_off_retry, mtape_vol_set.dev_att_retry = "0"b; /* reset flags */ end; if mtape_data.force_end_of_volume then do; /* but feov order executed */ mtape_data.force_end_of_volume = "0"b; /* reset flag */ rx = TAPE_IO_EOT; /* simulate EOT */ call CHECK_RX; end; end; end; flush_bufs_return: arg_code = code; return; %page; /* allocate_buffers - entry to allocate data buffers to read or write tape blocks from/to */ allocate_buffers: entry (arg_mtdp, arg_buf_size, arg_code); call SETUP; /* set up our environment */ req_buffers = hbound (mtape_data.buf_ptrs, 1) * 2;/* request 2 subsets of max size */ if arg_buf_size > BYTES_PER_DCW then /* if large records */ if mtape_data.last_io ^= WRITE_IO then /* and reading tape */ req_buffers = 1; /* only ask for one */ code = error_table_$buffer_big; /* set code for at least one loop */ do alloc_tries = 1 to 2 while (code = error_table_$buffer_big); call tape_ioi_$allocate_buffers (mtape_data.tioi_id, arg_buf_size, req_buffers, act_length, mtape_data.nbufs, all_buf_ptrs, code); if code = error_table_$buffer_big then /* if he can't fit req buffs */ req_buffers = 0; /* let him decide */ end; if code ^= 0 then /* problem allocating buffers */ go to allocate_buffers_return; /* let caller handle it */ if act_length < arg_buf_size then do; /* can't allow this */ code = error_table_$buffer_big; go to allocate_buffers_return; end; mtape_data.buf_size = act_length; /* save allocated buffer length */ mtape_data.bufs_per_subset = divide (mtape_data.nbufs, 2, 17, 0); /* subset is <= 1/2 of buffers */ if mtape_data.bufs_per_subset = 0 then /* but we must have at least 1 buffer */ mtape_data.bufs_per_subset = 1; mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1); mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx); call set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set desired HW mode */ if code = 0 then call set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and length mode */ allocate_buffers_return: arg_code = code; /* return error code */ return; %page; /* write_label - entry to copy contents of label record to an ioi_ buffer and initiate a sync write */ write_label: entry (arg_mtdp, arg_lr_ptr, arg_code); call SETUP; /* set up our environment */ mtape_data.last_io = 0; /* indicates not data I/O */ lr_ptr = arg_lr_ptr; if mtape_data.lab_bufp = null then do; /* first label I/O? */ call ALLOCATE_LABEL_BUFFER (mtape_label_record.lab_length); /* yes, get one allocated */ if code ^= 0 then /* if fatal error.. */ go to write_label_return; /* let caller handle it */ end; label_len = mtape_label_record.lab_length; /* copy length */ if mtape_label_record.conversion = MTAPE_CV_UC_ASCII | /* if label to be converted to upper case */ mtape_label_record.conversion = MTAPE_CV_UC_EBCDIC then /* convert in place */ based_label = translate (based_label, UC, LC); on mtape_dev_attention_recovery go to wcopy_label_end; go to wcopy_label (mtape_label_record.conversion);/* copy label and convert if neccessary */ wcopy_label (1): /* No conversion, copy as is */ wcopy_label (4): /* Convert to upper case ASCII */ mtape_data.lab_bufp -> based_label = based_label; go to wcopy_label_end; wcopy_label (2): /* Copy and convert to EBCDIC */ wcopy_label (5): /* Copy and convert to upper case EBCDIC */ call ascii_to_ebcdic_ (based_label, mtape_data.lab_bufp -> based_label); go to wcopy_label_end; wcopy_label (3): /* Copy and convert to BCD */ call ascii_to_bcd_ (based_label, mtape_data.lab_bufp -> based_bits); label_len = divide (label_len * 6, 9, 21, 0); /* recompute length */ wcopy_label_end: on mtape_dev_attention_recovery goto wcopy_label_retry; wcopy_label_retry: call set_mode (mtdp, "data", mtape_label_record.mode, null, code); /* make sure we are writing in right mode */ if code ^= 0 then /* if fatal error let user handle it */ go to write_label_return; call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.lab_bufp, label_len, code); if code = 0 then do; /* if everything ok.. */ call tape_ioi_$check_write (mtape_data.tioi_id, mtape_data.lab_bufp, rx, code); call CHECK_RX; /* go check result index */ if code = 0 then mtape_data.phy_block = mtape_data.phy_block + 1; /* increment block number */ end; write_label_return: arg_code = code; return; /* return to caller */ %page; /* read_label - entry to initiate a sync read for a label record and put it into the indicated buffer, converted if necessary */ read_label: entry (arg_mtdp, arg_lr_ptr, arg_code); call SETUP; /* set up our environment */ mtape_data.last_io = 0; /* indicates not data I/O */ lr_ptr = arg_lr_ptr; if mtape_data.lab_bufp = null then do; /* first label I/O? */ call ALLOCATE_LABEL_BUFFER (mtape_label_record.lab_length); /* yes, get one allocated */ if code ^= 0 then /* if fatal error.. */ go to read_label_return; /* let caller handle it */ end; on mtape_dev_attention_recovery go to read_label_retry; read_label_retry: call set_mode (mtdp, "data", mtape_label_record.mode, null, code); /* make sure we are reading in right mode */ if code ^= 0 then /* if fatal error.. */ go to read_label_return; /* let caller handle it */ call tape_ioi_$queue_read (mtape_data.tioi_id, mtape_data.lab_bufp, code); if code ^= 0 then /* if fatal error.. */ go to read_label_return; /* let caller handle it */ call tape_ioi_$check_read (mtape_data.tioi_id, mtape_data.lab_bufp, label_len, rx, code); call CHECK_RX; if code ^= 0 then /* if some error */ go to read_label_return; /* let caller handle it */ mtape_data.phy_block = mtape_data.phy_block + 1; /* increment block number */ go to rcopy_label (mtape_label_record.conversion);/* convert label if necessary */ rcopy_label (1): /* No conversion */ rcopy_label (4): /* convert to upper case ASCII (write only) */ based_label = mtape_data.lab_bufp -> based_label; /* copy directly */ go to rcopy_label_end; rcopy_label (2): /* convert EBCDIC to ASCII */ rcopy_label (5): /* convert to upper case ASCII (write only) */ call ebcdic_to_ascii_ (mtape_data.lab_bufp -> based_label, based_label); go to rcopy_label_end; rcopy_label (3): /* convert BCD to ASCII */ call bcd_to_ascii_ (mtape_data.lab_bufp -> based_bits, based_label); label_len = divide (label_len * 9, 6, 21, 0); /* adjust label length */ rcopy_label_end: mtape_label_record.lab_length = label_len; /* set length of label */ read_label_return: arg_code = code; return; %page; /* order - entry to issue tape control orders (e.g. positioning commands), on behalf of the Per-Format modules */ order: entry (arg_mtdp, arg_order, arg_repeat_cnt, arg_infop, arg_code); call SETUP; /* set up our environment */ order = arg_order; /* copy the rest of the arguments */ repeat_cnt = arg_repeat_cnt; infop = arg_infop; do oidx = hbound (order_mnemonics, 1) to lbound (order_mnemonics, 1) by -1 while (order_mnemonics (oidx) ^= arg_order); /* get the order index */ end; go to PROC_ORDER (oidx); /* and go process it */ PROC_ORDER (-1): /* unknown order */ code = error_table_$bad_arg; /* set appropriate error code */ go to order_return; PROC_ORDER (0): /* backspace file */ call SPACE_FILE (BACKWARD); /* correct for position and do the order */ go to order_return; PROC_ORDER (1): /* backspace record (block) */ call SPACE_BLOCK (BACKWARD); /* correct for position and do the order */ go to order_return; PROC_ORDER (2): /* forward space file */ call SPACE_FILE (FORWARD); /* correct for position and do the order */ go to order_return; PROC_ORDER (3): /* forward space record (block) */ call SPACE_BLOCK (FORWARD); /* correct for position and do the order */ go to order_return; PROC_ORDER (4): /* write end of file mark */ on mtape_dev_attention_recovery go to RETRY_WEOF; /* establis condition handler */ do while (repeat_cnt > 0); /* write requested EOFs */ call tape_ioi_$order (mtape_data.tioi_id, order, repeat_cnt, null, act_cnt, rx, code); mtape_data.phy_file = mtape_data.phy_file + act_cnt; /* increment file count */ repeat_cnt = repeat_cnt - act_cnt; call CHECK_RX; /* go check the result index */ if code ^= 0 then /* if error */ if code ^= error_table_$eov_on_write then /* if not EOT */ go to order_return; /* return the error */ else code = 0; /* EOT is not error in this case */ RETRY_WEOF: end; mtape_data.phy_block = 0; /* reset block position to 0 */ go to order_return; PROC_ORDER (5): /* erase */ PROC_ORDER (6): /* data security erase */ call RESOLVE_POSITION; /* make sure we are positioned where we think we are */ if code = 0 then /* if no error yet */ call DO_ORDER (order, repeat_cnt); /* do the requested order */ go to order_return; PROC_ORDER (7): /* rewind */ PROC_ORDER (8): /* rewind unload */ call REWIND_PROC (order, WAIT); /* do it all from this subroutine */ go to order_return; PROC_ORDER (21): /* "rwnw", rewind no wait */ call REWIND_PROC ("rew", NO_WAIT); /* do it all from this subroutine */ go to order_return; PROC_ORDER (22): /* "runw", rewind unload no wait */ call REWIND_PROC ("run", NO_WAIT); /* do it all from this subroutine */ go to order_return; PROC_ORDER (14): /* set density */ call REWIND_PROC ("rew", WAIT); /* rewind the tape first */ if code = 0 then /* if no error on rewind.. */ call DO_ORDER (order, repeat_cnt); /* go do the density order */ go to order_return; /* The following control orders require no special action, except that the tape must be stopped first */ PROC_ORDER (9): /* load tape */ PROC_ORDER (10): /* request status */ PROC_ORDER (11): /* reset status */ PROC_ORDER (12): /* request device status */ PROC_ORDER (13): /* reset device status */ PROC_ORDER (15): /* set file protect */ PROC_ORDER (16): /* set file permit */ PROC_ORDER (17): /* reserve device */ PROC_ORDER (18): /* release device */ PROC_ORDER (19): /* read control registers */ PROC_ORDER (20): /* write control registers */ call STOP_TAPE; /* stop the tape drive */ if code = 0 then /* if no errors stopping the tape */ call DO_ORDER (order, repeat_cnt); /* then do the control order */ order_return: arg_code = code; return; %page; /* set_mode - entry to allow PFMs to set tape_ioi_ modes */ set_mode: entry (arg_mtdp, arg_mode, arg_index, arg_mode_ptr, arg_code); call SETUP; /* set up our enviornment */ mode_ptr = arg_mode_ptr; arg_code = 0; do oidx = hbound (mode_mnemonics, 1) to lbound (mode_mnemonics, 1) by -1 while (mode_mnemonics (oidx) ^= arg_mode); /* get the mode index */ end; go to PROC_MODE (oidx); /* go process correct mode */ PROC_MODE (-1): /* unknown mode */ arg_code = error_table_$bad_arg; return; PROC_MODE (0): /* set data mode */ mode_ptr = addr (HDW_MODE_STR (arg_index)); /* set desired data mode */ go to PROC_MODE_END; PROC_MODE (1): /* set length mode */ mode_ptr = addr (LENGTH_MODES (arg_index)); go to PROC_MODE_END; PROC_MODE (2): /* set alignment mode */ mode_ptr = addr (ALIGN_MODES (arg_index)); go to PROC_MODE_END; PROC_MODE (3): /* set data recovery mode */ mode_ptr = addr (RECOVERY_MODES (arg_index)); go to PROC_MODE_END; PROC_MODE (4): /* set wait mode */ mode_ptr = addr (WAIT_MODES (arg_index)); go to PROC_MODE_END; PROC_MODE (5): /* set event channel, mode_ptr already set */ PROC_MODE (6): /* set recovery channel instruction field */ PROC_MODE_END: call tape_ioi_$set_mode (mtape_data.tioi_id, arg_mode, mode_ptr, arg_code); /* set the mode */ return; %page; /* stop_tape - entry to stop tape motion and syncronize position */ stop_tape: entry (arg_mtdp, arg_code); call SETUP; /* set up our enviornment */ if mtape_data.nbufs > 0 & (mtape_file_info.position_within_file = AT_BOFD | mtape_file_info.position_within_file = AT_IFD) then do; /* don't bother if buffers not allocated */ call STOP_TAPE; /* stop the tape and get the last status */ if ths.major = END_OF_FILE & descrep_cnt > 0 then do; /* if end of file status */ mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file # */ mtape_data.position.phy_block = 0; /* and zero out block number */ mtape_file_info.position_within_file = AT_BOFT; end; else mtape_data.position.phy_block = mtape_data.position.phy_block + descrep_cnt; end; return; %page; /* ALLOCATE_LABEL_BUFFER - internal procedure to allocate and reserve a sync buffer for reading and writing labels */ ALLOCATE_LABEL_BUFFER: proc (buf_len); dcl buf_len fixed bin; dcl act_length fixed bin (21); dcl act_number fixed bin; dcl lbuf_arrayp (1) ptr; call tape_ioi_$allocate_buffers (mtape_data.tioi_id, (buf_len), 1, act_length, act_number, lbuf_arrayp, code); if code ^= 0 then return; /* return on fatal error */ call tape_ioi_$reserve_buffer (mtape_data.tioi_id, lbuf_arrayp (1), code); /* reserve the buffer */ if code ^= 0 then return; /* return on fatal error */ mtape_data.lab_bufp = lbuf_arrayp (1); /* copy label buffer ptr */ mtape_data.lab_buf_len = buf_len; /* set label buffer length */ end ALLOCATE_LABEL_BUFFER; %page; /* RESOLVE_POSITION - subroutine to correct position resulting from reading ahead/writing behind */ RESOLVE_POSITION: proc; if mtape_data.nbufs > 0 then do; /* don't bother if buffers not allocated */ call STOP_TAPE; /* stop the tape and get the last status */ if ths.major = END_OF_FILE then do; /* if end of file status */ descrep_cnt = descrep_cnt - 1; /* decrease descrepency count */ call DO_ORDER ("bsf", 1); /* and backspace across file mark */ end; if descrep_cnt > 0 then /* if we are not already where we should be */ call DO_ORDER ("bsr", descrep_cnt); /* backspace this many blocks */ end; end RESOLVE_POSITION; %page; /* REWIND_PROC - subroutine to stop tape, rewind tape and wait for special */ REWIND_PROC: proc (rew_order, wait); dcl rew_order char (4); /* either "rew" or "run" */ dcl wait bit (1) aligned; mtape_data.phy_file, mtape_data.phy_block = 0; /* reset position */ on mtape_dev_attention_recovery go to WAIT_FOR_REWIND; /* wait for special on recovery */ on cleanup begin; call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code); call CHECK_RX; /* if already rewinding, wait until complete */ end; call tape_ioi_$stop_tape (mtape_data.tioi_id, descrep_cnt, rx, code); /* stop the tape first */ call CHECK_RX; /* check the result index */ if code ^= 0 then /* if error */ return; call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code); call CHECK_RX; /* if already rewinding, wait until complete */ if code ^= 0 then /* if error */ return; call tape_ioi_$order (mtape_data.tioi_id, rew_order, 0, null, act_cnt, rx, code); /* issue rewind order */ call CHECK_RX; /* check the result index */ if code ^= 0 then /* if error */ return; mtape_vol_set.volume_end = "0"b; /* reset EOV flag in vol set structure */ if wait then do; /* user wants to wait for rewind to complete */ WAIT_FOR_REWIND: call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code); call CHECK_RX; /* wait for special interrupt & check the result index */ /* set the density after rewind. */ if vs_ptr ^= null then do; infop = addr (mtape_vol_set.volume_density); call DO_ORDER ("den", 1); end; end; return; end REWIND_PROC; %page; /* SPACE_FILE - subroutine to correct position when forward/backspacing files */ SPACE_FILE: proc (direction); dcl direction bit (1) aligned; /* "1"b => forward space; "0"b => backspace */ if mtape_data.nbufs > 0 then do; /* don't bother if buffers not allocated */ call STOP_TAPE; /* stop the tape and get the last status */ /* if EOF status & we were not already stopped, must correct for async position */ if ths.major = END_OF_FILE & descrep_cnt > 0 then do; if direction = FORWARD then /* forward */ repeat_cnt = repeat_cnt - 1; /* decrease repeat count by 1 */ else repeat_cnt = repeat_cnt + 1; /* backspacing, must backspace 1 more */ end; end; mtape_data.position.phy_block = 0; /* reset block position */ /* Note that block position is undefined if backspacing files */ if repeat_cnt = 0 then do; /* if position adjusted to 0 .. */ mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file position */ return; /* don't do the order, we are already where we should be */ end; call DO_ORDER (order, repeat_cnt); /* do the order */ if code = error_table_$end_of_info then code = 0; /* ignore EOF status */ if direction = FORWARD then /* if spacing forward */ mtape_data.position.phy_file = mtape_data.position.phy_file + act_cnt; /* add files spaced */ else mtape_data.position.phy_file = mtape_data.position.phy_file - act_cnt; /* back, subtract files spaced */ end SPACE_FILE; %page; /* SPACE_BLOCK - subroutine to correct position when forward/backspacing records (blocks) */ SPACE_BLOCK: proc (direction); dcl direction bit (1) aligned; /* "1"b => forward space; "0"b => backspace */ if mtape_data.nbufs > 0 then do; /* don't bother if buffers not allocated */ call STOP_TAPE; /* stop the tape and get the last status */ if ths.major = END_OF_FILE & descrep_cnt > 0 then do; /* if end of file status */ if direction = FORWARD then /* forward spacing? */ if repeat_cnt >= descrep_cnt then do; /* farther than we can go */ mtape_data.position.phy_block = 0; /* correct position */ mtape_data.position.phy_file = mtape_data.position.phy_file + 1; code = error_table_$end_of_info; /* return EOF status to caller */ return; end; call DO_ORDER ("bsf", 1); /* must backspace across file mark */ descrep_cnt = descrep_cnt - 1; /* correct descrepency count */ end; if direction = FORWARD then /* if forward spacing */ if descrep_cnt > repeat_cnt then do; /* but actual position is beyond desired position */ order = "bsr"; /* we will actually have to backspace */ repeat_cnt = (descrep_cnt - repeat_cnt) + 1; /* this many blocks to get to desired position */ end; else repeat_cnt = repeat_cnt - descrep_cnt; /* forward, desired position is beyond actual position */ else repeat_cnt = repeat_cnt + descrep_cnt; /* backward, adjust position */ end; call DO_ORDER (order, repeat_cnt); /* execute the control order */ if code = 0 then do; if direction = FORWARD then /* spacing forward */ mtape_data.position.phy_block = mtape_data.position.phy_block + arg_repeat_cnt; else mtape_data.position.phy_block = mtape_data.position.phy_block - arg_repeat_cnt; end; end SPACE_BLOCK; %page; /* CHECK_RX - internal procedure to check the result index returned by tape_ioi_ and take appropriate action */ CHECK_RX: proc; if rx = TAPE_IO_SUCCESS then /* if no problems */ return; mtape_data.run = "0"b; /* anything else has stopped I/O */ go to RX_ACTION (rx); /* otherwise take appropriate action */ RX_ACTION (-1): /* TAPE_IO_BLOCK, we should never have to go blocked */ RX_ACTION (1): /* TAPE_IO_USER_PROGRAM_ERROR */ RX_ACTION (3): /* TAPE_IO_RECOVERABLE_IO_ERROR, error code set */ RX_ACTION (7): /* TAPE_IO_RECOVERABLE_IO_ERROR_AND_EOT, will lose EOT stat */ return; RX_ACTION (4): /* TAPE_IO_EOF, encountered EOF mark */ mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file number */ mtape_data.position.phy_block = 0; /* reset block number */ code = error_table_$end_of_info; /* set appropriate error code */ return; RX_ACTION (5): /* TAPE_IO_EOT, EOT foil detected */ mtape_vol_set.volume_end = "1"b; /* set EOV flag in vol set structure */ call SYNC_POSITION; /* correct block count */ code = error_table_$eov_on_write; /* set appropriate error code */ return; RX_ACTION (6): /* TAPE_IO_BOT, backspaced into BOT */ code = error_table_$positioned_on_bot; /* set appropriate error code */ return; RX_ACTION (8): /* TAPE_IO_CODE_ALERT */ code = error_table_$nine_mode_parity; /* set appropriate error code */ RX_ACTION (2): /* TAPE_IO_UNRECOVERABLE_IO_ERROR, error code set */ unr_code = code; /* save error code */ call SYNC_POSITION; /* correct the block count */ if mtape_data.last_io = WRITE_IO then /* if we are writing data */ mtape_data.phy_block = mtape_data.phy_block - 1; /* subtract current buffer */ call mtape_check_status_ (mtdp, unr_code); /* go check the error */ code = unr_code; /* copy returned error code */ end CHECK_RX; %page; /* UNLOAD_LREC_CNT - internal procedure to increment the logical record round robin counter */ UNLOAD_LREC_CNT: proc; mtape_data.tot_lrec = mtape_data.tot_lrec + mtape_data.log_record; /* increment total */ mtape_data.blk_rrrc (mtape_data.blk_rrcx) = mtape_data.log_record; /* save lrecs in last block */ mtape_data.log_record = 0; /* reset inter-block rec count */ mtape_data.blk_rrcx = mtape_data.blk_rrcx + 1; /* increment index for next block */ if mtape_data.blk_rrcx > hbound (mtape_data.blk_rrrc, 1) then /* if at end of RRC */ mtape_data.blk_rrcx = 0; /* reset it to top of RRC */ end UNLOAD_LREC_CNT; /* GET_HDW_STATUS - internal procedure to get the current hardware status from tape_ioi_ */ GET_HDW_STATUS: proc; ths_ptr = addr (auto_ths); /* set pointer to auto structure */ ths.version = THS_VERSION; /* set version */ call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, scode); /* get status */ end GET_HDW_STATUS; /* STOP_TAPE - subroutine to stop the tape and get the last hardware status */ STOP_TAPE: proc; code = 0; call tape_ioi_$stop_tape (mtape_data.tioi_id, descrep_cnt, rx, code); call CHECK_RX; /* check result index */ call GET_HDW_STATUS; /* get the current hardware status */ end STOP_TAPE; %page; /* DO_ORDER - subroutine to execute a control order */ DO_ORDER: proc (order, arg_repeat_cnt); dcl order char (4); dcl (arg_repeat_cnt, repeat_cnt) fixed bin; code = 0; repeat_cnt = arg_repeat_cnt; /* establish conditon handler */ on mtape_dev_attention_recovery go to REPEAT_ORDER; do while (repeat_cnt > 0 & code = 0); /* do requested orders */ call tape_ioi_$order (mtape_data.tioi_id, order, repeat_cnt, infop, act_cnt, rx, code); repeat_cnt = repeat_cnt - act_cnt; call CHECK_RX; /* go check the result index */ REPEAT_ORDER: end; if code ^= 0 then do; if code = error_table_$end_of_info then code = 0; else call mtape_util_$error (mtdp, code, "While attempting a ^a control order.", order); end; return; end DO_ORDER; /* SYNC_POSITION - internal procedure to syncronize the position after a write err */ SYNC_POSITION: proc; dcl susp_smple (1) ptr; dcl n_susp_bufs fixed bin; call tape_ioi_$list_buffers (mtape_data.tioi_id, SUSPENDED_STATE, susp_smple, n_susp_bufs, code); if code ^= 0 then do; /* error from list_buffers */ call mtape_util_$error (mtdp, code, /* report it */ "Error from tape_ioi_$list_buffers"); return; end; mtape_data.position.phy_block = mtape_data.position.phy_block - n_susp_bufs; end SYNC_POSITION; %page; /* SETUP - internal procedure to set up environment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinent data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; if mtape_data.tioi_id = "0"b then do; /* should only happen if "ring_in" order executed */ call mtape_mount_cntl_$mount (mtdp, code); /* get the volume mounted */ if code ^= 0 then do; call mtape_util_$error (mtdp, code, "^/Attempting to mount volume ^a following ""ring_in"" control operation", mtape_vol_set.volume_name); go to ERROR_RETURN; /* take non_local goto */ end; arg_mtdp = mtdp; /* reset callers control structure ptr */ free mtape_data.cmtdp -> mtape_data in (based_area); /* free the old structure */ mtape_data.cmtdp = null; end; rx, arg_code, code = 0; /* and reset error codes */ end SETUP; ERROR_RETURN: /* target of non-local gotos */ arg_code = code; /* copy return code */ return; /* return to caller */ %page; %include mtape_data; %page; %include mtape_vol_set; %page; %include mtape_label_record; %include mtape_err_stats; %page; %include mtape_file_info; %page; %include mtape_constants; %page; %include tape_ioi_dcls; %page; %include tape_ioi_buffer_status; %page; %include tape_ioi_result_indexes; %include tape_ioi_hw_status; end mtape_io_;  mtape_iox_.pl1 12/01/87 0801.0rew 11/30/87 1323.7 311769 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Added more complete setting of the iocb. Return on tape errors. 2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. END HISTORY COMMENTS */ mtape_iox_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. This * program implements most of the entries called through iox_ for * mtape_. * * Modification History: * * Created by J. A. Bush 10/05/82 * Modified by J. A. Bush 12/01/83 for performance improvements */ /* ARGUMENT DATA */ dcl arg_iocbp ptr; /* (Input) Pointer to the I/O control block */ dcl arg_options (*) char (*) varying; /* (Input) Attach options from attach description. */ dcl arg_com_err_flag bit (1) aligned; /* (Input) "1"b => call com_err_ on attach errors */ dcl arg_extend_flag bit (1); dcl arg_open_mode fixed bin; /* Opening mode */ dcl arg_buf_ptr ptr; /* Pointer to users buffer to read into/write from */ dcl arg_buf_len fixed bin (21); /* Length of users buffer/bytes to be read */ dcl arg_rec_len fixed bin (21); /* Length of record/number of bytes read */ dcl arg_code fixed bin (35); /* (Output) Standard system error code */ /* AUTOMATIC DATA */ dcl iocbp ptr; /* pointer to our IOCB */ dcl com_err_flag bit (1) aligned; /* "1"b => call com_err_ on attach errors */ dcl (output, com_sent) bit (1) aligned; dcl (i, nsusp_bufs) fixed bin; dcl ips_mask bit (36) aligned; dcl desc_len fixed bin (21); dcl (code, iox_code) fixed bin (35); /* error code value */ dcl 1 auto_mtd like mtape_data aligned; /* temporary auto copy of mtape_ data base */ dcl 1 ai like area_info aligned; /* CONSTANT DATA */ dcl myname char (6) int static options (constant) init ("mtape_"); dcl null_options (1) char (1) varying int static options (constant) init (""); dcl READ_IO fixed bin int static options (constant) init (1); dcl WRITE_IO fixed bin int static options (constant) init (2); /* EXTERNAL STATIC DATA */ dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$bad_label fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, hbound, lbound, length, null, unspec) builtin; /* EXTERNAL ENTRIES */ dcl (ioa_, com_err_) entry options (variable); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl user_info_$process_type entry (fixed bin); dcl mtape_util_$error entry options (variable); dcl mtape_util_$get_statistics entry (ptr, fixed bin (35)); dcl mtape_util_$init_pfm entry (ptr, fixed bin (35)); dcl mtape_util_$user_query entry (ptr, fixed bin, fixed bin (35)); dcl mtape_parse_$attach entry (ptr, (*) char (*) varying, fixed bin (35)); dcl mtape_parse_$open entry (ptr, (*) char (*) varying, fixed bin, fixed bin (35)); dcl mtape_parse_$close entry (ptr, (*) char (*) varying, fixed bin (35)); dcl mtape_parse_$detach entry (ptr, (*) char (*) varying, fixed bin (35)); dcl mtape_mount_cntl_$mount entry (ptr, fixed bin (35)); dcl mtape_mount_cntl_$demount entry (ptr, fixed bin (35)); dcl mtape_iox_$open entry options (variable); dcl mtape_iox_$open_file entry options (variable); dcl mtape_iox_$close entry options (variable); dcl mtape_iox_$close_file entry options (variable); dcl mtape_iox_$detach entry options (variable); dcl mtape_iox_$detach_iocb entry options (variable); dcl mtape_control_$control entry options (variable); dcl mtape_position_ entry options (variable); dcl mtape_position_$read_length entry options (variable); dcl mtape_io_$allocate_buffers entry (ptr, fixed bin (21), fixed bin (35)); dcl mtape_io_$set_mode entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl mtape_io_$stop_tape entry (ptr, fixed bin (35)); dcl mtape_iox_$write entry options (variable); dcl mtape_iox_$read entry options (variable); dcl iox_$propagate entry (ptr); dcl iox_$err_not_open entry () options (variable); dcl iox_$err_not_closed entry () options (variable); dcl iox_$err_not_attached entry () options (variable); dcl define_area_ entry (ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); /* BASED STORAGE */ dcl desc_string char (desc_len) varying based; dcl based_area area based (mtape_data.areap); /* CONDITIONS */ dcl (any_other, cleanup) condition; %page; mtape_attach: entry (arg_iocbp, arg_options, arg_com_err_flag, arg_code); /* * This entry is called to attach a tape volume or volume set to the * users process through the specified I/O switch. The major tasks * performed by this entry are as follows: * * 1. Parsing and validation of the options array, which iox_ generated * from the users attach description. * 2. Initialization of the mtape_ environment, including allocation of * 1 volume set structure for each volume set member specified in * the options array and initialization of the global default values * from the users default value_seg (this includes creation of the * global default values on first reference). * 3. Requesting the mount of the first volume in the volume set via * RCP. * 4. Establishing the tape_ioi_ activation. * 5. Selection of the appropriate "Per-Format" module, based on * information returned from RCP in conjuction with any "-label" and * "-no_labels" information specified by the user in the attach * description and/or the current value of the "mtape_.global.label" * default value. * 6. Perform a search for the selected per-format module via the * search path mechanism to verify its existence. * 7. Fill in the standard fields of the I/O control block to indicate * I/O switch attachment complete, ready for opening. */ iocbp = arg_iocbp; /* copy arguments */ com_err_flag = arg_com_err_flag; mtdp = null; /* make this ptr consistent for first possible error msg */ if iocbp -> iocb.attach_data_ptr ^= null then do; /* If aready attached.. */ call ATTACH_ERROR (error_table_$not_detached, (iocbp -> iocb.name)); /* complain and let user call */ return; /* again until he gets it right */ end; on cleanup call CLEANUP; call INIT_ENVIRONMENT; /* Initialize working environment */ if arg_code ^= 0 then /* quit if some problem */ return; call mtape_parse_$attach (mtdp, arg_options, code); /* parse the attach options */ if code ^= 0 then do; /* return to user if unrecoverable error */ arg_code = code; call CLEANUP; /* undo everything we have done so far */ return; end; com_err_flag = com_err_flag | mtape_data.display_errors; /* error messages if either one */ if mtape_attach_info.display then do; /* user wants to see attach description */ desc_len = length (mtape_data.atdp -> desc_string); /* set the length */ call ioa_ ("^/ATTACH DESCRIPTION:^/^a^/", mtape_data.atdp -> desc_string); /* display it */ end; call mtape_mount_cntl_$mount (mtdp, code); /* get the first volume mounted */ if code ^= 0 then do; /* return to user if unrecoverable error */ arg_code = code; call CLEANUP; /* undo everything we have done so far */ return; end; call mtape_util_$init_pfm (mtdp, code); /* perform the Per-Format module selection */ if code ^= 0 then do; /* if we can't find it, bail out */ call CLEANUP; arg_code = code; return; end; call mtape_data.pfm_init (mtdp, code); /* Let PFM initialize and check volume label */ if code ^= 0 then do; arg_code = code; call CLEANUP; return; end; if (^mtape_attach_info.labeled & ^mtape_pfm_info.no_labels_ok) then do; /* illegal combo */ arg_code = error_table_$inconsistent; call mtape_util_$error (mtdp, arg_code, "^/The ^a Per-Format module does not support unlabeled volumes", mtape_pfm_info.module_id); return; end; /* The attachment is now complete. We must now fill in the IOCB with appropriate information and propagate it. */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocbp -> iocb.attach_descrip_ptr = mtape_data.atdp; iocbp -> iocb.attach_data_ptr = mtdp; iocbp -> iocb.detach_iocb = mtape_iox_$detach_iocb; iocbp -> iocb.detach = mtape_iox_$detach; iocbp -> iocb.open = mtape_iox_$open; iocbp -> iocb.open_file = mtape_iox_$open_file; iocbp -> iocb.close = iox_$err_not_open; iocbp -> iocb.close_file = iox_$err_not_open; iocbp -> iocb.control = mtape_control_$control; call iox_$propagate (iocbp); /* propagate this IOCB */ call hcs_$reset_ips_mask (ips_mask, ips_mask); return; /* thats all folks */ %page; /* open - entry to open the I/O switch */ open: entry (arg_iocbp, arg_open_mode, arg_extend_flag, arg_code); /* this entry merely passes control to the open_file entry with a null option array */ call open_file_int (arg_iocbp, arg_open_mode, null_options, arg_extend_flag, arg_code); return; /* open_file - entry to open an I/O switch with open arguments passed in the open argument array */ open_file: open_file_int: entry (arg_iocbp, arg_open_mode, arg_options, arg_extend_flag, arg_code); iocbp = arg_iocbp -> iocb.actual_iocb_ptr; /* copy argument */ code, arg_code = 0; /* reset return code */ mtdp = iocbp -> iocb.attach_data_ptr; /* get our working storage pointer */ mtape_data.iocb_ptr = iocbp; /* save our IOCB ptr */ maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; mspfmip = mtape_data.saved_pfm_info_ptr; vs_ptr = mtape_data.vs_current; /* get vol set structure ptr */ do i = 1 to hbound (mtape_pfm_info.open_modes_allowed, 1) /* check open mode legality */ while (arg_open_mode ^= mtape_pfm_info.open_modes_allowed (i)); end; if i > hbound (mtape_pfm_info.open_modes_allowed, 1) then do; /* can't open for this mode */ code = error_table_$bad_mode; /* set appropriate error code */ call mtape_util_$error (mtdp, code, "Open mode of ^d is invalid for the selected Per-Format module", arg_open_mode); go to OPEN_EXIT; end; if arg_open_mode = Stream_input | arg_open_mode = Sequential_input then /* input mode? */ output = "0"b; else output = "1"b; /* no output type mode */ if output & ^mtape_attach_info.ring then do; /* if output mode and no write ring */ code = error_table_$bad_mode; call mtape_util_$error (mtdp, code, "Opening for ""^a"" requires the presence of a write ring.^/^a^/^a", iox_modes (arg_open_mode), "Either detach and reattach with a ""-ring"" attach description argument,", "or use the ""ring_in"" control order."); go to OPEN_EXIT; end; if ^mtape_data.first_file then /* if the first opening */ if output then do; /* opening for output */ mtape_vol_set.volume_density = mtape_attach_info.density; if mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME | /* query user before destroying */ (mtape_vol_set.volume_check < BLANK_VOLUME & ^mtape_attach_info.labeled) then do; call mtape_util_$user_query (mtdp, Q_LABELED_VOLUME, code); if code ^= 0 then go to OPEN_EXIT; end; end; else do; /* opening for input */ if mtape_vol_set.volume_check > NON_MULT_VOLUME & /* trying to read is clearly wrong */ ^(mtape_pfm_info.no_labels_ok & mtape_vol_set.volume_check = UNLABELED_VOLUME) then do; code = error_table_$bad_label; /* set appropriate error code */ call mtape_util_$error (mtdp, code,/* and report error */ "^/Attempting to open a file for ^a on a volume ^[(^a) ^;^1s^]which has an ^a label", iox_modes (arg_open_mode), (mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME), mtape_vol_set.volume_id, Tape_volume_types (mtape_vol_set.volume_type)); end; else if (mtape_vol_set.volume_check < BLANK_VOLUME & ^mtape_attach_info.labeled) then do; call mtape_util_$error (mtdp, 0, "Volume ^a will be processed as a standard ^a labeled tape. ^a.", mtape_vol_set.volume_id, mtape_pfm_info.module_id, "The ""-no_labels"" attach description argument will be ignored"); mtape_attach_info.labeled = "1"b; /* make it a labeled tape */ end; else if (mtape_vol_set.volume_check = UNLABELED_VOLUME & mtape_pfm_info.no_labels_ok) then if mtape_attach_info.labeled then do; /* go ahead and process as unlabeled */ call mtape_util_$error (mtdp, 0, "Volume ^a will be processed as an ^a unlabeled volume", mtape_vol_set.volume_name, mtape_pfm_info.module_id); mtape_attach_info.labeled = "0"b; /* force the unlabeled attribute */ end; end; if code ^= 0 then /* if some problem up above */ go to OPEN_EXIT; /* bail out now */ call mtape_parse_$open (mtdp, arg_options, arg_open_mode, code); /* go parse the open options */ if code ^= 0 then go to OPEN_EXIT; if mtape_open_info.display then do; /* user wants to see open description */ desc_len = length (mtape_data.opdp -> desc_string); /* set the length */ call ioa_ ("^/OPEN DESCRIPTION:^/^a^/", mtape_data.opdp -> desc_string); /* display it */ end; call mtape_data.file_open (mtdp, code); /* let the PFM do his thing */ if code ^= 0 then go to OPEN_EXIT; mtape_data.error_lock = 0; /* reset data error lock */ if mspfmip ^= null then /* if we have done a change_module control OP */ if output then /* and this is an output type opening */ if mtape_saved_pfm_info.open_mode = 0 then /* and first output */ mtape_saved_pfm_info.open_mode = arg_open_mode; /* save this one */ fi_ptr = mtape_data.fi_current; mtape_data.char_size = mtape_file_info.char_size; /* copy required info into mtape_data */ mtape_data.length_mode = mtape_file_info.length_mode; mtape_data.hdw_mode = mtape_file_info.hdw_mode; mtape_data.conversion = mtape_file_info.conversion; mtape_data.buffer_offset = mtape_file_info.buffer_offset; mtape_data.block_size, mtape_data.length = mtape_file_info.block_size; mtape_data.record_size = mtape_file_info.record_size; mtape_data.native_file = mtape_file_info.native_file; if mtape_file_info.file_format > 4 then do; /* set adjusted format code */ mtape_data.ad_file_format = mtape_file_info.file_format - 3; mtape_data.file_blocked = "1"b; /* set switch for blocked file */ end; else do; /* not a blocked file */ mtape_data.ad_file_format = mtape_file_info.file_format; mtape_data.file_blocked = "0"b; end; mtape_data.tot_bytes_processed, mtape_data.last_io, mtape_data.prev_block_no = 0; mtape_data.write_after_read, mtape_data.run = "0"b; mtape_data.first_file = "1"b; if mtape_data.nbufs > 0 then /* buffers already allocated? */ if mtape_data.buf_size ^= mtape_data.block_size then do; call tape_ioi_$deallocate_buffers (mtape_data.tioi_id, code); if code ^= 0 then go to OPEN_EXIT; mtape_data.nbufs = 0; /* set indicator to reallocate buffers */ end; else do; /* buffers allocated and of right size */ call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, nsusp_bufs, code); if code ^= 0 then go to OPEN_EXIT; end; if mtape_data.nbufs = 0 then do; /* If we don't already have buffers */ call mtape_io_$allocate_buffers (mtdp, mtape_data.block_size, code); /* allocate them */ if code ^= 0 then go to OPEN_EXIT; end; call mtape_io_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set desired HW mode */ if code = 0 then call mtape_io_$set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and length mode */ if code ^= 0 then go to OPEN_EXIT; mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1); mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx); mtape_data.cur_block.length = mtape_data.buf_size;/* set up for max length */ mtape_data.processed = mtape_data.buffer_offset; /* skip over any buffer offset */ if output then /* if writing, set remaining bytes */ mtape_data.remain = mtape_data.cur_block.length - mtape_data.processed; else mtape_data.remain = 0; /* if reading, must read first block */ mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); /* set initial lrec ptr */ mtape_data.buf_len (*) = 0; if mtape_open_info.comment ^= "" then /* user wants to see comment */ call ioa_ ("^/OPEN COMMENT:^/^a^/", mtape_open_info.comment); /* opened ok, now fill in IOCB */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocbp -> iocb.open_descrip_ptr = mtape_data.opdp; iocbp -> iocb.open = iox_$err_not_closed; iocbp -> iocb.open_file = iox_$err_not_closed; iocbp -> iocb.detach_iocb = iox_$err_not_closed; iocbp -> iocb.detach = iox_$err_not_closed; iocbp -> iocb.close = mtape_iox_$close; iocbp -> iocb.close_file = mtape_iox_$close_file; if arg_open_mode = Sequential_output then iocbp -> iocb.write_record = mtape_iox_$write; else if arg_open_mode = Stream_output then iocbp -> iocb.put_chars = mtape_iox_$write; else if arg_open_mode = Sequential_input then do; iocbp -> iocb.read_record = mtape_iox_$read; iocbp -> iocb.position = mtape_position_; iocbp -> iocb.read_length = mtape_position_$read_length; end; else if arg_open_mode = Stream_input then do; iocbp -> iocb.get_chars = mtape_iox_$read; iocbp -> iocb.position = mtape_position_; end; else if arg_open_mode = Sequential_input_output then do; iocbp -> iocb.read_record = mtape_iox_$read; iocbp -> iocb.write_record = mtape_iox_$write; iocbp -> iocb.position = mtape_position_; iocbp -> iocb.read_length = mtape_position_$read_length; end; else do; /* Steam_input_output */ iocbp -> iocb.get_chars = mtape_iox_$read; iocbp -> iocb.put_chars = mtape_iox_$write; iocbp -> iocb.position = mtape_position_; end; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (ips_mask, ips_mask); OPEN_EXIT: arg_code = code; return; %page; /* close - entry to close the I/O switch */ close: entry (arg_iocbp, arg_code); /* this entry merely passes control to the close_file entry with a null option array */ call close_file_int (arg_iocbp, null_options, arg_code); return; /* close_file - entry to close an I/O switch with close arguments passed in the close argument array */ close_file: close_file_int: entry (arg_iocbp, arg_options, arg_code); iocbp = arg_iocbp -> iocb.actual_iocb_ptr; /* copy argument */ arg_code = 0; /* reset return code */ mtdp = iocbp -> iocb.attach_data_ptr; /* get our working storage pointer */ mtape_data.iocb_ptr = iocbp; /* save our IOCB ptr */ vs_ptr = mtape_data.vs_current; /* get vol set structure ptr */ maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mcip = mtape_data.close_info_ptr; mpfmip = mtape_data.pfm_info_ptr; call mtape_parse_$close (mtdp, arg_options, code);/* go parse the close description */ if code ^= 0 then go to CLOSE_EXIT; if mtape_close_info.display then do; /* user wants to see close description */ desc_len = length (mtape_data.cldp -> desc_string); /* set the length */ call ioa_ ("^/CLOSE DESCRIPTION:^/^a^/", mtape_data.cldp -> desc_string); /* display it */ end; call mtape_data.file_close (mtdp, code); /* let the PFM do his thing */ if mtape_data.fi_current ^= null then /* if we were actually processing file */ call mtape_io_$stop_tape (mtdp, code); /* get the tape stopped & buffers rdyed */ call mtape_util_$get_statistics (mtdp, code); /* update error stats */ mtape_data.error_lock = 0; /* reset data error lock */ mtape_data.cur_block.length, mtape_data.cur_block.processed, mtape_data.cur_block.remain, mtape_data.cur_block.log_record = 0; mtape_data.last_io, mtape_data.lrec_rrcx = 0; mtape_data.lrec_rrc (*).block_no, mtape_data.lrec_rrc (*).abs_byte, mtape_data.lrec_rrc (*).byte_offset = 0; if mtape_close_info.comment ^= "" then /* user wants to see comment */ call ioa_ ("^/CLOSE COMMENT:^/^a^/", mtape_close_info.comment); /* closed ok, now reset pertinent IOCB entries */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocbp -> iocb.detach_iocb = mtape_iox_$detach_iocb; iocbp -> iocb.detach = mtape_iox_$detach; iocbp -> iocb.open = mtape_iox_$open; iocbp -> iocb.open_file = mtape_iox_$open_file; iocbp -> iocb.control = mtape_control_$control; iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.put_chars = iox_$err_not_open; iocbp -> iocb.get_chars = iox_$err_not_open; iocbp -> iocb.write_record = iox_$err_not_open; iocbp -> iocb.read_record = iox_$err_not_open; iocbp -> iocb.read_length = iox_$err_not_open; iocbp -> iocb.position = iox_$err_not_open; iocbp -> iocb.close = iox_$err_not_open; iocbp -> iocb.close_file = iox_$err_not_open; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (ips_mask, ips_mask); CLOSE_EXIT: arg_code = code; return; %page; /* detach_iocb - entry to detach the I/O switch */ detach_iocb: entry (arg_iocbp, arg_code); /* this entry merely passes control to the detach entry with a null option array */ call detach_int (arg_iocbp, null_options, arg_code); return; /* detach - entry to detach an I/O switch with detach arguments passed in the detach argument array */ detach: detach_int: entry (arg_iocbp, arg_options, arg_code); iocbp = arg_iocbp -> iocb.actual_iocb_ptr; /* copy argument */ arg_code = 0; /* reset return code */ mtdp = iocbp -> iocb.attach_data_ptr; /* get our root pointer */ mtape_data.iocb_ptr = iocbp; /* save our IOCB ptr */ mdip = mtape_data.detach_info_ptr; /* set this ptr */ call mtape_parse_$detach (mtdp, arg_options, code); /* parse detach options */ if code ^= 0 then go to DETACH_EXIT; if mtape_detach_info.display then do; /* user wants to see detach description */ desc_len = length (mtape_data.dtdp -> desc_string); /* set the length */ call ioa_ ("^/DETACH DESCRIPTION:^/^a^/", mtape_data.dtdp -> desc_string); /* display it */ end; auto_mtd = mtape_data; /* copy mtape_data back to auto storage */ mtdp = addr (auto_mtd); /* now we can deallocate our work area */ /* Now go through the entire volume set and demount all volumes */ com_sent = "0"b; do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null); if mtape_vol_set.mounted then do; /* if volume currently mounted... */ mtape_data.vs_current = vs_ptr; /* set current volume set ptr */ mtape_data.tioi_id = mtape_vol_set.tioi_id; /* just to be sure */ if mtape_detach_info.comment ^= "" then /* if we have a demount comment */ if ^com_sent then do; /* and it hasn't already been seen */ com_sent = "1"b; /* set flag so we want send it again */ mtape_vol_set.demount_comment = mtape_detach_info.comment; /* copy the comment */ end; if mtape_detach_info.unload then /* if user wants volume unloaded */ call mtape_io_$order (mtdp, "runw", 0, null, code); /* unload volume */ else call mtape_io_$order (mtdp, "rwnw", 0, null, code); /* rewind volume */ call mtape_mount_cntl_$demount (mtdp, code); /* demount the volume */ end; end; call release_area_ (mtape_data.areap); /* we can free up our area now */ if mtape_data.mount_echan ^= 0 then /* if we created mount event channel.. */ call ipc_$delete_ev_chn (mtape_data.mount_echan, code); /* delete it */ if mtape_data.io_echan ^= 0 then /* if we created io event channel.. */ call ipc_$delete_ev_chn (mtape_data.io_echan, code); /* delete it */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocbp -> iocb.attach_data_ptr = null; iocbp -> iocb.attach_descrip_ptr = null; iocbp -> iocb.open = iox_$err_not_attached; iocbp -> iocb.open_file = iox_$err_not_attached; iocbp -> iocb.close = iox_$err_not_attached; iocbp -> iocb.close_file = iox_$err_not_attached; iocbp -> iocb.detach = iox_$err_not_attached; iocbp -> iocb.detach_iocb = iox_$err_not_attached; call iox_$propagate (iocbp); /* wipe us out as far as iox_ is concerned */ call hcs_$reset_ips_mask (ips_mask, ips_mask); DETACH_EXIT: arg_code = code; /* copy return code */ return; %page; /* read - This entry implements the iox_$read_record entry for sqi and sqio openings, and the iox_$get_chars entry for si and sio openings */ read: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_rec_len, arg_code); mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */ mtape_data.iocb_ptr = arg_iocbp -> iocb.actual_iocb_ptr; /* save IOCB ptr */ mtape_data.arg_buf_ptr = arg_buf_ptr; /* save iox_ args for PFM */ mtape_data.arg_buf_len = arg_buf_len; if mtape_data.error_lock ^= 0 then do; /* if a previous error exists.. */ arg_rec_len = 0; /* can't read anymore */ arg_code = mtape_data.error_lock; /* give user back same error */ return; end; if mtape_data.last_io = WRITE_IO then do; /* Read after write a no-no */ iox_code = error_table_$no_operation; /* set error code */ call mtape_util_$error (mtdp, code, "Attempting forward read after write."); go to read_return; end; mtape_data.last_io = READ_IO; /* set for next operation check */ call RECORD_HISTORY; /* update record history counters */ call mtape_data.read (mtdp, iox_code); /* let the PFM do the work */ arg_rec_len = mtape_data.arg_rec_len; /* copy record length for user */ if iox_code ^= 0 then /* if we had an error */ if iox_code ^= error_table_$long_record then do; /* and not a long record */ mtape_data.error_lock = iox_code; /* set the error lock */ go to read_return; end; mtape_data.log_record = mtape_data.log_record + 1;/* increment log records, this block */ read_return: arg_code = iox_code; /* return error code */ return; %page; /* write - This entry implements the iox_$write_record entry for sqo and sqio openings, and the iox_$put_chars entry for so and sio openings */ write: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_code); mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */ mtape_data.iocb_ptr = arg_iocbp -> iocb.actual_iocb_ptr; /* save IOCB ptr */ mtape_data.arg_buf_ptr = arg_buf_ptr; /* copy iox_ args for PFM */ mtape_data.arg_buf_len = arg_buf_len; if mtape_data.error_lock ^= 0 then do; /* if a previous error exists.. */ arg_code = mtape_data.error_lock; /* give user back same error */ return; end; if mtape_data.last_io = READ_IO then /* nothing wrong with this for input/output openings */ mtape_data.write_after_read = "1"b; /* But flag it */ mtape_data.last_io = WRITE_IO; call RECORD_HISTORY; /* increment record history counters */ call mtape_data.write (mtdp, iox_code); /* let the PFM do the work */ if iox_code ^= 0 then /* if we had an error */ if iox_code ^= error_table_$long_record then do; /* and not a long record */ mtape_data.error_lock = iox_code; /* set the error lock */ go to write_return; end; mtape_data.log_record = mtape_data.log_record + 1;/* increment log record counter */ write_return: arg_code = iox_code; /* return error code */ return; %page; /* ATTACH_ERROR - internal procedure to handle errors encountered during the attach call. */ ATTACH_ERROR: procedure (ecode, msg); dcl ecode fixed bin (35); dcl msg char (*); arg_code = ecode; /* return error code to user */ if com_err_flag then call com_err_ (ecode, myname, "^a", msg); end ATTACH_ERROR; /* CLEANUP - internal procedure to clean up the mtape_ environment on an attach error */ CLEANUP: procedure; if mtdp ^= null then do; /* if we have a structure already */ if mtape_data.vs_current ^= null then /* if we have a volume set */ if mtape_data.vs_current -> mtape_vol_set.mounted then do; /* and a volume is mounted */ auto_mtd = mtape_data; /* copy mtape_ data out of work area */ mtdp = addr (auto_mtd); /* and set ptr to it */ call mtape_mount_cntl_$demount (mtdp, (0)); /* demount it */ end; call release_area_ (mtape_data.areap); /* release our area */ mtdp = null; /* set pointer to null */ end; end CLEANUP; /* RECORD_HISTORY - internal procedure to record logical record history */ RECORD_HISTORY: proc; mtape_data.lrec_rrc (mtape_data.lrec_rrcx).block_no = mtape_data.phy_block; mtape_data.lrec_rrc (mtape_data.lrec_rrcx).block_len = mtape_data.length; mtape_data.lrec_rrc (mtape_data.lrec_rrcx).lrec_no = mtape_data.log_record; mtape_data.lrec_rrc (mtape_data.lrec_rrcx).abs_byte = mtape_data.tot_bytes_processed; mtape_data.lrec_rrc (mtape_data.lrec_rrcx).byte_offset = mtape_data.processed + 1; mtape_data.lrec_rrcx = mtape_data.lrec_rrcx + 1; /* increment history index */ if mtape_data.lrec_rrcx > hbound (mtape_data.lrec_rrc.block_no, 1) then /* if at the top of RRC */ mtape_data.lrec_rrcx = lbound (mtape_data.lrec_rrc.block_no, 1); /* reset for bottom */ end RECORD_HISTORY; %page; /* INIT_ENVIRONMENT - internal procedure to initialize the mtape_ working environment */ INIT_ENVIRONMENT: procedure; mtdp = addr (auto_mtd); /* put data in temporary auto copy for now */ unspec (auto_mtd) = "0"b; /* Initialize structure */ mtape_data.version = mtape_data_version_1; /* set version */ mtape_data.areap = null; /* Now set some required fields */ mtape_data.iocb_ptr = iocbp; /* save IOCB ptr */ mtape_data.atdp, mtape_data.opdp, mtape_data.cldp, mtape_data.dtdp, mtape_data.cmtdp = null; mtape_data.vs_head, mtape_data.vs_tail, mtape_data.vs_current = null; mtape_data.fi_head, mtape_data.fi_tail, mtape_data.fi_current = null; mtape_data.vs_mounted_tail, mtape_data.tape_infop, mtape_data.tlb = null; mtape_data.buf_ptrs (*), mtape_data.saved_pfm_info_ptr, mtape_data.last_ur_status_ptr = null; mtape_data.lab_bufp, mtape_data.cur_buf_ptr, mtape_data.log_record_ptr = null; mtape_data.pfm_name, mtape_data.abs_ans = ""; call user_info_$process_type (i); /* What kind of user is this anyway? */ if i ^= 2 then /* if not absentee.... */ mtape_data.user_type = "1"b; /* set bit for interactive user */ unspec (ai) = "0"b; /* clear out area info */ ai.version = area_info_version_1; /* set up area info block */ ai.control.extend = "1"b; ai.control.zero_on_alloc = "1"b; ai.owner = myname; ai.size = sys_info$max_seg_size; ai.version_of_area = area_info_version_1; ai.areap = null; call define_area_ (addr (ai), code); /* get an area, for general use */ if code ^= 0 then do; call ATTACH_ERROR (code, "from define_area_"); return; end; mtape_data.areap = ai.areap; /* copy area pointer */ /* Now allocate assorted info structures */ allocate mtape_attach_info in (based_area) set (maip); /* allocate attach info structure */ allocate mtape_open_info in (based_area) set (moip); /* allocate open info structure */ allocate mtape_close_info in (based_area) set (mcip); /* allocate close info structure */ allocate mtape_detach_info in (based_area) set (mdip); /* allocate detach info structure */ allocate mtape_pfm_info in (based_area) set (mpfmip); /* allocate pfm info structure */ /* and do any necessary initialization */ mtape_attach_info.version = mtape_attach_info_version_1; /* Set proper structure version */ mtape_attach_info.version = mtape_attach_info_version_1; mtape_open_info.version = mtape_open_info_version_1; mtape_close_info.version = mtape_close_info_version_1; mtape_open_info.cs_ptr, mtape_close_info.cs_ptr = null; mtape_open_info.cal_ptr, mtape_close_info.cal_ptr = null; mtape_open_info.so_ptr, mtape_close_info.so_ptr = null; mtape_detach_info.version = mtape_detach_info_version_1; mtape_pfm_info.version = mtape_pfm_info_version_1; mtape_data.attach_info_ptr = maip; /* Record ptrs in root structure */ mtape_data.open_info_ptr = moip; mtape_data.close_info_ptr = mcip; mtape_data.detach_info_ptr = mdip; mtape_data.pfm_info_ptr = mpfmip; mtape_pfm_info.module_id = ""; /* Do any necessary blank filling */ mtape_pfm_info.pfm_open_options.pfm_opt_flags (*).flag_name = ""; mtape_pfm_info.pfm_open_options.pfm_opt_flags (*).flag_ant_name = ""; mtape_pfm_info.pfm_open_options.pfm_opt_value_name (*) = ""; mtape_pfm_info.pfm_open_options.pfm_opt_str_name (*) = ""; mtape_pfm_info.pfm_close_options.pfm_opt_flags (*).flag_name = ""; mtape_pfm_info.pfm_close_options.pfm_opt_flags (*).flag_ant_name = ""; mtape_pfm_info.pfm_close_options.pfm_opt_value_name (*) = ""; mtape_pfm_info.pfm_close_options.pfm_opt_str_name (*) = ""; mtape_attach_info.pfm_prefix, mtape_attach_info.default_pfm_prefix = ""; end INIT_ENVIRONMENT; %page; %include iocb; %page; %include mtape_data; %page; %include mtape_attach_info; %include mtape_detach_info; %include mtape_saved_pfm_info; %page; %include mtape_open_close_info; %page; %include mtape_pfm_info; %include mtape_err_stats; %page; %include mtape_vol_set; %page; %include mtape_file_info; %page; %include mtape_constants; %page; %include area_info; %page; %include rcp_volume_formats; %page; %include iox_modes; %page; %include tape_ioi_dcls; %page; %include tape_ioi_buffer_status; end mtape_iox_;  mtape_mount_cntl_.pl1 12/01/87 0801.0rew 11/30/87 1323.7 236529 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(82-10-05,Bush), approve(), audit(), install(): Created. 2) change(83-12-01,Bush), approve(), audit(), install(): Modified for performance improvements. 3) change(85-10-03,GWMay), approve(85-10-03,MCR7282), audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001): Added history comments in required format. Modified the display that tells the recording density of the requested tape. It was printing "CPI" instead of "BPI". 4) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Simplified the code that determines the type of tape being read. Added interrupt masking while modifying the iocb. 5) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. END HISTORY COMMENTS */ mtape_mount_cntl_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. This * module implements the mtape_ interface to RCP for mounting, * demounting and volume switching tape volumes. * */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Input pointer to the mtape_data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl vs_arg_mtdp ptr; /* Input pointer to the mtape_data structure */ dcl vs_arg_code fixed bin (35); /* Return error code */ dcl vs_arg_volp ptr; /* Pointer to VS structure of volume to mount */ /* AUTOMATIC DATA */ dcl (req_work_area_len, act_work_area_len, ws_max) fixed bin (19); dcl (rcp_state, ioi_id, err_count, num_waits) fixed bin; dcl ips_mask bit (36) aligned; dcl to_max fixed bin (71); dcl (code, vs_code, max_buf_len) fixed bin (35); dcl (dl, act_len) fixed bin (21); dcl susp_buf_ptrs (16) ptr; dcl lbuf_arrayp (1) ptr; dcl (i, j, n_susp_bufs, act_num) fixed bin; dcl (wa_ptr, tptr, volp) ptr; dcl rcp_comment char (256); dcl Stape_is_readable bit (1) aligned; dcl 1 auto_tioi_info aligned like tioi_info; dcl 1 auto_err_count aligned like tec; dcl 1 atbs aligned like tbs; dcl 1 event_info aligned like event_wait_info; /* CONSTANT DATA */ dcl myname char (6) int static options (constant) init ("mtape_"); dcl DISPOSITION bit (1) int static options (constant) init ("0"b); dcl SAVE_CUR_BUF bit (1) int static options (constant) init ("1"b); dcl DONT_SAVE_CUR_BUF bit (1) int static options (constant) init ("0"b); dcl WRITE_IO fixed bin int static options (constant) init (2); /* EXTERNAL STATIC DATA */ dcl error_table_$resource_unavailable fixed bin (35) ext static; dcl error_table_$resource_reserved fixed bin (35) ext static; dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, null, size, unspec) builtin; dcl (any_other, cleanup) condition; /* EXTERNAL ENTRIES */ dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr); dcl mtape_util_$error entry options (variable); dcl mtape_util_$get_statistics entry (ptr, fixed bin (35)); dcl mtape_util_$user_query entry (ptr, fixed bin, fixed bin (35)); dcl mtape_io_$allocate_buffers entry (ptr, fixed bin (21), fixed bin (35)); dcl mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl hcs_$assign_channel entry (fixed bin (71), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl iox_$propagate entry (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl rcp_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)); dcl rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71), fixed bin, fixed bin (35)); dcl rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35)); /* BASED DATA */ dcl 1 save_wks based (tptr) aligned, /* structure to save workspace */ 2 smtd like mtape_data, /* for copying mtape_data structure out */ 2 n_susp_buffers fixed bin, /* number of suspended buffers to copy out */ 2 susp_buffers (mtape_data.nbufs), 3 stbs like tbs, /* for the suspended buffers status */ 3 buffer char (max_buf_len) unaligned; /* buffer data */ dcl based_buffer char (dl) based; %page; /* mount - entry to mount a volume from the volume set */ mount: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy argument */ maip = mtape_data.attach_info_ptr; arg_code, code = 0; /* Reset return error code */ if mtape_data.tape_infop = null then do; /* if rcp data block not allocated.. */ call INIT_RCP_DATA; /* do it now */ if code ^= 0 then go to mount_return; end; tape_info_ptr = mtape_data.tape_infop; /* set tape info pointer */ vs_ptr = mtape_data.vs_current; /* get pointer to this volumes VS structure */ tape_info.device_name = ""; /* set tape info that changes */ tape_info.model = 0; tape_info.write_flag = mtape_attach_info.ring; tape_info.speed = mtape_attach_info.speed; if mtape_attach_info.density = 1600 then /* set density */ tape_info.density = "00010"b; else if mtape_attach_info.density = 6250 then tape_info.density = "00001"b; else if mtape_attach_info.density = 800 then tape_info.density = "00100"b; else if mtape_attach_info.density = 556 then /* MUST CHECK THESE *** */ tape_info.density = "01000"b; else tape_info.density = "10000"b; /* 200 BPI */ tape_info.volume_name = mtape_vol_set.volume_name;/* copy volume name */ call ioa_ ("Mounting volume ""^a"" with ^[a^;no^] write ring", /* Let user know whats going on */ mtape_vol_set.volume_name, mtape_attach_info.ring); /* Now request the volume mount from RCP */ call rcp_$attach (DEVICE_TYPE (TAPE_DRIVE_DTYPEX), tape_info_ptr, mtape_data.mount_echan, (mtape_vol_set.mount_comment), mtape_vol_set.rcp_id, code); if code ^= 0 then do; /* some problem */ call mtape_util_$error (mtdp, code, "Error from rcp_$attach"); go to mount_return; end; /* Now wait for the mount to complete */ event_wait_channel.channel_id (1) = mtape_data.mount_echan; num_waits = 0; /* initialize wait loop counter */ rcp_state = 1; /* set state to go through loop once */ on cleanup call DETACH_ON_CLEANUP; /* in case user does not want to wait.. */ do while (rcp_state ^= 0); /* do until mounted, or mount timer running */ rcp_comment = ""; /* initialize comment */ call rcp_$check_attach (mtape_vol_set.rcp_id, tape_info_ptr, rcp_comment, ioi_id, ws_max, to_max, rcp_state, code); if rcp_comment ^= "" then /* if we got something to report from RCP.. */ call mtape_util_$error (mtdp, 0, "RCP comment: ^a", rcp_comment); go to ATTACH_STATE (rcp_state); /* do appropriate processing */ ATTACH_STATE (2): /* long wait */ code = error_table_$resource_unavailable; /* set appropriate error code */ ATTACH_STATE (3): /* fatal error */ if mtape_attach_info.wait then /* if we will wait for attachment */ if (code = error_table_$resource_unavailable | /* and one of these */ code = error_table_$resource_reserved) then if num_waits <= mtape_attach_info.wait_time then do; /* wait for 1 minute */ call SLEEP; go to ATTACH_STATE (0); end; else do; /* wait time exceeded */ call mtape_util_$error (mtdp, code, "Mount wait time of ^d minutes exceeded", mtape_attach_info.wait_time); go to mount_return; end; call mtape_util_$error (mtdp, code, "Error from rcp_$check_attach, while waiting for tape mount"); go to mount_return; ATTACH_STATE (1): /* short wait, go blocked */ call ipc_$block (addr (event_wait_channel), addr (event_info), code); if code ^= 0 then do; /* error from block */ call mtape_util_$error (mtdp, code, "Error from ipc_$block, while waiting for tape mount"); go to mount_return; end; ATTACH_STATE (0): /* mount complete */ end; revert cleanup; mtape_vol_set.mounts = mtape_vol_set.mounts + 1; /* increment number of times mounted */ if (tape_info.volume_type = Volume_blank | tape_info.volume_type = Volume_unreadable) then do; Stape_is_readable = "0"b; mtape_vol_set.volume_density = mtape_attach_info.density; end; else do; Stape_is_readable = "1"b; mtape_vol_set.volume_density = MTAPE_VALID_DENSITIES (tape_info.volume_density); end; mtape_vol_set.volume_type = tape_info.volume_type; call ioa_ ("Mounted ^a volume ""^a"" ^[(recorded at ^d BPI), ^;^1s^]on device ^a", Tape_volume_types (tape_info.volume_type), tape_info.volume_name, Stape_is_readable, mtape_vol_set.volume_density, tape_info.device_name); mtape_vol_set.device_name = tape_info.device_name;/* copy values from the tape_info structure */ if Stape_is_readable then /* only copy if valid name */ mtape_vol_set.volume_id = tape_info.volume_name; mtape_vol_set.mounted, mtape_vol_set.ever_mounted = "1"b; /* set mounted flags */ if mtape_data.vs_mounted_tail ^= null then /* thread in MRM chain, if possible */ mtape_data.vs_mounted_tail -> mtape_vol_set.mrm_vs_ptr = vs_ptr; mtape_vol_set.lrm_vs_ptr = mtape_data.vs_mounted_tail; /* thread the LRM chain */ mtape_data.vs_mounted_tail = vs_ptr; mtape_vol_set.auth_required = tape_info.opr_auth; mtape_data.drives_in_use = mtape_data.drives_in_use + 1; /* one more drive used */ call INIT_TIOI; /* activate tape_ioi_ for this volume */ mount_return: arg_code = code; return; %page; /* demount - entry to demount the current volume of the volume set */ demount: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy argument */ arg_code = 0; /* reset return error code */ vs_ptr = mtape_data.vs_current; /* set the volume set members ptr */ /* Update error stats and deactivate tape_ioi_. Note: suspended buffers/work area have already been copied out */ call mtape_util_$get_statistics (mtdp, code); /* update error stats */ tape_ioi_error_counts_ptr = addr (auto_err_count); tec.version = TEC_VERSION_1; /* set version number */ call tape_ioi_$deactivate (mtape_vol_set.tioi_id, tape_ioi_error_counts_ptr, code); err_count = mtape_vol_set.rel_error_stats.read.errors + mtape_vol_set.rel_error_stats.write.errors + mtape_vol_set.rel_error_stats.orders.errors; /* RCP S/B changed to get all stats */ /* Now detach the device */ call rcp_$detach (mtape_vol_set.rcp_id, DISPOSITION, err_count, (mtape_vol_set.demount_comment), code); mtape_vol_set.mounted = "0"b; /* volume is no longer mounted */ mtape_vol_set.device_name = ""; /* its no longer on a device */ mtape_vol_set.rcp_id, mtape_vol_set.tioi_id = "0"b; /* Not needed now */ mtape_data.drives_in_use = mtape_data.drives_in_use - 1; /* 1 less drive in use */ unspec (mtape_vol_set.rel_error_stats) = "0"b; /* init error stats, this mount */ /* Now thread this volume set member out of LRM and MRM chains */ if mtape_vol_set.lrm_vs_ptr ^= null then do; if mtape_vol_set.mrm_vs_ptr ^= null then /* if in middle of mounted list.. */ mtape_vol_set.mrm_vs_ptr -> mtape_vol_set.lrm_vs_ptr = mtape_vol_set.lrm_vs_ptr; end; else do; /* lrm_vs_ptr = null => this was first vol mounted */ if mtape_vol_set.mrm_vs_ptr ^= null then /* if there is a next volume */ mtape_vol_set.mrm_vs_ptr -> mtape_vol_set.lrm_vs_ptr = null; /* make it first mounted */ end; if mtape_vol_set.mrm_vs_ptr ^= null then do; if mtape_vol_set.lrm_vs_ptr ^= null then /* if in middle of mounted list.. */ mtape_vol_set.lrm_vs_ptr -> mtape_vol_set.mrm_vs_ptr = mtape_vol_set.mrm_vs_ptr; end; else do; /* mrm_vs_ptr = null => this was last vol mounted */ mtape_data.vs_mounted_tail = mtape_vol_set.lrm_vs_ptr; if mtape_vol_set.lrm_vs_ptr ^= null then /* if there is a previous volume.. */ mtape_vol_set.lrm_vs_ptr -> mtape_vol_set.mrm_vs_ptr = null; /* make it last mounted */ end; mtape_vol_set.lrm_vs_ptr, mtape_vol_set.mrm_vs_ptr = null; arg_code = code; return; %page; /* volume_switch - entry to perform volume switching on demand */ volume_switch: entry (vs_arg_mtdp, vs_arg_volp, vs_arg_code); mtdp = vs_arg_mtdp; /* copy args */ maip = mtape_data.attach_info_ptr; volp = vs_arg_volp; vs_arg_code = 0; if volp = null then do; /* No vol_set structure */ call mtape_util_$user_query (mtdp, Q_NO_NEXT_VOLUME, vs_code); /* ask user for new volume */ if vs_code ^= 0 then /* user did not want new volume */ go to vs_return; volp = mtape_data.vs_tail; /* this will be the last allocated */ end; if volp -> mtape_vol_set.version ^= mtape_vs_version_1 then do; /* is it a vol_set structure? */ vs_code = error_table_$unimplemented_version;/* no, set error code */ go to vs_return; end; vs_ptr = mtape_data.vs_current; /* set for current volume */ call mtape_io_$order (mtdp, "rwnw", 0, null, vs_code); /* rewind old volume */ if vs_code ^= 0 then /* can't win no_how */ go to vs_return; call SAVE_ACTIVATION (DONT_SAVE_CUR_BUF); /* go save suspended buffers etc. */ if vs_code ^= 0 then go to vs_return; if volp -> mtape_vol_set.mounted then do; /* if required tape volume already mounted */ vs_ptr = volp; /* set vol set for new volume */ call tape_ioi_$allocate_work_area (mtape_vol_set.tioi_id, size (mtape_data), act_work_area_len, wa_ptr, vs_code); wa_ptr -> mtape_data = mtape_data; /* move mtape_data to new work area */ mtdp = wa_ptr; /* and reset pointer to same */ mtape_data.tioi_id = mtape_vol_set.tioi_id; /* copy tape_ioi_ activation ID into work area */ mtape_data.vs_current = vs_ptr; /* set current vs ptr */ call mtape_io_$order (mtdp, "rew", 0, null, vs_code); /* make sure he is rewound */ if vs_code ^= 0 then /* can't win no_how */ go to vs_return; end; else do; /* volume not mounted */ if mtape_data.drives_in_use = mtape_attach_info.ndrives then do; /* must demount one first */ call FIND_DEMOUNT_CANDIDATE; /* go find volume to demount */ call demount (mtdp, vs_code); /* demount it */ if vs_code ^= 0 then go to vs_return; end; mtape_data.vs_current = volp; /* set current volume set ptr */ call mount (mtdp, vs_code); /* go mount the requested volume */ if vs_code ^= 0 then go to vs_return; end; call RESTORE_ACTIVATION; /* copy suspended buffers back in etc */ if vs_code ^= 0 then go to vs_return; call mtape_data.pfm_init (mtdp, vs_code); /* Go read the volume labels */ vs_return: vs_arg_code = vs_code; /* copy return code */ vs_arg_mtdp = mtdp; /* reset value of mtdp */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* and reset IOCB */ call iox_$propagate (mtape_data.iocb_ptr); /* propagate the IOCB change */ call hcs_$reset_ips_mask (ips_mask, ips_mask); return; /* and return to caller */ %page; /* remount - external entry for remounting same volume after device attention condition */ remount: entry (arg_mtdp, vs_arg_code); mtdp = arg_mtdp; maip = mtape_data.attach_info_ptr; vs_ptr = mtape_data.vs_current; vs_arg_code = 0; call SAVE_ACTIVATION (SAVE_CUR_BUF); /* save suspended buffers etc. */ if vs_code ^= 0 then /* quit on error */ go to remount_return; call demount (mtdp, vs_code); /* demount current volume */ if vs_code = 0 then /* if all ok */ call mount (mtdp, vs_code); /* remount the volume */ if vs_code ^= 0 then go to remount_return; call RESTORE_ACTIVATION; /* copy suspended buffers back in */ remount_return: vs_arg_code = vs_code; /* copy return code */ vs_arg_mtdp = mtdp; /* reset value of mtdp */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* and reset IOCB */ call iox_$propagate (mtape_data.iocb_ptr); /* propagate the IOCB change */ call hcs_$reset_ips_mask (ips_mask, ips_mask); return; /* and return to caller */ %page; /* INIT_RCP_DATA - procedure to set up the tape_info structure */ INIT_RCP_DATA: proc; call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, size (tape_info) * 4, mtape_data.tape_infop); tape_info_ptr = mtape_data.tape_infop; tape_info.version_num = tape_info_version_3; /* set version number */ tape_info.tracks = mtape_attach_info.tracks; /* set constant data */ tape_info.system_flag = mtape_attach_info.system; /* Create an event channel for mount requests */ if mtape_data.mount_echan = 0 then do; /* Only create if we hav'nt already */ call ipc_$create_ev_chn (mtape_data.mount_echan, code); if code ^= 0 then do; /* we loose altogether */ call mtape_util_$error (mtdp, code, "Can't create ipc wait channel for mount requests."); return; end; end; end INIT_RCP_DATA; /* SLEEP - internal procedure to go to sleep for 1 minute and incrment the sleep loop counter */ SLEEP: proc; call timer_manager_$sleep (60, "11"b); /* Wait for one minute. */ num_waits = num_waits + 1; /* increment number of loops */ end SLEEP; /* DETACH_ON_CLEANUP - int procedure to detach tape when cleanup condition is raised */ DETACH_ON_CLEANUP: proc; dcl clean_code fixed bin (35); call rcp_$detach (mtape_vol_set.rcp_id, "0"b, (0), "", clean_code); /* no frills */ if clean_code ^= 0 then ; end DETACH_ON_CLEANUP; %page; /* INIT_TIOI - internal procedure to activate tape_ioi_ and create a work area */ INIT_TIOI: proc; /* On first call, create a fast event channel for doing I/O if possible, if not create regular one */ if mtape_data.io_echan = 0 then do; /* if not already there create one */ call hcs_$assign_channel (mtape_data.io_echan, code); if code ^= 0 then do; /* if we didn't get fast channel... */ call ipc_$create_ev_chn (mtape_data.io_echan, code); if code ^= 0 then do; /* we loose altogether */ call mtape_util_$error (mtdp, code, "Can't create ipc wait channel for doing I/O."); return; end; end; end; tioi_info_ptr = addr (auto_tioi_info); /* initialize the tape_ioi_ info structure */ tioi_info.version = tioi_info_version_1; tioi_info.ioi_index = ioi_id; tioi_info.timeout_max = to_max; tioi_info.event_id = mtape_data.io_echan; tioi_info.workspace_max = ws_max; call tape_ioi_$activate (tape_info_ptr, tioi_info_ptr, mtape_vol_set.tioi_id, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Calling tape_ioi_$activate"); return; end; /* Get workspace for permanent mtape_data storage. */ req_work_area_len = size (mtape_data); call tape_ioi_$allocate_work_area (mtape_vol_set.tioi_id, req_work_area_len, act_work_area_len, wa_ptr, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Calling tape_ioi_$allocate_work_area"); return; end; if act_work_area_len ^= req_work_area_len then do; code = error_table_$area_too_small; /* A different code should be used. */ call mtape_util_$error (mtdp, code, "Can't get a big enough work area, need ^d words, tape_ioi_ will give us ^d words.", req_work_area_len, act_work_area_len); return; end; wa_ptr -> mtape_data = mtape_data; /* copy the data into the work area */ mtdp, arg_mtdp = wa_ptr; /* now everyone will look in work area */ mtape_data.tioi_id = mtape_vol_set.tioi_id; /* copy for fast reference */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* reset iocb */ call iox_$propagate (mtape_data.iocb_ptr); /* let iox_ know about iocb change */ call hcs_$reset_ips_mask (ips_mask, ips_mask); return; end INIT_TIOI; %page; /* FIND_DEMOUNT_CANDIDATE - subroutine to find a volume to demount on a LRU basis */ FIND_DEMOUNT_CANDIDATE: proc; if mtape_attach_info.ndrives = 1 then /* if we have only 1 tape drive, must demount */ return; /* current volume. mtape_data.vs_current already set */ fi_ptr = mtape_data.fi_current; /* get current file_info pointer */ /* Now thread the LRM chain until we find the head */ do vs_ptr = mtape_data.vs_mounted_tail repeat mtape_vol_set.lrm_vs_ptr while (mtape_vol_set.lrm_vs_ptr ^= null); end; if vs_ptr = mtape_file_info.begin_vs_ptr then /* if the selected volume is 1st file section */ if mtape_vol_set.mrm_vs_ptr ^= null then /* and there is a more recent mount */ vs_ptr = mtape_vol_set.mrm_vs_ptr; /* use the next LRU volume */ mtape_data.vs_current = vs_ptr; /* finished, he is the guy to demount */ end FIND_DEMOUNT_CANDIDATE; %page; /* SAVE_ACTIVATION - internal procedure to save suspended buffers, deallocate buffers and work area */ SAVE_ACTIVATION: proc (cur_buf_disp); dcl cur_buf_disp bit (1); call get_temp_segment_ (myname, tptr, vs_code); /* get temp seg to copy stuff into */ if vs_code ^= 0 then /* can't get it, give up */ return; save_wks.smtd = mtape_data; /* copy the mtape_data structure out */ mtdp = addr (save_wks.smtd); /* and switch pointer */ max_buf_len = mtape_data.block_size; /* set the max buffer size */ atbs.version = TBS_VERSION_1; /* set version */ if cur_buf_disp = SAVE_CUR_BUF & mtape_data.last_io = WRITE_IO then do; call tape_ioi_$list_buffers (mtape_vol_set.tioi_id, READY_STATE, susp_buf_ptrs, n_susp_bufs, vs_code); if vs_code ^= 0 then return; call tape_ioi_$buffer_status (mtape_vol_set.tioi_id, susp_buf_ptrs (n_susp_bufs), addr (atbs), vs_code); if vs_code ^= 0 then return; save_wks.susp_buffers (1).stbs = atbs; /* save buffer status */ dl = atbs.data_len; /* set data length */ save_wks.susp_buffers (1).buffer = susp_buf_ptrs (n_susp_bufs) -> based_buffer; /* and data */ j = 1; /* set offset */ end; else j = 0; call tape_ioi_$list_buffers (mtape_vol_set.tioi_id, SUSPENDED_STATE, susp_buf_ptrs, n_susp_bufs, vs_code); if vs_code ^= 0 then return; save_wks.n_susp_buffers = n_susp_bufs + j; if n_susp_bufs ^= 0 then do; /* if we have suspended buffers, copy them out too */ do i = 1 to n_susp_bufs; j = j + 1; /* increment saved buffer index */ call tape_ioi_$buffer_status (mtape_vol_set.tioi_id, susp_buf_ptrs (i), addr (atbs), vs_code); if vs_code ^= 0 then return; save_wks.susp_buffers (j).stbs = atbs; /* save buffer status */ dl = atbs.data_len; /* set data length */ save_wks.susp_buffers (j).buffer = susp_buf_ptrs (i) -> based_buffer; /* and data */ call tape_ioi_$set_buffer_ready (mtape_vol_set.tioi_id, susp_buf_ptrs (i), vs_code); if vs_code ^= 0 then return; end; end; call mtape_util_$get_statistics (mtdp, vs_code); /* update error stats */ call tape_ioi_$deallocate (mtape_vol_set.tioi_id, vs_code); /* deallocate all buffers and work area */ all_buf_ptrs (*) = null; /* reset buffer pointers */ all_buf_lens (*) = 0; /* and buffer lengths */ mtape_data.lab_bufp = null; /* set label buffer to null too */ mtape_data.phy_file, mtape_data.phy_block = 0; /* reset position counters */ end SAVE_ACTIVATION; %page; /* RESTORE_ACTIVATION - internal procedure to allocate buffers and copy suspended buffers to new buffers. */ RESTORE_ACTIVATION: proc; call tape_ioi_$allocate_buffers (mtape_data.tioi_id, /* allocate and reserve a label buffer */ mtape_data.lab_buf_len, 1, act_len, act_num, lbuf_arrayp, vs_code); if vs_code ^= 0 then return; call tape_ioi_$reserve_buffer (mtape_data.tioi_id, lbuf_arrayp (1), vs_code); /* reserve the buffer */ if vs_code ^= 0 then return; mtape_data.lab_bufp = lbuf_arrayp (1); /* copy label buffer ptr */ /* Allocate data buffers and copy any suspended buffers back in 1 at a time */ if mtape_data.nbufs > 0 then do; /* if we had buffers allocated before, do it now */ call mtape_io_$allocate_buffers (mtdp, mtape_data.block_size, vs_code); if vs_code ^= 0 then return; if save_wks.n_susp_buffers ^= 0 then do; do i = 1 to save_wks.n_susp_buffers; /* do each buffer */ tbs_ptr = addr (susp_buffers (i).stbs); all_buf_lens (i), dl = tbs.data_len; /* copy length */ all_buf_ptrs (i) -> based_buffer = addr (susp_buffers (i).buffer) -> based_buffer; /* copy data */ end; mtape_data.cur_buf_idx = save_wks.n_susp_buffers + 1; /* set up the current buffer index */ end; end; call release_temp_segment_ (myname, tptr, (0)); /* release our temp segment */ end RESTORE_ACTIVATION; %page; %include mtape_data; %page; %include mtape_attach_info; %include mtape_detach_info; %page; %include mtape_vol_set; %page; %include mtape_file_info; %page; %include mtape_err_stats; %include tape_ioi_info; %page; %include rcp_tape_info; %include rcp_volume_formats; %page; %include mtape_constants; %include rcp_resource_types; %page; %include event_wait_channel; %include event_wait_info; %page; %include iocb; %page; %include tape_ioi_dcls; %include tape_ioi_error_counts; %page; %include tape_ioi_buffer_status; end mtape_mount_cntl_;  mtape_parse_.pl1 12/17/86 0925.7r w 12/17/86 0830.0 353619 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ mtape_parse_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. * * Modification History: * * Created by J. A. Bush 10/05/82 * Modified by J. A. Bush 6/15/83 to use process_arguments_ for parsing * Modified by J. A. Bush 11/06/83 to fix bug causing inconsistent * opening modes in mtape_ and the selected PFM. * Modified: October 1984 by Greg Texada for basic gullibility checking of the open description. * Modified: November 1984 by Greg Texada to enforce data set naming specs for ANSI/IBM. */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to mtape_data */ dcl arg_options (*) char (*) varying; /* Input options array */ dcl arg_open_mode fixed bin; /* Opening mode */ dcl arg_code fixed bin (35); /* Return error code */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl (vname, cname, cspeed, cpos, ulab_name) char (32); dcl (pos_ref_name, neg_ref_name, vol_ref_name) char (32) varying; dcl (rpvap, ap_areap, ad_cs_ptr, def_ptr, desc_ptr, cvlp, saved_opt_ptr) ptr; dcl (i, j, vx, nxt_vx, cvx, str_len, spos, cs, all_len, open_mode) fixed bin; dcl opn_desc_len fixed bin (21); dcl term bit (1) aligned; dcl found_opts bit (36) aligned; dcl 1 ai like area_info aligned; /* CONSTANT DATA */ dcl myname char (6) int static options (constant) init ("mtape_"); /* EXTERNAL STATIC DATA */ dcl error_table_$bad_name fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, char, copy, hbound, index, length, ltrim, mod, null, rtrim, search, substr, unspec, verify) builtin; /* EXTERNAL ENTRIES */ dcl resource_info_$canonicalize_name entry (char (*), char (*), char (*), fixed bin (35)); dcl mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr); dcl mtape_util_$error entry options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl process_arguments_$argument_array entry (char (*), fixed bin, (*) char (*) varying, ptr, ptr, ptr, fixed bin (35)); dcl process_arguments_$get_option_value entry options (variable); dcl process_arguments_$cv_result_to_linear_form entry (ptr, ptr, char (*) varying, fixed bin (35)); dcl process_arguments_$get_definition entry (char (*) varying, ptr, ptr, fixed bin (35)); dcl process_arguments_$get_reference_name entry (ptr, char (*) varying, char (*) varying, char (*) varying); dcl process_arguments_$free_print_vector_array entry (ptr); dcl define_area_ entry (ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); /* BASED DATA */ dcl based_area area based (mtape_data.areap); dcl ap_area area based (ap_areap); dcl desc_string char (1024) varying based (desc_ptr); dcl open_desc char (mtape_data.opd_len) varying based (mtape_data.opdp); dcl vb_str char (128) varying based; dcl 1 saved_options aligned based (saved_opt_ptr), /* template for allocation of last saved option array */ 2 nopts fixed bin, /* number of options in array */ 2 saved_option (all_len refer (saved_options.nopts)) char (32) varying; %page; /* mtape_parse_$attach - entry to parse up the attach options list * * Usage: * * dcl mtape_parse_$attach entry (ptr, (*) char (*) varying, fixed bin (35)); * call mtape_parse_$attach (mtdp, options, code); * * where: * 1. mtdp * is a pointer to the mtape_data structure defined by * mtape_data.incl.pl1. (INPUT) * 2. options * is the array of attach options received from * iox_$attach_(name ptr). (INPUT) * 3. code * is a standard system error code. (OUTPUT) */ attach: entry (arg_mtdp, arg_options, arg_code); call SETUP; /* go setup our enviornment */ call ALLOCATE_AP_AREA; /* allocate area for process_arguments_ to use */ call PROC_ARGS (myname || ".attach", ad_cs_ptr); /* Let process_arguments_ do the work */ /* Now lets get the option values */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, DISPLAY, mtape_attach_info.display, ERROR, mtape_data.display_errors, LABEL, mtape_attach_info.labeled, RING, mtape_attach_info.ring, SYSTEM, mtape_attach_info.system, WAIT, mtape_attach_info.wait); /* get the switch flags first */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, DEFAULT_VOL_TYPE, mtape_attach_info.default_pfm_prefix, DENSITY, mtape_attach_info.density, DEVICE, mtape_attach_info.ndrives, TRACK, mtape_attach_info.tracks, VOL_TYPE, mtape_attach_info.pfm_prefix, WAIT_TIME, mtape_attach_info.wait_time); /* get other options */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, SPEED, cspeed); /* get the speed values if any */ if found_opts ^= "0"b then do; /* if some speeds specified */ term = "0"b; spos = 1; str_len = length (rtrim (cspeed)); do while (^term); cs = search (substr (cspeed, spos), ","); /* more than one specified */ if cs = 0 then do; /* last one */ term = "1"b; cs = (str_len - spos) + 1; /* set for end of string */ end; else cs = cs - 1; if substr (cspeed, spos, cs) = "75" then/* 75 IPS specified */ mtape_attach_info.speed = mtape_attach_info.speed | "100"b; else if substr (cspeed, spos, cs) = "125" then /* 125 IPS specified */ mtape_attach_info.speed = mtape_attach_info.speed | "010"b; else if substr (cspeed, spos, cs) = "200" then /* 200 IPS specified */ mtape_attach_info.speed = mtape_attach_info.speed | "001"b; spos = spos + cs + 1; /* increment for next search */ end; end; /* Now lets get the volume sequence list and any mount comments */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, VOLUME, option_value_list_ptr, COMMENT, cvlp); if ^substr (found_opts, 1, 1) then do; /* need at least one volume */ code = error_table_$noarg; call mtape_util_$error (mtdp, code, "At least one volume name must be specified"); go to non_local_return; /* abort attachment */ end; do i = 1 to option_value_list.number_of_values; /* process all volumes */ vname = option_value_list.value (i).ptr -> vb_str; /* get volume name */ vx = option_value_list.value (i).vector_idx; /* and index into the rpva */ if i = option_value_list.number_of_values then /* if at end */ nxt_vx = -1; /* indicate so */ else nxt_vx = option_value_list.value (i + 1).vector_idx; /* not end get next index */ call resource_info_$canonicalize_name (VOLUME_TYPE (TAPE_VOL_VTYPEX), vname, cname, code); if code ^= 0 then do; /* bad volume name */ call mtape_util_$error (mtdp, code, "Cannot canonicalize volume name ""^a""", vname); arg_code = code; /* save code, but continue to check description */ go to vol_end; /* get the next argument */ end; call mtape_util_$alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, vs_ptr); mtape_data.vs_tail = vs_ptr; /* Link this VS structure in */ if mtape_data.vs_head = null then /* if this is first volume set member */ mtape_data.vs_current, mtape_data.vs_head = vs_ptr; /* set the link head too */ mtape_vol_set.volume_name = cname; /* set the canonical volume name */ if substr (found_opts, 2, 1) then do; /* if we have some comments */ term = "0"b; do j = 1 to cvlp -> option_value_list.number_of_values while (^term); cvx = cvlp -> option_value_list.value (j).vector_idx; /* get option index */ if cvx > vx then /* check position of comment */ if (nxt_vx ^= -1 & cvx < nxt_vx) | nxt_vx = -1 then do; term = "1"b; /* set terminate condition and copy comment */ mtape_vol_set.mount_comment = cvlp -> option_value_list.value (j).ptr -> vb_str; end; end; end; vol_end: end; %page; /* Now build a printable attach description, get volume sequence list first */ desc_string = myname; /* start off the attach description with I/O module name */ vol_ref_name = GET_REF_NAME (VOLUME); /* get the volume option ref name */ do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null); if substr (mtape_vol_set.volume_name, 1, 1) = "-" then /* if volume name begins with "-" */ desc_string = rtrim (desc_string) || " " || vol_ref_name; /* add volume qualifier */ desc_string = rtrim (desc_string) || " " || mtape_vol_set.volume_name; end; /* now add control args with values */ desc_string = rtrim (desc_string) || " " || GET_REF_NAME (DENSITY); desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.density)); desc_string = rtrim (desc_string) || " " || GET_REF_NAME (TRACK); desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.tracks)); if mtape_attach_info.speed ^= "0"b then do; /* only display speed if one specified */ desc_string = rtrim (desc_string) || " " || GET_REF_NAME (SPEED); desc_string = rtrim (desc_string) || " " || cspeed; end; desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (RING, mtape_attach_info.ring); desc_string = rtrim (desc_string) || " " || GET_REF_NAME (DEVICE); desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.ndrives)); desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (LABEL, mtape_attach_info.labeled); if mtape_attach_info.pfm_prefix ^= "" then do; /* put in PFM prefix only if given by user */ desc_string = rtrim (desc_string) || " " || GET_REF_NAME (VOL_TYPE); desc_string = rtrim (desc_string) || " " || mtape_attach_info.pfm_prefix; end; desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (WAIT, mtape_attach_info.wait); if mtape_attach_info.wait then do; /* if we are waiting, put in wait time too */ desc_string = rtrim (desc_string) || " " || GET_REF_NAME (WAIT_TIME); desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.wait_time)); end; desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (DISPLAY, mtape_attach_info.display); desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (SYSTEM, mtape_attach_info.system); desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (ERROR, mtape_data.display_errors); call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.atdp); mtape_data.atdp -> desc_string = desc_string; /* move attach description to perm storage */ non_local_return: /* target of non-local gotos */ if arg_code = 0 then /* if previous error was not saved */ arg_code = code; if ap_areap ^= null then /* if arg processing area defined.. */ call release_area_ (ap_areap); /* release it */ if ad_cs_ptr ^= null then /* if attach/detach control print_vector allocated */ call process_arguments_$free_print_vector_array (ad_cs_ptr); /* free it */ return; /* end of attach entry */ %page; /* open - entry to parse open description */ open: entry (arg_mtdp, arg_options, arg_open_mode, arg_code); call SETUP; /* go setup our enviornment */ open_mode = arg_open_mode; /* copy opening mode arg */ call OPTIMIZE_PARSE (mtape_open_info.so_ptr); /* Do we have to call process_arguments_? */ call ALLOCATE_AP_AREA; /* yes, allocate area for process_arguments_ to use */ unspec (mtape_open_info.init_to_zero) = "0"b; /* initialize open info structure */ mtape_open_info.comment, mtape_open_info.expiration, mtape_open_info.file_format = ""; mtape_open_info.recording_mode, mtape_open_info.file_name, mtape_open_info.replace_id = ""; mtape_open_info.pfm_opt_str (*) = ""; ulab_name = ""; mtape_open_info.open_mode = open_mode; /* copy opening mode */ /* Let process_arguments_ do the work */ call PROC_ARGS (myname || ".open." || mtape_attach_info.pfm_prefix, mtape_open_info.cs_ptr); call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, /* get option values */ COMMENT, mtape_open_info.comment, DISPLAY, mtape_open_info.display, BLOCK, mtape_open_info.block_length, RECORD, mtape_open_info.record_length, NUMBER, mtape_open_info.seq_number, REPLACE, mtape_open_info.replace_id, NAME, mtape_open_info.file_name, MODE, mtape_open_info.recording_mode, FORMAT, mtape_open_info.file_format, EXPIRES, mtape_open_info.expiration, DEFAULT_SPAN_RLEN, mtape_open_info.default_span_rlen, DEFAULT_VAR_RLEN, mtape_open_info.default_var_rlen, DEFAULT_FIX_RLEN, mtape_open_info.default_fix_rlen, APPEND, mtape_open_info.append, EXTEND, mtape_open_info.extend, FORCE, mtape_open_info.force, LAST_FILE, mtape_open_info.last_file, NEXT_FILE, mtape_open_info.next_file, MODIFY, mtape_open_info.modify, LABEL_ENTRY, ulab_name); if ulab_name ^= "" then do; /* if user label reoutine specified, convert it */ mtape_open_info.user_label = cv_entry_ (ulab_name, null, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "^/Attempting to convert the user label entry ""^a"".", ulab_name); go to non_local_return; end; mtape_open_info.label_entry_present = "1"b; /* set flag for PFM */ end; /* Now let's look at the open info and check some basic requirements. */ if mtape_attach_info.pfm_prefix = "ibm" then do; if ^(valid_IBM_open_args ()) then goto non_local_return; end; else if mtape_attach_info.pfm_prefix = "ansi" then do; if ^(valid_ANSI_open_args ()) then goto non_local_return; end; /* Now lets get PFM dependent options */ call GET_PFM_OPTIONS (addr (mtape_open_info.pfm_args), addr (mtape_pfm_info.pfm_open_options)); /* generate printable open description and move it to perm storage */ call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code); if mtape_data.opdp ^= null then do; /* must free desc. first */ free open_desc in (based_area); mtape_data.opdp = null; end; mtape_data.opd_len = length (desc_string) + 64; call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, mtape_data.opd_len, mtape_data.opdp); open_desc = rtrim (iox_modes (mtape_open_info.open_mode)) || " " || desc_string; call SAVE_OPTIONS (mtape_open_info.so_ptr); /* save current option array */ if ap_areap ^= null then /* if arg processing area defined.. */ call release_area_ (ap_areap); /* release it */ return; %page; /* close - entry to parse close description */ close: entry (arg_mtdp, arg_options, arg_code); call SETUP; /* set up our enviornment */ open_mode = 0; /* indicate not open entry to optimize routine */ call OPTIMIZE_PARSE (mtape_close_info.so_ptr); /* Do we have to call process_arguments_? */ call ALLOCATE_AP_AREA; /* yes, allocate area for process_arguments_ to use */ unspec (mtape_close_info.init_to_zero) = "0"b; /* initialize close info structure */ mtape_close_info.comment, mtape_close_info.pfm_opt_str (*) = ""; /* Let process_arguments_ do the work */ call PROC_ARGS (myname || ".close." || mtape_attach_info.pfm_prefix, mtape_close_info.cs_ptr); /* Now lets get the option values */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, COMMENT, mtape_close_info.comment, DISPLAY, mtape_close_info.display, CLOSE_POSITION, cpos); if cpos = BOF then /* position to beginning of file on closing */ mtape_close_info.position = 1; else if cpos = EOF then /* position to end of file on closing */ mtape_close_info.position = 2; else if cpos = LEAVE then /* leave the tape positioned where it is */ mtape_close_info.position = 0; /* Now lets get PFM dependent options */ call GET_PFM_OPTIONS (addr (mtape_close_info.pfm_args), addr (mtape_pfm_info.pfm_close_options)); /* generate printable close description and move it to perm storage */ call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code); call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.cldp); mtape_data.cldp -> desc_string = desc_string; call SAVE_OPTIONS (mtape_close_info.so_ptr); /* save current option array */ if ap_areap ^= null then /* if arg processing area defined.. */ call release_area_ (ap_areap); /* release it */ return; %page; /* detach - entry to parse detach description */ detach: entry (arg_mtdp, arg_options, arg_code); call SETUP; /* go setup our enviornment */ call ALLOCATE_AP_AREA; /* allocate area for process_arguments_ to use */ mdip = mtape_data.detach_info_ptr; /* set detach info ptr also */ unspec (mtape_detach_info) = "0"b; /* initialize detach info structure */ mtape_detach_info.version = mtape_detach_info_version_1; /* set proper version */ mtape_detach_info.comment = ""; call PROC_ARGS (myname || ".detach", ad_cs_ptr); /* Let process_arguments_ do the work */ /* Now lets get the option values */ call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, COMMENT, mtape_detach_info.comment, DISPLAY, mtape_detach_info.display, REWIND, mtape_detach_info.unload); mtape_detach_info.unload = ^mtape_detach_info.unload; /* invert flag for correct meaning */ /* generate printable detach description and move it to perm storage */ call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code); call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.dtdp); mtape_data.dtdp -> desc_string = desc_string; if ap_areap ^= null then /* if arg processing area defined.. */ call release_area_ (ap_areap); /* release it */ return; %page; /* OPTIMIZE_PARSE - internal procedure to determine if open and close descriptions really need to be passed by process_arguments_. If one open or close description has already been parsed, and if the arg_option array passed by iox_ is exactly the same or if the only difference is the "-name" or "-number" arg then do not expend the overhead to call process_arguments_. Instead use the already initialized open or close info structure, changing the file_name and/or seq_number args as is appropriate */ OPTIMIZE_PARSE: proc (sop); dcl sop ptr; dcl (saved_name, saved_number) char (32); dcl i fixed bin; if sop = null then /* if first open or close, */ return; /* must call process_arguments_ */ saved_opt_ptr = sop; /* get ptr to allocated saved_options */ if hbound (arg_options, 1) ^= saved_options.nopts then /* if differenct number of opts.. */ return; /* call process_arguments_ */ if open_mode ^= 0 then /* if parsing open description */ if open_mode ^= mtape_open_info.open_mode then /* but not opeing for same mode */ return; /* let process_arguments_ handle it */ saved_name, saved_number = ""; /* init key variables */ term = "0"b; do i = 1 to hbound (arg_options, 1) while (^term);/* go through all options */ if arg_options (i) ^= saved_options.saved_option (i) then /* if options not equal */ if arg_options (i - 1) = "-name" | /* if current option is file name arg */ arg_options (i - 1) = "-nm" then saved_name = arg_options (i); /* save the name */ else if arg_options (i - 1) = "-number" | /* if current option is file seq number */ arg_options (i - 1) = "-nb" then saved_number = arg_options (i); /* save the file seq number */ else term = "1"b; /* otherwise, found real mismatch */ end; if term then /* if we found mismatch, */ return; /* call process_arguments_ */ if saved_name ^= "" then do; mtape_open_info.file_name = saved_name; /* copy file name */ call INSERT_STRING ("-name", "-nm", saved_name); /* update open description */ end; if saved_number ^= "" then do; /* if we found different seq number */ mtape_open_info.seq_number = cv_dec_check_ (saved_number, code); if code ^= 0 then /* if invalid number */ return; /* let process_arguments_ put out diagnostic */ if mtape_open_info.seq_number > 9999 then /* if seq number to large */ return; /* let process_arguments_ put out diagnostic */ call INSERT_STRING ("-number", "-nb", saved_number); /* update open description */ end; go to non_local_return; /* optimization worked, arg processing complete */ end OPTIMIZE_PARSE; %page; /* SAVE_OPTIONS - internal procedure to save current iox_ open array for open and close */ SAVE_OPTIONS: proc (sop); dcl sop ptr; if sop ^= null then /* if we had a saved option array before */ free sop -> saved_options in (based_area); /* free it first */ all_len = hbound (arg_options, 1); /* get number of options to allocate */ allocate saved_options in (based_area) set (saved_opt_ptr); saved_options.saved_option = arg_options; /* copy them in */ sop = saved_opt_ptr; /* and set the pointer */ end SAVE_OPTIONS; /* INSERT_STRING - internal procedure to update open description with new values */ INSERT_STRING: proc (prim_ref, alt_ref, ins_str); dcl (prim_ref, alt_ref, ins_str) char (*); dcl (ref_pos, arg_start, arg_len, ins_str_len) fixed bin; opn_desc_len = length (open_desc); /* set open desc length variable */ ins_str_len = length (rtrim (ins_str)); /* get string length to insert */ ref_pos = index (open_desc, prim_ref); /* get start position of reference name */ if ref_pos = 0 then do; /* couldn't find primary ref name */ ref_pos = index (open_desc, alt_ref); /* try alternate */ if ref_pos = 0 then return; /* could not find it either, forget it */ ref_pos = ref_pos + length (alt_ref); /* go to end of ref name */ end; else ref_pos = ref_pos + length (prim_ref); /* go to end of ref name */ arg_start = verify (substr (open_desc, ref_pos), " "); /* find beginning of arg */ arg_start = (arg_start + ref_pos) - 1; /* make it absolute position */ arg_len = search (substr (open_desc, arg_start), " "); /* get length */ if arg_len = 0 then /* if at end of string */ arg_len = (opn_desc_len - arg_start) + 1; /* figure length to end of string */ else arg_len = arg_len - 1; if arg_start = opn_desc_len then do; /* if appending to end of string */ if ins_str_len > arg_len then /* if new string is longer than old */ open_desc = open_desc || copy (" ", ins_str_len - arg_len); /* grow string length */ substr (open_desc, arg_start) = rtrim (ins_str); end; else substr (open_desc, arg_start) = rtrim (ins_str) || substr (open_desc, arg_start + arg_len); end INSERT_STRING; %page; /* PROC_ARGS - internal procedure to get arg processing definition ptr and call in to process the args */ PROC_ARGS: proc (def_name, ctl_ptr); dcl def_name char (*) varying; dcl ctl_ptr ptr; /* ptr to arg processing control structure */ if ctl_ptr = null then do; /* if first time, get ctl structure */ call process_arguments_$get_definition (def_name, mtape_data.areap, ctl_ptr, code); /* get ptr to definition */ if code ^= 0 then /* can't find it */ go to non_local_return; /* take non-local goto and return */ end; def_ptr = ctl_ptr; /* save the ctl ptr */ call process_arguments_$argument_array ((def_name), 0, arg_options, def_ptr, ap_areap, rpvap, code); if code ^= 0 then /* if error */ go to non_local_return; /* take non-local goto and return */ end PROC_ARGS; /* GET_REF_NAME - internal procedure to return an options reference name, given the option name */ GET_REF_NAME: proc (opt_name) returns (char (32) varying); dcl opt_name char (*) varying; call process_arguments_$get_reference_name (def_ptr, opt_name, pos_ref_name, neg_ref_name); return (pos_ref_name); /* return name to caller */ end GET_REF_NAME; /* GET_BIN_REF_NAME - internal procedure to return a binary options positive or negative reference name, given the option name and the binary state of the option */ GET_BIN_REF_NAME: proc (opt_name, bin_state) returns (char (32) varying); dcl opt_name char (*) varying; dcl bin_state bit (1) aligned; call process_arguments_$get_reference_name (def_ptr, opt_name, pos_ref_name, neg_ref_name); if bin_state then /* if option is "on" */ return (pos_ref_name); /* return positive name to caller */ else return (neg_ref_name); /* switch is off, return neg name */ end GET_BIN_REF_NAME; %page; /* SETUP - internal procedure to set up our enviornment */ SETUP: proc; mtdp = arg_mtdp; maip = mtape_data.attach_info_ptr; /* get info ptrs set up */ moip = mtape_data.open_info_ptr; mcip = mtape_data.close_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; rpvap, ad_cs_ptr, ap_areap = null; end SETUP; /* ALLOCATE_AP_AREA - internal procedure to allocate temp area for process_arguments_ */ ALLOCATE_AP_AREA: proc; unspec (ai) = "0"b; /* clear out area info */ ai.version = area_info_version_1; /* set up area info block */ ai.control.extend = "1"b; ai.control.zero_on_alloc = "1"b; ai.owner = myname; ai.size = sys_info$max_seg_size; ai.version_of_area = area_info_version_1; ai.areap = null; call define_area_ (addr (ai), code); /* get an area, for arg processing use */ if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Error from define_area_"); go to non_local_return; end; ap_areap = ai.areap; /* copy area pointer */ allocate desc_string in (ap_area) set (desc_ptr); /* allocate storage for description */ end ALLOCATE_AP_AREA; %page; /* GET_PFM_OPTIONS - internal procedure to get PFM dependent options */ GET_PFM_OPTIONS: proc (pavp, pop); dcl (pavp, pop) ptr; do i = 1 to hbound (PFM_OPT_SW, 1); call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, PFM_OPT_SW (i), pavp -> pfm_arg_values.pfm_opt_sw (i)); if found_opts ^= "0"b then do; /* if option exists.. */ pop -> pfm_options.pfm_opt_flags (i).flag_name = GET_REF_NAME (PFM_OPT_SW (i)); pop -> pfm_options.pfm_opt_flags (i).flag_ant_name = neg_ref_name; end; end; do i = 1 to hbound (PFM_OPT_VALUE, 1); call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, PFM_OPT_VALUE (i), pavp -> pfm_arg_values.pfm_opt_value (i)); if found_opts ^= "0"b then /* if option exists.. */ pop -> pfm_options.pfm_opt_value_name (i) = GET_REF_NAME (PFM_OPT_VALUE (i)); end; do i = 1 to hbound (PFM_OPT_STR, 1); call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, PFM_OPT_STR (i), pavp -> pfm_arg_values.pfm_opt_str (i)); if found_opts ^= "0"b then /* if option exists.. */ pop -> pfm_options.pfm_opt_str_name (i) = GET_REF_NAME (PFM_OPT_STR (i)); end; end GET_PFM_OPTIONS; %page; /* valid_IBM_open_args - internal proc to perform some basic checking of format vis-a-vis block and record sizes. */ valid_IBM_open_args: proc () returns (bit (1)); if (valid_ibm_file_name (rtrim (mtape_open_info.file_name))) then ; else do; code = error_table_$bad_name; call mtape_util_$error (mtdp, code, "The data set name ^a does not meet the IBM specifications.", mtape_open_info.file_name); return ("0"b); end; if mtape_open_info.file_format = "f" then do; /* fixed format */ if mtape_open_info.block_length ^= 0 then do; /* if it's specified, it better equal the record length */ if mtape_open_info.block_length ^= mtape_open_info.record_length then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Fixed format requires that record and block lengths be equal."); return ("0"b); end; end; return ("1"b); end; else if mtape_open_info.file_format = "fb" then do; /* fixed block */ if mtape_open_info.block_length = 0 then do; /* must be specified */ code = error_table_$noarg; call mtape_util_$error (mtdp, code, "^/Fixed block format requires a ""-block"" size."); return ("0"b); end; if mtape_open_info.record_length = 0 then do; /* this must be there too... */ code = error_table_$noarg; call mtape_util_$error (mtdp, code, "^/""-record"" argument not specified."); return ("0"b); end; if mod (mtape_open_info.block_length, mtape_open_info.record_length) ^= 0 then do; /* and they must be mod 0 */ code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block size must be a mod 0 of the record size."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "v" then do;/* v format */ if mtape_open_info.block_length ^= 0 then do;/* if there, it MUST be record length + 4 */ if mtape_open_info.block_length ^= mtape_open_info.record_length + 4 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The specified block length MUST be record_length + 4."); return ("0"b); end; end; return ("1"b); end; else if mtape_open_info.file_format = "vb" then do; /* vb format */ if mtape_open_info.block_length = 0 then do; code = error_table_$noarg; call mtape_util_$error (mtdp, code, "^/No ""-block"" specified."); return ("0"b); end; if mtape_open_info.block_length >= mtape_open_info.record_length + 4 then ; else do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block length must be greater than or equal to the record_length + 4."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "vs" then do; if (mtape_open_info.block_length < 20) | (mtape_open_info.block_length > 32760) then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Format ""vs"" requires that the block length be >= 20 and <= 32760 characters."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "vbs" then do; if (mtape_open_info.block_length < 20) | (mtape_open_info.block_length > 32760) then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Format ""vbs"" requires that the block length be >= 20 and <= 32760 characters."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "u" then do;/* u format */ if mtape_open_info.record_length ^= 0 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Format u and ""-record""."); return ("0"b); end; return ("1"b); end; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Didn't recognize format ^a.", mtape_open_info.file_format); return ("0"b); end valid_IBM_open_args; %page; /* valid_ANSI_open_args - Like for IBM above, but using ANSI laws... */ valid_ANSI_open_args: proc () returns (bit (1)); if (valid_ansi_file_name (rtrim (mtape_open_info.file_name))) then ; else do; code = error_table_$bad_name; call mtape_util_$error (mtdp, code, "The file name ^a does not meet the ANSI specifications.", mtape_open_info.file_name); return ("0"b); end; if mtape_open_info.file_format = "f" then do; /* fixed format */ if mtape_open_info.block_length ^= 0 then do; /* if it's specified, it better equal the record length */ if mtape_open_info.block_length ^= mtape_open_info.record_length then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Fixed format requires that record and block lengths be equal."); return ("0"b); end; end; return ("1"b); end; else if mtape_open_info.file_format = "fb" then do; /* fixed block */ if mtape_open_info.block_length = 0 then do; /* must be specified */ code = error_table_$noarg; call mtape_util_$error (mtdp, code, "^/Fixed block format requires a ""-block"" size."); return ("0"b); end; if mtape_open_info.record_length = 0 then do; /* this must be there too... */ code = error_table_$noarg; call mtape_util_$error (mtdp, code, "^/""-record"" argument not specified."); return ("0"b); end; if mod (mtape_open_info.block_length, mtape_open_info.record_length) ^= 0 then do; /* and they must be mod 0 */ code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block size must be mod 0 the record size."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "d" then do;/* v format */ if mtape_open_info.block_length ^= 0 then do; if mtape_open_info.block_length ^= mtape_open_info.record_length then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Format ""d"" requires that block and record sizes be equal."); return ("0"b); end; end; if mtape_open_info.record_length > 9996 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The maximum record length for format ""d"" is 9996 bytes to allow for the record control word."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "db" then do; /* vb format */ if mtape_open_info.block_length < mtape_open_info.record_length then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block size must not be less than the record size."); return ("0"b); end; if mtape_open_info.record_length > 9996 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The maximum record length for format ""db"" is 9996 bytes to allow for the record control word."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "s" then do; if mtape_open_info.record_length > 1044480 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The record length must be <= 1044480 characters."); return ("0"b); end; if (mtape_open_info.block_length < 18) | (mtape_open_info.block_length > 99996) then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block length must be >= 18 and <= 99996 characters."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "sb" then do; if mtape_open_info.record_length > 1044480 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The record length must be <= 1044480 characters."); return ("0"b); end; if (mtape_open_info.block_length < 18) | (mtape_open_info.block_length > 99996) then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block length must be >= 18 and <= 99996 characters."); return ("0"b); end; return ("1"b); end; else if mtape_open_info.file_format = "u" then do; if mtape_open_info.record_length ^= 0 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Format ""u"" does not allow the ""-record"" control argument."); return ("0"b); end; if mtape_open_info.block_length > 32760 then do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/The block length must not be greater than 32760 characters."); return ("0"b); end; return ("1"b); end; else do; code = error_table_$inconsistent; call mtape_util_$error (mtdp, code, "^/Did not recognize ANSI formt ^a.", mtape_open_info.file_format); return ("0"b); end; end valid_ANSI_open_args; %page; valid_ibm_file_name: proc (namein) returns (bit (1)); dcl namein char (*), (first_dot, begin_next_dot, next_dot) fixed bin (24) init (0), valid_ibm_first_chars char (29) int static options (constant) init ( "ABCDEFGHIJKLMNOPQRSTUVWXYZ#@$"), valid_ibm_rest_chars char (10) int static options (constant) init ("1234567890"), ibm_name_seperator char (1) int static options (constant) init ("."), ibm_name_max_length fixed bin int static options (constant) init (44), ibm_name_indiv_len fixed bin int static options (constant) init (8); if (mtape_open_info.open_mode = 2 | mtape_open_info.open_mode = 5) then ; else return ("1"b); /* for input ignoe nameing specs */ if namein = "" then return ("1"b); /* FUDGE */ if length (namein) > ibm_name_max_length then return ("0"b); if length (namein) <= ibm_name_indiv_len then do; if verify (substr (namein, 1, 1), valid_ibm_first_chars) > 0 then return ("0"b); else do; if verify (namein, valid_ibm_first_chars || valid_ibm_rest_chars) > 0 then return ("0"b); else return ("1"b); /* finished here */ end; end; if verify (namein, valid_ibm_first_chars || valid_ibm_rest_chars || ibm_name_seperator) > 0 then return ("0"b); first_dot = index (namein, ibm_name_seperator); if first_dot > ibm_name_indiv_len + 1 then return ("0"b); /* needs to be there */ begin_next_dot = first_dot + 1; /* ok, cut up the simple names */ do while ("1"b); if verify (substr (namein, begin_next_dot, 1), valid_ibm_first_chars) > 0 then return ("0"b); /* check first chars of each name */ next_dot = index (substr (namein, begin_next_dot), ibm_name_seperator); if next_dot > ibm_name_indiv_len + 1 then return ("0"b); if next_dot = 0 then return ("1"b); begin_next_dot = begin_next_dot + next_dot; if begin_next_dot >= length (namein) then return ("1"b); end; return ("1"b); end valid_ibm_file_name; valid_ansi_file_name: proc (namein) returns (bit (1)); dcl namein char (*), valid_ansi_chars char (56) int static options (constant) init ( "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 !""%&'()*+,-./:;<=>?"); if (mtape_open_info.open_mode = 2 | mtape_open_info.open_mode = 5) then ; else return ("1"b); /* for input ignoe nameing specs */ if length (namein) > 17 then return ("0"b); /* max len is 17 */ if verify (namein, valid_ansi_chars) = 0 then return ("1"b); else return ("0"b); end valid_ansi_file_name; %page; %include mtape_data; %page; %include mtape_vol_set; %page; %include mtape_attach_info; %include mtape_detach_info; %page; %include mtape_open_close_info; %page; %include mtape_pfm_info; %include mtape_err_stats; %page; %include mtape_option_names; %page; %include mtape_constants; %page; %include rcp_resource_types; %page; %include rcp_volume_formats; %page; %include area_info; %page; %include iox_modes; %page; %include pa_option_value_list; end mtape_parse_;  mtape_position_.pl1 06/11/85 1409.7r w 06/11/85 1244.4 86535 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ mtape_position_: procedure (arg_iocbp, arg_type, arg_n, arg_code); /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. * This program contains the entries necessary to implement the * iox_$position and iox_$read_length entries for the mtape_ I/O module. * * Modification History: * * Created by J. A. Bush 12/13/82 * Modified by J. A. Bush 12/01/83 for performance improvements */ /* ARGUMENT DATA */ dcl arg_iocbp ptr; /* Pointer to our IOCB */ dcl arg_type fixed bin; /* Type of positioning to be done */ dcl arg_n fixed bin (21); /* Number of elements to position, or the length of record */ dcl arg_code fixed bin (35); /* Return error code */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl (i, tot_rcds, fwd_rcds, n_its, n_chars, n, rcd_len) fixed bin (21); dcl (j, idx) fixed bin; dcl found bit (1) aligned; /* EXTERNAL STATIC DATA */ dcl error_table_$no_operation fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (abs, addr, hbound, lbound, null, sum) builtin; /* EXTERNAL ENTRIES */ dcl mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl mtape_io_$read_block entry (ptr, fixed bin (35)); /* BASED DATA */ %page; /* Start of the mtape_position_ entry. This implements the iox_$position entry */ call SETUP; /* get things set up */ if arg_type < -1 | arg_type > 3 | (arg_type = 3 & mtape_open_info.open_mode ^= Stream_input) then do; /* Invalid type? */ arg_code = error_table_$no_operation; /* yes, can't do this type of positioning */ return; end; n = abs (arg_n); /* get the absolute value of arg_n */ go to action (arg_type); /* go do appropriate positioning */ action (-1): /* Position to beginning of file */ mtape_close_info.position = 1; /* simulate closing the file, and position to BOF */ call mtape_data.file_close (mtdp, code); /* call the PFM entry to close the file */ go to position_exit; action (+1): /* Position to end of file */ mtape_close_info.position = 2; /* simulate closing the file, and position to EOF */ call mtape_data.file_close (mtdp, code); /* call the PFM entry to close the file */ go to position_exit; action (0): /* Position fwd or backward arg_n records */ if mtape_open_info.open_mode = Stream_input | mtape_open_info.open_mode = Stream_input_output then do; code = error_table_$no_operation; /* Type 0 not supported for Stream I/O */ go to position_exit; end; if arg_n = 0 then /* if nothing to do, return */ go to position_exit; if arg_n > 0 then /* position fwd n records */ call FORWARD_SPACE (n); else call BACKSPACE (n); /* backspace n records */ go to position_exit; action (2): /* position to absolute record or character */ if n = mtape_data.tot_lrec then ; /* we are there now */ else if n > mtape_data.tot_lrec then do; /* position forward from this point */ fwd_rcds = n - mtape_data.tot_lrec; call FORWARD_SPACE (fwd_rcds); /* go forward delta amount */ end; else do; /* must backspace to get there */ n = mtape_data.tot_lrec - n; /* adjust count */ call BACKSPACE (n); /* and backup this many records */ end; go to position_exit; action (3): /* position fwd arg_n characters (stream_input only) */ call FORWARD_SPACE (n); /* this should do it */ position_exit: arg_code = code; /* copy return error code */ return; %page; /* The following entry implements the iox_$read_length entry for mtape_ */ read_length: entry (arg_iocbp, arg_n, arg_code); call SETUP; /* get things set up */ mtape_data.arg_buf_ptr = null; /* don't have a buffer */ mtape_data.arg_buf_len = 0; call mtape_data.read (mtdp, code); /* read the next logical record */ arg_n = mtape_data.arg_rec_len; /* copy length for user */ if code = 0 then /* only reposition if no error */ call BACKSPACE (1); /* yes, must backspace a block */ arg_code = code; /* copy return error code */ return; %page; /* SETUP - internal procedure to initialize our processing enviornment */ SETUP: proc; mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */ fi_ptr = mtape_data.fi_current; /* and pointer to our current file structure */ moip = mtape_data.open_info_ptr; mcip = mtape_data.close_info_ptr; code = 0; /* reset error code */ end SETUP; /* FORWARD_SPACE - internal procedure to position forward desired records or chars */ FORWARD_SPACE: proc (fn); dcl fn fixed bin (21); if mtape_open_info.open_mode = Sequential_input | mtape_open_info.open_mode = Sequential_input_output then do; n_its = fn; /* reading records, set number of iterations */ mtape_data.arg_buf_len = 0; /* and characters to read to 0 */ end; else do; /* Stream_input or Stream_input_output */ n_its = 1; /* set iterations to 1 and */ mtape_data.arg_buf_len = fn; /* characters to read forward */ end; mtape_data.arg_buf_ptr = null; /* We don't have a buffer for data */ do i = 1 to n_its while (code = 0); /* go forward desired number of records */ call mtape_data.read (mtdp, code); end; end FORWARD_SPACE; %page; /* BACKSPACE - internal procedure to position backwards desired records or chars */ BACKSPACE: proc (bn); dcl bn fixed bin (21); if bn <= hbound (mtape_data.lrec_rrc.block_no, 1) + 1 then do; /* Record in lrec history? */ idx = mtape_data.lrec_rrcx - 1; /* yes, repostion to apropriate log record */ do i = 1 to bn; if i ^= bn then do; idx = idx - 1; if idx < lbound (mtape_data.lrec_rrc.block_no, 1) then /* if we have reached the bottom */ idx = hbound (mtape_data.lrec_rrc.block_no, 1); /* reset to top */ end; end; if mtape_data.lrec_rrc (idx).block_no < mtape_data.phy_block then do; j = mtape_data.phy_block - mtape_data.lrec_rrc (idx).block_no + 1; /* we have to bks "j" blocks */ call mtape_io_$order (mtdp, "bsr", j, null, code); if code ^= 0 then return; mtape_data.prev_block_no = mtape_data.prev_block_no - (j - 1); /* correct prev block */ call mtape_io_$read_block (mtdp, code); if code ^= 0 then return; end; mtape_data.log_record_ptr = addr (tape_blk (mtape_data.lrec_rrc (idx).byte_offset)); mtape_data.processed = mtape_data.lrec_rrc (idx).byte_offset - 1; mtape_data.length = mtape_data.lrec_rrc (idx).block_len; mtape_data.log_record = mtape_data.lrec_rrc (idx).lrec_no; mtape_data.remain = mtape_data.length - mtape_data.processed; mtape_data.lrec_rrcx = idx; /* reset lrec history index */ end; else do; /* no, is it in the block history? */ if bn <= mtape_data.log_record then do; /* reposition within current block */ fwd_rcds = mtape_data.log_record - bn; /* compute rcds fwd from 1st rcd in blk */ mtape_data.log_record = 0; /* reset logical records in this blk */ mtape_data.processed = mtape_data.buffer_offset; mtape_data.remain = mtape_data.length - mtape_data.processed; mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); mtape_data.tot_lrec = mtape_data.tot_lrec - bn; /* adjust total log records */ end; else if bn <= sum (mtape_data.blk_rrrc) then do; /* repositon by backspacing blocks */ idx = mtape_data.blk_rrcx - 1; /* start from last block stored */ if idx < lbound (mtape_data.blk_rrrc, 1) then /* if at bottom of queue.. */ idx = hbound (mtape_data.blk_rrrc, 1); /* go to top */ tot_rcds = mtape_data.log_record; /* preload total with count of current blk */ j = 1; /* initialize blocks to backspace (including current) */ found = "0"b; do i = idx by -1 while (^found); /* scan the queue */ j = j + 1; /* increment blocks to backspace */ tot_rcds = tot_rcds + mtape_data.blk_rrrc (i); /* increment total */ mtape_data.blk_rrrc (i) = 0; /* clear this position */ if bn <= tot_rcds then found = "1"b; /* found the right block */ else if i - 1 < lbound (mtape_data.blk_rrrc, 1) then /* if at bottom of queue.. */ i = hbound (mtape_data.blk_rrrc, 1) + 1; /* set for the top */ end; mtape_data.blk_rrcx = i + 1; /* reset block index */ fwd_rcds = tot_rcds - bn; /* compute the number of rcds forward */ call mtape_io_$order (mtdp, "bsr", j, null, code); /* backspace j blocks */ if code ^= 0 then return; /* bad error return */ mtape_data.log_record_ptr = null; /* force block read */ mtape_data.remain = 0; mtape_data.tot_lrec = mtape_data.tot_lrec - bn; /* adjust total log records */ end; else do; /* must go to beginning of file */ fwd_rcds = mtape_data.tot_lrec - bn; /* get number forward */ mtape_close_info.position = 3; /* position to beginning of file section */ call mtape_data.file_close (mtdp, code);/* simulate closing */ if code ^= 0 then return; end; call FORWARD_SPACE (fwd_rcds); /* now position forward for indicated records */ end; end BACKSPACE; %page; %include iocb; %page; %include mtape_data; %page; %include mtape_open_close_info; %page; %include mtape_file_info; %page; %include iox_modes; end mtape_position_;  mtape_set_defaults.pl1 04/10/85 0831.6r w 04/08/85 1129.0 119421 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */ mtape_set_defaults: proc (); /* DESCRIPTION: This command sets default arguments used by the mtape_ I/O module. The default arguments, specified in the command line, for a particular tape operation and (perhaps) volume type are processed by the mtape_ argument processing routine (process_arguments_ for now) and are converted to a string representation which is stored in the data space of a specified value segment. */ /* HISTORY: Written 09/13/83 by S. Krupp. */ /* START OF DECLARATIONS */ /* Automatic */ dcl answer char(3) var; dcl arg_array_max_length fixed bin(21); dcl arg_array_ptr ptr; dcl arg_array_size fixed bin; dcl arg_list_ptr ptr; dcl arg_str_length fixed bin(21); dcl arg_str_ptr ptr; dcl based_varying_char_ptr ptr; dcl code fixed bin(35); dcl db_dirname char(168); dcl db_entryname char(32); dcl db_full_pathname char(168) var; dcl db_rel_pathname char(168) var; dcl default_arguments_ptr ptr; dcl definition_ptr ptr; dcl found_option bit(4); dcl idx fixed bin; dcl nargs fixed bin; dcl operation char(32) var; dcl program_name char(64) var; dcl result_ptr ptr; dcl value_seg_ptr ptr; dcl volume_type char(32) var; dcl 1 auto_area_info like area_info; dcl 1 auto_query_info like query_info; /* Based */ dcl arg_array(arg_array_size) char(arg_array_max_length) var based(arg_array_ptr); dcl arg_str char(arg_str_length) var based(arg_str_ptr); dcl based_varying_char char(sys_info$max_seg_size) var based(based_varying_char_ptr); dcl found_option_array(4) bit(1) unaligned based(addr(found_option)); dcl work_area area based(auto_area_info.areap); /* Builtin */ dcl (addr, divide, hbound, length, max, null, search, unspec) builtin; /* Condition */ dcl cleanup condition; /* Entries */ dcl com_err_ entry() options(variable); dcl command_query_ entry() options(variable); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_list_ptr entry (ptr); dcl define_area_ entry (ptr, fixed bin(35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl hcs_$append_branch entry (char(*), char(*), fixed bin(5), fixed bin(35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_ entry() options(variable); dcl ioa_$rsnnl entry() options(variable); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl process_arguments_$argument_array entry(char(*), fixed bin, (*) char(*) var, ptr, ptr, ptr, fixed bin(35)); dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35)); dcl process_arguments_$get_option_value entry options(variable); dcl release_area_ entry (ptr); dcl requote_string_ entry (char(*)) returns(char(*)); dcl term_$seg_ptr entry (ptr, fixed bin(35)); dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin(19), fixed bin(35)); dcl value_$set_data entry (ptr, bit(36) aligned, char(*), ptr, fixed bin(18), ptr, ptr, fixed bin(18), fixed bin(35)); /* Static */ dcl (MYNAME init("mtape_set_defaults"), PROGRAM_NAME_PREFIX init("mtape_"), RESERVED_CHARS init(" "";[]()|") /* SPACE || TAB || NEWLINE || """;[]()|" */ ) char(32) var int static options(constant); dcl (ARG_PROCESSING_MODE init(0), FIRST_ARG_TO_PROCESS init(1) ) fixed bin int static options(constant); dcl BIN_PERMANENT_VALUE fixed bin init(0) internal static options(constant); dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant); dcl VALUE_SUFFIX char(5) init("value") internal static options(constant); dcl VALUE_SEG_SIZE fixed bin(19) init(0) internal static options(constant); dcl (OPERATION_OPTION_IDX init(1), VOLUME_TYPE_OPTION_IDX init(2), PATHNAME_OPTION_IDX init(3), DEFAULT_ARGUMENTS_OPTION_IDX init(4) ) fixed bin int static options(constant); dcl (OPERATION_OPTION_NAME init("operation"), VOLUME_TYPE_OPTION_NAME init("volume_type"), PATHNAME_OPTION_NAME init("pathname"), DEFAULT_ARGUMENTS_OPTION_NAME init("default_arguments") ) char(32) var int static options(constant); dcl LONG_OPTION_REFNAME(4) char(32) var int static options(constant) init("operation", "-volume_type", "-pathname", "-arguments"); dcl (ATTACH_IDX init(1), OPEN_IDX init(2), CLOSE_IDX init(3), DETACH_IDX init(4) ) fixed bin internal static options(constant); dcl OPERATIONS(4) char(6) internal static options(constant) init("attach", "open", "close", "detach"); dcl VOLUME_TYPES(2) char(32) internal static options(constant) init("ansi", "ibm"); dcl (error_table_$bad_arg, error_table_$noarg, error_table_$noentry ) fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; /* Include */ %page; %include access_mode_values; %page; %include area_info; %page; %include pa_option_value_list; %page; %include pa_value_names; %page; %include query_info; /* END OF DECLARATIONS */ %page; /* Main Procedure */ /* Initialize */ value_seg_ptr = null; unspec (auto_area_info) = "0"b; auto_area_info.version = area_info_version_1; auto_area_info.areap = null; auto_area_info.owner = MYNAME; auto_area_info.size = sys_info$max_seg_size; auto_area_info.zero_on_alloc = "1"b; auto_area_info.extend = "1"b; call cu_$arg_count(nargs, code); if code ^= 0 then call ABORT(code, "Could not get the argument count.", ""); if nargs = 0 then call ABORT(0, "Usage ""mtape_set_defaults OPERATION {-control_args} -ag ARGS""", ""); unspec(auto_query_info) = "0"b; auto_query_info.version = query_info_version_5; auto_query_info.yes_or_no_sw = "1"b; auto_query_info.question_iocbp = null; auto_query_info.answer_iocbp = null; auto_query_info.explanation_ptr = null; on cleanup call CLEANUP(); call define_area_(addr(auto_area_info), code); if code ^= 0 then call ABORT(code, "Unable to allocate a work area.", ""); /* Get mtape_set_default's argument list. */ call cu_$arg_list_ptr(arg_list_ptr); /* Process mtape_set_defaults's arguments. */ call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE, arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap, result_ptr, code); if code ^= 0 then call ABORT_SILENT(); /* Error msg already printed. */ /* Get information needed to process the arguments that are the subject of the command line (i.e., the arguments that are the defaults for the specified tape processing operation and volume type). */ call process_arguments_$get_option_value(result_ptr, auto_area_info.areap, found_option, OPERATION_OPTION_NAME, operation, VOLUME_TYPE_OPTION_NAME, volume_type, PATHNAME_OPTION_NAME, db_rel_pathname, DEFAULT_ARGUMENTS_OPTION_NAME, default_arguments_ptr); if ^found_option_array(OPERATION_OPTION_IDX) then call ABORT(error_table_$noarg, "Missing ""^a"" option.", (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX))); do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation); end; if idx > hbound(OPERATIONS, 1) then call ABORT(error_table_$bad_arg, "Unknown operation specified: ""^a"".", (operation)); if ^found_option_array(DEFAULT_ARGUMENTS_OPTION_IDX) then call ABORT(error_table_$noarg, "Missing ""^a"" option.", (LONG_OPTION_REFNAME(DEFAULT_ARGUMENTS_OPTION_IDX))); if found_option_array(VOLUME_TYPE_OPTION_IDX) then do; do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type); end; if idx > hbound(VOLUME_TYPES, 1) then call ABORT(error_table_$bad_arg, "Unknown volume type specified: ""^a"".", (volume_type)); if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX) then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ || volume_type || """ with the ""^a"" operation.", (operation)); end; /* Build the program name from the specified tape processing operation and volume type. */ call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX, operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type); /* Transfer program_name's arguments to an array for processing by the mtape_ argument processing routine (process_arguments_). */ arg_array_size = default_arguments_ptr->option_value_list.number_of_values; arg_array_max_length = 0; arg_str_length = 0; do idx = 1 to arg_array_size; based_varying_char_ptr = default_arguments_ptr->option_value_list.value(idx).ptr; arg_array_max_length = max(arg_array_max_length, length(based_varying_char)); if idx ^= 1 then arg_str_length = arg_str_length + 1; if search(based_varying_char, RESERVED_CHARS) > 0 then arg_str_length = arg_str_length + length(requote_string_((based_varying_char))); else arg_str_length = arg_str_length + length(based_varying_char); end; alloc arg_array in (work_area) set (arg_array_ptr); alloc arg_str in(work_area) set(arg_str_ptr); arg_str = ""; do idx = 1 to arg_array_size; based_varying_char_ptr = default_arguments_ptr->option_value_list.value(idx).ptr; arg_array(idx) = based_varying_char; if idx ^= 1 then arg_str = arg_str || " "; if search(based_varying_char, RESERVED_CHARS) > 0 then arg_str = arg_str || requote_string_((based_varying_char)); else arg_str = arg_str || (based_varying_char); end; /* Process program_name's arguments. */ definition_ptr = null; call process_arguments_$argument_array((program_name), ARG_PROCESSING_MODE, arg_array, definition_ptr, auto_area_info.areap, result_ptr, code); if code ^= 0 then call ABORT_SILENT(); /* Error msg already printed. */ /* Now check out the value seg where we will store the user specified default arguments. Create it if necessary. */ call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code); if code ^= 0 then call ABORT(code, "^a", (db_rel_pathname)); db_full_pathname = pathname_(db_dirname, db_entryname); call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code); if code = error_table_$noentry then do; call command_query_(addr(auto_query_info), answer, MYNAME, "The value segment ""^a""^/does not exist." || "Do you wish to create it?", (db_full_pathname)); if answer = "no" | answer = "n" then call ABORT(code, "^a", (db_full_pathname)); else call ioa_("Creating ^a.", db_full_pathname); call hcs_$append_branch(db_dirname, db_entryname, RW_ACCESS_BIN, code); if code ^= 0 then call ABORT(code, "While creating ^a.", (db_full_pathname)); call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code); if code ^= 0 then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname)); call value_$init_seg(value_seg_ptr, BIN_PERMANENT_VALUE, null, VALUE_SEG_SIZE, code); if code ^= 0 then call ABORT(code, "While initiating ^a as a value segment.", (db_full_pathname)); end; else if code ^= 0 then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname)); /* Store the linear form (arg_str). */ call value_$set_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX || "." || program_name, addr(arg_str), divide(length(arg_str) + 3, 4, 17, 0) + 1, null, (null), (0), code); if code ^= 0 then call ABORT(code, "Unable to store the default arguments in ^a", (db_full_pathname)); call CLEANUP(); RETURN: return; %page; CLEANUP: proc(); if auto_area_info.areap ^= null then call release_area_(auto_area_info.areap); if value_seg_ptr ^= null then call term_$seg_ptr(value_seg_ptr, code); end CLEANUP; ABORT: proc (code, msg, msg_arg); /* Parameter */ dcl code fixed bin (35); dcl msg char (*); dcl msg_arg char (*); call com_err_ (code, MYNAME, msg, msg_arg); call CLEANUP(); goto RETURN; end ABORT; ABORT_SILENT: proc(); call CLEANUP(); goto RETURN; end ABORT_SILENT; end mtape_set_defaults;  mtape_util_.pl1 12/17/86 0925.7r w 12/17/86 0830.0 234360 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ mtape_util_: procedure; /* format: style4 */ /* * This program is part of the mtape_ I/O module and as such is not * called directly by users, but through the iox_ I/O system. This * program implements several common subroutines. * * Modification History: * * Created by J. A. Bush 10/05/82 * Modified by J. A. Bush 01/09/84 to enable referencing dir search rule * when searching for Per-Format modules */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to mtape_data */ dcl arg_alloc_type fixed bin; /* Type of structure to allocate */ dcl arg_prev_ptr ptr; /* Pointer to previously allocated structure */ dcl arg_length fixed bin (21); /* Length of string to allocate */ dcl arg_return_ptr ptr; /* Pointer to allocated storage */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_qcode fixed bin; /* User query index */ /* AUTOMATIC DATA */ dcl (prev_ptr, temp_ptr, argp, qep, ep) ptr; dcl pfmn char (32); dcl (str_length, rs_len) fixed bin (21); dcl (alloc_type, i, cdx) fixed bin; dcl explain_str char (1024); dcl rs_emess char (512); dcl answer char (128); dcl code fixed bin (35); dcl invert_qsw bit (1) aligned; dcl 1 atec aligned like tec; /* CONSTANT DATA */ dcl myname char (6) int static options (constant) init ("mtape_"); dcl 1 EXPLAIN_NO_NEXT_VOLUME int static options (constant), 2 n_lines fixed bin init (5), 2 text (5) char (71) unaligned init ("Physical end of volume has been detected on a multi-volume file, but", "no volumes remain in the volume sequence list. A ""yes"" answer will", "lock the file such that no further I/O operations are possible (i.e.", "the file may only be closed). A ""no"" answer will cause a further", "query for the next volume name."); dcl 1 EXPLAIN_LABELED_VOLUME int static options (constant), 2 n_lines fixed bin init (9), 2 text (9) char (71) unaligned init ("The indicated volume requires initialization but contains a valid", "volume label of some other type not recognized by the Per Format", "module currently in control. A ""yes"" answer will cause the volume", "to be initialized with the volume label sequence of the Per-Format", "module in control. A ""no"" answer will cause one of the following", "actions. If this is the initial file opening, then the opening will", "be aborted. If this condition was detected on a subsequent volume", "switch of a multi-volume file, then the file will be locked such that", "further I/O operations are not possible."); dcl 1 EXPLAIN_UNEXPIRED_VOLUME int static options (constant), 2 n_lines fixed bin init (4), 2 text (4) char (71) unaligned init ("It has been determined that the indicated volume must be initialized", "but its first file contains an expiration date which is in the future.", "A ""yes"" answer will allow processing to continue.", "A ""no"" answer will abort the opening."); dcl 1 EXPLAIN_INCORRECT_VOLUME int static options (constant), 2 n_lines fixed bin init (6), 2 text (6) char (71) unaligned init ("The volume name specified by the user and the volume name recorded on", "the indicated volume do not agree. If opening for output, a ""yes""", "answer will cause the volume to be initialized with the volume name", "specified by the user. If opening for input, a ""yes"" answer will", "cause the descrepency to be ignored and processing will continue. A", """no"" answer will cause the opening to be aborted."); dcl 1 EXPLAIN_UNEXPIRED_FILE int static options (constant), 2 n_lines fixed bin init (5), 2 text (5) char (71) unaligned init ("The file that is being opened currently exists and must be replaced,", "modified or extended but the recorded files expiration date is in the", "future. A ""yes"" answer will cause the file labels to be overwritten", "and processing will continue. A ""no"" answer will abort the file", "opening."); dcl 1 EXPLAIN_ABORT_FILE int static options (constant), 2 n_lines fixed bin init (6), 2 text (6) char (71) unaligned init ("Unrecoverable tape errors have ocurred while attempting to write file", "headers, trailers or tape marks, thus invalidating the file-set", "structure. A ""yes"" answer causes an attempt to be made to delete", "the defective file section. A ""no"" answer will cause no action", "to be taken. In either case, the file is locked and no further", "I/O is possible."); dcl 1 EXPLAIN_NEW_VOLUME int static options (constant), 2 n_lines fixed bin init (4), 2 text (4) char (71) unaligned init ("The user is requested to supply the volume name of a new volume", "following a ""no"" answer from a previous ""no_next_volume"" query.", "An optional mount comment may also be supplied. The expected user", "response must be in the form: ""volume_name -comment STR""."); dcl NL char (1) int static options (constant) init (" "); /* EXTERNAL STATIC DATA */ dcl error_table_$no_next_volume fixed bin (35) ext static; dcl error_table_$uninitialized_volume fixed bin (35) ext static; dcl error_table_$unexpired_volume fixed bin (35) ext static; dcl error_table_$unexpired_file fixed bin (35) ext static; dcl error_table_$file_aborted fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, codeptr, hbound, index, length, ltrim, null, rtrim, substr, translate) builtin; /* EXTERNAL ENTRIES */ dcl tape_ioi_$get_statistics entry (bit (36) aligned, ptr, fixed bin (35)); dcl tape_ioi_$reset_statistics entry (bit (36) aligned, fixed bin (35)); dcl mtape_util_$error entry options (variable); dcl canon_for_volume_label_ entry (char (*), char (*), char (*) aligned, fixed bin, fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl com_err_ entry () options (variable); dcl command_query_ entry () options (variable); dcl cu_$arg_list_ptr entry (ptr); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); /* BASED STORAGE */ dcl based_str char (str_length) based; dcl based_area area based (mtape_data.areap); dcl 1 query_explanation based (qep), /* command query explanation template */ 2 n_lines fixed bin, /* number of lines in the explanation text */ 2 text (12) char (71) unaligned; /* message text array */ %page; /* alloc - entry to allocate storage for various structures * * Usage: * * dcl mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr); * call mtape_util_$alloc (mtdp, alloc_type, prev_ptr, str_length, return_ptr); * * where: * 1. mtdp * is a pointer to the mtape_data structure defined by * mtape_data.incl.pl1. (INPUT) * 2. alloc_type * is the structure type to be allocated, defined in * mtape_constants.incl.pl1. (INPUT) * 3. prev_ptr * is a pointer to the previous structure of this type, for types * 1 - 3. If non-null, the previous and next pointers in the * respective structures will be linked. (INPUT) * 4. str_length * is the string length in characters to be allocated for type 4 * allocation. The parameter is ignored for other allocation types. * (INPUT) * 5. return_ptr * is a pointer to the allocated storage. (OUTPUT) */ alloc: entry (arg_mtdp, arg_alloc_type, arg_prev_ptr, arg_length, arg_return_ptr); mtdp = arg_mtdp; /* copy arguments */ alloc_type = arg_alloc_type; prev_ptr = arg_prev_ptr; go to alloc_storage (alloc_type); /* go do the appropriate allocation */ alloc_storage (1): /* allocate a volume set structure */ allocate mtape_vol_set in (based_area) set (temp_ptr); /* that should do it */ vs_ptr = temp_ptr; /* initialize the structure */ mtape_vol_set.version = mtape_vs_version_1; mtape_vol_set.mrm_vs_ptr, mtape_vol_set.lrm_vs_ptr = null; mtape_vol_set.first_vl_ptr, mtape_vol_set.last_vl_ptr = null; mtape_vol_set.volume_name, mtape_vol_set.volume_id = ""; mtape_vol_set.mount_comment, mtape_vol_set.device_name = ""; mtape_vol_set.demount_comment = ""; mtape_vol_set.next_vs_ptr = null; /* link the structures if possible */ mtape_vol_set.prev_vs_ptr = prev_ptr; if prev_ptr ^= null then do; /* if user supplied valid prev ptr.. */ prev_ptr -> mtape_vol_set.next_vs_ptr = vs_ptr; /* link the previous volume set */ mtape_vol_set.volume_index = prev_ptr -> mtape_vol_set.volume_index + 1; /* increment vol sequence */ end; else mtape_vol_set.volume_index = 1; /* first volume, set to 1 */ go to alloc_end; alloc_storage (2): /* allocate a label record structure */ allocate mtape_label_record in (based_area) set (temp_ptr); /* that should do it */ lr_ptr = temp_ptr; /* initialize the structure */ mtape_label_record.version = mtape_lr_version_1; mtape_label_record.lab_ptr = null; mtape_label_record.next_lab_ptr = null; /* link the structures if possible */ mtape_label_record.prev_lab_ptr = prev_ptr; if prev_ptr ^= null then /* if user supplied valid prev ptr.. */ prev_ptr -> mtape_label_record.next_lab_ptr = lr_ptr; /* link the previous label record */ go to alloc_end; alloc_storage (3): /* allocate a file info structure */ allocate mtape_file_info in (based_area) set (temp_ptr); /* that should do it */ fi_ptr = temp_ptr; /* initialize structure */ mtape_file_info.version = mtape_fi_version_1; mtape_file_info.first_file_lab_ptr, mtape_file_info.last_file_lab_ptr = null; mtape_file_info.first_file_trail_ptr, mtape_file_info.last_file_trail_ptr = null; mtape_file_info.first_file_section_ptr = null; mtape_file_info.begin_vs_ptr, mtape_file_info.end_vs_ptr = null; mtape_file_info.file_id, mtape_file_info.file_set_id = ""; mtape_file_info.creation_date, mtape_file_info.expiration_date = ""; mtape_file_info.pfm_opt_str (*) = ""; mtape_file_info.char_size = 9; /* until told otherwise */ mtape_file_info.next_fi_ptr = null; /* link the structures if possible */ mtape_file_info.prev_fi_ptr = prev_ptr; if prev_ptr ^= null then /* if user supplied valid prev ptr.. */ prev_ptr -> mtape_file_info.next_fi_ptr = fi_ptr; /* link the previous file structure */ go to alloc_end; alloc_storage (4): /* allocate storage for a string of bytes */ str_length = arg_length; /* copy the length */ allocate based_str in (based_area) set (temp_ptr);/* that should do it */ go to alloc_end; alloc_end: arg_return_ptr = temp_ptr; /* copy the pointer for the user */ return; /* thats all folks */ %page; /* error - entry to display error messages */ error: entry (arg_mtdp, arg_code); /* externally declared as options (variable) */ if arg_mtdp -> mtape_data.display_errors then do; /* only display errors if he wants us to */ rs_emess = ""; /* pad the message first */ call cu_$arg_list_ptr (argp); /* get ptr to our argument list */ call ioa_$general_rs (argp, 3, 4, rs_emess, rs_len, "1"b, "0"b); /* format message */ call com_err_ (arg_code, myname, rs_emess); /* display message */ end; return; %page; /* get_statistics - entry to update error statistics counters in vol_set and file_info structures */ get_statistics: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy args */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; code, arg_code = 0; tape_ioi_error_counts_ptr = addr (atec); /* set ptr to auto structure */ tec.version = TEC_VERSION_1; /* set structure version */ call tape_ioi_$get_statistics (mtape_data.tioi_id, tape_ioi_error_counts_ptr, code); if code ^= 0 then do; /* if error, probably wrong version */ call mtape_util_$error (mtdp, code, "Error from tape_ioi_$get_statistics"); go to gs_return; end; call tape_ioi_$reset_statistics (mtape_data.tioi_id, code); /* reset tape_ioi_ error counters */ if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Error from tape_ioi_$reset_statistics"); go to gs_return; end; /* Now that we have the current error stats, merge them in with vol_set and file_info structures */ mtape_vol_set.tot_error_stats.read.errors = mtape_vol_set.tot_error_stats.read.errors + tec.reads.errors; mtape_vol_set.tot_error_stats.read.operations = mtape_vol_set.tot_error_stats.read.operations + tec.reads.total; mtape_vol_set.tot_error_stats.write.errors = mtape_vol_set.tot_error_stats.write.errors + tec.writes.errors; mtape_vol_set.tot_error_stats.write.operations = mtape_vol_set.tot_error_stats.write.operations + tec.writes.total; mtape_vol_set.tot_error_stats.orders.errors = mtape_vol_set.tot_error_stats.orders.errors + tec.orders.errors; mtape_vol_set.tot_error_stats.orders.operations = mtape_vol_set.tot_error_stats.orders.operations + tec.orders.total; mtape_vol_set.rel_error_stats.read.errors = mtape_vol_set.rel_error_stats.read.errors + tec.reads.errors; mtape_vol_set.rel_error_stats.read.operations = mtape_vol_set.rel_error_stats.read.operations + tec.reads.total; mtape_vol_set.rel_error_stats.write.errors = mtape_vol_set.rel_error_stats.write.errors + tec.writes.errors; mtape_vol_set.rel_error_stats.write.operations = mtape_vol_set.rel_error_stats.write.operations + tec.writes.total; mtape_vol_set.rel_error_stats.orders.errors = mtape_vol_set.rel_error_stats.orders.errors + tec.orders.errors; mtape_vol_set.rel_error_stats.orders.operations = mtape_vol_set.rel_error_stats.orders.operations + tec.orders.total; do i = 1 to hbound (mtape_vol_set.tot_error_stats.successful_retry, 1); mtape_vol_set.tot_error_stats.successful_retry (i) = mtape_vol_set.tot_error_stats.successful_retry (i) + tec.successful_retry_strategy (i); mtape_vol_set.rel_error_stats.successful_retry (i) = mtape_vol_set.rel_error_stats.successful_retry (i) + tec.successful_retry_strategy (i); end; if fi_ptr ^= null then do; /* update file error statistics? */ mtape_file_info.read_errors = mtape_file_info.read_errors + tec.reads.errors; mtape_file_info.write_errors = mtape_file_info.write_errors + tec.writes.errors; end; gs_return: arg_code = code; return; %page; /* init_pfm - entry to select the appropriate Per-Format module and check it for existence and access */ init_pfm: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy args */ vs_ptr = mtape_data.vs_current; maip = mtape_data.attach_info_ptr; code, arg_code = 0; if mtape_attach_info.pfm_prefix ^= "" then /* if a "-vt" specified by the user */ pfmn = mtape_attach_info.pfm_prefix; /* use user specifed prefix */ else do; /* otherwise check RCP designation */ if mtape_vol_set.volume_type = Volume_multics_tape | /* is tape one we recognize? */ mtape_vol_set.volume_type = Volume_gcos_tape | mtape_vol_set.volume_type = Volume_ibm_tape | mtape_vol_set.volume_type = Volume_ansi_tape then pfmn = Tape_volume_types (mtape_vol_set.volume_type); /* yes, form prefix directly */ else if mtape_vol_set.volume_type = Volume_unknown_format then /* if readable but unrecognized.. */ pfmn = "raw"; /* set prefix for the "raw" PFM */ else pfmn = mtape_attach_info.default_pfm_prefix; /* Use default prefix */ end; pfmn = translate (pfmn, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* Make it LC */ mtape_attach_info.pfm_prefix = pfmn; /* save the PFM prefix */ if index (pfmn, "_tape_io_") = 0 then /* if user didn't already do it.. */ pfmn = rtrim (pfmn) || "_tape_io_"; /* complete PFM name */ /* Locate the Per-Format module, using the standard object search rules */ call hcs_$make_ptr (codeptr (mtape_util_), pfmn, "", ep, code); if ep = null then do; /* if we can't find it complain */ call mtape_util_$error (mtdp, code, "Can't find the ""^a"" Per-Format module.", pfmn); arg_code = code; return; end; mtape_data.pfm_name = pfmn; /* success, save the PFM name */ /* Make sure all required entry points are there */ call hcs_$make_entry (codeptr (mtape_util_), pfmn, "pfm_init", mtape_data.pfm_init, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""pfm_init"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "file_open", mtape_data.file_open, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""file_open"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "file_close", mtape_data.file_close, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""file_close"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "read", mtape_data.read, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""read"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "write", mtape_data.write, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""write"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "order", mtape_data.order, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""order"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "decode_file_labels", mtape_data.decode_file_labels, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""decode_file_labels"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; call hcs_$make_entry (codeptr (mtape_util_), pfmn, "encode_file_labels", mtape_data.encode_file_labels, code); if code ^= 0 then do; call mtape_util_$error (mtdp, code, "Could not find the ""encode_file_labels"" entry point for the ""^a"" Per-Format module.", pfmn); call SAVE_CODE; /* set return code (if not already set ) */ end; return; %page; /* user_query - entry to generate standard user queries for various information */ user_query: entry (arg_mtdp, arg_qcode, arg_code); mtdp = arg_mtdp; /* copy args */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; rs_emess, answer = ""; /* pad message and answer with blanks */ invert_qsw = "0"b; /* yes answer is positive for most */ arg_code = 0; /* clear return code for positive response */ query_info.version = query_info_version_6; /* set version number */ query_info.yes_or_no_sw = "1"b; /* set yes or no switch */ query_info.prompt_after_explanation = "1"b; go to U_QUERY (arg_qcode); /* ask the right question */ U_QUERY (1): /* Q_NO_NEXT_VOLUME */ qep = addr (EXPLAIN_NO_NEXT_VOLUME); /* set the explaination ptr */ code = error_table_$no_next_volume; /* set appropriate error code */ invert_qsw = "1"b; /* no answer is the positive in this case */ call ioa_$rsnnl ("Reached the end of volume on volume ^a. Do you wish to terminate processing of this volume-set?", rs_emess, rs_len, mtape_vol_set.volume_id); go to U_QUERY_COM; U_QUERY (2): /* Q_LABELED_VOLUME */ qep = addr (EXPLAIN_LABELED_VOLUME); /* set the explaination ptr */ code = error_table_$uninitialized_volume; /* set appropriate error code */ query_info.query_code = 2; /* set query code of command_question handlers */ call ioa_$rsnnl ("Volume ^a has a valid ^a volume label. Do you want to ^[initialize it with a standard ^a volume label^;^1suse this volume for unlabeled output^]? ", rs_emess, rs_len, mtape_vol_set.volume_id, Tape_volume_types (mtape_vol_set.volume_type), mtape_attach_info.labeled, mtape_pfm_info.module_id); go to U_QUERY_COM; U_QUERY (3): /* Q_UNEXPIRED_VOLUME */ qep = addr (EXPLAIN_UNEXPIRED_VOLUME); /* set the explaination ptr */ code = error_table_$unexpired_volume; /* set appropriate error code */ call ioa_$rsnnl ("Volume ^a requires initialization, but contains an unexpired file. Do you want to initialize it?", rs_emess, rs_len, mtape_vol_set.volume_name); go to U_QUERY_COM; U_QUERY (4): /* Q_INCORRECT_VOLUME */ qep = addr (EXPLAIN_INCORRECT_VOLUME); /* set the explaination ptr */ code = error_table_$uninitialized_volume; /* set appropriate error code */ query_info.query_code = 3; /* set query code of command_question handlers */ call ioa_$rsnnl ("Warning: Label for volume ^a contains identifier ^a instead. Do you want to ^[continue processing^;re-initialize it as the desired volume^]?", rs_emess, rs_len, mtape_vol_set.volume_name, mtape_vol_set.volume_id, (mtape_open_info.open_mode = Sequential_input)); go to U_QUERY_COM; U_QUERY (5): /* Q_UNEXPIRED_FILE */ qep = addr (EXPLAIN_UNEXPIRED_FILE); /* set the explaination ptr */ code = error_table_$unexpired_file; /* set appropriate error code */ call ioa_$rsnnl ("Do you want to overwrite the unexpired file ""^a""?", rs_emess, rs_len, mtape_file_info.file_id); go to U_QUERY_COM; U_QUERY (6): /* Q_ABORT_FILE */ qep = addr (EXPLAIN_ABORT_FILE); /* set the explaination ptr */ code = error_table_$file_aborted; /* set appropriate error code */ call ioa_$rsnnl ("Error while writing labels of file ""^a"", section ^d. The defective file section invalidates the structure of the entire file set. Do you want to delete the defective section?", rs_emess, rs_len, mtape_file_info.file_id, mtape_file_info.section); go to U_QUERY_COM; U_QUERY_COM: query_info.status_code = code; /* set error code */ call SET_EXPLANATION; /* set up the explanation string */ call command_query_ (addr (query_info), answer, myname, rtrim (rs_emess)); /* ask question */ if (answer = "no" & ^invert_qsw) | (answer = "yes" & invert_qsw) then arg_code = code; /* answer was negative, return code */ else if arg_qcode = Q_NO_NEXT_VOLUME then do; /* must get new volume name */ call alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, vs_ptr); /* allocate vol_set struct. */ mtape_data.vs_tail = vs_ptr; answer = ""; /* initialize answer */ query_info.yes_or_no_sw = "0"b; /* not a yes/no answer */ query_info.suppress_name_sw = "0"b; query_info.status_code, query_info.query_code = 0; qep = addr (EXPLAIN_NEW_VOLUME); /* set the explaination ptr */ call SET_EXPLANATION; /* set up the explanation string */ code = 1; /* go through loop at least once */ do while (code ^= 0); /* do it until user gets it right */ call command_query_ (addr (query_info), answer, myname, "^[(""^a"" incorrect)^/^;^1s^]Enter volume name of next volume (and optional comment).^/", (answer ^= ""), answer); if answer ^= "" then do; /* if we have some answer */ cdx = index (answer, " ") - 1; /* index to end of volume name */ if cdx < 0 then /* if no comment given */ cdx = length (rtrim (answer)); call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, cdx), mtape_vol_set.volume_name, 0, code); if code ^= 0 then /* if error from canonicalize */ query_info.status_code = code; else do; /* now check for comment */ answer = ltrim (substr (answer, cdx + 1)); /* remove volume name */ if answer ^= "" then do; /* we have some comment */ if substr (answer, 1, 8) = "-comment" | substr (answer, 1, 4) = "-com" then answer = substr (answer, index (answer, " ") + 1); /* strip off control arg */ mtape_vol_set.mount_comment = answer; /* copy the mount comment */ end; end; end; end; end; return; %page; /* SET_EXPLANATION - internal procedure to set up the command_query_ explanation string and pointer */ SET_EXPLANATION: proc; dcl i fixed bin; explain_str = ""; do i = 1 to query_explanation.n_lines; explain_str = rtrim (explain_str) || query_explanation.text (i) || NL; end; query_info.explanation_ptr = addr (explain_str); query_info.explanation_len = length (rtrim (explain_str)); end SET_EXPLANATION; /* SAVE_CODE - internal procedure to set the return error code if not already set */ SAVE_CODE: proc; if arg_code = 0 then /* set return code only if not already set */ arg_code = code; end SAVE_CODE; %page; %include mtape_data; %page; %include mtape_attach_info; %page; %include mtape_open_close_info; %page; %include mtape_pfm_info; %page; %include mtape_vol_set; %page; %include mtape_label_record; %include mtape_err_stats; %page; %include mtape_file_info; %page; %include mtape_constants; %page; %include query_info; %page; %include rcp_resource_types; %page; %include rcp_volume_formats; %include tape_ioi_error_counts; %page; %include iox_modes; end mtape_util_;  pa_cv_result_to_lf.pl1 02/16/84 1306.5r w 02/16/84 1249.8 112518 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ pa_cv_result_to_lf: proc (p_definition_ptr, p_result_ptr, p_linear_form, p_code); /* DESCRIPTION: This entry converts a result pva into a linear form. */ /* HISTORY: Written by Lindsey L. Spratt, 07/05/83. Modified: 07/06/83 by Lindsey L. Spratt: Fixed setting of is_arg_dimension array to set "0"b for dimensions which aren't arg_dimensions. 07/08/83 by Lindsey L. Spratt: Fixed to prefix option values which start with "-" with a "-quote ". Fixed to requote all option values. 08/26/83 by S. Krupp: Changed to only requote option values that don't contain reserved command line characters. Changed to prefix only non-literal option values with "-quote". 09/13/83 by S. Krupp: Commented out -quote facility due to problems in making it compatible with the Force_literal facility. */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_definition_ptr ptr; /*is a pointer to the definition print_vector_array for the command named in the result pva. If this pointer is null, then a definition is found by searching the process_arguments search list.*/ dcl p_result_ptr ptr; /*is a pointer to a result print_vector_array.*/ dcl p_linear_form char (*) varying; /*is the linear form converted from*/ dcl p_code fixed bin (35); /*is a standard system error code.*/ /* Automatic */ dcl (command_name_id, option_name_identifier, instance_identifier, pv_idx) fixed bin init (-1); dcl (option_name, instance_count, old_instance_count) char (64) varying init (""); dcl current_linear_form char (1024) varying; dcl result_command_name char (32) varying init (""); dcl definition_ptr ptr init (null); dcl work_area_ptr ptr init (null); /* Based */ /* Builtin */ dcl null builtin; /* Condition */ dcl cleanup condition; /* Constant */ dcl myname init ("pa_cv_result_to_lf") char (32) varying internal static options (constant); dcl UNDEFINED_DIMENSION init (-1) fixed bin internal static options (constant); dcl ( SPACE_CHAR init (" "), TAB_CHAR init (" "), NEWLINE_CHAR init (" ") ) char (1) internal static options (constant); /* Entry */ dcl process_arguments_$get_definition entry (char (*) var, ptr, ptr, fixed bin (35)); dcl process_arguments_$get_reference_name entry (ptr, char (*) var, char (*) var, char (*) var); dcl get_system_free_area_ entry () returns (ptr); dcl sub_err_ entry () options (variable); dcl requote_string_ entry (char (*)) returns (char (*)); /* External */ dcl sys_info$max_seg_size fixed bin (35) ext static; dcl ( error_table_$unimplemented_version, error_table_$bad_arg ) fixed bin (35) ext; /* END OF DECLARATIONS */ p_linear_form = ""; definition_ptr = p_definition_ptr; on cleanup call FINISH; if work_area_ptr = null then work_area_ptr = get_system_free_area_ (); call CHECK_VERSION (p_result_ptr -> print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); call SET_ID_REQUIRED (p_result_ptr, COMMAND_NAME_DIM_NAME, command_name_id); call GET_VALUE (p_result_ptr -> print_vector_array.vector_slot (1), command_name_id, result_command_name); if definition_ptr = null then do; call process_arguments_$get_definition (result_command_name, work_area_ptr, definition_ptr, p_code); if p_code ^= 0 then call ERROR_RETURN; end; call CHECK_VERSION (definition_ptr -> print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); call SET_ID_REQUIRED (p_result_ptr, OPTION_NAME_DIM_NAME, option_name_identifier); call SET_ID_REQUIRED (p_result_ptr, INSTANCE_DIM_NAME, instance_identifier); BUILD_LINEAR_FORM_BLOCK: begin; dcl blfb_is_arg_dimension (p_result_ptr -> print_vector_array.number_of_dimensions) bit (1) aligned; call FIND_ARG_DIMENSIONS (p_result_ptr, blfb_is_arg_dimension); BLFB_PRINT_VECTOR_LOOP: do pv_idx = 1 to p_result_ptr -> print_vector_array.number_of_vectors; print_vector_ptr = p_result_ptr -> print_vector_array.vector_slot (pv_idx); old_instance_count = instance_count; call GET_VALUE (print_vector_ptr, option_name_identifier, option_name); call GET_VALUE (print_vector_ptr, instance_identifier, instance_count); if instance_count = old_instance_count then call GET_ARG_VALUES (blfb_is_arg_dimension, print_vector_ptr, current_linear_form); else call GET_REFNAME_AND_VALUES (blfb_is_arg_dimension, print_vector_ptr, option_name, current_linear_form); p_linear_form = p_linear_form || " " || current_linear_form; end BLFB_PRINT_VECTOR_LOOP; end BUILD_LINEAR_FORM_BLOCK; call FINISH; MAIN_RETURN: return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; SET_ID: proc (si_p_pva_ptr, si_p_dim_name, si_p_dim_id); dcl si_p_pva_ptr ptr parameter; dcl si_p_dim_name char (*) varying parameter; dcl si_p_dim_id fixed bin parameter; dcl si_dim_is_required bit (1) aligned init ("0"b); dcl requote_string_ entry (char (*)) returns (char (*)); goto SI_JOIN; SET_ID_REQUIRED: entry (si_p_pva_ptr, si_p_dim_name, si_p_dim_id); si_dim_is_required = "1"b; SI_JOIN: do si_p_dim_id = 1 to si_p_pva_ptr -> print_vector_array.number_of_dimensions while (si_p_pva_ptr -> print_vector_array.dimension_table (si_p_dim_id).name ^= si_p_dim_name); end; if si_p_dim_id > si_p_pva_ptr -> print_vector_array.number_of_dimensions then if si_dim_is_required then call sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0, "^/The argument processing definition structure must have a ^a dimension in it, but the one provided does not.", requote_string_ ((si_p_dim_name))); else si_p_dim_id = UNDEFINED_DIMENSION; end SET_ID; %page; GET_DIM_IDX: proc (gdi_p_pv_ptr, gdi_p_identifier, gdi_p_dim_idx); dcl gdi_p_pv_ptr ptr; dcl gdi_p_identifier fixed bin; dcl gdi_p_dim_idx fixed bin; do gdi_p_dim_idx = 1 to gdi_p_pv_ptr -> print_vector.number_of_dimensions while (gdi_p_pv_ptr -> print_vector.dimension (gdi_p_dim_idx).identifier ^= gdi_p_identifier); end; if gdi_p_dim_idx > gdi_p_pv_ptr -> print_vector.number_of_dimensions then gdi_p_dim_idx = UNDEFINED_DIMENSION; end GET_DIM_IDX; %page; GET_VALUE: proc (gv_p_print_vector_ptr, gv_p_dim_identifier, gv_p_dim_value); dcl gv_p_print_vector_ptr ptr parameter; dcl gv_p_dim_identifier fixed bin parameter; dcl gv_p_dim_value char (*) varying; dcl gv_dim_idx fixed bin init (0); call GET_DIM_IDX (gv_p_print_vector_ptr, gv_p_dim_identifier, gv_dim_idx); if gv_dim_idx = UNDEFINED_DIMENSION then call sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0, "^/All of the vectors in the result print_vector_array must contain the dimension with identifier ^d. The current print_vector does not.", gv_p_dim_identifier); gv_p_dim_value = gv_p_print_vector_ptr -> print_vector.dimension (gv_dim_idx).value; end GET_VALUE; %page; FINISH: proc; if p_definition_ptr = null & definition_ptr ^= null then do; do pv_idx = 1 to definition_ptr -> print_vector_array.number_of_vectors; print_vector_ptr = definition_ptr -> print_vector_array.vector_slot (pv_idx); if print_vector_ptr ^= null then free print_vector; end; free definition_ptr -> print_vector_array; end; end FINISH; ERROR_RETURN: proc (); call FINISH (); goto MAIN_RETURN; end ERROR_RETURN; %page; GET_ARG_VALUES: proc (gav_p_is_arg_dimension, gav_p_print_vector_ptr, gav_p_value_str); dcl gav_p_is_arg_dimension (*) bit (1) aligned parameter; dcl gav_p_print_vector_ptr ptr parameter; dcl gav_p_value_str char (*) varying parameter; dcl gav_current_value_ptr ptr init (null); dcl gav_current_value based (gav_current_value_ptr) char (sys_info$max_seg_size * 4) varying; dcl gav_dim_idx fixed bin init (0); dcl RESERVED_CHARS char(64) var init(SPACE_CHAR || TAB_CHAR || NEWLINE_CHAR || """;[]()|"); gav_p_value_str = ""; do gav_dim_idx = 1 to gav_p_print_vector_ptr -> print_vector.number_of_dimensions; if gav_p_is_arg_dimension (gav_p_print_vector_ptr -> print_vector.dimension (gav_dim_idx).identifier) then do; gav_current_value_ptr = addr (gav_p_print_vector_ptr -> print_vector.dimension (gav_dim_idx).value); /* if index (ltrim (gav_current_value, SPACE_CHAR || TAB_CHAR), "-") = 1 then gav_p_value_str = gav_p_value_str || " " || "-quote"; */ if search(gav_current_value, RESERVED_CHARS) > 0 then gav_p_value_str = gav_p_value_str || " " || requote_string_((gav_current_value)); else gav_p_value_str = gav_p_value_str || " " || gav_current_value; end; end; end GET_ARG_VALUES; %page; GET_REFNAME_AND_VALUES: proc (grav_p_is_arg_dimension, grav_p_print_vector_ptr, grav_p_option_name, grav_p_linear_form); dcl grav_p_is_arg_dimension (*) bit (1) aligned parameter; dcl grav_p_print_vector_ptr ptr parameter; dcl grav_p_option_name char (*) varying parameter; dcl grav_p_linear_form char (*) varying parameter; dcl (grav_positive_refname, grav_negative_refname) char (256) varying init (""); grav_p_linear_form = ""; call process_arguments_$get_reference_name (definition_ptr, grav_p_option_name, grav_positive_refname, grav_negative_refname); call GET_ARG_VALUES (grav_p_is_arg_dimension, grav_p_print_vector_ptr, grav_p_linear_form); if grav_negative_refname = "" then grav_p_linear_form = grav_positive_refname || " " || grav_p_linear_form; else if index (grav_p_linear_form, "false") > 0 then grav_p_linear_form = grav_negative_refname; else grav_p_linear_form = grav_positive_refname; end GET_REFNAME_AND_VALUES; %page; FIND_ARG_DIMENSIONS: proc (fad_p_result_ptr, fad_p_is_arg_dimension); dcl fad_p_result_ptr ptr parameter; dcl fad_p_is_arg_dimension (*) bit (1) aligned parameter; dcl fad_dim_identifier fixed bin init (0); dcl fad_dim_name char (128) varying init (""); fad_p_is_arg_dimension (*) = "1"b; do fad_dim_name = COMMAND_NAME_DIM_NAME, OPTION_NAME_DIM_NAME, ORDER_DIM_NAME, INSTANCE_DIM_NAME; call SET_ID_REQUIRED (fad_p_result_ptr, fad_dim_name, fad_dim_identifier); fad_p_is_arg_dimension (fad_dim_identifier) = "0"b; end; end FIND_ARG_DIMENSIONS; %page; %include sub_err_flags; %page; %include vu_print_vector_array; %page; %include pa_dim_name_constants; end pa_cv_result_to_lf;  pa_get_option_value.pl1 10/24/88 1652.3r w 10/24/88 1359.0 189540 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ pa_get_option_value: proc (p_result_print_vector_array_ptr, p_area_ptr, p_found_option); /* DESCRIPTION: This entry extracts the values of arguments of options as present in a result print_vector_array produced by process_arguments_. */ /* HISTORY: Written by Lindsey L. Spratt, 06/11/83. Modified: 06/15/83 by Lindsey L. Spratt: Added a new argument, p_found_option, to record which of the requested options were found in the result pva. 06/30/83 by Lindsey L. Spratt: Changed to use pa_dim_name_constants.incl.pl1. Changed to look for the option name dimension in the print_vector rather than assume it is the next to last dimension. 07/07/83 by Lindsey L. Spratt: Fixed to correctly handle varying character return data. 08/04/83 by S. Krupp to correctly handle varying character input data (the option_name argument specifically). */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_result_print_vector_array_ptr ptr; /*is a pointer to a result print_vector_array produced by process_arguments_.*/ dcl p_area_ptr ptr; /*is a pointer to the area in which this entry is to allocate its output information (when appropriate).*/ dcl p_found_option bit (*) parameter; /* Automatic */ dcl output_area_ptr ptr init (null); /* Pointer on which output_area is based. */ dcl system_area_ptr ptr init (null); dcl nargs fixed bin init (0); /* Number of arguments with which this subroutine was called. */ dcl arg_list_ptr ptr init (null); /* Pointer to the argument list for this subroutine. */ dcl arg_list_arg_count fixed bin init (0); /* Variable used by the arg_list structure. */ dcl number_of_option_values_requested fixed bin init (0); dcl option_name_identifier fixed bin init (0); /* This is the index into the dimension_table */ /* of the definition of the option_name dimension. */ dcl vhbu_number_of_vectors fixed bin init (0); /* The extent of the vector_has_been_used bit array. */ dcl vector_has_been_used_ptr ptr init (null); /* Points at the vector_has_been_used array. */ dcl option_idx fixed bin init (0); /* The loop counter for the OPTION_LOOP. */ dcl option_name_arg_idx fixed bin init (0); /* The index into the argument list of the current */ /* (in the OPTION_LOOP) option's name. */ dcl option_variable_arg_idx fixed bin init (0); /* The index into the argument list of the */ /* current option's return value variable. */ dcl type fixed bin init (0); /* Set by calling decode_descriptor_. */ dcl packed bit (1) aligned init ("0"b); /* Set by calling decode_descriptor_. */ dcl ndims fixed bin init (0); /* Set by calling decode_descriptor_. */ dcl size fixed bin init (0); /* Set by calling decode_descriptor_. */ dcl scale fixed bin init (0); /* Set by calling decode_descriptor_. */ dcl option_name_ptr ptr init (null); /* Pointer on which option_name is based. Set from */ /* the argument_list. */ dcl option_name_length fixed bin init (0); /* Length of the option_name from the argument_list. */ dcl current_option_vector_idx fixed bin init (0); /* Index into the print_vector_array of */ /* the print_vector from which the current */ /* option_value was extracted. */ dcl option_value_ptr ptr init (null); /* Pointer on which the option_value is based. */ dcl data_ptr ptr init (null); /* Pointer to return variable in which the option_value is to */ /* be placed. */ dcl char_data_length fixed bin init (0); dcl vchar_data_length fixed bin init (0); dcl option_value_link_ptr ptr init (null); dcl root_option_value_link_ptr ptr init (null); dcl previous_option_value_link_ptr ptr init (null); dcl next_option_value_link_ptr ptr init (null); dcl value_idx fixed bin init (0); /* Based */ dcl output_area area based (output_area_ptr); /* Area in which option_value_list structures */ /* area allocated for the caller. */ dcl system_area area based (system_area_ptr); /* Area for scratch storage. */ dcl vector_has_been_used (vhbu_number_of_vectors) bit (1) aligned based (vector_has_been_used_ptr); /* This array is used by FIND_OPTION_VALUE to avoid looking at */ /* any vector in the caller-provided print_vector_array */ /* more than once. */ dcl option_name char (option_name_length) based (option_name_ptr); dcl option_value char (sys_info$max_seg_size * 4) varying based (option_value_ptr); dcl var_option_name_size fixed bin(21) based(addwordno(option_name_ptr, -1)); dcl aligned_char_data based (data_ptr) aligned char (char_data_length); dcl unaligned_char_data based (data_ptr) unaligned char (char_data_length); dcl aligned_vchar_data based (data_ptr) aligned char (vchar_data_length) varying; dcl unaligned_vchar_data based (data_ptr) unaligned char (vchar_data_length) varying; dcl aligned_flag_data based (data_ptr) aligned bit (1); dcl unaligned_flag_data based (data_ptr) unaligned bit (1); dcl aligned_integer_data based (data_ptr) aligned fixed bin (35); dcl unaligned_integer_data based (data_ptr) unaligned fixed bin (35); dcl aligned_list_ptr_data based (data_ptr) aligned ptr; dcl unaligned_list_ptr_data based (data_ptr) unaligned ptr; dcl 1 option_value_link based (option_value_link_ptr), 2 next_ptr ptr init (null), 2 value_ptr ptr init (null), 2 vector_idx fixed bin init (0); /* Builtin */ dcl (addr, divide, null, substr) builtin; /* Condition */ dcl cleanup condition; /* Constant */ dcl ( MINIMUM_POSSIBLE_NUMBER_OF_ARGS init (5), NUMBER_OF_NONVALUE_ARGS init (3), NUMBER_OF_INITIAL_NONVALUE_ARGS init (3), NO_CURRENT_OPTION_VECTOR_IDX init (0) ) fixed bin internal static options (constant); dcl MYNAME init ("pa_get_option_value") char (32) varying internal static options (constant); /* Entry */ dcl requote_string_ entry (char (*)) returns (char (*)); dcl get_system_free_area_ entry () returns (ptr); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl sub_err_ entry () options (variable); /* External */ dcl sys_info$max_seg_size fixed bin (35) ext static; dcl ( error_table_$unimplemented_version, error_table_$too_few_args, error_table_$bad_arg, error_table_$noarg ) fixed bin (35) ext; /* END OF DECLARATIONS */ print_vector_array_ptr = p_result_print_vector_array_ptr; output_area_ptr = p_area_ptr; system_area_ptr = get_system_free_area_ (); call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); on cleanup call FINISH; call cu_$arg_count (nargs, (0)); arg_list_arg_count = nargs; call cu_$arg_list_ptr (arg_list_ptr); if nargs < MINIMUM_POSSIBLE_NUMBER_OF_ARGS then call sub_err_ (error_table_$too_few_args, MYNAME, ACTION_CANT_RESTART, null, 0); else if mod (nargs - NUMBER_OF_NONVALUE_ARGS, 2) ^= 0 then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The option names/value variable arguments must be paired. This was not the case."); number_of_option_values_requested = divide (nargs - NUMBER_OF_NONVALUE_ARGS, 2, 17, 0); call GET_DIMENSION_IDENTIFIER (print_vector_array_ptr, (OPTION_NAME_DIM_NAME), option_name_identifier); vhbu_number_of_vectors = print_vector_array.number_of_vectors; alloc vector_has_been_used in (system_area); unspec (vector_has_been_used) = "0"b; if length (p_found_option) < number_of_option_values_requested then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The caller-provided ""found_option"" string must have as many bits in it as the number of options for which values are requested. However, there are only ^d bits in the ""found_option"" string and ^d options were requested.", length (p_found_option), number_of_option_values_requested); p_found_option = "0"b; OPTION_LOOP: do option_idx = 1 to number_of_option_values_requested; option_name_arg_idx = 2 * (option_idx - 1) + 1 + NUMBER_OF_INITIAL_NONVALUE_ARGS; option_variable_arg_idx = option_name_arg_idx + 1; call decode_descriptor_ (arg_list_ptr, option_name_arg_idx, type, packed, ndims, size, scale); if type ^= char_dtype & type ^= varying_char_dtype then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/Option name parameter number ^d (argument number ^d) does not have a character string data type.", option_idx, option_name_arg_idx); option_name_ptr = arg_list_ptr -> arg_list.arg_ptrs (option_name_arg_idx); if type = varying_char_dtype then option_name_length = var_option_name_size; else option_name_length = size; current_option_vector_idx = NO_CURRENT_OPTION_VECTOR_IDX; call FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name), vector_has_been_used, current_option_vector_idx, option_value_ptr); if option_value_ptr ^= null then PROCESS_OPTION_VALUE: do; substr (p_found_option, option_idx, 1) = "1"b; call decode_descriptor_ (arg_list_ptr, option_variable_arg_idx, type, packed, ndims, size, scale); data_ptr = arg_list_ptr -> arg_list.arg_ptrs (option_variable_arg_idx); if type = char_dtype then CHAR_DATA: do; char_data_length = size; if packed then do; (stringsize): unaligned_char_data = option_value; end; else do; (stringsize): aligned_char_data = option_value; end; end CHAR_DATA; else if type = varying_char_dtype then VCHAR_DATA: do; data_ptr = addwordno (data_ptr, -1); /* To adjust for peculiar handling of the varying data type in arg_list preparation. */ vchar_data_length = size; if packed then do; (stringsize): unaligned_vchar_data = option_value; end; else do; (stringsize): aligned_vchar_data = option_value; end; end VCHAR_DATA; else if type = bit_dtype & size = 1 then FLAG_DATA: do; if packed then unaligned_flag_data = CONVERT_TO_FLAG (option_value); else aligned_flag_data = CONVERT_TO_FLAG (option_value); end FLAG_DATA; else if type = real_fix_bin_1_dtype then INTEGER_DATA: do; if packed then unaligned_integer_data = CONVERT_TO_INTEGER (option_value); else aligned_integer_data = CONVERT_TO_INTEGER (option_value); end INTEGER_DATA; else if type = pointer_dtype then DATA_LIST: do; alloc option_value_link in (system_area); root_option_value_link_ptr = option_value_link_ptr; option_value_link.value_ptr = option_value_ptr; option_value_link.vector_idx = current_option_vector_idx; call FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name), vector_has_been_used, current_option_vector_idx, option_value_ptr); DATA_LIST_LOOP: do ovl_number_of_values = 1 by 1 while (option_value_ptr ^= null); previous_option_value_link_ptr = option_value_link_ptr; alloc option_value_link in (system_area); previous_option_value_link_ptr -> option_value_link.next_ptr = option_value_link_ptr; option_value_link.next_ptr = null; option_value_link.value_ptr = option_value_ptr; option_value_link.vector_idx = current_option_vector_idx; call FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name), vector_has_been_used, current_option_vector_idx, option_value_ptr); end DATA_LIST_LOOP; /* The refer extent variable, ovl_number_of_values, is set in the DATA_LIST_LOOP. */ alloc option_value_list in (output_area); option_value_list.version = OPTION_VALUE_LIST_VERSION_1; option_value_link_ptr = root_option_value_link_ptr; do value_idx = 1 to option_value_list.number_of_values; next_option_value_link_ptr = option_value_link.next_ptr; option_value_list.value (value_idx).ptr = option_value_link.value_ptr; option_value_list.value (value_idx).vector_idx = option_value_link.vector_idx; option_value_link_ptr = next_option_value_link_ptr; end; if packed then unaligned_list_ptr_data = option_value_list_ptr; else aligned_list_ptr_data = option_value_list_ptr; end DATA_LIST; else call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/Option variable parameter number ^d (argument number ^d) does not have a valid data type. It must be one of the following data types: character (varying or non-varying), bit (1), fixed bin (<36), or pointer.", option_idx, option_variable_arg_idx); end PROCESS_OPTION_VALUE; end OPTION_LOOP; call FINISH; return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, MYNAME, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; GET_DIMENSION_IDENTIFIER: proc (gdi_p_pva_ptr, gdi_p_dimension_name, gdi_p_dimension_identifier); dcl gdi_p_pva_ptr ptr parameter; dcl gdi_p_dimension_name char (*) parameter; dcl gdi_p_dimension_identifier fixed bin parameter; dcl gdi_dim_idx fixed bin; do gdi_dim_idx = 1 to gdi_p_pva_ptr -> print_vector_array.number_of_dimensions while (gdi_p_pva_ptr -> print_vector_array.dimension_table (gdi_dim_idx).name ^= gdi_p_dimension_name); end; if gdi_dim_idx > gdi_p_pva_ptr -> print_vector_array.number_of_dimensions then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The input result print_vector_array does not have a dimension named ^a.", requote_string_ (gdi_p_dimension_name)); gdi_p_dimension_identifier = gdi_dim_idx; end GET_DIMENSION_IDENTIFIER; %page; FIND_OPTION_VALUE: proc (fov_p_print_vector_array_ptr, fov_p_option_name_identifier, fov_p_option_name, fov_p_vector_has_been_used, fov_p_current_option_vector_idx, fov_p_option_value_ptr); dcl fov_p_print_vector_array_ptr ptr parameter; dcl fov_p_option_name_identifier fixed bin parameter; dcl fov_p_option_name char (*) parameter; dcl fov_p_vector_has_been_used (*) bit (1) aligned parameter; dcl fov_p_current_option_vector_idx fixed bin parameter; dcl fov_p_option_value_ptr ptr parameter; dcl fov_print_vector_ptr ptr; dcl fov_print_vector_idx fixed bin (35); dcl (fov_name_dim_idx, fov_value_dim_idx) fixed bin init (0); FOV_PRINT_VECTOR_LOOP: do fov_print_vector_idx = fov_p_current_option_vector_idx + 1 to fov_p_print_vector_array_ptr -> print_vector_array.number_of_vectors; if ^fov_p_vector_has_been_used (fov_print_vector_idx) then do; fov_print_vector_ptr = fov_p_print_vector_array_ptr -> print_vector_array.vector_slot (fov_print_vector_idx); do fov_name_dim_idx = 1 to fov_print_vector_ptr -> print_vector.number_of_dimensions while (fov_print_vector_ptr -> print_vector.dimension (fov_name_dim_idx).identifier ^= fov_p_option_name_identifier); end; if fov_name_dim_idx > fov_print_vector_ptr -> print_vector.number_of_dimensions then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The option name dimension must be present in all of the result print_vectors. This is not the case for print_vector ^d.", fov_print_vector_idx); if fov_p_option_name = fov_print_vector_ptr -> print_vector.dimension (fov_name_dim_idx).value then do; fov_p_current_option_vector_idx = fov_print_vector_idx; fov_value_dim_idx = fov_print_vector_ptr -> print_vector.number_of_dimensions; fov_p_option_value_ptr = addr (fov_print_vector_ptr -> print_vector.dimension (fov_value_dim_idx).value); fov_p_vector_has_been_used (fov_print_vector_idx) = "1"b; return; end; end; end FOV_PRINT_VECTOR_LOOP; fov_p_current_option_vector_idx = 0; fov_p_option_value_ptr = null; end FIND_OPTION_VALUE; %page; CONVERT_TO_FLAG: proc (ctf_p_option_value) returns (bit (1) aligned); dcl ctf_p_option_value char (*) varying parameter; if ctf_p_option_value = "true" | ctf_p_option_value = "t" | ctf_p_option_value = "on" | ctf_p_option_value = "yes" | ctf_p_option_value = "y" | ctf_p_option_value = "1" then return ("1"b); else if ctf_p_option_value = "false" | ctf_p_option_value = "f" | ctf_p_option_value = "off" | ctf_p_option_value = "no" | ctf_p_option_value = "n" | ctf_p_option_value = "0" then return ("0"b); else call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The option ^a has a value which is not convertable to a flag. Its value is ^a.", requote_string_ ((option_name)), requote_string_ ((ctf_p_option_value))); end CONVERT_TO_FLAG; %page; CONVERT_TO_INTEGER: proc (cti_p_option_value) returns (fixed bin (35)); dcl cti_p_option_value char (*) varying parameter; dcl cti_integer fixed bin (35); dcl cti_code fixed bin (35); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); cti_integer = cv_dec_check_ ((cti_p_option_value), cti_code); if cti_code ^= 0 then call sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0, "^/The value for option ^a, ^a, couldn't be converted to an integer. The conversion failed on character ^d, ^a.", requote_string_ ((option_name)), requote_string_ ((cti_p_option_value)), cti_code, requote_string_ (substr (cti_p_option_value, cti_code, 1))); return (cti_integer); end CONVERT_TO_INTEGER; %page; FINISH: proc (); if root_option_value_link_ptr ^= null then do; root_option_value_link_ptr = null; option_value_link_ptr = root_option_value_link_ptr; do while (option_value_link_ptr ^= null); next_option_value_link_ptr = option_value_link_ptr; free option_value_link in (system_area); option_value_link_ptr = next_option_value_link_ptr; end; end; if vector_has_been_used_ptr ^= null then free vector_has_been_used in (system_area); end FINISH; %page; %include sub_err_flags; %page; %include vu_print_vector_array; %page; %include std_descriptor_types; %page; %include pa_option_value_list; %page; %include pa_dim_name_constants; %page; %include arg_list; end pa_get_option_value;  pa_get_refname.pl1 02/16/84 1306.5r w 02/16/84 1249.8 68796 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ pa_get_refname: proc (p_definition_pva_ptr, p_option_name, p_positive_reference_name, p_negative_reference_name); /* DESCRIPTION: This entry returns the primary name by which the specified option can be referenced in a linear form. If the option is one which sets a flag based on whether it is referenced by its "positive" name or its "negative" name, then this entry returns the primary "positive" and the primary "negative" reference names. */ /* HISTORY: Written by Lindsey L. Spratt, 06/30/83. Modified: */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_definition_pva_ptr ptr; /*is a pointer to a standard argument processing definition.*/ dcl p_option_name char (*) varying; /*is the name of an option for which the reference name is desired.*/ dcl p_positive_reference_name char (*) varying; /*is the primary reference name for the specified option. If the option has positive and negative reference names, then this is the primary positive reference name.*/ dcl p_negative_reference_name char (*) varying; /*is the primary negative reference name. If the option does not have a negative reference name, this parameter gets a null value.*/ /* Automatic */ dcl (option_name_identifier, synonym_identifier, negative_form_identifier) fixed bin init (0); dcl (pv_dim_idx, syn_pv_dim_idx, neg_pv_dim_idx) fixed bin init (0); dcl print_vector_idx fixed bin init (0); dcl (finished, have_found_a_vector_for_the_option) bit (1) aligned init ("0"b); /* Based */ /* Builtin */ dcl null builtin; /* Constant */ dcl UNDEFINED_DIMENSION init (-1) fixed bin internal static options (constant); dcl myname init ("pa_get_refname") char (32) varying internal static options (constant); /* Entry */ dcl sub_err_ entry () options (variable); /* External */ dcl ( error_table_$unimplemented_version, error_table_$bad_arg ) fixed bin (35) ext; /* END OF DECLARATIONS */ print_vector_array_ptr = p_definition_pva_ptr; call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); call SET_ID_REQUIRED (print_vector_array_ptr, OPTION_NAME_DIM_NAME, option_name_identifier); call SET_ID_REQUIRED (print_vector_array_ptr, SYNONYM_DIM_NAME, synonym_identifier); call SET_ID (print_vector_array_ptr, NEGATIVE_FORM_DIM_NAME, negative_form_identifier); if negative_form_identifier = UNDEFINED_DIMENSION then neg_pv_dim_idx = UNDEFINED_DIMENSION; else neg_pv_dim_idx = 0; p_negative_reference_name, p_positive_reference_name = ""; DEFINITION_LOOP: do print_vector_idx = 1 to print_vector_array.number_of_vectors while (^finished); print_vector_ptr = print_vector_array.vector_slot (print_vector_idx); call GET_DIM_IDX (print_vector_ptr, option_name_identifier, pv_dim_idx); if pv_dim_idx ^= UNDEFINED_DIMENSION then if print_vector.dimension (pv_dim_idx).value = p_option_name then FOUND_VECTOR_FOR_OPTION: do; have_found_a_vector_for_the_option = "1"b; call GET_DIM_IDX (print_vector_ptr, synonym_identifier, syn_pv_dim_idx); if syn_pv_dim_idx ^= UNDEFINED_DIMENSION then PROCESS_REFNAME: do; if negative_form_identifier ^= UNDEFINED_DIMENSION then call GET_DIM_IDX (print_vector_ptr, negative_form_identifier, neg_pv_dim_idx); if neg_pv_dim_idx = UNDEFINED_DIMENSION then do; if p_positive_reference_name = "" then p_positive_reference_name = print_vector.dimension (syn_pv_dim_idx).value; finished = (p_negative_reference_name ^= "" | negative_form_identifier = UNDEFINED_DIMENSION); end; else do; if p_negative_reference_name = "" then p_negative_reference_name = print_vector.dimension (syn_pv_dim_idx).value; finished = (p_positive_reference_name ^= ""); end; end PROCESS_REFNAME; end FOUND_VECTOR_FOR_OPTION; else finished = have_found_a_vector_for_the_option; end DEFINITION_LOOP; return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; SET_ID: proc (si_p_pva_ptr, si_p_dim_name, si_p_dim_id); dcl si_p_pva_ptr ptr parameter; dcl si_p_dim_name char (*) varying parameter; dcl si_p_dim_id fixed bin parameter; dcl si_dim_is_required bit (1) aligned init ("0"b); dcl requote_string_ entry (char (*)) returns (char (*)); goto SI_JOIN; SET_ID_REQUIRED: entry (si_p_pva_ptr, si_p_dim_name, si_p_dim_id); si_dim_is_required = "1"b; SI_JOIN: do si_p_dim_id = 1 to si_p_pva_ptr -> print_vector_array.number_of_dimensions while (si_p_pva_ptr -> print_vector_array.dimension_table (si_p_dim_id).name ^= si_p_dim_name); end; if si_p_dim_id > si_p_pva_ptr -> print_vector_array.number_of_dimensions then if si_dim_is_required then call sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0, "^/The argument processing definition structure must have a ^a dimension in it, but the one provided does not.", requote_string_ ((si_p_dim_name))); else si_p_dim_id = UNDEFINED_DIMENSION; end SET_ID; %page; GET_DIM_IDX: proc (gdi_p_pv_ptr, gdi_p_identifier, gdi_p_dim_idx); dcl gdi_p_pv_ptr ptr; dcl gdi_p_identifier fixed bin; dcl gdi_p_dim_idx fixed bin; do gdi_p_dim_idx = 1 to gdi_p_pv_ptr -> print_vector.number_of_dimensions while (gdi_p_pv_ptr -> print_vector.dimension (gdi_p_dim_idx).identifier ^= gdi_p_identifier); end; if gdi_p_dim_idx > gdi_p_pv_ptr -> print_vector.number_of_dimensions then gdi_p_dim_idx = UNDEFINED_DIMENSION; end GET_DIM_IDX; %page; %include sub_err_flags; %page; %include vu_print_vector_array; %page; %include pa_dim_name_constants; end pa_get_refname;  pa_process_arguments.pl1 10/24/88 1652.3r w 10/24/88 1359.1 793485 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(82-03-18,Spratt), approve(), audit(), install(): Written. 2) change(83-05-01,York), approve(), audit(), install(): William M. York and Suzanne Krupp: to prepare for exposure release as part of the new tape software. 3) change(83-06-20,Spratt), approve(), audit(), install(): Converted from process_arguments_.pl1. Renamed the main entry $argument_list, added the $argument_array and $argument_string entries, and the code which supports them. 4) change(83-06-27,Spratt), approve(), audit(), install(): Moved the search list code into a separate module, pa_search_list. 5) change(83-06-29,York), approve(), audit(), install(): Get all the excluded options out of the definition, fix checking for required arguments, and add validation of arguments. 6) change(83-07-01,York), approve(), audit(), install(): Interpret a required argument as meaning that only one instance of the argument is required even if more are allowed. Also improved error messages and set proper maximum value lengths for the dimensions of the result pva. 7) change(83-07-01,Spratt), approve(), audit(), install(): Fixed to use the new calling sequence of $get_default_linear_form. The process_arguments_$argument_string entry is now used to parse the default_linear_form into an initial result_print_vector_array. This interaction should be improved so that the invocation of pa_process_arguments which gets the default_linear_form and the invocation of pa_process_arguments can share the processed form of the definition. Fixed to call CONVERT_STRING_TO_ARG_LIST for the default_linear_form. 8) change(83-07-07,Spratt), approve(), audit(), install(): Fixed to use a first_arg_idx of 1 when processing the default linear form. Also fixed to report a missing explanation instead of taking a null pointer fault. Changed to evaluate active strings in default linear forms. 9) change(83-07-08,Spratt), approve(), audit(), install(): Changed to use "-quote -foo" instead of "--foo" to force the interpretation of "-foo" as an option value and not an option reference name. Moved the invocation of PRINT_EXPLANATION into the main option-value-processing do-group of the ARG_LOOP to ensure that the control_argument_ptr is set. 10) change(83-07-20,Spratt), approve(), audit(), install(): Changed the CONVERT_ARRAY_TO_LIST to return a null arg_list_ptr when the input argument_array has one element which equals "". Changed CONVERT_STRING_TO_LIST to return a null arg_list_ptr when the input arg_string equals "". 11) change(83-07-25,SKrupp), approve(), audit(), install(): Fixed handling of implied options that have arguments prefixed by a "-quote". Fixed MISPLACED_CONTROL_ARGUMENT to test for control_argument_is_in_effect as well as what it already tests for. 12) change(83-08-03,SKrupp), approve(), audit(), install(): Added result validation and fixed assorted bugs. 13) change(83-08-28,SKrupp), approve(), audit(), install(): Added argument validation explanations and the ability to force arguments to be taken literally in to the -quote facility. 14) change(85-10-03,GWMay), approve(85-10-03,MCR7282), audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001): Reformatted history comments. Modified PROCESS_ARGUMENT_LIST to initialize the control_argument_is_in_effect, using_implicit_control_argument and option_accepts_explicit_argument switches to false. END HISTORY COMMENTS */ /* format: style2,ind3 */ pa_process_arguments: proc (); /* START OF DECLARATIONS */ /* Parameter */ dcl p_command_name char (*); dcl p_arg_processing_mode fixed bin; dcl p_arg_list_ptr ptr; dcl p_first_arg_idx fixed bin; dcl p_arg_array (*) char (*) varying; dcl p_arg_string char (*) varying; dcl p_definition_print_vector_array_ptr ptr; dcl p_work_area_ptr ptr; dcl p_result_print_vector_array_ptr ptr; dcl p_code fixed bin (35); /* Automatic */ dcl using_implicit_control_argument bit (1) aligned init ("0"b); dcl last_arg_idx_processed fixed bin init (0); dcl first_arg_idx fixed bin init (0); dcl (arg_list_ptr, default_arg_list_ptr) ptr init (null); dcl dim_idx fixed bin; dcl max_value_arg_len fixed bin; dcl (implied_control_argument_name_identifier, control_argument_name_identifier, next_implied_control_argument_name_identifier, result_control_argument_name_identifier, argument_name_identifier, initial_argument_name_identifier, next_argument_name_identifier, option_presence_identifier, argument_presence_identifier, explanation_identifier, synonym_identifier, validation_string_identifier, antonym_identifier, result_instance_identifier, result_command_name_identifier, result_order_identifier, default_argument_value_identifier, negative_default_argument_value_identifier, excluded_option_identifier) fixed bin; dcl implied_control_argument_ptr ptr; dcl vector_idx fixed bin; dcl temp_idx fixed bin; dcl real_vector_count fixed bin; dcl control_argument_name_dim_id fixed bin; dcl old_control_argument_name_dim_id fixed bin; dcl old_print_vector_ptr ptr; dcl old_control_argument_ptr ptr; dcl root_control_argument_ptr ptr; dcl arg_exists bit (1) aligned; dcl option_accepts_explicit_argument bit (1) aligned; dcl control_argument_is_in_effect bit (1) aligned init ("0"b); dcl exists_implied_control_argument bit (1) aligned init ("0"b); dcl implied_control_argument_name_ptr ptr; dcl implied_control_argument_name_length fixed bin; dcl first_argument_name_ptr pointer; dcl first_argument_name_len fixed bin; dcl global_instance_count fixed bin init (0); dcl value_idx fixed bin init (0); dcl arg_idx fixed bin; dcl nargs fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin; dcl force_interpretation_as_non_control_argument bit (1) aligned init ("0"b); dcl control_argument_ptr ptr; dcl arg_info_ptr ptr; dcl name_array_idx fixed bin; dcl active_string char (4096) varying; dcl active_explanation char(4096) varying; dcl result char (5) varying; dcl name_array_count fixed bin init (0); dcl 1 name_array (200), 2 name_ptr ptr, 2 def_ptr ptr, 2 antonym bit (1) aligned; dcl 1 value (100), 2 arg_name_ptr ptr, 2 arg_name_len fixed bin, 2 arg_ptr ptr, 2 arg_len fixed bin; dcl default_linear_form_string char (4096) varying init (""); dcl command_name_str char(86) var init(""); dcl validate_result_identifier fixed bin; dcl validate_result_explanation_identifier fixed bin; dcl validate_result_list_ptr ptr; dcl validate_result_explanation_list_ptr ptr; dcl list_ptr ptr; dcl node_ptr ptr; dcl force_literal_identifier fixed bin; dcl validate_explanation_identifier fixed bin; /* Based */ dcl based_real_fix_bin_1u fixed bin (35) based unaligned; dcl name_array_name char (256) varying based (name_array (name_array_idx).name_ptr); dcl active_string_length fixed bin (21) based (addr (active_string)); dcl active_explanation_length fixed bin(21) based(addr(active_explanation)); dcl active_string_nonvarying char (4096) based (addwordno (addr (active_string), 1)); dcl active_explanation_nonvarying char(4096) based(addwordno(addr(active_explanation), 1)); dcl implied_control_argument_name char (implied_control_argument_name_length) varying based (implied_control_argument_name_ptr); dcl first_argument_name char (first_argument_name_len) based (first_argument_name_ptr); dcl arg char (arg_len) based (arg_ptr); dcl arg_char_array (arg_len) char (1) based (arg_ptr); dcl 1 control_argument based (control_argument_ptr), 2 next ptr, 2 previous ptr, 2 excluded_option_chain pointer, 2 control_argument_name_ptr ptr, 2 control_argument_name_length fixed bin, 2 first_arg_vector_idx fixed bin, 2 last_arg_vector_idx fixed bin, 2 initial_arg_vector_idx fixed bin, 2 vector_idx fixed bin, 2 instance_count fixed bin, /* how many so far this command line? */ 2 instances_required fixed bin, /* how many must we have? */ 2 flags unaligned, 3 accepts_explicit_argument bit (1), 3 antonym bit (1), 3 pad bit (34); dcl control_argument_name char (control_argument.control_argument_name_length) based (control_argument.control_argument_name_ptr); dcl 1 arg_info based (arg_info_ptr), 2 arg_name_ptr ptr, 2 arg_name_len fixed bin, 2 explanation_ptr ptr, 2 validation_string_ptr ptr, 2 validation_string_length fixed bin, 2 validate_explanation_ptr ptr, 2 arg_def_vector_idx fixed bin, 2 number_of_required_occurences fixed bin, 2 default_argument_value_ptr pointer, 2 default_argument_value_len fixed bin, 2 flags unaligned, 3 got_explicit_value bit(1), 3 force_literal bit(1), 3 pad bit(34); dcl arg_name char (arg_info.arg_name_len) based (arg_info.arg_name_ptr); dcl arg_explanation char (sys_info$max_seg_size) varying based (arg_info.explanation_ptr); dcl validation_string char (arg_info.validation_string_length) based (arg_info.validation_string_ptr); dcl validate_explanation char(sys_info$max_seg_size) var based(arg_info.validate_explanation_ptr); dcl 1 excluded_option aligned based, 2 next_excluded_option pointer, 2 option_name_length fixed bin, 2 option_name char (excluded_option_name_length refer (excluded_option.option_name_length)); dcl excluded_option_name_length fixed bin; dcl work_area area (sys_info$max_seg_size) based (p_work_area_ptr); dcl 1 validate_result_list like list based(validate_result_list_ptr); dcl 1 validate_result_explanation_list like list based(validate_result_explanation_list_ptr); dcl 1 list based(list_ptr), 2 head_ptr ptr, 2 tail_ptr ptr; dcl 1 node based(node_ptr), 2 str_len fixed bin(21), 2 str_ptr ptr, 2 next_ptr ptr; /* Builtin */ dcl (addr, addcharno, addwordno, after, index, length, null, reverse, rtrim, substr, unspec) builtin; /* Condition */ dcl active_function_error condition; dcl cleanup condition; dcl stringrange condition; /* Constant */ dcl MY_NAME init ("pa_process_arguments") char (20) static options (constant); dcl ( NO_MODE init (1), PROMPT_MODE init (2), MENU_MODE init (3), NUMBER_OF_NON_ARGUMENT_DIMENSIONS init (4), SLOT_INCREASE_FACTOR init (25), RETRY_LIMIT init (10) ) fixed bin internal static options (constant); dcl PROCESS_ARGUMENTS_SEARCH_LIST_NAME init ("process_arguments") char (17) internal static options (constant); dcl ( COMMAND_NAME_DIM_NAME init ("command name"), DEFAULT_LINEAR_FORM_DIM_NAME init ("default linear form"), CONTROL_ARGUMENT_NAME_DIM_NAME init ("option"), SYNONYM_DIM_NAME init ("synonym"), ANTONYM_DIM_NAME init ("negative form"), EXCLUDED_OPTION_DIM_NAME init ("excluded option"), IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME init ("initial implied option"), NEXT_IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME init ("next implied option"), ARGUMENT_NAME_DIM_NAME init ("argument"), INITIAL_ARGUMENT_NAME_DIM_NAME init ("initial argument"), NEXT_ARGUMENT_NAME_DIM_NAME init ("next argument"), DEFAULT_ARGUMENT_VALUE_DIM_NAME init ("default value"), NEGATIVE_VALUE_DIM_NAME init ("negative value"), ARGUMENT_VALIDATION_STRING_DIM_NAME init ("validation string"), EXPLANATION_DIM_NAME init ("explanation"), ARGUMENT_PRESENCE_DIM_NAME init ("presence required"), INSTANCE_DIM_NAME init ("instance"), RESULT_ORDER_DIM_NAME init ("order"), VALIDATE_RESULT_DIM_NAME init("validate result"), VALIDATE_RESULT_EXPLANATION_DIM_NAME init("validate result explanation"), VALIDATE_EXPLANATION_DIM_NAME init("validate explanation"), FORCE_LITERAL_DIM_NAME init("force literal") ) char (64) varying internal static options (constant); dcl NO_ARGUMENT init ("NONE") char (32) varying internal static options (constant); dcl LEFT_BOUND_STR init("&(") char(2) int static options(constant); dcl RIGHT_BOUND_STR init(")") char(1) int static options(constant); dcl ARG_PROC_MSG init("(argument processing)") char(21) int static options(constant); dcl ( CONTROL_ARGUMENT_NAME_DIM_IDX init(1), INSTANCE_DIM_IDX init(2), COMMAND_NAME_DIM_IDX init(3), RESULT_ORDER_DIM_IDX init(4) ) fixed bin int static options(constant); /* Entry */ dcl process_arguments_$argument_string entry (char (*), fixed bin, char (*) var, ptr, ptr, ptr, fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl sub_err_ entry () options (variable); dcl com_err_ entry () options (variable); dcl ioa_ entry () options (variable); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl process_arguments_$get_definition entry (char (*) var, ptr, ptr, fixed bin (35)); dcl process_arguments_$get_default_linear_form entry (char (*) var, char (*) var, fixed bin (35)); dcl process_arguments_$get_option_value entry options(variable); dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)); dcl find_condition_frame_ entry (ptr) returns(ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl define_area_ entry (ptr, fixed bin(35)); dcl release_area_ entry (ptr); /* External */ dcl error_table_$asynch_change fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl vd_error_$dimension_already_defined fixed bin (35) ext; dcl vd_error_$no_vector fixed bin (35) ext; dcl error_table_$fatal_error fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$smallarg fixed bin(35) ext static; dcl error_table_$unimplemented_version fixed bin(35) ext static; /* END OF DECLARATIONS */ argument_array: entry (p_command_name, p_arg_processing_mode, p_arg_array, p_definition_print_vector_array_ptr, p_work_area_ptr, p_result_print_vector_array_ptr, p_code); call CONVERT_ARGUMENT_ARRAY_TO_LIST (p_arg_array, p_work_area_ptr, arg_list_ptr); first_arg_idx = 1; goto JOIN; argument_string: entry (p_command_name, p_arg_processing_mode, p_arg_string, p_definition_print_vector_array_ptr, p_work_area_ptr, p_result_print_vector_array_ptr, p_code); call CONVERT_ARGUMENT_STRING_TO_LIST (p_arg_string, p_work_area_ptr, arg_list_ptr); first_arg_idx = 1; goto JOIN; argument_list: entry (p_command_name, p_arg_processing_mode, p_arg_list_ptr, p_first_arg_idx, p_definition_print_vector_array_ptr, p_work_area_ptr, p_result_print_vector_array_ptr, p_code); arg_list_ptr = p_arg_list_ptr; first_arg_idx = p_first_arg_idx; %page; JOIN: command_name_str = rtrim(p_command_name) || " " || ARG_PROC_MSG; p_result_print_vector_array_ptr = null; if p_definition_print_vector_array_ptr = null then do; call process_arguments_$get_definition ((p_command_name), p_work_area_ptr, p_definition_print_vector_array_ptr, p_code); if p_code ^= 0 then do; call REPORT_MISSING_DEFINITION(p_code); return; end; end; call process_arguments_$get_default_linear_form ((p_command_name), default_linear_form_string, p_code); if p_code ^= 0 | default_linear_form_string = "" then do; if (p_code = vd_error_$no_vector | default_linear_form_string = "") & arg_list_ptr = null then do; p_code = vd_error_$no_vector; /* Make sure nonzero p_code is returned. */ call com_err_((0), (command_name_str), "There is no default linear form."); return; end; else if p_code = vd_error_$no_vector then p_code = 0; else if p_code ^= 0 then do; call com_err_(p_code, (command_name_str), "Unable to get the default linear form for ""^a"".", p_command_name); return; end; end; call SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST; alloc arg_info in (work_area); print_vector_array_ptr = null; if p_result_print_vector_array_ptr = null then do; result_control_argument_name_identifier = 1; result_command_name_identifier = 2; result_instance_identifier = 3; result_order_identifier = 4; call vector_util_$init_print_vector_array (p_work_area_ptr, SLOT_INCREASE_FACTOR, CONTROL_ARGUMENT_NAME_DIM_NAME, COMMAND_NAME_DIM_NAME, INSTANCE_DIM_NAME, RESULT_ORDER_DIM_NAME, p_result_print_vector_array_ptr, p_code); if p_code ^= 0 then return; end; else call SET_RESULT_IDS; p_result_print_vector_array_ptr -> print_vector_array.dimension_table (result_command_name_identifier).maximum_value_length = length (p_command_name); if default_linear_form_string ^= "" then do; call cu_$evaluate_active_string (null (), "do " || requote_string_ ((default_linear_form_string)), NORMAL_ACTIVE_STRING, default_linear_form_string, p_code); if p_code ^= 0 then return; call CONVERT_ARGUMENT_STRING_TO_LIST (default_linear_form_string, p_work_area_ptr, default_arg_list_ptr); call PROCESS_ARGUMENT_LIST (default_arg_list_ptr, 1, p_code); if p_code ^= 0 then return; end; if arg_list_ptr ^= null then call PROCESS_ARGUMENT_LIST (arg_list_ptr, first_arg_idx, p_code); if p_code ^= 0 then return; /* Now compress the print vector array, removing entries that we nulled out earlier. */ do vector_idx = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors; if p_result_print_vector_array_ptr -> print_vector_array.vector_slot (vector_idx) = null () then do; /* copy the remaining vectors down one slot */ p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors = p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors - 1; do temp_idx = vector_idx to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors; p_result_print_vector_array_ptr -> print_vector_array.vector_slot (temp_idx) = p_result_print_vector_array_ptr -> print_vector_array.vector_slot (temp_idx + 1); end; /* make sure to check the same slot again */ vector_idx = vector_idx - 1; end; end; call VALIDATE_RESULTS(p_code); return; /* Effective end of process_arguments. */ %page; SET_IDS: proc; call SET_ID (SYNONYM_DIM_NAME, synonym_identifier); call SET_ID (ANTONYM_DIM_NAME, antonym_identifier); call SET_ID (EXCLUDED_OPTION_DIM_NAME, excluded_option_identifier); call SET_ID (IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME, implied_control_argument_name_identifier); call SET_ID (EXPLANATION_DIM_NAME, explanation_identifier); call SET_ID (CONTROL_ARGUMENT_NAME_DIM_NAME, control_argument_name_identifier); call SET_ID (ARGUMENT_NAME_DIM_NAME, argument_name_identifier); call SET_ID (INITIAL_ARGUMENT_NAME_DIM_NAME, initial_argument_name_identifier); call SET_ID (NEXT_ARGUMENT_NAME_DIM_NAME, next_argument_name_identifier); call SET_ID (DEFAULT_ARGUMENT_VALUE_DIM_NAME, default_argument_value_identifier); call SET_ID (NEGATIVE_VALUE_DIM_NAME, negative_default_argument_value_identifier); call SET_ID (NEXT_IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME, next_implied_control_argument_name_identifier); call SET_ID (ARGUMENT_PRESENCE_DIM_NAME, argument_presence_identifier); call SET_ID (ARGUMENT_VALIDATION_STRING_DIM_NAME, validation_string_identifier); call SET_ID (VALIDATE_RESULT_DIM_NAME, validate_result_identifier); call SET_ID (VALIDATE_RESULT_EXPLANATION_DIM_NAME, validate_result_explanation_identifier); call SET_ID (FORCE_LITERAL_DIM_NAME, force_literal_identifier); call SET_ID (VALIDATE_EXPLANATION_DIM_NAME, validate_explanation_identifier); end SET_IDS; %skip; SET_ID: proc (p_dim_name, p_identifier); dcl p_dim_name char (*) varying; dcl p_identifier fixed bin; do p_identifier = 1 to p_definition_print_vector_array_ptr -> print_vector_array.number_of_dimensions while (p_definition_print_vector_array_ptr -> print_vector_array.dimension_table (p_identifier).name ^= p_dim_name); end; if p_identifier > p_definition_print_vector_array_ptr -> print_vector_array.number_of_dimensions then p_identifier = -1; end SET_ID; %page; SET_RESULT_IDS: proc; call SET_RESULT_ID (COMMAND_NAME_DIM_NAME, result_command_name_identifier); call SET_RESULT_ID (RESULT_ORDER_DIM_NAME, result_order_identifier); call SET_RESULT_ID (INSTANCE_DIM_NAME, result_instance_identifier); call SET_RESULT_ID (CONTROL_ARGUMENT_NAME_DIM_NAME, result_control_argument_name_identifier); end SET_RESULT_IDS; %skip; SET_RESULT_ID: proc (p_dimension_name, p_identifier); dcl p_dimension_name char (*) varying; dcl p_identifier fixed bin; do p_identifier = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_dimensions while (p_result_print_vector_array_ptr -> print_vector_array.dimension_table (p_identifier).name ^= p_dimension_name); end; if p_identifier > p_result_print_vector_array_ptr -> print_vector_array.number_of_dimensions then p_identifier = -1; end SET_RESULT_ID; %page; SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST: proc; dcl dim_idx fixed bin; dcl temp_ptr pointer; call SET_IDS; print_vector_ptr = null; control_argument_ptr = null; control_argument_name_dim_id = -1; implied_control_argument_name_ptr = null; implied_control_argument_ptr = null; exists_implied_control_argument = "0"b; validate_result_list_ptr = null; validate_result_explanation_list_ptr = null; do vector_idx = 1 to p_definition_print_vector_array_ptr -> print_vector_array.number_of_vectors; old_control_argument_name_dim_id = control_argument_name_dim_id; old_print_vector_ptr = print_vector_ptr; call SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID (vector_idx, print_vector_ptr, control_argument_name_dim_id); if control_argument_name_dim_id = -1 then call SETUP_IMPLIED_CONTROL_ARGUMENT; else do; if control_argument_ptr = null then call SETUP_NEW_CONTROL_ARGUMENT; /* check to see if we have finished the definition of the option we were just working on */ else if print_vector.dimension (control_argument_name_dim_id).value ^= old_print_vector_ptr -> print_vector.dimension (old_control_argument_name_dim_id).value then do; call CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION; call SETUP_NEW_CONTROL_ARGUMENT; end; /* see if this is the initial implied option */ if vector_idx = control_argument.vector_idx then if implied_control_argument_name_ptr ^= null then if control_argument_name = implied_control_argument_name then do; implied_control_argument_ptr = control_argument_ptr; exists_implied_control_argument = "1"b; end; /* Now check for other dimensions in the vector that define other attributes of the option */ call GET_DIM_IDX (print_vector_ptr, argument_name_identifier, dim_idx); if dim_idx > 0 then do; if print_vector_ptr -> print_vector.dimension (dim_idx).value = first_argument_name then control_argument.initial_arg_vector_idx = vector_idx; if control_argument.first_arg_vector_idx = 0 then do; control_argument.first_arg_vector_idx = vector_idx; control_argument.last_arg_vector_idx = vector_idx; end; end; /* See if there is an excluded option dimension */ call GET_DIM_IDX (print_vector_ptr, excluded_option_identifier, dim_idx); if dim_idx > 0 then do; excluded_option_name_length = length (print_vector_ptr -> print_vector.dimension (dim_idx).value); allocate excluded_option in(work_area) set (temp_ptr); temp_ptr -> excluded_option.option_name = print_vector_ptr -> print_vector.dimension (dim_idx).value; temp_ptr -> excluded_option.next_excluded_option = control_argument.excluded_option_chain; control_argument.excluded_option_chain = temp_ptr; end; /* see if the vector defines a synonym for the option */ call ADD_SYNONYM; end; call SETUP_RESULT_VALIDATION_INFO(print_vector_ptr, validate_result_list_ptr, validate_result_explanation_list_ptr); end; /* We have run out of vectors, close out the last option definition */ call CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION; end SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST; %page; ADD_SYNONYM: proc; dcl dim_idx fixed bin; call GET_DIM_IDX (print_vector_ptr, synonym_identifier, dim_idx); if dim_idx = -1 then return; name_array_count = name_array_count + 1; name_array (name_array_count).name_ptr = addr (print_vector.dimension (dim_idx).value); name_array (name_array_count).def_ptr = control_argument_ptr; /* See if this synonym is really an antonym. Will be used for filling in the default value later. */ call GET_DIM_IDX (print_vector_ptr, antonym_identifier, dim_idx); name_array (name_array_count).antonym = (dim_idx ^= -1); end ADD_SYNONYM; %page; SETUP_NEW_CONTROL_ARGUMENT: proc (); old_control_argument_ptr = control_argument_ptr; alloc control_argument in (work_area); control_argument.next = null; control_argument.previous = old_control_argument_ptr; if old_control_argument_ptr = null then root_control_argument_ptr = control_argument_ptr; else old_control_argument_ptr -> control_argument.next = control_argument_ptr; /* relies on vector_idx being set by caller, presumably while looping through all the vectors */ control_argument.vector_idx = vector_idx; control_argument.control_argument_name_ptr = addrel (addr (print_vector.dimension (control_argument_name_dim_id).value), 1); control_argument.control_argument_name_length = length (print_vector.dimension (control_argument_name_dim_id).value); control_argument.excluded_option_chain = null (); control_argument.initial_arg_vector_idx = 0; control_argument.first_arg_vector_idx = 0; control_argument.last_arg_vector_idx = 0; control_argument.accepts_explicit_argument = "0"b; /* Get the name of the initial arg for this option. If there is no such dimension, the option doesn't accept command line arguments. However, it may still have one argument whose value will be filled in from the default. This is how -long/-brief style flags work. */ call GET_DIM_IDX (print_vector_ptr, initial_argument_name_identifier, dim_idx); if dim_idx ^= -1 then do; first_argument_name_ptr = addrel (addr (print_vector_ptr -> print_vector.dimension (dim_idx).value), 1); first_argument_name_len = length (print_vector_ptr -> print_vector.dimension (dim_idx).value); control_argument.accepts_explicit_argument = "1"b; end; else do; first_argument_name_ptr = addr (NO_ARGUMENT); first_argument_name_len = length (NO_ARGUMENT); control_argument.accepts_explicit_argument = "0"b; end; /* at this point we should find the option_presence dimension a gets its value, but it isn7t in the DB yet. */ control_argument.instance_count = 0; /* this field isn't examined yet */ control_argument.instances_required = 1; end SETUP_NEW_CONTROL_ARGUMENT; CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION: procedure; if control_argument_ptr = null () then return; control_argument.last_arg_vector_idx = vector_idx - 1; if ^control_argument.accepts_explicit_argument /* the option doesn't accept explicit args, but we still have to set the initial arg idx so defaults work later */ then control_argument.initial_arg_vector_idx = control_argument.first_arg_vector_idx; /* if no argument matched the name of the first argument for this option (as specified in the definition for this command), then signal an error. */ else if (control_argument.initial_arg_vector_idx = 0) then call sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0, "First argument of ""^a"" specified for option ""^a"" of command ""^a"" is not defined.", first_argument_name, control_argument_name); end CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION; %page; SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID: proc (p_vector_idx, p_print_vector_ptr, p_control_argument_name_dim_id); dcl p_vector_idx fixed bin; dcl p_print_vector_ptr ptr; dcl p_control_argument_name_dim_id fixed bin; p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx); call GET_DIM_IDX (p_print_vector_ptr, control_argument_name_identifier, p_control_argument_name_dim_id); end SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID; %page; SETUP_IMPLIED_CONTROL_ARGUMENT: proc; dcl dim_idx fixed bin; call GET_DIM_IDX (print_vector_ptr, implied_control_argument_name_identifier, dim_idx); if dim_idx = -1 then return; implied_control_argument_name_ptr = addr (print_vector.dimension (dim_idx).value); implied_control_argument_name_length = length (print_vector.dimension (dim_idx).value); end SETUP_IMPLIED_CONTROL_ARGUMENT; %page; PROCESS_ARGUMENT_LIST: proc (pal_p_arg_list_ptr, pal_p_first_arg_idx, pal_p_code); dcl pal_p_arg_list_ptr ptr parameter; dcl pal_p_first_arg_idx fixed bin parameter; dcl pal_p_code fixed bin (35) parameter; nargs = pal_p_arg_list_ptr -> arg_list.header.arg_count - pal_p_first_arg_idx + 1; last_arg_idx_processed = pal_p_first_arg_idx - 1; force_interpretation_as_non_control_argument = "0"b; value_idx = 0; max_value_arg_len = 0; unspec(arg_info) = "0"b; control_argument_is_in_effect = "0"b; using_implicit_control_argument = "0"b; option_accepts_explicit_argument = "0"b; control_argument_ptr = null; ARG_LOOP: do arg_idx = pal_p_first_arg_idx to pal_p_arg_list_ptr -> arg_list.header.arg_count; arg_ptr = pal_p_arg_list_ptr -> arg_list.arg_ptrs (arg_idx); call decode_descriptor_ (pal_p_arg_list_ptr -> arg_list.desc_ptrs (arg_idx), 0, 0, "0"b, 0, arg_len, 0); force_interpretation_as_non_control_argument = (force_interpretation_as_non_control_argument | (arg_info.force_literal & control_argument_is_in_effect)); /* if arg = "-quote" & ^force_interpretation_as_non_control_argument then do; last_arg_idx_processed = arg_idx; force_interpretation_as_non_control_argument = "1"b; end; /* Now for the non-option cases. else */ if index (arg, "-") ^= 1 | force_interpretation_as_non_control_argument then do; /* if there is no explicit option in effect, try the current implied option */ force_interpretation_as_non_control_argument = "0"b; if ^control_argument_is_in_effect then if exists_implied_control_argument then do; /* If we already processed the previous token, don't do it again. */ if last_arg_idx_processed < (arg_idx - 1) then call CLOSE_OUT_OPTION; control_argument_ptr = implied_control_argument_ptr; call SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr); /* if this option doesn't accept an argument, the current token is bogus */ if ^option_accepts_explicit_argument then call sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0, "Error in definition. Implied option ^a doesn't accept arguments.", control_argument_name); control_argument_is_in_effect, using_implicit_control_argument = "1"b; end; if arg = "?" then do; last_arg_idx_processed = arg_idx; call PRINT_EXPLANATION; end; /* OK, the token is an argument to an option. */ else do; call PROCESS_ARGUMENT (pal_p_code); if pal_p_code = error_table_$bad_arg then do; call PRINT_VALIDATION_EXPLANATION(); return; end; else if pal_p_code ^= 0 then return; end; end; else if MISPLACED_CONTROL_ARGUMENT () then do; pal_p_code = error_table_$noarg; call com_err_ (pal_p_code, (command_name_str), "^/Encountered option ^a instead of the ^a argument to option ^a.", requote_string_ (arg), requote_string_ (arg_name), requote_string_ (control_argument_name)); return; end; /* The token is an option */ else CONTROL_ARGUMENT: do; /* If we already processed the previous token, don't do it again. */ if last_arg_idx_processed < (arg_idx - 1) then call CLOSE_OUT_OPTION; using_implicit_control_argument = "0"b; /* See if the token matches any known option name */ do name_array_idx = 1 to name_array_count while (arg ^= name_array_name); end; if name_array_idx > name_array_count then do; call REPORT_UNRECOGNIZED_CONTROL_ARGUMENT (); return; end; control_argument_ptr = name_array (name_array_idx).def_ptr; /* depending on which name (e.g. -foo vs. -no_foo) was used to find this option, set the antonym flag */ control_argument.antonym = name_array (name_array_idx).antonym; /* fill in arg_info structure for the option's first arg */ call SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr); /* if the option has args, future tokens should be interpreted as "belonging" to this option, so we say the option is still in effect. If the option has no args, future tokens are unrelated to the option. */ control_argument_is_in_effect = option_accepts_explicit_argument; if ^control_argument_is_in_effect then call CLOSE_OUT_OPTION; end CONTROL_ARGUMENT; end ARG_LOOP; /* The loop above increments the arg_idx to one past the last argument. Set it back for comparison purposes. */ arg_idx = arg_idx - 1; /* No more command line arguments. Check to see if any more were required. */ if using_implicit_control_argument then do; /* if the pending option is implicit we don't care if there is no associated argument as long as we have seen at least one instance of the option before, e.g. "copy foo bar" is OK even though there is a pending implicit -source_pathname option with a required argument */ if control_argument.instance_count = 0 then do; call SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr); if ^option_accepts_explicit_argument then call sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0, "Error in definition. Implied option ^a doesn't accept arguments.", control_argument_name); if (arg_info.number_of_required_occurences > 0) then do; pal_p_code = error_table_$noarg; call REPORT_MISSING_ARGUMENT (); return; end; end; end; /* if the option was explicit, then honor the required flag */ else if control_argument_is_in_effect then if (arg_info.number_of_required_occurences > 0) then do; pal_p_code = error_table_$noarg; call REPORT_MISSING_ARGUMENT (); return; end; /* Close out the last token if it hasn't been processed yet */ if last_arg_idx_processed < arg_idx then call CLOSE_OUT_OPTION; end PROCESS_ARGUMENT_LIST; %page; PROCESS_ARGUMENT: proc (p_code); dcl p_code fixed bin (35) parameter; dcl temp_value_idx fixed bin; if ^control_argument_is_in_effect then do; p_code = error_table_$bad_arg; call com_err_ (p_code, (command_name_str), "^/Argument ^a can not be matched with any option.", arg); return; end; /* Validate the argument value if possible */ if arg_info.validation_string_ptr ^= null () then do; /* Get a temp for the requoted string */ call ioa_$rsnnl ("do ^a ^a", active_string_nonvarying, active_string_length, requote_string_ ("[" || validation_string || "]"), requote_string_ (arg)); on active_function_error begin; goto validation_error_return; end; call cu_$evaluate_active_string (null (), (active_string), NORMAL_ACTIVE_STRING, result, p_code); if p_code ^= 0 then return; revert active_function_error; if result ^= "true" then do; validation_error_return: p_code = error_table_$bad_arg; call com_err_ (p_code, (command_name_str), "^/Invalid argument ^a for option ^a", requote_string_ (arg), requote_string_ (control_argument_name)); return; end; end; value_idx = value_idx + 1; value (value_idx).arg_name_ptr = arg_info.arg_name_ptr; value (value_idx).arg_name_len = arg_info.arg_name_len; value (value_idx).arg_ptr = arg_ptr; value (value_idx).arg_len = arg_len; max_value_arg_len = max (max_value_arg_len, arg_len); call SETUP_NEXT_ARG_INFO (control_argument_ptr, arg_exists, arg_info_ptr); control_argument_is_in_effect = arg_exists; if ^control_argument_is_in_effect then call CLOSE_OUT_OPTION; else do; do temp_value_idx = 1 to value_idx while (arg_info.arg_name_ptr ^= value (temp_value_idx).arg_name_ptr); end; if temp_value_idx <= value_idx then /* Only one occurence of each named argument can be present per "result" vector. */ call ADD_VALUE_TO_RESULT; end; end PROCESS_ARGUMENT; %page; GET_NEXT_IMPLIED_CONTROL_ARGUMENT: proc; print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (control_argument.vector_idx); call GET_DIM_IDX (print_vector_ptr, next_implied_control_argument_name_identifier, dim_idx); if dim_idx = -1 then return; else do; implied_control_argument_name_ptr = addr (print_vector.dimension (dim_idx).value); implied_control_argument_name_length = length (print_vector.dimension (dim_idx).value); do control_argument_ptr = root_control_argument_ptr repeat (control_argument.next) while (control_argument.next ^= null & control_argument_name ^= implied_control_argument_name); end; if control_argument_name = implied_control_argument_name then do; exists_implied_control_argument = "1"b; implied_control_argument_ptr = control_argument_ptr; end; else do; exists_implied_control_argument = "0"b; implied_control_argument_ptr = null; end; end; end GET_NEXT_IMPLIED_CONTROL_ARGUMENT; %page; /* Internal routine to close out the current option. This is called when we run out of arguments for a particular option (either by getting all the arguments we expect or encountering the next option), or when there are no more tokens on the command line. */ CLOSE_OUT_OPTION: procedure; if control_argument_ptr = null () then return; /* If no explicit value was specified for the argument to this option then see if there was a default argument value in the definition. */ if ^arg_info.got_explicit_value then if arg_info.default_argument_value_ptr ^= null () then do; value_idx = value_idx + 1; value (value_idx).arg_name_ptr = arg_info.arg_name_ptr; value (value_idx).arg_name_len = arg_info.arg_name_len; value (value_idx).arg_ptr = arg_info.default_argument_value_ptr; value (value_idx).arg_len = arg_info.default_argument_value_len; max_value_arg_len = max (max_value_arg_len, value (value_idx).arg_len); end; call ADD_VALUE_TO_RESULT; /* If the option that we just processed is the same as the current implied option, move on to the next implied option */ if exists_implied_control_argument then if control_argument_name = implied_control_argument_name then call GET_NEXT_IMPLIED_CONTROL_ARGUMENT; return; end CLOSE_OUT_OPTION; %page; /* Routine to add the vector for this option (including all argument values) to the result pva. */ ADD_VALUE_TO_RESULT: proc; dcl temp_value_idx fixed bin; dcl dim_idx fixed bin; dcl value_arg_name char (value (temp_value_idx).arg_name_len) based (value (temp_value_idx).arg_name_ptr); dcl instance_count_pic pic "999v"; dcl order_pic pic "999v"; dcl value_arg char (value (temp_value_idx).arg_len) based (value (temp_value_idx).arg_ptr); last_arg_idx_processed = arg_idx; call vector_util_$append_general_print_vector (p_work_area_ptr, SLOT_INCREASE_FACTOR, "1"b, (-1), value_idx + 4, max (length (control_argument_name), length (p_command_name), max_value_arg_len), p_result_print_vector_array_ptr, p_code); if p_code ^= 0 then do; call sub_err_ (p_code, p_command_name, "h", null, 0, "^/Unable to add the result vector for the ""^a"" control argument (and associated arguments) ending with argument number ^d.", control_argument_name, arg_idx); return; end; print_vector_ptr = p_result_print_vector_array_ptr -> print_vector_array.vector_slot (p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors); /* Fill in all the non-argument-value dimensions */ print_vector.dimension (INSTANCE_DIM_IDX).identifier = result_instance_identifier; instance_count_pic = global_instance_count; print_vector.dimension (INSTANCE_DIM_IDX).value = instance_count_pic; global_instance_count = global_instance_count + 1; print_vector.dimension (CONTROL_ARGUMENT_NAME_DIM_IDX).identifier = result_control_argument_name_identifier; print_vector.dimension (CONTROL_ARGUMENT_NAME_DIM_IDX).value = control_argument_name; /* now set the maximum option name length. */ p_result_print_vector_array_ptr -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length = max (p_result_print_vector_array_ptr -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length, length (control_argument_name)); p_result_print_vector_array_ptr -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length = max (p_result_print_vector_array_ptr -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length, length (control_argument_name)); print_vector.dimension (COMMAND_NAME_DIM_IDX).identifier = result_command_name_identifier; print_vector.dimension (COMMAND_NAME_DIM_IDX).value = p_command_name; print_vector.dimension (RESULT_ORDER_DIM_IDX).identifier = result_order_identifier; order_pic = p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors; print_vector.dimension (RESULT_ORDER_DIM_IDX).value = order_pic; /* Now fill in all the arguments */ do temp_value_idx = 1 to value_idx; /* skip over those dims that we already filled in */ dim_idx = temp_value_idx + NUMBER_OF_NON_ARGUMENT_DIMENSIONS; call vector_util_$append_dimension_print (p_work_area_ptr, "0"b, value_arg_name, null, p_result_print_vector_array_ptr, print_vector.dimension (dim_idx).identifier, p_code); if p_code ^= 0 then if p_code = vd_error_$dimension_already_defined then p_code = 0; else return; print_vector.dimension (dim_idx).value = value_arg; /* keep track of longest dimension id */ p_result_print_vector_array_ptr -> print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length = max (p_result_print_vector_array_ptr -> print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length, length (value_arg)); end; max_value_arg_len = 0; value_idx = 0; end ADD_VALUE_TO_RESULT; %page; /* Routine to set up state information for a an option that has just been encountered on the command line. */ SETUP_FIRST_ARG_INFO: proc (p_control_argument_ptr, p_option_accepts_explicit_argument, p_arg_info_ptr); dcl p_control_argument_ptr ptr; dcl p_option_accepts_explicit_argument bit (1) aligned; dcl p_arg_info_ptr ptr; dcl 1 p_arg_info like arg_info based (p_arg_info_ptr); dcl idx fixed bin; dcl (temp_print_vector_ptr, temp_excluded_option_ptr) pointer; /* First remove any vectors belonging to options that are excluded by the current option */ do idx = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors; temp_print_vector_ptr = p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx); /* loop through the chain of excluded options, checking the option names against the option that owns the current vector */ do temp_excluded_option_ptr = (p_control_argument_ptr -> control_argument.excluded_option_chain) repeat (temp_excluded_option_ptr -> excluded_option.next_excluded_option) while ((temp_excluded_option_ptr ^= null ()) & (p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx) ^= null ())); /* If this vector belongs to an excluded option, free it */ if temp_print_vector_ptr -> print_vector.dimension (1).value = temp_excluded_option_ptr -> excluded_option.option_name then do; free temp_print_vector_ptr -> print_vector; p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx) = null (); end; end; end; p_arg_info.arg_def_vector_idx = 0; /* Keep track of how many times we see each control argument */ p_control_argument_ptr -> control_argument.instance_count = p_control_argument_ptr -> control_argument.instance_count + 1; p_arg_info.force_literal = "0"b; call SETUP_NEXT_ARG_INFO (p_control_argument_ptr, p_option_accepts_explicit_argument, p_arg_info_ptr); p_option_accepts_explicit_argument = p_control_argument_ptr -> control_argument.accepts_explicit_argument; end SETUP_FIRST_ARG_INFO; SETUP_NEXT_ARG_INFO: proc (p_control_argument_ptr, p_arg_exists, p_arg_info_ptr); dcl p_control_argument_ptr ptr; dcl p_arg_exists bit (1) aligned; dcl p_arg_info_ptr ptr; dcl 1 p_arg_info like arg_info based (p_arg_info_ptr); dcl p_arg_name char (p_arg_info.arg_name_len) based (p_arg_info.arg_name_ptr); dcl local_print_vector_ptr ptr; dcl temp_dimension_identifier fixed bin; dcl dim_idx fixed bin; dcl p_control_argument_name char (p_control_argument_ptr -> control_argument.control_argument_name_length) based (p_control_argument_ptr -> control_argument.control_argument_name_ptr); if p_arg_info.arg_def_vector_idx ^= 0 then call FIND_NEXT_ARG (p_arg_info.arg_def_vector_idx, local_print_vector_ptr, dim_idx); else if p_control_argument_ptr -> control_argument.initial_arg_vector_idx = 0 then do; arg_exists = "0"b; return; end; else do; p_arg_info.arg_def_vector_idx = p_control_argument_ptr -> control_argument.initial_arg_vector_idx; call SETUP_VECTOR_AND_ARG_NAME_DIM_IDX (p_arg_info.arg_def_vector_idx, local_print_vector_ptr, dim_idx); end; if dim_idx = -1 then do; p_arg_exists = "0"b; return; end; p_arg_exists = "1"b; if local_print_vector_ptr = null then do; if p_arg_info.number_of_required_occurences > 0 then p_arg_info.number_of_required_occurences = p_arg_info.number_of_required_occurences - 1; return; end; /* Fill in arg_info structure with data for this argument. */ p_arg_info.arg_name_ptr = addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1); p_arg_info.arg_name_len = length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value); call GET_DIM_IDX (local_print_vector_ptr, validation_string_identifier, dim_idx); if dim_idx > 0 then do; p_arg_info.validation_string_ptr = addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1); p_arg_info.validation_string_length = length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value); end; else p_arg_info.validation_string_ptr = null (); call GET_DIM_IDX(local_print_vector_ptr, validate_explanation_identifier, dim_idx); if dim_idx > 0 then p_arg_info.validate_explanation_ptr = addr(local_print_vector_ptr->print_vector.dimension(dim_idx).value); else p_arg_info.validate_explanation_ptr = null; call GET_DIM_IDX (local_print_vector_ptr, explanation_identifier, dim_idx); if dim_idx > 0 then p_arg_info.explanation_ptr = addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value); else p_arg_info.explanation_ptr = null; call GET_DIM_IDX (local_print_vector_ptr, argument_presence_identifier, dim_idx); /* If there is such a dim, the arg is required. Later we may want a count of the number of required occurences, but for now it is yes or no. */ if dim_idx = -1 then p_arg_info.number_of_required_occurences = 0; else p_arg_info.number_of_required_occurences = 1; /* If the option was -no_foo, get the negative default value for the argument, otherwise get the regular default */ if control_argument.antonym then temp_dimension_identifier = negative_default_argument_value_identifier; else temp_dimension_identifier = default_argument_value_identifier; /* Now try to find the default value for this argument. */ call GET_DIM_IDX (local_print_vector_ptr, temp_dimension_identifier, dim_idx); if dim_idx = -1 then p_arg_info.default_argument_value_ptr = null (); else do; p_arg_info.default_argument_value_ptr = addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1); p_arg_info.default_argument_value_len = length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value); end; call GET_DIM_IDX(local_print_vector_ptr, force_literal_identifier, dim_idx); p_arg_info.force_literal = (dim_idx ^= -1); /* This flag is used later to determine if we have seen an explicit value for this argument on the command line. If not, use the default value*/ p_arg_info.got_explicit_value = "0"b; return; SETUP_VECTOR_AND_ARG_NAME_DIM_IDX: proc (p_vector_idx, p_print_vector_ptr, p_dim_idx); dcl p_vector_idx fixed bin; dcl p_print_vector_ptr ptr; dcl p_dim_idx fixed bin; p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx); call GET_DIM_IDX (p_print_vector_ptr, argument_name_identifier, p_dim_idx); end SETUP_VECTOR_AND_ARG_NAME_DIM_IDX; FIND_NEXT_ARG: proc (p_vector_idx, p_print_vector_ptr, p_dim_idx); dcl p_vector_idx fixed bin; dcl p_print_vector_ptr ptr; dcl p_dim_idx fixed bin; dcl next_arg_dim_idx fixed bin; dcl temp_print_vector_ptr ptr; p_dim_idx = 0; p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx); /* No next_argument dimension means use the same argument again. Returning a null pointer is a convention for this case. */ call GET_DIM_IDX (p_print_vector_ptr, next_argument_name_identifier, next_arg_dim_idx); if next_arg_dim_idx = -1 then do; p_print_vector_ptr = null; return; end; /* If the next arg is the same as this arg, use the same values */ else if p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value = p_arg_name then do; p_print_vector_ptr = null (); return; end; /* If there is no next argument at all, indicate that fact. */ else if p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value = NO_ARGUMENT then do; p_dim_idx = -1; p_print_vector_ptr = null; return; end; do p_vector_idx = p_control_argument_ptr -> control_argument.first_arg_vector_idx to p_control_argument_ptr -> control_argument.last_arg_vector_idx; call SETUP_VECTOR_AND_ARG_NAME_DIM_IDX (p_vector_idx, temp_print_vector_ptr, p_dim_idx); if p_dim_idx = -1 then call sub_err_ (error_table_$fatal_error, p_command_name, "h", null, 0, "^/Vector ^d of the definition is in the argument definition range of vectors for control argument ""^a"", but does not specify an argument name (as it must).", p_vector_idx, p_control_argument_name) ; else if temp_print_vector_ptr -> print_vector.dimension (p_dim_idx).value = p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value then do; p_print_vector_ptr = temp_print_vector_ptr; return; end; end; p_code = error_table_$fatal_error; end FIND_NEXT_ARG; end SETUP_NEXT_ARG_INFO; %page; GET_DIM_IDX: proc (p_print_vector_ptr, p_identifier, p_dim_idx); dcl p_print_vector_ptr ptr; dcl p_identifier fixed bin; dcl p_dim_idx fixed bin; do p_dim_idx = 1 to p_print_vector_ptr -> print_vector.number_of_dimensions while (p_print_vector_ptr -> print_vector.dimension (p_dim_idx).identifier ^= p_identifier); end; if p_dim_idx > p_print_vector_ptr -> print_vector.number_of_dimensions then p_dim_idx = -1; end GET_DIM_IDX; MISPLACED_CONTROL_ARGUMENT: proc () returns (bit (1) aligned); if arg_info_ptr = null then return ("0"b); else return ((arg_info.number_of_required_occurences > 0) & ^using_implicit_control_argument & control_argument_is_in_effect); end MISPLACED_CONTROL_ARGUMENT; REPORT_UNRECOGNIZED_CONTROL_ARGUMENT: proc; p_code = error_table_$badopt; call com_err_ (p_code, (command_name_str), """^a""", arg); end REPORT_UNRECOGNIZED_CONTROL_ARGUMENT; %page; REPORT_MISSING_ARGUMENT: proc; call com_err_ (error_table_$noarg, (command_name_str), "^/Expected the ""^a"" argument of the ""^a"" control argument.", arg_name, control_argument_name); end REPORT_MISSING_ARGUMENT; %page; REPORT_MISSING_DEFINITION: proc(code); dcl code fixed bin(35); call com_err_ (code, (command_name_str), "Unable to locate the argument-processing^/syntax definition for this command."); end REPORT_MISSING_DEFINITION; %page; PRINT_EXPLANATION: proc; if arg_info.explanation_ptr ^= null then call ioa_ ("Explanation for the ""^a"" argument of the ^[(implicit)^] ""^a"" option: ^a", arg_name, using_implicit_control_argument, control_argument_name, arg_explanation); else call ioa_ ("There is no explanation provided for the ""^a"" argument of the ^[(implicit)^] ""^a"" option.", arg_name, using_implicit_control_argument, control_argument_name); end PRINT_EXPLANATION; %page; PRINT_VALIDATION_EXPLANATION: proc(); /* Automatic */ dcl code fixed bin(35); if arg_info.validate_explanation_ptr ^= null then do; call MAKE_V_SUBSTITUTIONS((validate_explanation), arg_name, arg, active_explanation_nonvarying, active_explanation_length, code); if code ^= 0 then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to make substitutions in the validation explanation:^/""^a"".", validate_explanation); else call ioa_((active_explanation)); end; end PRINT_VALIDATION_EXPLANATION; %page; CONVERT_ARGUMENT_ARRAY_TO_LIST: proc (caatl_p_arg_array, caatl_p_work_area_ptr, caatl_p_arg_list_ptr); dcl caatl_p_arg_array (*) char (*) varying; dcl caatl_p_work_area_ptr ptr; dcl caatl_p_arg_list_ptr ptr; dcl caatl_al_arg_count fixed bin init (0); dcl caatl_arg_idx fixed bin init (0); dcl 1 caatl_arg_descriptor_template like arg_descriptor; dcl caatl_arg_descriptor_ptr ptr init (null); dcl caatl_work_area area based (caatl_p_work_area_ptr); dcl 1 caatl_arg_list based (caatl_p_arg_list_ptr), 2 header like arg_list.header, 2 arg_ptrs (caatl_al_arg_count refer (caatl_arg_list.header.arg_count)) ptr, 2 desc_ptrs (caatl_al_arg_count refer (caatl_arg_list.header.arg_count)) ptr; dcl 1 caatl_arg_descriptor based (caatl_arg_descriptor_ptr) like arg_descriptor; caatl_p_arg_list_ptr = null; caatl_al_arg_count = hbound (caatl_p_arg_array, 1); if caatl_al_arg_count = 1 & caatl_p_arg_array (1) = "" then return; alloc caatl_arg_list in (caatl_work_area); caatl_arg_list.header.pad1 = "0"b; caatl_arg_list.header.call_type = Interseg_call_type; caatl_arg_list.header.desc_count = caatl_al_arg_count; caatl_arg_list.header.pad2 = "0"b; caatl_arg_descriptor_template.flag = "1"b; caatl_arg_descriptor_template.type = char_dtype; caatl_arg_descriptor_template.packed = "0"b; caatl_arg_descriptor_template.number_dims = 0; caatl_arg_descriptor_template.size = 0; do caatl_arg_idx = 1 to caatl_al_arg_count; caatl_arg_list.arg_ptrs (caatl_arg_idx) = addwordno (addr (caatl_p_arg_array (caatl_arg_idx)), 1); alloc caatl_arg_descriptor in (caatl_work_area); caatl_arg_descriptor = caatl_arg_descriptor_template; caatl_arg_descriptor.size = length (caatl_p_arg_array (caatl_arg_idx)); caatl_arg_list.desc_ptrs (caatl_arg_idx) = caatl_arg_descriptor_ptr; end; end CONVERT_ARGUMENT_ARRAY_TO_LIST; %page; CONVERT_ARGUMENT_STRING_TO_LIST: proc (castl_p_arg_string, castl_p_work_area_ptr, castl_p_arg_list_ptr); dcl castl_p_arg_string char (*) varying; dcl castl_p_work_area_ptr ptr; dcl castl_p_arg_list_ptr ptr; dcl castl_al_arg_count fixed bin init (0); dcl 1 castl_arg_descriptor_template like arg_descriptor; dcl castl_arg_descriptor_ptr ptr init (null); dcl castl_arg_link_ptr ptr init (null); dcl (castl_arg_idx, castl_arg_index, castl_new_arg_index, castl_arg_length, castl_quote_index, castl_old_quote_index) fixed bin init (0); dcl (castl_root_arg_link_ptr, castl_old_arg_link_ptr) ptr init (null); dcl castl_work_area area based (castl_p_work_area_ptr); dcl 1 castl_arg_list based (castl_p_arg_list_ptr), 2 header like arg_list.header, 2 arg_ptrs (castl_al_arg_count refer (castl_arg_list.header.arg_count)) ptr, 2 desc_ptrs (castl_al_arg_count refer (castl_arg_list.header.arg_count)) ptr; dcl 1 castl_arg_descriptor based (castl_arg_descriptor_ptr) like arg_descriptor; dcl 1 castl_arg_link based (castl_arg_link_ptr), 2 next_ptr ptr, 2 arg_ptr ptr, 2 arg_length fixed bin, 2 desc_ptr ptr; dcl ( CASTL_SPACE_CHAR init (" "), CASTL_TAB_CHAR init (" "), CASTL_QUOTE_CHAR init ("""") ) char (1) internal static options (constant); castl_p_arg_list_ptr = null; if castl_p_arg_string = "" then return; castl_al_arg_count = 0; castl_arg_descriptor_template.flag = "1"b; castl_arg_descriptor_template.type = char_dtype; castl_arg_descriptor_template.packed = "0"b; castl_arg_descriptor_template.number_dims = 0; castl_arg_descriptor_template.size = 0; castl_new_arg_index = 1; castl_arg_index = 1; castl_arg_length = 0; CASTL_PARSE_LOOP: do while (castl_new_arg_index > 0); castl_new_arg_index = verify (substr (castl_p_arg_string, castl_arg_index + castl_arg_length), CASTL_SPACE_CHAR || CASTL_TAB_CHAR); if castl_new_arg_index > 0 then CASTL_HAVE_ARG: do; castl_arg_index = castl_arg_length + castl_arg_index + castl_new_arg_index - 1; castl_arg_length = search (substr (castl_p_arg_string, castl_arg_index), CASTL_SPACE_CHAR || CASTL_TAB_CHAR); if castl_arg_length = 0 then castl_arg_length = length (castl_p_arg_string) - castl_arg_index + 1; else castl_arg_length = castl_arg_length - 1; castl_quote_index = index (substr (castl_p_arg_string, castl_arg_index, castl_arg_length), CASTL_QUOTE_CHAR); castl_old_quote_index = castl_arg_index; CASTL_QUOTE_LOOP: do while (castl_quote_index > 0); castl_quote_index = castl_old_quote_index + castl_quote_index; CASTL_DOUBLE_QUOTE_LOOP: do while (substr (castl_p_arg_string, castl_quote_index, 1) = CASTL_QUOTE_CHAR); castl_old_quote_index = castl_quote_index; castl_quote_index = index (substr (castl_p_arg_string, castl_old_quote_index + 1), CASTL_QUOTE_CHAR); if castl_quote_index = 0 then call sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to process the ^a command. There is a missing quote character after character ^d, in its argument string: ^a.", requote_string_ ((p_command_name)), castl_old_quote_index, requote_string_ ((castl_p_arg_string))); castl_quote_index = castl_old_quote_index + castl_quote_index; end CASTL_DOUBLE_QUOTE_LOOP; castl_old_quote_index = castl_quote_index; castl_quote_index = index (substr (castl_p_arg_string, castl_old_quote_index), CASTL_QUOTE_CHAR); castl_arg_length = search (substr (castl_p_arg_string, castl_quote_index + castl_old_quote_index), CASTL_SPACE_CHAR || CASTL_TAB_CHAR) + castl_quote_index + castl_old_quote_index - 1; castl_quote_index = index (substr (castl_p_arg_string, castl_old_quote_index + castl_quote_index, castl_arg_length), CASTL_QUOTE_CHAR); end CASTL_QUOTE_LOOP; castl_old_arg_link_ptr = castl_arg_link_ptr; alloc castl_arg_link in (castl_work_area); if castl_old_arg_link_ptr = null then castl_root_arg_link_ptr = castl_arg_link_ptr; else castl_old_arg_link_ptr -> castl_arg_link.next_ptr = castl_arg_link_ptr; castl_arg_link.arg_ptr = addcharno (addwordno (addr (castl_p_arg_string), 1), castl_arg_index - 1); alloc castl_arg_descriptor in (castl_work_area); castl_arg_descriptor = castl_arg_descriptor_template; castl_arg_descriptor.size = castl_arg_length; castl_arg_link.desc_ptr = castl_arg_descriptor_ptr; castl_al_arg_count = castl_al_arg_count + 1; end CASTL_HAVE_ARG; end CASTL_PARSE_LOOP; alloc castl_arg_list in (castl_work_area); castl_arg_list.header.pad1 = "0"b; castl_arg_list.header.call_type = Interseg_call_type; castl_arg_list.header.desc_count = castl_al_arg_count; castl_arg_list.header.pad2 = "0"b; castl_arg_link_ptr = castl_root_arg_link_ptr; do castl_arg_idx = 1 to castl_al_arg_count; castl_arg_list.arg_ptrs (castl_arg_idx) = castl_arg_link.arg_ptr; castl_arg_list.desc_ptrs (castl_arg_idx) = castl_arg_link.desc_ptr; castl_old_arg_link_ptr = castl_arg_link_ptr; castl_arg_link_ptr = castl_arg_link.next_ptr; free castl_old_arg_link_ptr -> castl_arg_link in (castl_work_area); end; end CONVERT_ARGUMENT_STRING_TO_LIST; %page; /* This procedure takes two lists as input, the validate_result_list and the validate_result_explanation_list. Each member (node) of the validate_result_list contains an active function that is applied to the results of the previous argument processing (i.e., the information in the result_print_vector_array). Each member of the validate_result_explanation_list contains an explanation (error message) that is printed if the result of evaluating the corresponding validate_result_list_node is "false". If there is no explanation supplied, a "standard" error message This procedure returns on the first error encountered after printing an error message. The input lists, validate_result_list and validate_result_explanation_list, are initialized in "SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST". */ VALIDATE_RESULTS: proc(code); /* Parameter */ dcl code fixed bin(35); /* Automatic */ dcl i fixed bin(35); dcl result char(5) var; dcl vr_ptr ptr; dcl vre_ptr ptr; dcl vr_ovl_ptr ptr; dcl vre_ovl_ptr ptr; /* Based */ dcl validate_result_explanation char(vre_node.str_len) var based(vre_node.str_ptr); dcl validate_result_str char(vr_node.str_len) var based(vr_node.str_ptr); dcl 1 vr_node based(vr_ptr) like node; dcl 1 vre_node based(vre_ptr) like node; code = 0; if validate_result_list_ptr = null then return; if validate_result_explanation_list_ptr ^= null then vre_ptr = validate_result_explanation_list.head_ptr; else vre_ptr = null; do vr_ptr = validate_result_list.head_ptr repeat(vr_node.next_ptr) while(vr_ptr ^= null); call MAKE_VR_SUBSTITUTIONS((validate_result_str), active_string_nonvarying, active_string_length, code); if code ^= 0 then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to make substitutions in the result validation string:^/""^a"".", validate_result_str); on active_function_error call PRINT_AF_ERROR_MSG("result validation", (active_string)); call cu_$evaluate_active_string(null, (active_string), NORMAL_ACTIVE_STRING, result, code); if code ^= 0 then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to evaluate the active string:^/""^a"".", active_string); revert active_function_error; if result ^= "true" then do; if vre_ptr ^= null then do; call MAKE_VR_SUBSTITUTIONS((validate_result_explanation), active_explanation_nonvarying, active_explanation_length, code); if code ^= 0 then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to make substitutions in the result validation explanation:^/""^a"".", validate_result_explanation); call com_err_(0, (command_name_str), active_explanation); end; else call com_err_(0, (command_name_str), "Evaluation of the following" || "^/result validation active string yields ""false"":^/""^a""." || "^/No explanation has been provided.", active_string); code = error_table_$bad_arg; return; end; if validate_result_explanation_list_ptr ^= null then do; if vre_ptr = null then ; /* End of explanation list. */ else vre_ptr = vre_node.next_ptr; end; end; call FREE_LIST (validate_result_list_ptr); call FREE_LIST (validate_result_explanation_list_ptr); end VALIDATE_RESULTS; %page; /* This procedure makes substitutions in an input string and returns the resulting character string. It searches the input string for occurences of option names framed on the left by "&(" and on the right by ")". For each such occurence it substitutes the option value found in the result_print_vector_array. If the result_print_vector_array contains no such option, the null string is substituted. */ MAKE_VR_SUBSTITUTIONS: proc(initial_vr_str, buffer, n_chars_ret, code); /* Parameter */ dcl buffer char(*); dcl code fixed bin(35); dcl initial_vr_str char(*); dcl n_chars_ret fixed bin(21); /* Automatic */ dcl begin_looking_pos fixed bin(21); dcl found_option bit(1); dcl option_name char(length(initial_vr_str)) var; dcl search_str_len fixed bin(21); dcl search_str_pos fixed bin(21); dcl sub_str char(length(buffer)) var; dcl temp_buffer char(length(buffer)) var; /* Based */ dcl search_str char(search_str_len) based(addcharno(addr(temp_buffer), (search_str_pos - 1) + 4)); /* 4 for str len at beginning of var str. */ dcl sub_str_len fixed bin(21) based(addr(sub_str)); dcl sub_str_nonvar char(length(buffer)) based(addwordno(addr(sub_str), 1)); code = 0; buffer = ""; n_chars_ret = 0; temp_buffer = initial_vr_str; begin_looking_pos = 1; call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len); do while(search_str_pos ^= 0); option_name = LR_TRIM((search_str), LEFT_BOUND_STR, RIGHT_BOUND_STR); call process_arguments_$get_option_value(p_result_print_vector_array_ptr, p_work_area_ptr, found_option, option_name, option_value_list_ptr); if ^found_option then sub_str = ""; else do; call CV_OPTION_VALUES_TO_STRING(option_value_list_ptr, sub_str_nonvar, sub_str_len, code); if code ^= 0 then return; end; call SUBSTITUTE((temp_buffer),(search_str), (sub_str), search_str_pos, addr(temp_buffer), code); if code ^= 0 then return; begin_looking_pos = search_str_pos + sub_str_len; call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len); end; buffer = temp_buffer; n_chars_ret = length(temp_buffer); end MAKE_VR_SUBSTITUTIONS; %page; /* This routine substitutes argument values into a specified character string and returns the resulting character string. It searches the input string for occurences of the current argument name framed on the left by "&( and on the right by ")". For each such occurence it substitutes the current argument value into the string. */ MAKE_V_SUBSTITUTIONS: proc(initial_vr_str, input_arg_name, input_arg_value, buffer, n_chars_ret, code); /* Parameter */ dcl buffer char(*); dcl code fixed bin(35); dcl initial_vr_str char(*); dcl input_arg_name char(*); dcl input_arg_value char(*); dcl n_chars_ret fixed bin(21); /* Automatic */ dcl arg_name char(length(buffer)) var; dcl begin_looking_pos fixed bin(21); dcl search_str_len fixed bin(21); dcl search_str_pos fixed bin(21); dcl temp_buffer char(length(buffer)) var; /* Based */ dcl search_str char(search_str_len) based(addcharno(addr(temp_buffer), (search_str_pos - 1) + 4)); /* 4 for str length at beginning of var str. */ code = 0; buffer = ""; n_chars_ret = 0; temp_buffer = initial_vr_str; begin_looking_pos = 1; call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len); do while(search_str_pos ^= 0); arg_name = LR_TRIM(search_str, LEFT_BOUND_STR, RIGHT_BOUND_STR); if arg_name = input_arg_name then do; call SUBSTITUTE((temp_buffer), (search_str), (input_arg_value), search_str_pos, addr(temp_buffer), code); if code ^= 0 then return; begin_looking_pos = search_str_pos + length(input_arg_value); end; else begin_looking_pos = search_str_pos + search_str_len; call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len); end; buffer = temp_buffer; n_chars_ret = length(temp_buffer); end MAKE_V_SUBSTITUTIONS; %page; /* This procedure searches an input string for occurences of a search string. The search string has definite sets of characters on the left and right and a non-deterministic set of characters in the middle. The search begins at a designated position in the input string, not always at the beginning. The position of the search string (relative to the beginning of the input string) and its length are returned. If the search string is not found, a position and length of 0 are returned. */ STAR_STR_SEARCH: proc(str_to_search, start_str, end_str, initial_begin_looking_pos, search_str_pos, search_str_len); /* Parameter */ dcl end_str char(*); dcl initial_begin_looking_pos fixed bin(21); dcl search_str_len fixed bin(21); dcl search_str_pos fixed bin(21); dcl start_str char(*); dcl str_to_search char(*); /* Automatic */ dcl begin_looking_pos fixed bin(21); dcl end_str_idx fixed bin(21); dcl end_str_pos fixed bin(21); dcl start_str_idx fixed bin(21); dcl start_str_pos fixed bin(21); dcl substr_to_search char(length(str_to_search)) var; search_str_pos = 0; search_str_len = 0; begin_looking_pos = initial_begin_looking_pos; substr_to_search = substr(str_to_search, begin_looking_pos); start_str_idx = index(substr_to_search, start_str); if start_str_idx = 0 then return; start_str_pos = begin_looking_pos + start_str_idx - 1; begin_looking_pos = start_str_pos + length(start_str); substr_to_search = substr(str_to_search, begin_looking_pos); end_str_idx = index(substr_to_search, end_str); if end_str_idx = 0 then return; end_str_pos = begin_looking_pos + (end_str_idx - 1) + length(end_str) - 1; search_str_pos = start_str_pos; search_str_len = end_str_pos - start_str_pos + 1; end STAR_STR_SEARCH; %page; /* This procedure takes a pointer to an option_value_list and returns all of the values concatenated together separated by spaces in the buffer provided. */ CV_OPTION_VALUES_TO_STRING: proc(ovl_ptr, buffer, n_chars_ret, code); /* Parameter */ dcl buffer char(*); dcl code fixed bin(35); dcl n_chars_ret fixed bin(21); dcl ovl_ptr ptr; /* Automatic */ dcl i fixed bin; dcl max_buffer_len fixed bin(21); dcl option_value_ptr ptr; dcl temp_buffer char(length(buffer)) var; dcl work_str char(length(buffer)) var; /* Based */ dcl option_value char(sys_info$max_seg_size) var based(option_value_ptr); code = 0; buffer = ""; n_chars_ret = 0; max_buffer_len = length(buffer); temp_buffer = ""; do i = 1 to ovl_ptr->option_value_list.number_of_values; work_str = temp_buffer; option_value_ptr = ovl_ptr->option_value_list.value(i).ptr; if length(requote_string_((option_value))) + length(work_str) + 1 > max_buffer_len then do; code = error_table_$smallarg; return; end; if i = 1 then temp_buffer = requote_string_((option_value)); else temp_buffer = work_str || " " || requote_string_((option_value)); end; buffer = temp_buffer; n_chars_ret = length(temp_buffer); end CV_OPTION_VALUES_TO_STRING; %page; /* This function takes an input string, and trims one occurence of given character strings off the immediate left and immediate right of the input string. It returns the result. */ LR_TRIM: proc(str, lchars, rchars) returns(char(*)); /* Parameter */ dcl lchars char(*); dcl rchars char(*); dcl str char(*); /* Automatic */ dcl new_str char(length(str)) var; new_str = str; if index(new_str, lchars) = 1 then new_str = after(new_str, lchars); if index(reverse(new_str), reverse(rchars)) = 1 then new_str = reverse(after(reverse(new_str), reverse(rchars))); return((new_str)); end LR_TRIM; %page; /* This procedure takes a string that contains an occurence of an "old" sequence of characters at a specified position in the string, and replaces the old sequence with a new sequence handing the result back in a varying character buffer. */ (stringrange): SUBSTITUTE: proc(str, old, new, old_pos, buffer_ptr, code); /* Parameter */ dcl buffer_ptr ptr; dcl code fixed bin(35); dcl new char(*); dcl old char(*); dcl old_pos fixed bin(21); dcl str char(*); /* Automatic */ dcl left_str char(length(buffer)) var; dcl old_len fixed bin(21); dcl right_str char(length(buffer)) var; /* Based */ dcl buffer char(sys_info$max_seg_size) var based(buffer_ptr); code = 0; on stringrange begin; code = error_table_$smallarg; goto SUBSTITUTE_RETURN; end; old_len = length(old); left_str = substr(str, 1, old_pos - 1); right_str = substr(str, old_pos + old_len); buffer = left_str || new || right_str; SUBSTITUTE_RETURN: return; end SUBSTITUTE; %page; /* This procedure is called when evaluating an active function and the active_function_error condition is signalled. It finds the condition_info set up for active function errors, extracts and prints the error message. */ PRINT_AF_ERROR_MSG: proc(af_user_name, af); /* Parameter */ dcl af char(*); dcl af_user_name char(*); /* Automatic */ dcl code fixed bin(35); dcl stack_ptr ptr; dcl 1 auto_condition_info aligned like condition_info; /* Based */ dcl af_error_msg char(com_af_error_info.errmess_lth) based(com_af_error_info.errmess_ptr); dcl af_name char(com_af_error_info.name_lth) based(com_af_error_info.name_ptr); unspec(auto_condition_info) = "0"b; auto_condition_info.version = condition_info_version_1; stack_ptr = find_condition_frame_(null); call find_condition_info_(stack_ptr, addr(auto_condition_info), code); if code ^= 0 then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to obtain an error message for an error that occured while" || "^/processing the ^a active string:^/""^a"".", af_user_name, af); com_af_error_info_ptr = auto_condition_info.info_ptr; if com_af_error_info.version ^= com_af_error_info_version_3 then call sub_err_(error_table_$unimplemented_version, MY_NAME, ACTION_CANT_RESTART, null, 0, "^/Unable to obtain the correct version of error information for an error" || "^/that occured while processing the ^a active string:^/""^a"".", af_user_name, af); call sub_err_(error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null, 0, "^a^/An error occured while processing the ^a active string:^/""^a"".", af_error_msg, af_user_name, af); end PRINT_AF_ERROR_MSG; %page; /* This procedure is called to build and maintain the validate_result_list and the validate_result_explanation_list. It looks in a given print_vector for a validate_result_string and validate_result_explanation, and adds them to the appropriate list if they are found. */ SETUP_RESULT_VALIDATION_INFO: proc(pv_ptr, vr_list_ptr, vre_list_ptr); /* Parameter */ dcl pv_ptr ptr; dcl vre_list_ptr ptr; dcl vr_list_ptr ptr; call ADD_TO_LIST(pv_ptr, vr_list_ptr, validate_result_identifier); call ADD_TO_LIST(pv_ptr, vre_list_ptr, validate_result_explanation_identifier); end SETUP_RESULT_VALIDATION_INFO; %page; /* This is a list maintenance procedure. It adds a node to a list if there is a specific dimension value in a given print_vector. */ ADD_TO_LIST: proc(pv_ptr, list_ptr, dim_identifier); /* Parameter */ dcl dim_identifier fixed bin; dcl list_ptr ptr; dcl pv_ptr ptr; /* Automatic */ dcl dim_idx fixed bin; dcl new_node_ptr ptr; call GET_DIM_IDX(pv_ptr, dim_identifier, dim_idx); if dim_idx = -1 then return; call GET_LIST_NODE(list_ptr, new_node_ptr); new_node_ptr->node.str_len = length(pv_ptr->print_vector.dimension(dim_idx).value); new_node_ptr->node.str_ptr = addr(pv_ptr->print_vector.dimension(dim_idx).value); end ADD_TO_LIST; %page; /* This is a list maintenance procedure. It allocates storage for a node in a given list, initializes the values in the node, and tacks that node on to the end of the list. It also initializes the list header if necessary. */ GET_LIST_NODE: proc(list_ptr, new_node_ptr); /* Parameter */ dcl list_ptr ptr; dcl new_node_ptr ptr; allocate node in(work_area) set(new_node_ptr); new_node_ptr->node.next_ptr = null; if list_ptr = null then do; allocate list in(work_area) set(list_ptr); list_ptr->list.head_ptr = new_node_ptr; list_ptr->list.tail_ptr = new_node_ptr; end; else do; list_ptr->list.tail_ptr->node.next_ptr = new_node_ptr; list_ptr->list.tail_ptr = new_node_ptr; end; end GET_LIST_NODE; %page; /* This is a list maintenance procedure. I frees up all of the storage that has been allocated for a list. */ FREE_LIST: proc(list_ptr); /* Parameter */ dcl list_ptr ptr; /* Automatic */ dcl next_node_ptr ptr; if list_ptr = null then return; node_ptr = list_ptr->list.head_ptr; do while(node_ptr ^= null); next_node_ptr = node.next_ptr; free node; node_ptr = next_node_ptr; end; end FREE_LIST; %page; /* This entry really belongs in vector_util. It is just temporary. */ free_print_vector_array: entry(p_print_vector_array_ptr); /* Parameter */ dcl p_print_vector_array_ptr ptr; /* Automatic */ dcl i fixed bin; if p_print_vector_array_ptr = null then return; print_vector_array_ptr = p_print_vector_array_ptr; do i = 1 to print_vector_array.number_of_vectors; print_vector_ptr = print_vector_array.vector_slot(i); free print_vector; end; free print_vector_array; return; %page; %include vu_print_vector_array; %page; %include arg_list; %page; %include vu_entry_dcls; %page; %include sub_err_flags; %page; %include arg_descriptor; %page; %include std_descriptor_types; %page; %include cp_active_string_types; %page; %include pa_option_value_list; %page; %include condition_info_header; %page; %include com_af_error_info; %page; %include condition_info; end pa_process_arguments;  pa_search_list.pl1 02/27/89 1058.7rew 02/27/89 1051.8 125001 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-01-17,TLNguyen), approve(89-01-27,MCR8052), audit(89-02-06,Parisek), install(89-02-27,MR12.3-1015): a. Replace error_table_$programming_error with error_table_$fatal_error when calling sub_err_ to report a null area pointer error. b. Assign initial values for automatic variables in the internal procedure, INITIALIZATION. Remove the reference to get_temp_segment_. END HISTORY COMMENTS */ /* format: style2,ind3 */ pa_search_list: proc (p_command_name, p_caller_area_ptr, p_array_ptr, p_code); /* DESCRIPTION: This subroutine searches the databases in the process_arguments search list for either an argument processing definition or a default linear form. */ /* HISTORY: Written by Lindsey Spratt, 06/27/83. Modified: 06/28/83 by Lindsey L. Spratt: Fixed to not report errors encountered while searching the list until the list just searched passes the change count test. Also fixed to check the change count before using the stored sl_info. 07/01/83 by Lindsey L. Spratt: Fixed to look for default linear form strings, rather than result pva's. Also, taught to look in value segments (when that's specified in the search list). 07/07/83 by Lindsey L. Spratt: Fixed to set the sl_info_p pointer to the current value of search_list_info_ptr. 07/08/83 by Lindsey L. Spratt: Fixed to not report errors of vd_error_$no_vector or error_table_$noentry when searching for a default linear form. 07/24/83 by Lindsey L. Spratt: Converted to retrieve a pva_string definition from a value seg, rather than a print_vector_array definition from a vector_db. 08/03/83 by S.Krupp to distinguish between internal work area and caller provided area to fix bad search_list_info_ptr bug. The sl_info structure is now allocated in the internal work area. Also, to change the name of the search list to mtape_arguments and fix assorted bugs. */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_command_name char (*) varying; dcl p_caller_area_ptr ptr; dcl p_array_ptr ptr; dcl p_default_linear_form char (*) varying; dcl p_code fixed bin (35); /* Automatic */ dcl (retry_count, path_idx) fixed bin; dcl definition_value_name char (256) varying; dcl dir_name char (256); dcl entry_name char (128); dcl default_linear_form_value_name char (128) varying; dcl get_definition bit (1) aligned; dcl work_area_ptr ptr; dcl caller_area_ptr ptr; /* Based */ dcl based_real_fix_bin_2u fixed bin (71) unaligned based; /* Builtin */ dcl (addr, null, string) builtin; /* Controlled */ /* Constant */ dcl myname init ("pa_get_definition") char (64) varying internal static options (constant); dcl PROCESS_ARGUMENTS_SEARCH_LIST_NAME init ("mtape_arguments") char (64) varying internal static options (constant); dcl VALUE_SUFFIX init ("value") char (5) internal static options (constant); dcl PERMANENT_VALUE init ("01"b) bit (2) aligned internal static options (constant); dcl ( RETRY_LIMIT init (5), BYTES_PER_WORD init (4) ) fixed bin internal static options (constant); /* Entry */ dcl get_system_free_area_ entry () returns (ptr); dcl value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)); dcl sub_err_ entry options (variable); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl ioa_$rsnnl entry() options(variable); /* External */ dcl ( error_table_$asynch_change, error_table_$noentry, error_table_$fatal_error, error_table_$oldnamerr ) fixed bin (35) ext; /* Internal */ dcl (search_list_info_ptr) ptr init (null) internal static; /* END OF DECLARATIONS */ get_definition: entry (p_command_name, p_caller_area_ptr, p_array_ptr, p_code); call INITIALIZATION (); caller_area_ptr = p_caller_area_ptr; get_definition = "1"b; goto JOIN; get_default_linear_form: entry (p_command_name, p_default_linear_form, p_code); call INITIALIZATION (); get_definition = "0"b; JOIN: work_area_ptr = get_system_free_area_ (); if (caller_area_ptr = null) & (get_definition) then call sub_err_ (error_table_$fatal_error, myname, "s", null, 0, "The area_ptr given to this module must be non-null."); p_code = 0; p_array_ptr = null; default_linear_form_value_name = DEFAULT_LINEAR_FORM_PREFIX || "." || p_command_name; definition_value_name = DEFINITION_PREFIX || "." || p_command_name; if search_list_info_ptr = null then do; call SETUP_SEARCH_LIST (search_list_info_ptr, p_code); if p_code ^= 0 then call ERROR_RETURN (); end; sl_info_p = search_list_info_ptr; if sl_info.change_index ^= sl_info.change_index_p -> based_real_fix_bin_2u then do; call SETUP_SEARCH_LIST (search_list_info_ptr, p_code); if p_code ^= 0 then call ERROR_RETURN (); sl_info_p = search_list_info_ptr; end; call SEARCH_LIST; RETRY_SEARCH: do while (retry_count <= RETRY_LIMIT & sl_info.change_index ^= sl_info.change_index_p -> based_real_fix_bin_2u); call SETUP_SEARCH_LIST (search_list_info_ptr, p_code); if p_code ^= 0 then call ERROR_RETURN (); sl_info_p = search_list_info_ptr; retry_count = retry_count + 1; call SEARCH_LIST; end RETRY_SEARCH; if p_code ^= 0 then call ERROR_RETURN (); else if retry_count > RETRY_LIMIT then p_code = error_table_$asynch_change; call FINISH; MAIN_RETURN: return; %page; INITIALIZATION: proc(); retry_count = 0; path_idx = 0; definition_value_name = ""; dir_name = ""; entry_name = ""; get_definition = "0"b; work_area_ptr = null; caller_area_ptr = null; return; end INITIALIZATION; %page; FINISH: proc (); end FINISH; ERROR_RETURN: proc (); call FINISH; goto MAIN_RETURN; end ERROR_RETURN; %page; SEARCH_LIST: proc (); dcl sl_pv_idx fixed bin; if get_definition then do; if p_array_ptr ^= null then do; do sl_pv_idx = 1 to p_array_ptr -> print_vector_array.number_of_vectors; free p_array_ptr -> print_vector_array.vector_slot (sl_pv_idx) -> print_vector; end; free p_array_ptr -> print_vector_array; p_array_ptr = null; end; end; else p_default_linear_form = ""; do path_idx = 1 to sl_info.num_paths; call expand_pathname_$add_suffix (sl_info.paths (path_idx).pathname, VALUE_SUFFIX, dir_name, entry_name, p_code); if p_code ^= 0 then return; if get_definition then do; call RETRIEVE_DEFINITION (dir_name, entry_name, p_array_ptr, p_code); if p_array_ptr ^= null then return; /* A definition was found. */ else if p_code ^= error_table_$oldnamerr & p_code ^= error_table_$noentry then return; /* An error fatal to the search was hit. */ end; else do; call RETRIEVE_DEFAULT_LINEAR_FORM (dir_name, entry_name, p_default_linear_form, p_code); if p_code ^= 0 then if p_code ^= error_table_$oldnamerr & p_code ^= error_table_$noentry then return; /* An error fatal to the search was hit. */ else p_code = 0; end; end; if get_definition then if p_array_ptr = null then p_code = error_table_$oldnamerr; end SEARCH_LIST; %page; RETRIEVE_DEFAULT_LINEAR_FORM: proc (rdlf_p_db_dir, rdlf_p_db_entry, rdlf_p_default_linear_form, rdlf_p_code); dcl rdlf_p_db_dir char (*) parameter; dcl rdlf_p_db_entry char (*) parameter; dcl rdlf_p_default_linear_form char (*) varying parameter; dcl rdlf_p_code fixed bin (35) parameter; dcl rdlf_value_seg_ptr ptr init (null); dcl rdlf_default_linear_form_value char (rdlf_dlfv_length_in_bytes) varying based(rdlf_dlfv_ptr); dcl rdlf_dlfv_length_in_bytes fixed bin(21) init(0); dcl rdlf_dlfv_length_in_words fixed bin(18) init(0); dcl rdlf_dlfv_ptr ptr init(null); call initiate_file_ (rdlf_p_db_dir, rdlf_p_db_entry, R_ACCESS, rdlf_value_seg_ptr, (0), p_code); if rdlf_value_seg_ptr = null then return; call value_$get_data (rdlf_value_seg_ptr, (PERMANENT_VALUE), (default_linear_form_value_name), work_area_ptr, rdlf_dlfv_ptr, rdlf_dlfv_length_in_words, p_code); if p_code ^= 0 then do; call RDLF_FINISH; return; end; rdlf_dlfv_length_in_bytes = rdlf_dlfv_length_in_words * BYTES_PER_WORD; call terminate_file_ (rdlf_value_seg_ptr, (0), TERM_FILE_TERM, p_code); if p_code ^= 0 then do; call RDLF_FINISH; return; end; call ioa_$rsnnl("^a^[^; ^]^a", rdlf_p_default_linear_form, 0, (rdlf_default_linear_form_value), (rdlf_default_linear_form_value = "" | rdlf_p_default_linear_form = ""), (rdlf_p_default_linear_form)); /* rdlf_p_default_linear_form = rdlf_default_linear_form_value || " " || rdlf_p_default_linear_form*/ call RDLF_FINISH; return; RDLF_FINISH: proc; if rdlf_value_seg_ptr ^= null then call terminate_file_ (rdlf_value_seg_ptr, (0), TERM_FILE_TERM, (0)); end RDLF_FINISH; end RETRIEVE_DEFAULT_LINEAR_FORM; %page; RETRIEVE_DEFINITION: proc (rd_p_db_dir, rd_p_db_entry, rd_p_array_ptr, rd_p_code); dcl rd_p_db_dir char (*) parameter; dcl rd_p_db_entry char (*) parameter; dcl rd_p_array_ptr ptr parameter; dcl rd_p_code fixed bin (35) parameter; dcl rd_value_seg_ptr ptr init (null); dcl rd_definition_pva_string char (rd_definition_pva_string_length_in_bytes) varying based (rd_definition_pva_string_ptr); dcl rd_definition_pva_string_ptr ptr init (null); dcl rd_definition_pva_string_length_in_words fixed bin (18) init (0); dcl rd_definition_pva_string_length_in_bytes fixed bin (21) init (0); call initiate_file_ (rd_p_db_dir, rd_p_db_entry, R_ACCESS, rd_value_seg_ptr, (0), p_code); if rd_value_seg_ptr = null then return; call value_$get_data (rd_value_seg_ptr, (PERMANENT_VALUE), (definition_value_name), caller_area_ptr, rd_definition_pva_string_ptr, rd_definition_pva_string_length_in_words, p_code); if p_code ^= 0 then do; call RD_FINISH; return; end; rd_definition_pva_string_length_in_bytes = rd_definition_pva_string_length_in_words * BYTES_PER_WORD; call terminate_file_ (rd_value_seg_ptr, (0), TERM_FILE_TERM, p_code); if p_code ^= 0 then do; call RD_FINISH; return; end; call vector_util_$cv_string_to_pva ((rd_definition_pva_string_ptr), (rd_definition_pva_string_length_in_bytes), caller_area_ptr, rd_p_array_ptr, rd_p_code); call RD_FINISH; return; %page; RD_FINISH: proc; if rd_definition_pva_string_ptr ^= null then free rd_definition_pva_string; end RD_FINISH; end RETRIEVE_DEFINITION; %page; SETUP_SEARCH_LIST: proc (ssl_p_sl_info_p, ssl_p_code); dcl ssl_p_code fixed bin (35) parameter; dcl ssl_p_sl_info_p ptr parameter; ssl_p_code = 0; ssl_p_sl_info_p = null; sl_control_s.af_pathname = "1"b; sl_control_s.pad1 = "0"b; sl_control_s.key_ref_dir = "0"b; sl_control_s.key_work_dir = "1"b; sl_control_s.key_home_dir = "1"b; sl_control_s.key_proc_dir = "1"b; sl_control_s.pad2 = "0"b; call search_paths_$get ((PROCESS_ARGUMENTS_SEARCH_LIST_NAME), string (sl_control_s), "", null, work_area_ptr, sl_info_version_1, ssl_p_sl_info_p, ssl_p_code); end SETUP_SEARCH_LIST; %page; %include pa_value_names; %page; %include vu_entry_dcls; %page; %include vu_print_vector_array; %page; %include sl_info; %page; %include sl_control_s; %page; %include sub_err_flags; %page; %include pa_dim_name_constants; %page; %include access_mode_values; %page; %include terminate_file; end pa_search_list;  process_arguments_.alm 02/16/84 1306.5r w 02/16/84 1249.9 15480 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " " HISTORY: " " Written By Lindsey Spratt, 06/20/83. " Modified: " 06/27/83 by Lindsey Spratt: Fixed the $get_definition and " $get_default_linear_form entries to transfer into pa_search_list. " 06/30/83 by Lindsey Spratt: Added the $get_refname entry. " 07/05/83 by Lindsey Spratt: Changed cv_result_to_linear_form to reference " pa_cv_result_to_lf$pa_cv_result_to_lf, $get_option_refname to " reference pa_get_refname$pa_get_refname. " Changed $get_refname to $get_reference_name. " 09/06/83 by S. Krupp: Added free_print_vector_array. " name process_arguments_ " " Macro to generate a call to an external entrypoint in the manager macro ext_transfer segdef &1 &1: getlp tra &2 &end ext_transfer argument_array,pa_process_arguments$argument_array ext_transfer argument_list,pa_process_arguments$argument_list ext_transfer argument_string,pa_process_arguments$argument_string ext_transfer get_option_value,pa_get_option_value$pa_get_option_value ext_transfer cv_result_to_linear_form,pa_cv_result_to_lf$pa_cv_result_to_lf ext_transfer get_option_refname,pa_get_refname$pa_get_refname ext_transfer get_default_linear_form,pa_search_list$get_default_linear_form ext_transfer get_definition,pa_search_list$get_definition ext_transfer get_reference_name,pa_get_refname$pa_get_refname ext_transfer free_print_vector_array,pa_process_arguments$free_print_vector_array end  vd_error_.alm 11/05/86 1243.0r w 11/04/86 1038.2 21051 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** include et_macros et vd_error_ " " Written by Lindsey Spratt. " Modified: " 07/08/82 by Lindsey Spratt: Added the short_buffer error code. " 08/29/82 by Ed Wallman: Added nonexistent_variable_reference error code. " 09/25/82 by Ed Wallman: Added empty_report error code. " 10/14/82 by Lindsey Spratt: Added the mismatched_descriptors and wrong_type " error codes. " 06/09/83 by S. Krupp: added bad_print_vector_index and dim_not_in_vector " error codes. " ec no_vector,novec, (No vector was found.) ec bad_parent_pos,badprnt, (The parent position in the node does not match the position of the parent node in the current path.) ec bad_node,bn, (A node is inconsistent.) ec vector_is_already_in_db,vecdup, (The vector is already present.) ec line_too_short_for_vector,shrtline, (Data does not fit given line length.) ec inconsistent_display_definition,bad_def, (Display definition is inconsistent.) ec invalid_field_name,badfield, (Invalid field name specified.) ec dim_already_in_vector,dimdup, (The dimension is already present in the vector.) ec bad_range_syntax,badrange, (The syntax of the range specification is invalid.) ec dimension_already_defined,dimdef, (The dimension was already present in the dimension_table.) ec short_buffer,shortbuf, (The buffer is to small for the requested data.) ec nonexistent_variable_reference,novarref, (A reference to a nonexistent variable has been found.) ec empty_report,empty, (The report as specified is empty.) ec wrong_type,badtype, (The wrong type of vector structure was provided.) ec mismatched_descriptors,baddesc, (The descriptors aren't the same.) ec invalid_alignment,invalign, (The data is incorrectly aligned.) ec unimplemented_data_type,baddt, (The data type is no implemented.) ec bad_print_vector_index,badpvi, (The index does given not specify a print_vector in the print_vector_array.) ec dim_not_in_vector,nodim, (The specified dimension is not present in the print_vector.) end  vector_util_.alm 02/16/84 1306.5r w 02/16/84 1249.9 16029 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** name vector_util_ " Modified: " 06/28/82 by Lindsey Spratt: added the cv_typed_to_print entry_point. " 09/19/82 by Ed Wallman: Added build_display_info entrypoint. " 09/23/82 by Lindsey Spratt: Added the free_typed_vector and " free_typed_vector_array entries. " 02/08/83 by Lindsey Spratt: added copy_typed_vector, " copy_typed_vector_array. " 03/08/83 by Matthew Pierret: added copy_typed_vector_array for real. " 06/09/83 by S. Krupp: added replace_print_value entry. " 07/24/83 by Lindsey Spratt: added cv_pva_to_string and cv_string_to_pva. " 08/31/83 by J. A. Bush: remove entries not needed by process_arguments_ for " inclusion in bound_mtape_ for the MR10.2 release. " Macro to generate a call to an external entrypoint in the utilities macro ext_transfer segdef &1 &1: getlp tra &2 &end ext_transfer init_print_vector_array,vu_init_print_vector_array$vu_init_print_vector_array ext_transfer append_simple_print_vector,vu_append_simple_print$vu_append_simple_print ext_transfer append_general_print_vector,vu_append_general_print$vu_append_general_print ext_transfer append_dimension_print,vu_append_dimension_print$vu_append_dimension_print ext_transfer err_no_operation,vu_err_no_operation$vu_err_no_operation ext_transfer replace_print_value,vu_replace_print_value$replace_print_value ext_transfer cv_pva_to_string,vu_cv_pva_to_string$vu_cv_pva_to_string ext_transfer cv_string_to_pva,vu_cv_string_to_pva$vu_cv_string_to_pva end  vu_append_dimension_print.pl1 02/16/84 1306.5r w 02/16/84 1249.9 52200 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_append_dimension_print: append_dimension_print: proc (p_work_area_ptr, p_free_old_print_vector_array, p_dimension_name, p_descriptor_ptr, p_print_vector_array_ptr, p_dimension_identifier, p_code); /* DESCRIPTION: This module adds a new dimension to an existing print_vector_array. */ /* HISTORY: Written by Lindsey Spratt, 06/01/82. Modified: 06/30/83 by Lindsey L. Spratt: Due to an apparent bug in the PL/1 compiler, an assignment of structure element of an array to a new copy of the array was not working (off by a word, or so). This assignment was replaced with a set of explicit assignments, one for each element of the structure. */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_work_area_ptr ptr; dcl p_free_old_print_vector_array bit (1) aligned; dcl p_dimension_name char (*); dcl p_descriptor_ptr ptr; dcl p_print_vector_array_ptr ptr; dcl p_dimension_identifier fixed bin; dcl p_code fixed bin (35); /* Automatic */ dcl dim_idx fixed bin; dcl old_pva_ptr ptr; dcl vector_idx fixed bin; /* Based */ dcl descriptor_string bit (36) aligned based; dcl work_area area based (p_work_area_ptr); /* Builtin */ dcl null builtin; /* Controlled */ /* Constant */ dcl MYNAME init ("vu_append_dimension_print") char (40) varying internal static options (constant); /* Entry */ dcl sub_err_ entry () options (variable); /* External */ dcl vd_error_$dimension_already_defined fixed bin (35) ext; dcl error_table_$bad_arg fixed bin (35) ext; dcl vd_error_$mismatched_descriptors fixed bin (35) ext; dcl error_table_$fatal_error fixed bin (35) ext; /* END OF DECLARATIONS */ print_vector_array_ptr = p_print_vector_array_ptr; do p_dimension_identifier = 1 to print_vector_array.number_of_dimensions while (print_vector_array.dimension_table (p_dimension_identifier).name ^= p_dimension_name); end; if p_dimension_identifier <= print_vector_array.number_of_dimensions then do; p_code = vd_error_$dimension_already_defined; if p_descriptor_ptr = print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr then return; else if p_descriptor_ptr = null | print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr = null then return; else if p_descriptor_ptr -> descriptor_string = print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr -> descriptor_string then return; else do; p_code = vd_error_$mismatched_descriptors; return; end; end; pva_number_of_vector_slots = print_vector_array.number_of_vector_slots; pva_number_of_dimensions = p_dimension_identifier; pva_maximum_dimension_name_length = max (print_vector_array.maximum_dimension_name_length, length (p_dimension_name)); old_pva_ptr = print_vector_array_ptr; alloc print_vector_array in (work_area); print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2; print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors; print_vector_array.vector_slot = old_pva_ptr -> print_vector_array.vector_slot; do p_dimension_identifier = 1 to print_vector_array.number_of_dimensions - 1; print_vector_array.dimension_table (p_dimension_identifier).name = old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).name; print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr = old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr; print_vector_array.dimension_table (p_dimension_identifier).cv_to_print = old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).cv_to_print; print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed = old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed; print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length = old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length; end; print_vector_array.dimension_table (p_dimension_identifier).name = p_dimension_name; print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr = p_descriptor_ptr; print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length = 0; print_vector_array.dimension_table (p_dimension_identifier).cv_to_print = vector_util_$err_no_operation; print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed = vector_util_$err_no_operation; p_print_vector_array_ptr = print_vector_array_ptr; p_dimension_identifier = pva_number_of_dimensions; p_code = 0; if p_free_old_print_vector_array then free old_pva_ptr -> print_vector_array in (work_area); return; %include vu_print_vector_array; %page; %include desc_types; %page; %include descriptor; %page; %include arg_list; %page; %include vu_entry_dcls; end vu_append_dimension_print;  vu_append_general_print.pl1 02/16/84 1306.5r w 02/16/84 1249.9 114795 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_append_general_print: append_general_print_vector: proc (); /* DESCRIPTION: This entry appends a print vector to a print vector array. */ /* HISTORY: Written by Lindsey Spratt, sometime in 1980? Modified: 03/10/83 by Lindsey Spratt: Added a new parameter (now the 4th one) which is used to specify that an existing print_vector is to be added onto. 03/15/83 by Lindsey Spratt: Added a nosubrg prefix to avoid a compiler bug in assigning from one array to another when the arrays have different extents. 08/30/83 by Lindsey L. Spratt: Fixed to use vd_error_$dim_already_in_vector. */ /* START OF DECLARATIONS */ /* Parameter */ /* Automatic */ dcl dimension_name_ptr ptr; dcl dimension_name_length fixed bin; dcl CODE_ARG_IDX fixed bin; dcl PVA_PTR_ARG_IDX fixed bin; dcl (dim_idx, temp_dim_idx) fixed bin; dcl values_given bit (1) aligned init ("0"b); dcl is_dimension_value bit (1) aligned; dcl old_pva_ptr ptr; dcl vector_idx fixed bin; dcl (vector_slot_idx_ptr, old_print_vector_ptr) ptr init (null); dcl free_old_print_vector_array_ptr ptr; dcl arg_list_arg_count fixed bin; dcl arg_list_ptr ptr; dcl type fixed bin; dcl packed bit (1) aligned; dcl size fixed bin; dcl ndims fixed bin; dcl scale fixed bin; dcl p_code_ptr ptr; dcl nargs fixed bin; dcl arg_idx fixed bin; dcl work_area_ptr ptr; /* Based */ dcl vector_slot_idx fixed bin (35) based (vector_slot_idx_ptr) aligned; dcl free_old_print_vector_array bit (1) aligned based (free_old_print_vector_array_ptr); dcl work_area area based (work_area_ptr); dcl s_fixed_real_template based fixed bin; dcl ptr_template based ptr; dcl dimension_name based (dimension_name_ptr) char (dimension_name_length); dcl v_char_template based char (size) varying; dcl char_template based char (size); dcl p_code based (p_code_ptr) fixed bin (35); /* Builtin */ dcl null builtin; /* Controlled */ /* Constant */ dcl MYNAME init ("vu_append_general_print") char (40) varying internal static options (constant); dcl ( AREA_PTR_ARG_IDX init (1), SLOT_INCREASE_ARG_IDX init (2), FREE_OLD_PVA_ARG_IDX init (3), VECTOR_SLOT_IDX_ARG_IDX init (4), NUMBER_OF_DIMENSIONS_ARG_IDX init (5), MAXIMUM_VALUE_LENGTH_ARG_IDX init (6), NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING init (4), PVA_PTR_ARG_OFFSET_FROM_END init (1), NUMBER_OF_NONVALUE_ARGS_AT_END init (2) ) fixed bin internal static options (constant); /* Entry */ dcl cu_$arg_list_ptr entry (ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl cu_$arg_count entry (fixed bin); dcl sub_err_ entry () options (variable); /* External */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$fatal_error fixed bin (35) ext; dcl vd_error_$dim_already_in_vector fixed bin (35) ext; /* END OF DECLARATIONS */ call cu_$arg_count (nargs); arg_list_arg_count = nargs; call cu_$arg_list_ptr (arg_list_ptr); CODE_ARG_IDX = nargs; PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END; call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then call sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0, "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME); p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX); call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template; call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template; call decode_descriptor_ (arg_list_ptr, SLOT_INCREASE_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then do; p_code = error_table_$bad_arg; return; end; pva_number_of_vector_slots = print_vector_array.number_of_vector_slots + arg_list_ptr -> arg_list.arg_ptrs (SLOT_INCREASE_ARG_IDX) -> s_fixed_real_template; call decode_descriptor_ (arg_list_ptr, FREE_OLD_PVA_ARG_IDX, type, packed, ndims, size, scale); if type ^= bit_desc | packed | size ^= 1 then do; p_code = error_table_$bad_arg; return; end; free_old_print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (FREE_OLD_PVA_ARG_IDX); call decode_descriptor_ (arg_list_ptr, VECTOR_SLOT_IDX_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc | packed then do; p_code = error_table_$bad_arg; return; end; vector_slot_idx_ptr = arg_list_ptr -> arg_list.arg_ptrs (VECTOR_SLOT_IDX_ARG_IDX); if vector_slot_idx = 0 | vector_slot_idx < -1 | vector_slot_idx > print_vector_array.number_of_vectors then do; p_code = error_table_$bad_arg; return; end; else if vector_slot_idx = -1 then old_print_vector_ptr = null; else old_print_vector_ptr = print_vector_array.vector_slot (vector_slot_idx); call decode_descriptor_ (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, type, packed, ndims, size, scale); if type = s_fixed_real_desc then if ^packed then do; values_given = "0"b; pv_number_of_dimensions = arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_DIMENSIONS_ARG_IDX) -> s_fixed_real_template; call decode_descriptor_ (arg_list_ptr, MAXIMUM_VALUE_LENGTH_ARG_IDX, type, packed, ndims, size, scale); if type = s_fixed_real_desc then if ^packed then pv_maximum_value_length = arg_list_ptr -> arg_list.arg_ptrs (MAXIMUM_VALUE_LENGTH_ARG_IDX) -> s_fixed_real_template; else do; p_code = error_table_$bad_arg; return; end; end; else do; p_code = error_table_$bad_arg; return; end; else do; values_given = "1"b; pv_number_of_dimensions = (nargs - (NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + NUMBER_OF_NONVALUE_ARGS_AT_END)) / 2; pv_maximum_value_length = 0; do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 2 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END by 2; call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type = v_char_desc | type = char_desc then do; pv_maximum_value_length = max (pv_maximum_value_length, length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template))); end; else do; p_code = error_table_$bad_arg; return; end; end; end; if old_print_vector_ptr = null then do; alloc print_vector in (work_area); print_vector_array.number_of_vectors = print_vector_array.number_of_vectors + 1; if print_vector_array.number_of_vectors > print_vector_array.number_of_vector_slots then do; pva_maximum_dimension_name_length = print_vector_array.maximum_dimension_name_length; pva_number_of_dimensions = print_vector_array.number_of_dimensions; old_pva_ptr = print_vector_array_ptr; alloc print_vector_array in (work_area); arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template = print_vector_array_ptr; print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2; print_vector_array.dimension_table = old_pva_ptr -> print_vector_array.dimension_table; print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors; /* This number includes the newly created print_vector. */ do vector_idx = 1 to print_vector_array.number_of_vectors - 1; (nosubrg): print_vector_array.vector_slot (vector_idx) = old_pva_ptr -> print_vector_array.vector_slot (vector_idx); end; if free_old_print_vector_array then free old_pva_ptr -> print_vector_array in (work_area); end; print_vector_array.vector_slot (print_vector_array.number_of_vectors) = print_vector_ptr; dim_idx = 0; end; else do; pv_number_of_dimensions = pv_number_of_dimensions + old_print_vector_ptr -> print_vector.number_of_dimensions; pv_maximum_value_length = max (pv_maximum_value_length, old_print_vector_ptr -> print_vector.maximum_value_length); alloc print_vector in (work_area); do dim_idx = 1 to old_print_vector_ptr -> print_vector.number_of_dimensions; (nosubrg): print_vector.dimension (dim_idx) = old_print_vector_ptr -> print_vector.dimension (dim_idx); end; dim_idx = old_print_vector_ptr -> print_vector.number_of_dimensions; end; is_dimension_value = "1"b; if values_given then do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END; is_dimension_value = (mod (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING, 2) = 0); call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type ^= v_char_desc & type ^= char_desc then do; p_code = error_table_$bad_arg; return; end; else if is_dimension_value then do; print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length = max (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier) .maximum_value_length, size); print_vector.dimension (dim_idx).value = rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template); end; else do; dim_idx = dim_idx + 1; dimension_name_ptr = arg_list_ptr -> arg_list.arg_ptrs (arg_idx); dimension_name_length = size; do print_vector.dimension (dim_idx).identifier = 1 to print_vector_array.number_of_dimensions while (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).name ^= dimension_name); end; if print_vector.dimension (dim_idx).identifier > print_vector_array.number_of_dimensions then call vector_util_$append_dimension_print (work_area_ptr, free_old_print_vector_array, dimension_name, print_vector_array_ptr, null, print_vector.dimension (dim_idx).identifier, p_code); do temp_dim_idx = 1 to dim_idx - 1 while (print_vector.dimension (temp_dim_idx).identifier ^= print_vector.dimension (dim_idx).identifier); end; if temp_dim_idx < dim_idx then do; p_code = vd_error_$dim_already_in_vector; return; end; end; end; else do; do dim_idx = dim_idx + 1 to print_vector.number_of_dimensions; print_vector.dimension (dim_idx).value = ""; print_vector.dimension (dim_idx).identifier = 0; end; end; if old_print_vector_ptr ^= null then do; print_vector_array.vector_slot (vector_slot_idx) = print_vector_ptr; free old_print_vector_ptr -> print_vector in (work_area); old_print_vector_ptr = null; end; return; %include vu_print_vector_array; %page; %include desc_types; %page; %include descriptor; %page; %include arg_list; %page; %include vu_entry_dcls; end vu_append_general_print;  vu_append_simple_print.pl1 02/16/84 1306.5r w 02/16/84 1249.9 76131 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_append_simple_print: append_simple_print_vector: proc (); /* DESCRIPTION: This entry appends a print vector to a print vector array. */ /* History: Written by Lindsey Spratt, 02/01/82. Modified: 08/23/82 by Lindsey Spratt: Fixed to set the vector_slot when the number_of_vectors is less than or equal to the number of vector slots. */ /* START OF DECLARATIONS */ /* Parameter */ /* Automatic */ dcl CODE_ARG_IDX fixed bin; dcl PVA_PTR_ARG_IDX fixed bin; dcl dim_idx fixed bin; dcl values_given bit (1) aligned init ("0"b); dcl old_pva_ptr ptr; dcl vector_idx fixed bin; dcl free_old_print_vector_array_ptr ptr; dcl arg_list_arg_count fixed bin; dcl arg_list_ptr ptr; dcl type fixed bin; dcl packed bit (1) aligned; dcl size fixed bin; dcl ndims fixed bin; dcl scale fixed bin; dcl p_code_ptr ptr; dcl nargs fixed bin; dcl arg_idx fixed bin; dcl work_area_ptr ptr; /* Based */ dcl free_old_print_vector_array bit (1) aligned based (free_old_print_vector_array_ptr); dcl work_area area based (work_area_ptr); dcl s_fixed_real_template based fixed bin; dcl ptr_template based ptr; dcl v_char_template based char (size) varying; dcl char_template based char (size); dcl p_code based (p_code_ptr) fixed bin (35); /* Builtin */ dcl null builtin; /* Controlled */ /* Constant */ dcl MYNAME init ("vector_util_$init_print_vector_array") char (40) varying internal static options (constant); dcl ( AREA_PTR_ARG_IDX init (1), SLOT_INCREASE_ARG_IDX init (2), FREE_OLD_PVA_ARG_IDX init (3), MAXIMUM_VALUE_LENGTH_ARG_IDX init (4), NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING init (3), PVA_PTR_ARG_OFFSET_FROM_END init (1), NUMBER_OF_NONVALUE_ARGS_AT_END init (2) ) fixed bin internal static options (constant); /* Entry */ dcl cu_$arg_list_ptr entry (ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl cu_$arg_count entry (fixed bin); dcl sub_err_ entry () options (variable); /* External */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$fatal_error fixed bin (35) ext; /* END OF DECLARATIONS */ call cu_$arg_count (nargs); arg_list_arg_count = nargs; call cu_$arg_list_ptr (arg_list_ptr); CODE_ARG_IDX = nargs; PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END; call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then call sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0, "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME); p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX); call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template; call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template; call decode_descriptor_ (arg_list_ptr, SLOT_INCREASE_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then do; p_code = error_table_$bad_arg; return; end; pva_number_of_vector_slots = print_vector_array.number_of_vector_slots + arg_list_ptr -> arg_list.arg_ptrs (SLOT_INCREASE_ARG_IDX) -> s_fixed_real_template; call decode_descriptor_ (arg_list_ptr, FREE_OLD_PVA_ARG_IDX, type, packed, ndims, size, scale); if type ^= bit_desc | packed | size ^= 1 then do; p_code = error_table_$bad_arg; return; end; free_old_print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (FREE_OLD_PVA_ARG_IDX); pv_number_of_dimensions = print_vector_array.number_of_dimensions; call decode_descriptor_ (arg_list_ptr, MAXIMUM_VALUE_LENGTH_ARG_IDX, type, packed, ndims, size, scale); if type = s_fixed_real_desc then if ^packed then do; pv_maximum_value_length = arg_list_ptr -> arg_list.arg_ptrs (MAXIMUM_VALUE_LENGTH_ARG_IDX) -> s_fixed_real_template; values_given = "0"b; end; else do; p_code = error_table_$bad_arg; return; end; else do; values_given = "1"b; pv_maximum_value_length = 0; do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END; call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type = v_char_desc | type = char_desc then do; pv_maximum_value_length = max (pv_maximum_value_length, length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template))); end; else do; p_code = error_table_$bad_arg; return; end; end; end; alloc print_vector in (work_area); print_vector_array.number_of_vectors = print_vector_array.number_of_vectors + 1; if print_vector_array.number_of_vectors > print_vector_array.number_of_vector_slots then do; pva_maximum_dimension_name_length = print_vector_array.maximum_dimension_name_length; pva_number_of_dimensions = print_vector_array.number_of_dimensions; old_pva_ptr = print_vector_array_ptr; alloc print_vector_array in (work_area); print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2; print_vector_array.dimension_table = old_pva_ptr -> print_vector_array.dimension_table; print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors; /* This number includes the newly created print_vector. */ do vector_idx = 1 to print_vector_array.number_of_vectors - 1; print_vector_array.vector_slot (vector_idx) = old_pva_ptr -> print_vector_array.vector_slot (vector_idx); end; print_vector_array.vector_slot (vector_idx) = print_vector_ptr; if free_old_print_vector_array then free old_pva_ptr -> print_vector_array in (work_area); end; else print_vector_array.vector_slot (print_vector_array.number_of_vectors) = print_vector_ptr; if values_given then do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END; call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type = v_char_desc | type = char_desc then print_vector.dimension (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING).value = rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template); else do; p_code = error_table_$bad_arg; return; end; print_vector.dimension (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING).identifier = arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING; end; else do dim_idx = 1 to print_vector.number_of_dimensions; print_vector.dimension (dim_idx).value = ""; print_vector.dimension (dim_idx).identifier = dim_idx; end; return; %include vu_print_vector_array; %page; %include desc_types; %page; %include descriptor; %page; %include arg_list; end vu_append_simple_print;  vu_cv_pva_to_string.pl1 02/16/84 1306.5r w 02/16/84 1249.9 46341 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_cv_pva_to_string: proc (p_print_vector_array_ptr, p_pva_string_ptr, p_pva_string_length, p_code); /* DESCRIPTION: This entry takes a print_vector_array as input and produces a bit string as output which is suitable for permanent storage, formatted as a pva_string followed by any number of pv_strings. */ /* HISTORY: Written by Lindsey L. Spratt, 07/24/83. Modified: */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_print_vector_array_ptr ptr; /*is a pointer to a print_vector_array.*/ dcl p_pva_string_ptr ptr; /*is a pointer to a buffer in which the pva_string is to be placed.*/ dcl p_pva_string_length fixed bin (35); /*on input, this is the length in bytes of the pva_string buffer; on output, this is the length in bytes of the pva_string produced.*/ dcl p_code fixed bin (35); /*is a standard system error code.*/ /* Automatic */ dcl (pva_string_length_in_words, pva_string_buffer_length_in_words) fixed bin (35) init (0); dcl (dim_idx, vector_idx) init (0) fixed bin; /* Based */ /* Builtin */ dcl (addwordno, currentsize, divide, null) builtin; /* Constant */ dcl BYTES_PER_WORD init (4) fixed bin (35) internal static options (constant); dcl myname init ("vu_cv_pva_to_string") char (32) varying internal static options (constant); /* Entry */ dcl sub_err_ entry () options (variable); /* External */ dcl ( error_table_$unimplemented_version, error_table_$fatal_error ) fixed bin (35) ext; /* END OF DECLARATIONS */ p_code = 0; print_vector_array_ptr = p_print_vector_array_ptr; call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); pva_string_ptr = p_pva_string_ptr; pva_string.number_of_dimensions = print_vector_array.number_of_dimensions; pva_string.maximum_name_length = print_vector_array.maximum_dimension_name_length; pva_string_buffer_length_in_words = divide (p_pva_string_length, BYTES_PER_WORD, 35, 0); pva_string_length_in_words = currentsize (pva_string); if pva_string_length_in_words > pva_string_buffer_length_in_words then call sub_err_ (error_table_$fatal_error, myname, ACTION_CANT_RESTART, null, 0, "^/The buffer provided by the caller to hold the pva_string was only ^d words long, when ^d words are required to hold just the pva_string structure.", pva_string_buffer_length_in_words, pva_string_length_in_words); pva_string.version = PVA_STRING_VERSION_1; pva_string.number_of_vectors = print_vector_array.number_of_vectors; do dim_idx = 1 to print_vector_array.number_of_dimensions; pva_string.dimension_table (dim_idx).name = print_vector_array.dimension_table (dim_idx).name; end; do vector_idx = 1 to print_vector_array.number_of_vectors; pv_string_ptr = addwordno (pva_string_ptr, pva_string_length_in_words); print_vector_ptr = print_vector_array.vector_slot (vector_idx); pv_string.number_of_dimensions = print_vector.number_of_dimensions; pv_string.maximum_value_length = print_vector.maximum_value_length; do dim_idx = 1 to print_vector.number_of_dimensions; pv_string.dimension (dim_idx).identifier = print_vector.dimension (dim_idx).identifier; pv_string.dimension (dim_idx).value = print_vector.dimension (dim_idx).value; end; pva_string_length_in_words = pva_string_length_in_words + currentsize (pv_string); end; p_pva_string_length = BYTES_PER_WORD * pva_string_length_in_words; return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; %include sub_err_flags; %page; %include vu_pva_string; %page; %include vu_print_vector_array; end vu_cv_pva_to_string;  vu_cv_string_to_pva.pl1 02/16/84 1306.5r w 02/16/84 1249.9 54360 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_cv_string_to_pva: proc (p_pva_string_ptr, p_pva_string_length, p_area_ptr, p_print_vector_array_ptr, p_code); /* DESCRIPTION: This entry converts a pva_string representation of a print_vector_array back into a print_vector_array. */ /* HISTORY: Written by Lindsey L. Spratt, 07/24/83. Modified: */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_pva_string_ptr ptr; /*is a pointer to a pva_string.*/ dcl p_pva_string_length fixed bin (35); /*is the length of the pva_string in bytes.*/ dcl p_area_ptr ptr; /*is a pointer to a PL1 area in which the converted print_vector_array is to be placed.*/ dcl p_print_vector_array_ptr ptr; /*is a pointer to a print_vector_array which is the converted version of the pva_string.*/ dcl p_code fixed bin (35); /*is a standard system error code.*/ /* Automatic */ dcl (dim_idx, vector_idx) fixed bin (17) init (0); dcl current_pva_string_word_offset fixed bin (35) init (0); /* Based */ /* Builtin */ dcl (addwordno, currentsize, length, max, null) builtin; /* Constant */ dcl ( DEFAULT_SLOT_INCREASE_FACTOR init (0) fixed bin (35), DEFAULT_VECTOR_SLOT_IDX init (-1) fixed bin (35), DONT_FREE_OLD_PVA init ("0"b) bit (1) aligned, myname init ("vu_cv_string_to_pva") char (32) varying ) internal static options (constant); /* Entry */ dcl sub_err_ entry () options (variable); /* External */ dcl error_table_$unimplemented_version fixed bin (35) ext; /* END OF DECLARATIONS */ pva_string_ptr = p_pva_string_ptr; call CHECK_VERSION (pva_string.version, PVA_STRING_VERSION_1, "pva_string"); call vector_util_$init_print_vector_array (p_area_ptr, bin (pva_string.number_of_vectors, 35, 0), bin (pva_string.number_of_dimensions, 35, 0), bin (pva_string.maximum_name_length, 35, 0), print_vector_array_ptr, p_code); if p_code ^= 0 then return; call CHECK_VERSION_FB (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array"); print_vector_array.number_of_vectors = 0; /* This value is incremented by $append_general_print_vector */ do dim_idx = 1 to pva_string.number_of_dimensions; print_vector_array.dimension_table (dim_idx).name = pva_string.dimension_table (dim_idx).name; print_vector_array.dimension_table (dim_idx).maximum_value_length = 0; end; current_pva_string_word_offset = currentsize (pva_string); do vector_idx = 1 to pva_string.number_of_vectors; pv_string_ptr = addwordno (pva_string_ptr, current_pva_string_word_offset); call vector_util_$append_general_print_vector (p_area_ptr, DEFAULT_SLOT_INCREASE_FACTOR, DONT_FREE_OLD_PVA, DEFAULT_VECTOR_SLOT_IDX, bin (pv_string.number_of_dimensions, 35, 0), bin (pv_string.maximum_value_length, 35, 0), print_vector_array_ptr, p_code); if p_code ^= 0 then call ERROR_RETURN (); print_vector_ptr = print_vector_array.vector_slot (print_vector_array.number_of_vectors); do dim_idx = 1 to pv_string.number_of_dimensions; print_vector.dimension (dim_idx).identifier = pv_string.dimension (dim_idx).identifier; print_vector.dimension (dim_idx).value = pv_string.dimension (dim_idx).value; print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length = max (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length, length (print_vector.dimension (dim_idx).value)); end; current_pva_string_word_offset = current_pva_string_word_offset + currentsize (pv_string); end; p_print_vector_array_ptr = print_vector_array_ptr; MAIN_RETURN: return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version char (*); dcl p_expected_version char (*); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; CHECK_VERSION_FB: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^a of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION_FB; %page; ERROR_RETURN: proc; goto MAIN_RETURN; end ERROR_RETURN; %page; %include sub_err_flags; %page; %include vu_print_vector_array; %page; %include vu_pva_string; %page; %include vu_entry_dcls; end vu_cv_string_to_pva;  vu_err_no_operation.pl1 02/16/84 1306.5r w 02/16/84 1249.9 7362 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_err_no_operation: err_no_operation: proc (p1_ptr, p2_fb17, p3_fb17, p4_ptr, p5_ptr, p_code); dcl p1_ptr ptr; dcl p2_fb17 fixed bin (17); dcl p3_fb17 fixed bin (17); dcl p4_ptr ptr; dcl p5_ptr ptr; dcl p_code fixed bin (35); dcl error_table_$no_operation ext fixed bin (35); p_code = error_table_$no_operation; end vu_err_no_operation;  vu_init_print_vector_array.pl1 02/16/84 1306.5r w 02/16/84 1249.9 65268 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_init_print_vector_array: init_print_vector_array: proc (); /* Written by Lindsey Spratt. Modified: 03/09/82 by Lindsey Spratt: Changed to use named constants for the position of the arguments. Added another calling sequence. */ /* START OF DECLARATIONS */ /* Parameter */ /* Automatic */ dcl names_given bit (1) aligned init ("0"b); dcl arg_list_arg_count fixed bin; dcl arg_list_ptr ptr; dcl type fixed bin; dcl packed bit (1) aligned; dcl size fixed bin; dcl ndims fixed bin; dcl scale fixed bin; dcl CODE_ARG_IDX fixed bin; dcl PVA_PTR_ARG_IDX fixed bin; dcl p_code_ptr ptr; dcl nargs fixed bin; dcl arg_idx fixed bin; dcl work_area_ptr ptr; /* Based */ dcl work_area area based (work_area_ptr); dcl s_fixed_real_template based fixed bin; dcl ptr_template based ptr; dcl v_char_template based char (size) varying; dcl char_template based char (size); dcl p_code based (p_code_ptr) fixed bin (35); /* Builtin */ dcl null builtin; /* Controlled */ /* Constant */ dcl MYNAME init ("vector_util_$init_print_vector_array") char (40) varying internal static options (constant); dcl ( AREA_PTR_ARG_IDX init (1), NUMBER_OF_SLOTS_ARG_IDX init (2), NUMBER_OF_NONNAME_ARGS_AT_BEGINNING init (2), PVA_PTR_ARG_OFFSET_FROM_END init (1), NUMBER_OF_NONNAME_ARGS_AT_END init (2), NUMBER_OF_DIMENSIONS_ARG_IDX init (3), MAX_DIM_NAME_LEN_ARG_IDX init (4) ) fixed bin (17) internal static options (constant); /* Entry */ dcl vector_util_$err_no_operation entry (ptr, fixed bin (17), fixed bin (17), ptr, ptr, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl cu_$arg_count entry (fixed bin); dcl sub_err_ entry () options (variable); /* External */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$fatal_error fixed bin (35) ext; /* END OF DECLARATIONS */ call cu_$arg_count (nargs); arg_list_arg_count = nargs; call cu_$arg_list_ptr (arg_list_ptr); CODE_ARG_IDX = nargs; PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END; call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then call sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0, "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME); p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX); p_code = 0; call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template; call decode_descriptor_ (arg_list_ptr, NUMBER_OF_SLOTS_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then do; p_code = error_table_$bad_arg; return; end; pva_number_of_vector_slots = arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_SLOTS_ARG_IDX) -> s_fixed_real_template; call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale); if type ^= pointer_desc then do; p_code = error_table_$bad_arg; return; end; /* All of the arguments except for the vd_info_ptr, the max_splitter_len, the return pointer to the input_vector that is defined, and the final "code" argument, are dimension names.*/ call decode_descriptor_ (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, type, packed, ndims, size, scale); if type = s_fixed_real_desc then do; pva_number_of_dimensions = arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_DIMENSIONS_ARG_IDX) -> s_fixed_real_template; names_given = "0"b; call decode_descriptor_ (arg_list_ptr, MAX_DIM_NAME_LEN_ARG_IDX, type, packed, ndims, size, scale); if type ^= s_fixed_real_desc then do; p_code = error_table_$bad_arg; return; end; pva_maximum_dimension_name_length = arg_list_ptr -> arg_list.arg_ptrs (MAX_DIM_NAME_LEN_ARG_IDX) -> s_fixed_real_template; end; else do; names_given = "1"b; pva_number_of_dimensions = nargs - (NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + NUMBER_OF_NONNAME_ARGS_AT_END); pva_maximum_dimension_name_length = 0; do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END; call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type = v_char_desc | type = char_desc then do; pva_maximum_dimension_name_length = max (pva_maximum_dimension_name_length, length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template))); end; else do; p_code = error_table_$bad_arg; return; end; end; end; alloc print_vector_array in (work_area); print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2; print_vector_array.number_of_vectors = 0; print_vector_array.dimension_table.descriptor_ptr = null; print_vector_array.dimension_table.cv_to_print = vector_util_$err_no_operation; print_vector_array.dimension_table.cv_to_typed = vector_util_$err_no_operation; print_vector_array.dimension_table.maximum_value_length = 0; if names_given then do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END; call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale); if type = v_char_desc | type = char_desc then print_vector_array.dimension_table (arg_idx - NUMBER_OF_NONNAME_ARGS_AT_BEGINNING).name = rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template); else do; p_code = error_table_$bad_arg; return; end; end; else print_vector_array.dimension_table.name = ""; arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template = print_vector_array_ptr; return; %include vu_print_vector_array; %page; %include desc_types; %page; %include descriptor; %page; %include arg_list; end vu_init_print_vector_array;  vu_replace_print_value.pl1 02/16/84 1306.5r w 02/16/84 1249.9 45513 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ vu_replace_print_value: replace_print_value: proc (p_print_vector_array_ptr, p_print_vector_index, p_area_ptr, p_dimension_name, p_dimension_value, p_code); /* DESCRIPTION: This subroutine replaces the value of a specified dimension in a print vector. */ /* HISTORY: Written by S. Krupp, 06/07/83. Modified: */ /* START OF DECLARATIONS */ /* Automatic */ dcl i fixed bin; dcl old_pv_ptr ptr; dcl value_length fixed bin; /* Based */ dcl based_area area based (p_area_ptr); dcl 1 old_pv based (old_pv_ptr), /* like print_vector */ 2 number_of_dimensions fixed bin (17), 2 maximum_value_length fixed bin (35), 2 dimension (0 refer (old_pv.number_of_dimensions)), 3 identifier fixed bin (17), 3 value char (0 refer (old_pv.maximum_value_length)) varying; /* Builtin */ dcl (hbound, lbound, length, null) builtin; /* Constant */ dcl myname init ("vu_replace_print_value") char (32) varying internal static options (constant); /* Entry */ dcl sub_err_ entry () options (variable); /* External */ dcl error_table_$unimplemented_version fixed bin (35) ext; dcl ( vd_error_$bad_print_vector_index, vd_error_$dim_not_in_vector ) fixed bin (35) ext; /* Parameter */ dcl p_print_vector_array_ptr ptr; /*is a pointer to a print_vector_array.*/ dcl p_print_vector_index fixed bin; /*is the index of the print_vector in the print_vector_array that holds the dimension whose value is to be replaced.*/ dcl p_area_ptr ptr; /*is a pointer to an area where the print_vector may be reallocated if necessary.*/ dcl p_dimension_name char (*); /*is the name of the dimension whose value is to be replaced.*/ dcl p_dimension_value char (*); /*is the new value of the specified dimension.*/ dcl p_code fixed bin (35); /*is a standard system status code.*/ /* END OF DECLARATIONS */ p_code = 0; print_vector_array_ptr = p_print_vector_array_ptr; call CHECK_VERSION ((print_vector_array.version), (PRINT_VECTOR_ARRAY_VERSION_2), "print_vector_array"); if p_print_vector_index < lbound (print_vector_array.vector_slot, 1) | p_print_vector_index > hbound (print_vector_array.vector_slot, 1) then do; p_code = vd_error_$bad_print_vector_index; return; end; print_vector_ptr = print_vector_array.vector_slot (p_print_vector_index); do i = 1 to print_vector.number_of_dimensions while (print_vector_array.dimension_table (print_vector.dimension (i).identifier).name ^= p_dimension_name); end; if i > print_vector.number_of_dimensions then do; p_code = vd_error_$dim_not_in_vector; return; end; value_length = length (p_dimension_value); if value_length > print_vector.maximum_value_length then do; pv_maximum_value_length = value_length; pv_number_of_dimensions = print_vector.number_of_dimensions; old_pv_ptr = print_vector_ptr; allocate print_vector in (based_area) set (print_vector_ptr); print_vector.dimension = old_pv.dimension; print_vector_array.vector_slot (p_print_vector_index) = print_vector_ptr; free old_pv_ptr -> print_vector; end; print_vector.dimension (i).value = p_dimension_value; return; %page; CHECK_VERSION: proc (p_received_version, p_expected_version, p_structure_name); dcl p_received_version fixed bin (35); dcl p_expected_version fixed bin (35); dcl p_structure_name char (*); if p_received_version ^= p_expected_version then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0, "^/Expected version ^d of the ^a structure. Received version ^d instead.", p_expected_version, p_structure_name, p_received_version); end CHECK_VERSION; %page; %include sub_err_flags; %page; %include vu_print_vector_array; end vu_replace_print_value; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved