create_daemon_queues.pl1 10/28/88 1351.7rew 10/28/88 1234.0 94383 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ create_daemon_queues: cdq: procedure options (variable); /* Command for creating the dprint request queues and setting general access to them */ /* Uses iod_tables file to find out what request_types to create queues * for. Already existing queues are left alone. * * create_daemon_queues PATH {-control_args} * * PATH is the pfull pathname of an iod_tables segment * * * -dr path * -directory path * the queues will be created in the directory "path". * Defaults to >daemon_dir_dir>io_daemon_dir. * The iod tables iod_tables are used * * -reset_access forces default acl terms if queues already exist. * * Coded October 1973 by Robert S. Coren * Modified by J. Stern, 12/30/74 * Modified by J. C. Whitmore, 4/78, for max queues per request type. * Modified by J. C. Whitmore, 10/78, for version 3 iod_tables format. * Modified by Benson I. Margulies for PATHnames */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199): Changed to handle version 5 i/o daemon tables. END HISTORY COMMENTS */ dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_max_authorization_ entry returns (bit (72) aligned); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl message_segment_$create entry (char (*), char (*), fixed bin (35)); dcl message_segment_$ms_acl_add entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl system_info_$access_ceiling entry (bit (72) aligned); dcl system_high bit (72) aligned; dcl max_auth bit (72) aligned; dcl testing bit (1) aligned; dcl code fixed bin (35); dcl table_name char (32); dcl (dir, table) char (256); dcl dir_name char (168); dcl i fixed bin; dcl j fixed bin; dcl nargs fixed bin; dcl mseg_name char (32); dcl max_queues fixed bin; dcl reset_access bit (1); dcl (got_pn, got_dr) bit (1); dcl AROS bit (36) int static options (constant) init ("10111"b); dcl NONE bit (36) int static options (constant) init (""b); declare Default_io_daemon_dir init (">daemon_dir_dir>io_daemon_dir") char (168) int static options (constant); declare Default_iod_tables init ("iod_tables") char (32) int static options (constant); dcl 1 acla (4) aligned int static options (constant), 2 userid char (32) init ("IO.SysDaemon.*", "*.SysDaemon.*", "*.*.*", "*.*.*"), 2 access bit (36) init ((4) (1)"111"b), /* REW real access for all acl terms */ 2 ex_access bit (36) init ("11111"b, (2) (1)"10111"b, "00000"b), /* ADROS AROS AROS NULL */ 2 errcode fixed bin (35); dcl 1 an_acl (4) aligned like acla; /* automatic version */ dcl nacl fixed bin; /* number of acl entries defined above */ dcl argptr ptr; dcl arglen fixed bin; dcl arg char (arglen) based (argptr); dcl ( error_table_$badopt, error_table_$namedup, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args ) fixed bin (35) ext static; dcl myname char (20) int static init ("create_daemon_queues"); dcl cleanup condition; dcl (addr, after, null, ptr, substr) builtin; %page; testing = "0"b; /* not testing unless "-dir" option specified */ reset_access = "0"b; /* do not set access on existing queues */ /* find arguments if any */ call cu_$arg_count (nargs, code); /* get number of arguments given */ if code ^= 0 then do; call com_err_ (code, myname); return; /* We do not make a very useful AF */ end; table = ""; dir = ""; reset_access, got_pn, got_dr = ""b; do i = 1 to nargs; call cu_$arg_ptr (i, argptr, arglen, (0)); /* guaranteed by the doloop limit */ if substr (arg, 1, 1) = "-" then do; /* control argument */ if arg = "-dr" | arg = "-dir" | arg = "-directory" then do; /* REMOVE -dir SOMEDAY --bim */ i = i + 1; /* look at next arg */ if i > nargs then do; no_dp: call com_err_ (error_table_$noarg, myname, "-directory requires a pathname.") ; return; end; call cu_$arg_ptr (i, argptr, arglen, (0)); /* we know how many we have */ if substr (arg, 1, 1) = "-" then do; call com_err_ (error_table_$noarg, myname, "-directory requires a pathname. Control argument ^a was in error.", arg); return; end; if got_pn then do; call com_err_ (error_table_$inconsistent, myname, "-directory may not be given if a iod table pathname is given."); return; end; if got_dr then do; call com_err_ (error_table_$inconsistent, myname, "-directory may not be supplied twice"); return; end; got_dr = "1"b; dir = arg; /* do absolute pathname later */ testing = "1"b; /* test dir specified */ end; else if arg = "-reset_access" then reset_access = "1"b; /* set access on existing queues */ else do; call com_err_ (error_table_$badopt, myname, arg); return; end; end; /* the control arg dept. */ else do; /* a pathname */ if got_pn then do; call com_err_ (error_table_$too_many_args, myname, "Only one pathname may be supplied."); return; end; got_pn = "1"b; table = arg; testing = "1"b; end; /* the pathname */ end; /* the control arg loop */ if got_dr then do; call absolute_pathname_ (dir, dir_name, code); if code ^= 0 then do; call com_err_ (code, myname, "directory pathname ^a.", dir); return; end; table_name = Default_iod_tables; end; else if got_pn then do; call expand_pathname_ (table, dir_name, table_name, code); if code ^= 0 then do; call com_err_ (code, myname, "table pathname ^a.", table); return; end; end; else do; /* vanilla case */ table_name = Default_iod_tables; dir_name = Default_io_daemon_dir; end; /* If we're not testing, make sure caller's max authorization is "system_high". */ /* If it's not, any queues created will not be accessible at all authorizations. */ if ^testing then do; max_auth = get_max_authorization_ (); call system_info_$access_ceiling (system_high); if ^aim_check_$equal (system_high, max_auth) then /* max authorization is not system high */ call com_err_ (0, myname, "Warning -- Your maximum authorization is not ""system_high""."); end; /* get a pointer to the iod_tables segment */ ithp = null (); on cleanup begin; if ithp ^= null () then call hcs_$terminate_noname (ithp, (0)); end; call hcs_$initiate (dir_name, table_name, "", (0), (0), ithp, code); if ithp = null () then do; call com_err_ (code, myname, "^a>^a", dir_name, table_name); return; end; if iod_tables_hdr.version ^= IODT_VERSION_5 then do; /* check version number */ call com_err_ (0, myname, "Wrong version number for iod_tables."); go to finish; end; /* now create the queues */ qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset); /* get q group table ptr */ do j = 1 to q_group_tab.n_q_groups; qgtep = addr (q_group_tab.entries (j)); an_acl = acla; max_queues = qgte.max_queues; /* get max queues for this request type */ if qgte.driver_id = "IO.SysDaemon.*" then do; /* standard system driver */ an_acl (2).ex_access = AROS; /* let SysDaemons use it like other users */ an_acl (3).userid = "*.*.*"; /* this queue is for all users */ an_acl (3).ex_access = AROS; /* give them all access */ nacl = 3; /* say only three entries are defined */ end; else do; /* non-standard driver for this queue */ an_acl (2).ex_access = NONE; /* project must request SysDaemon access */ an_acl (3).userid = "*." || after (qgte.driver_id, "."); /* give access to all on project */ an_acl (3).ex_access = AROS; /* give them all access */ nacl = 4; /* we have four entries now */ end; do i = 1 to max_queues; call ioa_$rsnnl ("^a_^d.ms", mseg_name, arglen, qgte.name, i); call message_segment_$create (dir_name, mseg_name, code); if code = 0 then do; /* created one, set up acl. */ call ioa_ ("^a created.", mseg_name); set_access: call message_segment_$ms_acl_add (dir_name, mseg_name, addr (an_acl), nacl, code); if code ^= 0 then call com_err_ (code, myname, "Adding extended acl to ^a", mseg_name); end; else if code ^= error_table_$namedup then call com_err_ (code, myname, "Could not create ^a", mseg_name); else if reset_access then go to set_access; /* if queue exists, skip set_acl unless asked */ end; end; finish: call hcs_$terminate_noname (ithp, code); return; %page; %include iod_tables_hdr; %page; %include q_group_tab; end create_daemon_queues;  find_next_request_.pl1 10/28/88 1351.7rew 10/28/88 1234.0 147339 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ find_next_request_: proc (dev_class_index, descr_ptr) returns (bit (1) aligned); /* This is the io_coordinator procedure used for reading request messages * out of the IO daemon queues. It is normally the only procedure that * reads from message segments into request descriptors. * * This procedure returns a bit(1) result indicating whether or not it actually * found a message in the queue(s). */ /* Coded August 1973 by Robert S. Coren */ /* Modified for the Access Isolation Mechanism by J. Stern, 12/26/74 */ /* Modified by J. Stern, 11/25/75 */ /* Modified by J. C. Whitmore, 4/78, for max_queues per request type and new iod_tables format */ /* Modified by J. C. Whitmore, 7/78, for priority requests in waiting list */ /* Modified by J. C. Whitmore, 4/80, to mark the state of running requests */ /* Modified by R. Kovalcik, 6/82, to handle defer_until_process_termination */ /* Modified by R. Kovlacik, 1/83, to fix a problem in interaction between dupt and multiple printers */ /* Modified by C. Marker, 02/23/85, to use message_segment_$read_message_index to support version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. END HISTORY COMMENTS */ dcl dev_class_index fixed bin; /* index of device class entry (INPUT) */ dcl descr_ptr ptr; /* pointer to request descriptor to be filled in (INPUT) */ dcl code fixed bin (35); dcl err_len fixed bin; dcl err_mess char (200); dcl found bit (1) aligned; dcl (queue, q) fixed bin; /* queue number variables */ dcl last_id bit (72) aligned; dcl dcp ptr; dcl retp ptr; dcl q_idx fixed bin; dcl wlp ptr int static; /* ptr to the waiting list */ dcl dcx fixed bin; /* device class table entry index */ dcl i fixed bin; /* loop variable */ dcl auth bit (72) aligned; /* used to hold the sender authorization of a message */ dcl auth_string char (170); /* char string version of "auth" */ dcl message_len fixed bin (18); /* bit length of based_message */ dcl based_message bit (message_len) aligned based; /* a message read from a queue */ dcl (x, y, z) fixed bin; /* waiting list entry subscripts */ dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl free_oldest_request_$force entry; dcl ioa_$rsnnl entry options (variable); dcl iodc_message_ entry (bit (3) aligned, fixed bin (35), char (*)); dcl message_segment_$read_message_index entry (fixed bin, ptr, ptr, fixed bin (35)); dcl message_segment_$update_message_index entry (fixed bin, fixed bin (18), bit (72) aligned, ptr, fixed bin (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl re_read bit (2) int static options (constant) init ("00"b); /* mseg code to read given msg id */ dcl next_msg bit (2) int static options (constant) init ("01"b); /* mseg code to read next message forward */ dcl priority fixed bin int static options (constant) init (2); /* state code for priority requests */ dcl normal fixed bin int static options (constant) init (1); /* state code for normal priority */ dcl unused fixed bin int static options (constant) init (0); /* state code for a free entry */ dcl error_table_$bad_segment fixed bin (35) ext; dcl error_table_$invalid_lock_reset fixed bin (35) ext; dcl error_table_$no_message fixed bin (35) ext; dcl error_table_$notalloc fixed bin (35) ext; dcl (addr, unspec) builtin; %page; dcx = dev_class_index; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); /* get ptr to device class */ qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); /* get q group table entry ptr */ retp, mseg_message_info_ptr = descr_ptr; /* this points to mseg return args and request desc */ do queue = 1 to qgte.max_queues; call read_one; /* read a message from queue or list */ if found then do; /* got one */ retp -> request_descriptor.q = q; /* set source queue */ retp -> request_descriptor.charge_q = queue; /* and charging queue */ retp -> request_descriptor.dev_class_index = dcx; return ("1"b); end; end; /* no request found */ return ("0"b); read_one: proc; /* This subroutine first checks the waiting list of the target device class. If the waiting list is non-empty, the first waiting request is reread. Otherwise, the ID of the last read message from the current queue is checked. If zero, the first message is read from the queue. If non-zero, the next message is read. If the authorization of the new message fits the target device class access range and it should not be deferred for process termination, the message is returned. Otherwise it is appended to the waiting list of some other device class and the entire above procedure is repeated. */ dcl direction bit (2) aligned; /* = 01 if reading ahead, 00 if rereading */ dcl (bad, space) fixed bin; dcl dupt bit (1) aligned; /* flag to note process is still around */ dcl scan_wait bit (1) aligned; /* flag to scan wait list */ found = "0"b; scan_wait = (dcte.first_waiting (queue) ^= 0); z = dcte.last_waiting (queue); /* save stop marker */ next: if scan_wait then do; /* loop through requests in waiting list */ x = dcte.first_waiting (queue); /* get waiting list head index for this queue */ last_id = wlp -> waiting_list.ms_id (x);/* get message id of the request */ if wlp -> waiting_list.state (x) = priority then retp -> request_descriptor.priority_request = "1"b; else retp -> request_descriptor.priority_request = ""b; q = wlp -> waiting_list.orig_q (x); /* could have come from another queue */ if wlp -> waiting_list.next (x) = 0 then /* no more requests in waiting list */ dcte.last_waiting (queue), dcte.first_waiting (queue) = 0; else dcte.first_waiting (queue) = wlp -> waiting_list.next (x); /* advance the list */ dcte.n_waiting = dcte.n_waiting - 1; if (x = z) | (dcte.first_waiting (queue) = 0) then scan_wait = "0"b; /* if we are done with this, note it */ call free_wle; /* free the waiting list entry */ direction = re_read; end; else do; /* look through the queue */ q = queue; /* read a fresh request from the current queue */ last_id = qgte.last_read (q); /* prepare to read request after the last */ retp -> request_descriptor.priority_request = "0"b; /* this can't be priority */ direction = next_msg; end; q_idx = qgte.mseg_index (q); /* get message segment index for read call */ if q_idx = 0 then return; /* if it was dropped forget it */ bad, space = 0; unspec (mseg_message_info) = ""b; mseg_message_info.version = MSEG_MESSAGE_INFO_V1; mseg_message_info.ms_id = last_id; retry: if last_id = "0"b /* no previous message, read one first */ then mseg_message_info.message_code = MSEG_READ_FIRST; else if direction = re_read then mseg_message_info.message_code = MSEG_READ_SPECIFIED; else if direction = next_msg then mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED; call message_segment_$read_message_index (q_idx, iodc_static.req_seg_ptr, mseg_message_info_ptr, code); if code = 0 then do; /* fine */ dupt = "0"b; /* prepare to check for defer_until process termination */ if mseg_message_info.ms_ptr -> queue_msg_hdr.defer_until_process_termination then do; /* check to see if defer_until_process_termination is requested */ call set_lock_$lock (mseg_message_info.ms_ptr -> queue_msg_hdr.dupt_lock, 1, code); /* test to see if the process is still around */ if (code ^= 0) & (code ^= error_table_$invalid_lock_reset) then dupt = "1"b; /* it is, defer request until later */ else call set_lock_$unlock (mseg_message_info.ms_ptr -> queue_msg_hdr.dupt_lock, code); /* else, unlock the lock for good measure */ end; /* end of DUPT processing */ if direction = re_read then do; /* request is from wait list */ if ^dupt then do; /* when request was from wait list and dupt is ok, we are done */ call mark_request (STATE_RUNNING, code); if code ^= 0 then go to next; found = "1"b; end; else do; call add_wle (dupt, dctep); /* otherwise, add it back to wait list! */ goto flush; /* and try again */ end; end; else do; /* else request is from queue, check authorization */ qgte.last_read (q) = mseg_message_info.ms_id; /* update last_read */ auth = mseg_message_info.sender_authorization; do i = qgte.first_dev_class to qgte.last_dev_class; /* find dev class with right access range */ dcp = addr (iodc_static.dctp -> dev_class_tab.entries (i)); if aim_check_$greater_or_equal (auth, dcp -> dcte.min_access) then if aim_check_$greater_or_equal (dcp -> dcte.max_access, auth) then /* range is right */ if (dcx = i) & ^dupt then do; /* bingo, this is our device class and we aren't waitng for process termination */ call mark_request (STATE_RUNNING, code); if code ^= 0 then go to next; found = "1"b; return; end; else do; /* request belongs to another dev class or is waiting process termination, add it to waiting list */ call add_wle (dupt, dcp); go to flush; /* free this one and try the next one */ end; end; /* come here if we fell through, i.e. no device class had right access range for request */ auth_string = ""; call convert_authorization_$to_string_short (auth, auth_string, code); call ioa_$rsnnl ("Request skipped for request type ^a.^/Unexpected access class: ^a", err_mess, err_len, qgte.name, auth_string); call iodc_message_ ("101"b, 0, err_mess); /* tell the operator */ flush: message_len = mseg_message_info.ms_len; free mseg_message_info.ms_ptr -> based_message in (req_area); /* free request */ go to next; end; end; else if code = error_table_$no_message then /* this is okay too, but there's no message */ if direction = re_read then go to next; /* waiting request must have been cancelled */ else return; /* the queue is exhausted */ else do; /* not so good */ if code = error_table_$bad_segment then if bad = 0 then do; /* message seg. was just salvaged, try again */ bad = 1; /* once */ call ioa_$rsnnl ("Requests may be lost from queue ^d of request type ""^a"".", err_mess, err_len, q, qgte.name); call iodc_message_ ("101"b, code, err_mess); go to retry; end; if code = error_table_$notalloc then if space = 0 then do; /* if we couldn't allocate try freeing one */ space = 1; call free_oldest_request_$force; go to retry; end; /* come here if an unrecoverable error occurred */ /* report error and drop the offending queue */ call ioa_$rsnnl ("Dropping queue ^d of queue group ^a", err_mess, err_len, q, qgte.name); call iodc_message_ ("101"b, code, err_mess); /* tell the operator */ qgte.mseg_index (q) = 0; /* turn off the queue */ end; return; end read_one; %page; add_wle: proc (dupt_flag, dc_ptr); dcl dupt_flag bit (1) aligned; dcl dc_ptr pointer; call allocate_wle; /* get a waiting list entry */ if y = 0 then do; /* ugh, out of space */ call ioa_$rsnnl ("Waiting list full. Request skipped from queue ^a_^d.ms", err_mess, err_len, qgte.name, q); call iodc_message_ ("101"b, 0, err_mess); /* tell the operator */ end; else do; /* chain request into waiting list */ wlp -> waiting_list.ms_id (y) = mseg_message_info.ms_id; wlp -> waiting_list.state (y) = normal; /* normal waiting request */ wlp -> waiting_list.orig_q (y) = q; /* queue it is from */ if dc_ptr -> dcte.last_waiting (q) > 0 then /* waiting list is not empty */ wlp -> waiting_list.next (dc_ptr -> dcte.last_waiting (q)) = y; else dc_ptr -> dcte.first_waiting (q) = y; dc_ptr -> dcte.last_waiting (q) = y; dc_ptr -> dcte.n_waiting = dc_ptr -> dcte.n_waiting + 1; if dupt_flag then call mark_request (STATE_DUPT, (0)); else call mark_request (STATE_DEFERRED, (0)); end; end add_wle; %page; allocate_wle: proc; /* procedure to allocate a waiting list entry */ y = wlp -> waiting_list.first_free; if y > 0 then do; /* take block from free list */ wlp -> waiting_list.first_free = wlp -> waiting_list.next (y); /* move free list head */ wlp -> waiting_list.next (y) = 0; /* don't leave junk around */ end; else if wlp -> waiting_list.last_used = max_wl_size then y = 0; /* no more room */ else y, wlp -> waiting_list.last_used = wlp -> waiting_list.last_used + 1; /* raise high-water mark */ if y > 0 then do; /* clear the new entry */ wlp -> waiting_list.state (y) = unused; wlp -> waiting_list.next (y) = 0; wlp -> waiting_list.orig_q (y) = 0; wlp -> waiting_list.ms_id (y) = ""b; end; end allocate_wle; %page; free_wle: proc; /* procedure to free a waiting list entry */ if x = wlp -> waiting_list.last_used then do; /* lower high-water mark */ wlp -> waiting_list.last_used = wlp -> waiting_list.last_used - 1; wlp -> waiting_list.next (x) = 0; end; else do; /* add to head of free list */ wlp -> waiting_list.next (x) = wlp -> waiting_list.first_free; wlp -> waiting_list.first_free = x; end; wlp -> waiting_list.state (x) = unused; /* mark it as free */ wlp -> waiting_list.ms_id (x) = ""b; end free_wle; %page; mark_request: proc (new_state, code); dcl new_state fixed bin; dcl code fixed bin (35); dcl msg_p ptr; dcl msg_id bit (72) aligned; dcl msg_len fixed bin (18); dcl retry fixed bin; msg_p = mseg_message_info.ms_ptr; /* get ptr to msg text */ msg_p -> queue_msg_hdr.state = new_state; /* tell user */ msg_id = mseg_message_info.ms_id; /* get ready to re-write the message */ msg_len = mseg_message_info.ms_len; retry = 0; update: call message_segment_$update_message_index (q_idx, msg_len, msg_id, msg_p, code); if code ^= 0 then /* normal test should be cheap */ if code = error_table_$bad_segment /* message seg was salvaged */ then if retry = 0 then do; /* try once more */ retry = 1; go to update; end; end mark_request; %page; init: entry (a_ptr); dcl a_ptr ptr; stat_p = a_ptr; /* get ptr to iodc_static */ wlp = iodc_static.wait_list_ptr; wlp -> waiting_list.first_free, wlp -> waiting_list.last_used = 0; do dcx = 1 to iodc_static.dctp -> dev_class_tab.n_classes; /* init per device class info */ dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); dcte.n_waiting = 0; do q = 1 to 4; /* clear waiting list indices for all possible queues */ dcte.first_waiting (q), dcte.last_waiting (q) = 0; end; end; return; %page; %include device_class; %page; %include iod_tables_hdr; %page; %include iodc_static; %page; %include iodc_wait_list; %page; %include mseg_message_info; %page; %include q_group_tab; %page; %include queue_msg_hdr; %page; %include request_descriptor; end find_next_request_;  free_oldest_request_.pl1 03/14/85 0831.6r 03/13/85 1025.6 58995 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ free_oldest_request_: proc; /* Procedure to free oldest inactive request and associated descriptor. * Normally invoked in response to alarm call set when request was * completed, but also called by find_next_request_ if it didn't have space * to allocate a fresh message. * * This procedure will also delete the file if the user so requested (first * making sure he has "m" access on the directory containing it). */ /* Coded August 1973 by Robert S. Coren */ /* Modified by J. Stern, 12/27/74 */ /* Modified by J. Stern, 11/25/75 */ /* Modified by J. C. Whitmore, 4/78, to use the new queue_msg_hdr format */ /* Modified by C. Marker, 02/23/85, to use version 5 message segments */ dcl desc_off fixed bin (18); dcl desc_p ptr; /* pointer to a descriptor */ dcl code fixed bin (35); dcl mask_code fixed bin (35); dcl acc_mode fixed bin (5); /* access in form returned by get_user_effmode */ dcl dirname char (168); dcl ename char (32); dcl ddir char (168); /* directory portion of directory name */ dcl dent char (32); /* entry portion of directory name */ dcl force_bit bit (1) aligned; dcl mask_bit bit (1) aligned; dcl clean_bit bit (1) aligned; dcl mp ptr; dcl message_len fixed bin (18); dcl based_message bit (message_len) aligned based; dcl access_class bit (72) aligned; dcl cleanup condition; dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl clock_ entry returns (fixed bin (71)); dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl hcs_$get_access_class entry (char(*), char(*), bit(72) aligned, fixed bin(35)); dcl hcs_$get_link_target entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl hcs_$get_user_effmode entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)); dcl hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl ipc_$mask_ev_calls entry (fixed bin (35)); dcl ipc_$unmask_ev_calls entry (fixed bin (35)); dcl unthread_descriptor_ entry (ptr); dcl (addr, fixed, null, ptr, rel, bit) builtin; dcl 1 branch aligned, 2 pad1 fixed bin, 2 dtm bit (36), /* date-time modified */ 2 pad2 (2) fixed bin; /* */ /* get pointer to oldest request */ mask_code = -1; on cleanup begin; if mask_code = 0 then call ipc_$unmask_ev_calls (code); end; call ipc_$mask_ev_calls (mask_code); mask_bit = "1"b; clean_bit, force_bit = "0"b; join: desc_off = iodc_static.first_req_done; if desc_off = 0 then go to out; /* no requests threaded, don't bother */ desc_p, mseg_message_info_ptr = ptr (iodc_static.descr_seg_ptr, desc_off); /* if cleanup entry we want to free them all, but not delete uncompleted ones */ if clean_bit then do; if ^desc_p -> request_descriptor.finished then desc_p -> request_descriptor.dont_delete = "1"b; mseg_message_info.ms_ptr = ptr (iodc_static.req_seg_ptr, rel (mseg_message_info.ms_ptr)); /* segment number was left by previous coordinator process */ go to free_it; /* skip other checks */ end; do while (desc_p -> request_descriptor.saved); /* find one that's not saved */ desc_off = desc_p -> request_descriptor.next_done; if desc_off = 0 then return; desc_p = ptr (iodc_static.descr_seg_ptr, desc_off); end; /* make sure it's old enough */ if (clock_ () - desc_p -> request_descriptor.time_done) >= iodc_static.time_interval | force_bit then do; free_it: call unthread_descriptor_ (desc_p); mp = desc_p -> mseg_message_info.ms_ptr; if mp -> queue_msg_hdr.delete_sw /* user requested deletion */ then if ^desc_p -> request_descriptor.dont_delete /* and it's okay */ then do; /* check access on directory containing actual segment */ /* so if it's a link, chase it */ call hcs_$get_link_target ((mp -> queue_msg_hdr.dirname), (mp -> queue_msg_hdr.ename), dirname, ename, code); if code ^= 0 then go to skip_it; /* can't deal with this */ /* make sure the file hasn't been modified since */ /* the request was done */ call hcs_$status_ (dirname, ename, 1, addr (branch), null, code); if code ^= 0 then go to skip_it; if fixed (branch.dtm || (16)"0"b, 52) > desc_p -> request_descriptor.time_done then go to skip_it; /* now check the directory */ call expand_pathname_ (dirname, ddir, dent, code); if code ^= 0 then go to skip_it; /* God help us */ call hcs_$get_access_class (ddir, dent, access_class, code); if code ^= 0 then go to skip_it; if ^aim_check_$equal (desc_p -> mseg_message_info.sender_authorization, access_class) then go to skip_it; call hcs_$get_user_effmode (ddir, dent, desc_p -> mseg_message_info.sender_id, desc_p -> mseg_message_info.sender_level, acc_mode, code); if code ^= 0 then go to skip_it; if (bit (acc_mode, 5) & "00010"b) ^= "0"b then call delete_$path (dirname, ename, "000100"b, "", code); end; skip_it: /* now actually free the descriptor and the request */ message_len = desc_p -> mseg_message_info.ms_len; free mp -> based_message in (req_area); free desc_p -> request_descriptor in (descr_area); end; out: if mask_bit then call ipc_$unmask_ev_calls (code); return; force: entry; /* called when a request must be freed to make space */ clean_bit, mask_bit = "0"b; force_bit = "1"b; go to join; /* ************************************ */ /* ************************************ */ cleanup: entry; /* called at initialization time to delete segments from requests */ /* performed in previous session */ clean_bit = "1"b; mask_bit, force_bit = "0"b; go to join; init: entry (a_ptr); dcl a_ptr ptr; stat_p = a_ptr; return; /* */ %include iodc_static; %page; %include mseg_message_info; %page; %include queue_msg_hdr; %page; %include request_descriptor; end free_oldest_request_;  iod_overseer_.pl1 11/15/82 1834.0rew 11/15/82 1450.8 97371 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ iodc_overseer_: iod_overseer_: procedure; /* Login responder for I/O Daemon (IO.SysDaemon) */ /* It asks if it is supposed to be coordinator or driver, * so it can call the appropriate initializing routine. * For a coordinator, the "coordinator lock" is checked to make sure * that there is not already a coordinator running; for a driver process, * the lock is checked to make sure that a coordinator IS running, and if * not, we wait a bit and try once more. */ /* Modified by J. Stern, 12/31/74 */ /* Modified by B. Margulies November 1980 for search rules and test improvements, and to rename to iod_overseer_ */ /* Modified: 6 May 1982 by G. Palter to set the working directory */ dcl (Test_dir, Test_entry) char (*) parameter; dcl home_dir character (168); dcl iod_tables_entryname char (32); dcl iod_tables_dir char (168); dcl this_is_a_test bit (1) aligned; dcl exit_command char (6) aligned; dcl code fixed bin (35); dcl lock_ptr ptr int static init (null); dcl type char (32) varying; dcl iod_tables char (32); dcl any_other condition; dcl 1 daemon_search aligned static options (constant), /* Daemon search rules */ 2 number fixed bin init (1), 2 dirs (1) char (168) init ("io_daemon"); dcl 1 coord_lock_seg aligned based, 2 coord_lock bit (36), 2 driver_lock bit (36); %include query_info; dcl change_wdir_ entry (char (168) aligned, fixed bin (35)); dcl com_err_ entry options (variable); dcl command_query_ entry () options (variable); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$initiate_search_rules entry (ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl privileged_make_seg_ entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl iodc_$iodc_init entry (char (*), bit (1) aligned, char (*)); dcl iodd_$iodd_init entry (char (*), bit (1) aligned); dcl ioa_ entry options (variable); dcl logout entry; dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl system_privilege_$dir_priv_on entry (fixed bin (35)); dcl system_privilege_$ipc_priv_on entry (fixed bin (35)); dcl system_privilege_$ring1_priv_on entry (fixed bin (35)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl user_info_$homedir entry (char (*)); %page; dcl error_table_$argerr fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$lock_wait_time_exceeded fixed bin (35) ext static; dcl error_table_$invalid_lock_reset fixed bin (35) ext static; dcl error_table_$locked_by_this_process fixed bin (35) ext static; dcl (addr, null) builtin; %page; iod_tables_dir = ">daemon_dir_dir>io_daemon_dir"; iod_tables_entryname = "iod_tables"; this_is_a_test = "0"b; /* indicates we're not in test mode */ exit_command = "logout"; on any_other call early_handler; call hcs_$initiate_search_rules (addr (daemon_search), code); if code ^= 0 then call com_err_ (code, "iod_overseer_", "Warning: could not set search rules to the tagged set ""io_daemon"". Default search rules in use."); call user_info_$homedir (home_dir); call change_wdir_ ((home_dir), code); if code ^= 0 then call com_err_ (code, "iod_overseer_", "Warning: could not set working directory to ^a.", home_dir); /* find out what kind of process we're supposed to be */ common: read: query_info.version = query_info_version_4; query_info.switches.suppress_name_sw = "1"b; query_info.switches.cp_escape_control = "1"b || this_is_a_test; /* allowed if in test mode */ query_info.switches.suppress_spacing = "1"b; call command_query_ (addr (query_info), type, "iod_overseer_", "Enter command: coordinator, driver, or ^a:^/", exit_command); if type = "driver" /* regular driver */ then do; if ^coord_running () /* no coordinator */ then call com_err_ (0, "iod_overseer_", "Coordinator not ready or not logged in."); else do; /* start up a driver */ call iodd_$iodd_init (iod_tables_dir, this_is_a_test); /* byvalue until the aligned attribute is flushed from iodd_ */ go to exit; end; end; else if type = "coord" | type = "coordinator" then do; /* make sure there isn't already a Coordinator process */ if ^first_coord () /* somebody goofed */ then do; call com_err_ (0, "iod_overseer_", "Coordinator is already running."); goto read; end; if ^this_is_a_test then do; /* not testing, turn on privileges */ call system_privilege_$dir_priv_on (code); call system_privilege_$ipc_priv_on (code); call system_privilege_$ring1_priv_on (code); end; call iodc_$iodc_init (iod_tables_dir, this_is_a_test, iod_tables_entryname); call set_lock_$unlock (lock_ptr -> coord_lock, code); /* unlock the coordinator lock */ call set_lock_$unlock (lock_ptr -> driver_lock, code); /* and the driver lock */ go to exit; end; else if type = exit_command then go to exit; else call com_err_ (0, "iod_overseer_", "Invalid response."); go to read; test: entry (Test_dir); iod_tables_dir = Test_dir; iod_tables_entryname = "iod_tables"; goto TEST_COMMON; test_path: entry (Test_dir, Test_entry); iod_tables_dir = Test_dir; iod_tables_entryname = Test_entry; TEST_COMMON: this_is_a_test = "1"b; exit_command = "return"; go to common; exit: if this_is_a_test then return; else call logout; coord_ready: entry; /* This entry is called by the coordinator after it has initialized. Until this entry is called, drivers will not be allowed to start. */ if lock_ptr ^= null () then do; lock_ptr -> driver_lock = ""b; /* erase any previous lock */ call set_lock_$lock (lock_ptr -> driver_lock, 0, code); end; return; /* */ first_coord: proc returns (bit (1) aligned); /* This procedure verifies that no coordinator process yet exists. */ dcl 1 acl aligned, 2 name char (32), 2 modes bit (36), 2 mbz bit (36), 2 status fixed bin (35); if this_is_a_test then call hcs_$make_seg (iod_tables_dir, "coord_lock", "", 01010b, lock_ptr, code); else call privileged_make_seg_ (iod_tables_dir, "coord_lock", "", 01010b, lock_ptr, code); if lock_ptr = null () then do; call com_err_ (code, "iod_overseer_", "Cannot create coord_lock"); go to exit; end; if code = 0 then do; /* if just created, set acl */ acl.name = "*.*.*"; /* give everyone access to read the lock */ acl.modes = "1"b; acl.mbz = ""b; call hcs_$add_acl_entries (iod_tables_dir, "coord_lock", addr (acl), 1, code); if code ^= 0 then do; if code = error_table_$argerr then code = acl.status; call com_err_ (code, "iod_overseer_", "Cannot set access to coord_lock"); go to exit; end; end; call set_lock_$lock (lock_ptr -> coord_lock, 0, code); if code = 0 then return ("1"b); /* we locked it */ if code = error_table_$invalid_lock_reset then return ("1"b); /* we locked it */ if code = error_table_$lock_wait_time_exceeded then return ("0"b); /* we didn't lock it */ if this_is_a_test then /* we'll try anything in test mode */ if code = error_table_$locked_by_this_process then return ("1"b); call com_err_ (code, "iod_overseer_", "Attempting to lock coord_lock"); go to exit; end first_coord; /* */ coord_running: proc returns (bit (1) aligned); /* This procedure verifies that a coordinator process has been initialized. */ dcl test_lock bit (36) aligned; dcl i fixed bin; call hcs_$initiate (iod_tables_dir, "coord_lock", "", 0, 1, lock_ptr, code); if lock_ptr = null then if code = error_table_$noentry then return ("0"b); else do; call com_err_ (code, "iod_overseer_", "Cannot initiate coord_lock"); go to exit; end; do i = 1 to 10; /* try 10 times */ test_lock = lock_ptr -> driver_lock; /* copy driver_lock since we don't want to set it */ call set_lock_$lock (test_lock, 0, code); if code = error_table_$lock_wait_time_exceeded then return ("1"b); /* it's locked */ if code = 0 | code = error_table_$invalid_lock_reset then do; /* it's not locked */ call timer_manager_$sleep (6, "11"b); /* wait 6 seconds */ go to retry; end; if this_is_a_test then /* if we're testing */ if code = error_table_$locked_by_this_process then return ("1"b); /* this is probably deliberate */ call com_err_ (code, "iod_overseer_", "Attempting to test coord_lock"); go to exit; retry: end; return ("0"b); /* no luck, give up */ end coord_running; /* */ early_handler: proc; /* All conditions not recognized by early_handler are considered fatal. A standard message is printed, after which the process is logged out. */ dcl ec fixed bin (35); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr); dcl default_error_handler_ entry (ptr, char (*), ptr, ptr, bit (1) aligned); dcl 1 cond_info aligned, %include cond_info; cond_info.version = 1; /* version of cond_info */ call find_condition_info_ (null (), addr (cond_info), ec); if cond_info.condition_name = "command_error" then return; else if cond_info.condition_name = "command_question" then return; else if cond_info.condition_name = "cput" | cond_info.condition_name = "alrm" | cond_info.condition_name = "sus_" | cond_info.condition_name = "trm_" | cond_info.condition_name = "wkp_" | cond_info.condition_name = "finish" then do; call default_error_handler_ (mcptr, (condition_name), wcptr, infoptr, "0"b); return; end; call ioa_ ("iod_overseer_: ^a condition intercepted. Process will be terminated.", cond_info.condition_name); call condition_interpreter_ (null, null, 0, 3, mcptr, (condition_name), wcptr, infoptr); go to exit; end early_handler; end /* iod_overseeer_ */;  iod_set_line.pl1 10/28/88 1351.7rew 10/28/88 1233.9 48294 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: style4,indattr,ifthen,^indproc */ iod_set_line: proc; /* Command to patch the line number given for a device in iod_tables */ /****^ HISTORY COMMENTS: 1) change(85-02-06,Homan), approve(87-04-06,MCR7656), audit(87-07-08,Beattie), install(87-08-04,MR12.1-1055): Add new command to change line number for a device in the iod_working_tables. 2) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. END HISTORY COMMENTS */ ithp = null (); on cleanup call cleaner; call cu_$arg_list_ptr (arg_list_ptr); call process_args; call patch_it; EXIT: call cleaner; return; %page; cleaner: proc; if ithp ^= null () then call terminate_file_ (ithp, 0, TERM_FILE_TERM, (0)); end cleaner; %page; process_args: proc; daemon_dir = ">daemon_dir_dir>io_daemon_dir"; brief = "0"b; call cu_$arg_count_rel (nargs, arg_list_ptr, code); if code ^= 0 then do; call com_err_ (code, ME); goto EXIT; end; if nargs < 2 then do; call com_err_ (error_table_$wrong_no_of_args, ME, "^/Usage: ^a Device Line {-control_args}", ME); goto EXIT; end; call cu_$arg_ptr_rel (1, argp, argl, (0), arg_list_ptr); device_name = arg; call cu_$arg_ptr_rel (2, argp, argl, (0), arg_list_ptr); line_name = arg; argN = 3; do while (argN <= nargs); call cu_$arg_ptr_rel (argN, argp, argl, (0), arg_list_ptr); if arg = "-directory" | arg = "-dr" then do; argN = argN + 1; if argN > nargs then do; call com_err_ (error_table_$noarg, ME, "Argument missing after -directory."); goto EXIT; end; call cu_$arg_ptr_rel (argN, argp, argl, (0), arg_list_ptr); call absolute_pathname_ (arg, daemon_dir, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); goto EXIT; end; end; else if arg = "-brief" | arg = "-bf" then brief = "1"b; else do; call com_err_ (error_table_$bad_arg, ME, "^a", arg); goto EXIT; end; argN = argN + 1; end; end process_args; %page; patch_it: proc; dcl i fixed bin; call initiate_file_ (daemon_dir, "iod_working_tables", RW_ACCESS, ithp, (0), code); if code ^= 0 then do; call com_err_ (code, ME, "^a", pathname_ (daemon_dir, "iod_working_tables")); goto EXIT; end; idtp = ptr (ithp, iod_tables_hdr.device_tab_offset); do i = 1 to iod_device_tab.n_devices; idtep = addr (iod_device_tab.entries (i)); if idte.dev_id = device_name then do; if idte.attach_type ^= 2 then do; call com_err_ (0, ME, "Device ^a does not have a ""line:"" statement, or uses ""line: variable"".", device_name); goto EXIT; end; if ^brief then call ioa_ ("Line changed from ^a to ^a for device ^a.", requote_string_ (rtrim (idte.attach_name)), requote_string_ (rtrim (line_name)), device_name); idte.attach_name = line_name; goto EXIT; end; end; call com_err_ (0, ME, "Device ^a not found in ^a.", device_name, pathname_ (daemon_dir, "iod_working_tables")); end patch_it; %page; /* External entries */ dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl com_err_ entry () options (variable); dcl ioa_ entry () options (variable); 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 absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); /* Builtins */ dcl (addr, null, ptr, rtrim) builtin; /* External static */ dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; /* Automatic variables */ dcl arg_list_ptr ptr; dcl argp ptr; dcl argl fixed bin (21); dcl argN fixed bin; dcl nargs fixed bin; dcl code fixed bin (35); dcl brief bit (1); dcl daemon_dir char (168); dcl device_name char (32); dcl line_name char (32); /* Based variables */ dcl arg char (argl) based (argp); /* Constants */ dcl ME char (32) int static options (constant) init ("iod_set_line"); /* Conditions */ dcl cleanup condition; %page; %include access_mode_values; %page; %include iod_device_tab; %page; %include iod_tables_hdr; %page; %include terminate_file; end iod_set_line;  iod_tables_compiler.rd 10/23/89 1406.2rew 10/23/89 1405.0 941022 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(88-01-27,Brunelle), approve(), audit(), install(): Written by J. Stern, January 1975 Modified by J. C. Whitmore, April 1978 for new RQT substatements Modified by J. C. Whitmore, Oct 1978, for version 3 -> adding the line_id table Modified by J. C. Whitmore, Jan 1980, to remove warning 7 - ctl term illegal with line variable construct. Modified by R. McDonald May 1980 to add keywords card_charge and page_charge. (UNCA) Modified: 10 April 1981 by G. Palter to remove warning 4 -- dprint/dpunch restricts request type names to < 9 characters Modified by E. N. Kittlitz June 1981 for UNCA card_charge, page_charge 2) change(88-01-27,Brunelle), approve(88-10-31,MCR7911), audit(88-10-21,Wallman), install(89-10-23,MR12.3-1099): Converted to reduction form. Add new statements. 3) change(88-10-31,Brunelle), approve(88-10-31,MCR7911), audit(88-11-01,Wallman), install(89-10-23,MR12.3-1099): Add cross check to verify that any device defined as allowed for a request_type has a forms_table entry if the request_type has a forms_table entry. 4) change(89-02-28,Brunelle), approve(89-10-17,MCR8140), audit(89-10-23,Beattie), install(89-10-23,MR12.3-1099): Correct problem of truncated output file because bitcount not being set properly. END HISTORY COMMENTS */ %page; /*++ \" REDUCTIONS FOR iod_tables_compiler BEGIN / / ERROR (1) / RETURN \ \" Scan for main delimiting statements / Time : ; / LEX (2) store_global_grace_time NEXT_STMT / BEGIN \ / Time : / ERROR (3) NEXT_STMT / BEGIN \ / Max_queues : ; / LEX (2) store_global_max_queues NEXT_STMT / BEGIN \ / Max_queues : / ERROR (5) NEXT_STMT / BEGIN \ \" now the main group delimiting statements / Line : ; / LEX (2) line_create_table_entry LEX (2) / line_stmts \ / Line : / ERROR (3) LEX (2) line_create_table_entry NEXT_STMT / line_stmts \ / Device : ; / LEX (2) dev_create_table_entry LEX (2) / device_stmts \ / Device : / ERROR (3) LEX (2) dev_create_table_entry NEXT_STMT / device_stmts \ / Request_type : ; / LEX (2) rqt_create_table_entry LEX (2) / rqt_stmts \ / Request_type : / ERROR (3) LEX (2) rqt_create_table_entry NEXT_STMT / rqt_stmts \ / Forms_table : ; / LEX (2) forms_create_group_entry LEX (2) / forms_stmts \ / Forms_table : / ERROR (3) LEX (2) forms_create_group_entry NEXT_STMT / forms_stmts \ / End ; / LEX [if token.Pnext ^= null () then call statement_error ()] / RETURN \ / : / ERROR (2) NEXT_STMT / BEGIN \ / / ERROR (3) NEXT_STMT / BEGIN \ / / ERROR (1) / RETURN \ \" \" section to decode Line statements line_stmts / comment : ; / LEX (2) line_save_comment LEX (2) / line_stmts \ / comment : ; / LEX (2) line_save_comment LEX (2) / line_stmts \ / comment : / ERROR (3) NEXT_STMT / line_stmts \ / channel : ; / LEX (2) line_save_channel_id LEX (2) / line_stmts \ / channel : / ERROR (3) NEXT_STMT / line_stmts \ / att_desc : ; / LEX (2) line_save_att_desc LEX (2) / line_stmts \ / att_desc : ; / LEX (2) line_save_att_desc LEX (2) / line_stmts \ / att_desc : / ERROR (3) NEXT_STMT / line_stmts \ / device : ; / LEX (2) line_save_device LEX (2) / line_stmts \ / device : / ERROR (3) NEXT_STMT / line_stmts \ / / line_validate_entry / BEGIN \ \" \" section to decode Device statements device_stmts / comment : ; / LEX (2) dev_save_comment LEX (2) / device_stmts \ / comment : ; / LEX (2) dev_save_comment LEX (2) / device_stmts \ / comment : / ERROR (3) NEXT_STMT / device_stmts \ / prph : ; / LEX (2) dev_save_attach_method (1, ATTACH_TYPE_IOM) LEX (2) / device_stmts \ / prph : / ERROR (3) NEXT_STMT / device_stmts \ / line : variable ; / LEX (2) dev_save_attach_method (1, ATTACH_TYPE_VARIABLE_LINE) LEX (2) / device_stmts \ / line : ; / LEX (2) dev_save_attach_method (1, ATTACH_TYPE_TTY) LEX (2) / device_stmts \ / line : / ERROR (3) NEXT_STMT / device_stmts \ / dial_id : ; / LEX (2) dev_save_attach_method (1, ATTACH_TYPE_DIAL) LEX (2) / device_stmts \ / dial_id : / ERROR (3) NEXT_STMT / device_stmts \ / ctl_line : ; / LEX (2) dev_save_attach_method (2, CTL_ATTACH_TYPE_TTY) LEX (2) / device_stmts \ / ctl_line : / ERROR (3) NEXT_STMT / device_stmts \ / ctl_dial_id : ; / LEX (2) dev_save_attach_method (2, CTL_ATTACH_TYPE_DIAL) LEX (2) / device_stmts \ / ctl_dial_id : / ERROR (3) NEXT_STMT / device_stmts \ / ctl_source : ; / LEX (2) dev_save_attach_method (2, CTL_ATTACH_TYPE_MC) LEX (2) / device_stmts \ / ctl_source : / ERROR (3) NEXT_STMT / device_stmts \ / driver_module : ; / LEX (2) dev_save_driver_module LEX (2) / device_stmts \ / driver_module : / ERROR (3) NEXT_STMT / device_stmts \ / head_sheet : ; / LEX (2) dev_save_head_sheet LEX (2) / device_stmts \ / head_sheet : / ERROR (3) NEXT_STMT / device_stmts \ / tail_sheet : ; / LEX (2) dev_save_tail_sheet LEX (2) / device_stmts \ / tail_sheet : / ERROR (3) NEXT_STMT / device_stmts \ / paper_type : single ; / LEX (2) dev_save_paper_type LEX (2) / device_stmts \ / paper_type : continuous ; / LEX (2) dev_save_paper_type LEX (2) / device_stmts \ / paper_type : / ERROR (3) NEXT_STMT / device_stmts \ / forms_validation : ; / LEX (2) dev_save_forms_validation LEX (2) / device_stmts \ / forms_validation : / ERROR (3) NEXT_STMT / device_stmts \ / default_form : / LEX (2) / dev_process_default_form_string \ / font_dir : ; / LEX (2) dev_save_font_dir LEX (2) / device_stmts \ / font_dir : / ERROR (3) NEXT_STMT / device_stmts \ / forms_info : ; / LEX (2) dev_save_forms_table LEX (2) / device_stmts \ / forms_info : / ERROR (3) NEXT_STMT / device_stmts \ / args : ; / LEX (2) dev_save_args LEX (2) / device_stmts \ / args : ; / LEX (2) dev_save_args LEX (2) / device_stmts \ / args : / ERROR (3) NEXT_STMT / device_stmts \ / minor_device : ; / LEX (2) dev_create_minor_table_entry NEXT_STMT / device_stmts \ / minor_device : / ERROR (3) LEX (2) dev_create_minor_table_entry NEXT_STMT / device_stmts \ / minor_args : ; / LEX (2) dev_save_minor_args LEX (2) / device_stmts \ / minor_args : ; / LEX (2) dev_save_minor_args LEX (2) / device_stmts \ / minor_args : / ERROR (3) NEXT_STMT / device_stmts \ / default_type : ; / LEX (2) dev_save_default_type LEX (2) / device_stmts \ / default_type : / ERROR (3) NEXT_STMT / device_stmts \ / / dev_validate_entry / BEGIN \ \" routine to handle default form string for device dev_process_default_form_string / / PUSH (dev_process_default_form_string1) / build_temp_token_value \ dev_process_default_form_string1 / / dev_save_default_form / device_stmts \ build_temp_token_value / / [temp_token_value = ""; temp_token_value_used = TRUE] / \ build_temp_token_value_loop / ; / LEX / STACK_POP \ / / [temp_token_value = temp_token_value || token_value] LEX / build_temp_token_value_loop \ \" \" section to decode Request_type statements rqt_stmts / comment : ; / LEX (2) rqt_save_comment LEX (2) / rqt_stmts \ / comment : ; / LEX (2) rqt_save_comment LEX (2) / rqt_stmts \ / comment : / ERROR (3) NEXT_STMT / rqt_stmts \ / driver_userid : ; / LEX (2) rqt_save_driver_id LEX (2) / rqt_stmts \ / driver_userid : / ERROR (3) NEXT_STMT / rqt_stmts \ / accounting : ; / LEX (2) rqt_save_accounting LEX (2) / rqt_stmts \ / accounting : / ERROR (3) NEXT_STMT / rqt_stmts \ / generic_type : ; / LEX (2) rqt_save_generic_type LEX (2) / rqt_stmts \ / generic_type : / ERROR (3) NEXT_STMT / rqt_stmts \ / rqti_seg : ; / LEX (2) rqt_save_rqti_seg LEX (2) / rqt_stmts \ / rqti_seg : / ERROR (3) NEXT_STMT / rqt_stmts \ / max_queues : ; / LEX (2) rqt_save_max_queues LEX (2) / rqt_stmts \ / max_queues : / ERROR (3) NEXT_STMT / rqt_stmts \ / default_queue : ; / LEX (2) rqt_save_default_queue LEX (2) / rqt_stmts \ / default_queue : / ERROR (3) NEXT_STMT / rqt_stmts \ / line_charge : / LEX (2) rqt_save_charge (1) LEX / rqt_save_charges \ / page_charge : / LEX (2) rqt_save_charge (2) LEX / rqt_save_charges \ / card_charge : / LEX (2) rqt_save_charge (3) LEX / rqt_save_charges \ / forms_validation : ; / LEX (2) rqt_save_forms_validation LEX (2) / rqt_stmts \ / forms_validation : / ERROR (3) NEXT_STMT / rqt_stmts \ / default_form : / LEX (2) / rqt_process_default_form_string \ / font_dir : ; / LEX (2) rqt_save_font_dir LEX (2) / rqt_stmts \ / font_dir : / ERROR (3) NEXT_STMT / rqt_stmts \ / forms_info : ; / LEX (2) rqt_save_forms_table LEX (2) / rqt_stmts \ / forms_info : / ERROR (3) NEXT_STMT / rqt_stmts \ / device_class : ; / LEX (2) rqt_create_device_class_entry NEXT_STMT / rqt_stmts \ / device_class : / ERROR (3) LEX (2) rqt_create_device_class_entry NEXT_STMT / rqt_stmts \ / max_access_class : ;/ LEX (2) rqt_save_access (1) NEXT_STMT / rqt_stmts \ / max_access_class : / ERROR (3) NEXT_STMT / rqt_stmts \ / min_access_class : ;/ LEX (2) rqt_save_access (2) NEXT_STMT / rqt_stmts \ / min_access_class : / ERROR (3) NEXT_STMT / rqt_stmts \ / min_banner : ; / LEX (2) rqt_save_access (3) NEXT_STMT / rqt_stmts \ / min_banner : / ERROR (3) NEXT_STMT / rqt_stmts \ / device : ; / LEX (2) rqt_save_device LEX (2) / rqt_stmts \ / device : / ERROR (3) NEXT_STMT / rqt_stmts \ / / rqt_validate_entry / BEGIN \ \" section to handle multiple values for line/page/card_charge statements rqt_save_charges / , / LEX / rqt_save_charges \ / ; / LEX / rqt_stmts \ / / rqt_save_charge_continue LEX / rqt_save_charges\ / / / BEGIN \ \" routine to handle default form string for request type rqt_process_default_form_string / / PUSH (rqt_process_default_form_string1) / build_temp_token_value \ rqt_process_default_form_string1 / / rqt_save_default_form / rqt_stmts \ \" \" section to decode Forms_table statements forms_stmts / name : / LEX (2) forms_create_element_entry LEX / save_forms_name_synonyms \ / comment : ; / LEX (2) forms_save_comment LEX (2) / forms_stmts \ / comment : ; / LEX (2) forms_save_comment LEX (2) / forms_stmts \ / comment : / ERROR (3) NEXT_STMT / forms_stmts \ / type : ; / LEX (2) forms_save_type LEX (2) / forms_stmts \ / type : / ERROR (3) NEXT_STMT / forms_stmts \ / uses : / LEX (2) forms_save_uses_name LEX / save_forms_uses_names \ / string : ; / LEX (2) forms_save_string_token LEX (2) / forms_stmts \ / string : ; / LEX (3) / forms_stmts \ / string : / LEX (2) [forms_escape_string_index = 1; forms_escape_string_n (*) = 0] / forms_char_string \ / page_height : ; / LEX (2) forms_save_size (1) LEX (2) / forms_stmts \ / page_height : / ERROR (3) NEXT_STMT / forms_stmts \ / page_width : ; / LEX (2) forms_save_size (2) LEX (2) / forms_stmts \ / page_width : / ERROR (3) NEXT_STMT / forms_stmts \ / char_height : ; / LEX (2) forms_save_size (3) LEX (2) / forms_stmts \ / char_height : / ERROR (3) NEXT_STMT / forms_stmts \ / char_width : ; / LEX (2) forms_save_size (4) LEX (2) / forms_stmts \ / char_width : / ERROR (3) NEXT_STMT / forms_stmts \ / line_height : ; / LEX (2) forms_save_size (5) LEX (2) / forms_stmts \ / line_height : / ERROR (3) NEXT_STMT / forms_stmts \ / / forms_validate_group / BEGIN \ \" section to handle multiple values for uses statement save_forms_name_synonyms / , / LEX / save_forms_name_synonyms \ / ; / LEX / forms_stmts \ / / forms_add_syn_element_name LEX / save_forms_name_synonyms \ / / ERROR (3) forms_add_syn_element_name LEX / save_forms_name_synonyms \ / / / BEGIN \ save_forms_uses_names / , / LEX / save_forms_uses_names \ / ; / LEX / forms_stmts \ / / forms_save_uses_name_continue LEX / save_forms_uses_names \ / / ERROR (3) forms_save_uses_name_continue LEX / save_forms_uses_names \ / / / BEGIN \ \" section to handle string statements forms_char_string forms_string_item / / append_token_value_string LEX / forms_string_item \ / / insert_single_char ((token.Nvalue)) LEX / forms_string_item \ / ; / forms_save_string LEX / forms_stmts \ / / ERROR (3) NEXT_STMT / forms_stmts \ / / / RETURN \ ++*/ %page; /* format: style4 */ iod_tables_compiler: iodtc: proc; /* The iod_tables_compiler produces an encoded representation of the various IO daemon tables from a source language description. Source segments are assumed to have a name ending with the suffix ".iodt". An object segment will be given the same name as its corresponding source segment with the suffix removed. */ /* External Entries & Procedures */ dcl cdt_mgr_$find_cdt_channel entry (ptr, char (32), fixed bin, bit (1) aligned, fixed bin (35)); dcl clock_ entry () returns (fixed bin (71)); dcl com_err_ entry () options (variable); dcl com_err_$suppress_name entry () options (variable); dcl convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); 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 cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_float_ entry (char (*), fixed bin (35)) returns (float bin (27)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$bad_opt fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$too_many_args fixed bin (35) ext static; dcl error_table_$zero_length_seg fixed bin (35) ext static; dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl lex_error_ 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 release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl system_info_$resource_price entry (char (*), float bin (27), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), 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 tssi_$clean_up_segment entry (ptr); dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); /* Builtins */ dcl (addr, addrel, after, before, bin, char, collate, convert, currentsize, dimension, divide, fixed, hbound, index, lbound, length, max, mod, null, rank, rel, rtrim, substr, translate, unspec, verify) builtin; dcl cleanup condition; /* External Static */ dcl iod_tables_compiler_severity_ fixed bin (35) ext init (0); dcl sc_stat_$sysdir char (168) aligned external; /* Internal Static */ dcl ALL_VALID_CHARS_AND_NUMERIC char (62) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"); dcl BREAKS char (35) varying int static; dcl CTL_CHARS char (32) varying int static; dcl FALSE bit (1) int static options (constant) init ("0"b); dcl LEX_CHARS char (6) int static options (constant) init ("""/**/;"); dcl LEX_COMMENT_CLOSE char (2) defined LEX_CHARS pos (4); dcl LEX_COMMENT_OPEN char (2) defined LEX_CHARS pos (2); dcl LEX_STATEMENT_DELIMITER char (1) defined LEX_CHARS pos (6); dcl LEX_QUOTE_CLOSE char (1) defined LEX_CHARS pos (1); dcl LEX_QUOTE_OPEN char (1) defined LEX_CHARS pos (1); dcl LEXCTL char (80) varying int static; dcl LEXDLM char (80) varying int static; dcl TOKEN_BAD bit (1) int static options (constant) init ("0"b); dcl TOKEN_GOOD bit (1) int static options (constant) init ("1"b); dcl TRUE bit (1) int static options (constant) init ("1"b); dcl already_called bit (1) int static init (FALSE); dcl max_length_att_desc fixed bin int static options (constant) init (512); dcl max_length_att_desc_char char (3) int static options (constant) init ("512"); dcl max_length_comment fixed bin int static options (constant) init (256); dcl max_length_comment_char char (3) int static options (constant) init ("256"); dcl max_size fixed bin int static options (constant) init (360); dcl max_size_char char (3) int static options (constant) init ("360"); dcl prog_name char (32) int static options (constant) init ("new_iod_tables_compiler"); /* Internal Automatic */ dcl acl_info_ptr ptr; dcl arg char (argl) based (argp); /* command argument */ dcl argc fixed bin; /* input argument count */ dcl argl fixed bin (21); /* length of arg */ dcl argp ptr; /* ptr to arg */ dcl argx fixed bin; /* current input arg being processed */ dcl authorization_bits bit (72) aligned; /* converted authorization bits */ dcl bit_count fixed bin (24); /* bit count */ dcl cdtp ptr; /* Channel Definition Table ptr */ dcl code fixed bin (35); /* error code */ dcl copy_ptr ptr; dcl debug bit (1); dcl default_device_class_defined bit (1); dcl default_minor_device_defined bit (1); dcl default_print_defined bit (1); dcl default_punch_defined bit (1); dcl error_string char (128) varying; dcl fb35 fixed bin (35); dcl forms_size_info float bin; dcl forms_size_type fixed bin; dcl forms_element_validated bit (1); dcl (i, j, k, l) fixed bin; dcl input_dir_name char (168); /* input directory pathname */ dcl input_ent_name char (32); /* input entry name */ dcl input_ptr ptr; /* ptr to input segment */ dcl item_ok bit (1); dcl line_charge_keyword_used bit (1); dcl minor_name char (32); dcl output_dir_name char (168); /* output directory pathname */ dcl output_ent_name char (32); /* output entry name */ dcl output_ptr ptr; /* ptr to output segment */ dcl page_charge_keyword_used bit (1); dcl saved_charge_cntr fixed bin; dcl saved_charge_type fixed bin; dcl stmtp ptr; /* RDC statement ptr */ dcl temp_ptrs (10) ptr; /* scratch segment ptrs */ dcl text_strings_array (text_strings.length) char (1) unaligned based (text_strings_array_ptr); dcl text_strings_array_ptr ptr; dcl translator_temp_ptr ptr; /* temp storage for forms elements & groups used while building the forms info tab */ dcl forms_elements_ptr ptr; dcl forms_elements (iod_forms_info_tab.n_words) fixed bin (35) based (forms_elements_ptr); dcl forms_groups_ptr ptr; dcl 1 forms_groups (iod_forms_info_tab.n_groups) like iod_forms_info_tab.groups based (forms_groups_ptr); dcl 1 cn aligned, /* component names of a two-part name */ 2 first_name char (24), 2 second_name char (24); /* the following are for device names and other data which must be saved as we go along */ dcl misc_data_ptr ptr; dcl 1 misc_data based (misc_data_ptr), /* the following are for device names encountered while processing Line statements */ 2 line_device_names_count fixed bin, 2 line_device_names (max_size) char (32), 2 line_device_index (max_size) fixed bin, /* the following are for device names (major and/or minor) encountered while processing Request_type statements */ 2 q_group_device_names_count fixed bin, 2 q_group (max_size), 3 device_name like cn, 3 is_default_minor bit (1), /* ON if this is default minor device */ 3 is_default_device_class bit (1), /* ON if this is default device class */ 3 device_index fixed bin, /* device index for this device */ 3 default_type like cn, /* the following is used while processing Device statements where bit I is ON if Device I uses "line: variable;" statement */ 2 var_line_list bit (max_size), 2 forms_escape_string_index fixed bin, 2 forms_escape_string_n (1024) fixed bin (8) unaligned, 2 parms_count fixed bin, 2 parms_indices_start (64) fixed bin, 2 parms_indices_length (64) fixed bin, 2 parms (11) char (32), 2 temp_token_value_used bit (1), 2 temp_token_value char (1024) varying, /* the following two define those request type/device classes and major/minor devices which have a forms_table string defined for them */ 2 device_class_forms bit (max_size), 2 minor_device_forms bit (max_size), 2 pad fixed bin; %page; /* Actual Program Begins Here */ input_ptr, output_ptr, temp_ptrs (*), translator_temp_ptr, cdtp, acl_info_ptr, copy_ptr = null; on cleanup begin; call clean_up; iod_tables_compiler_severity_ = 5; end; call cu_$arg_count (argc, code); if code ^= 0 then do; call com_err_ (code, prog_name); go to severity_5_failure; end; debug = FALSE; SERROR_CONTROL = "00"b; TRACING = FALSE; if argc < 1 then do; call com_err_$suppress_name (0, prog_name, "Usage: iod_tables_compiler iod_tables_name [-brief | -long]"); go to severity_5_failure; end; input_ent_name = ""; /* no input name yet */ do argx = 1 to argc; call cu_$arg_ptr (argx, argp, argl, code); if char (arg, 1) ^= "-" then do; if input_ent_name ^= "" then do; call com_err_ (error_table_$too_many_args, prog_name, "Only one pathname may be given. ^a was the second.", arg); go to severity_5_failure; end; call expand_pathname_$add_suffix (arg, "iodt", input_dir_name, input_ent_name, code); if code ^= 0 then do; path_error: call com_err_ (code, prog_name, "^a", arg); go to severity_5_failure; end; /* if we get this far, how can we fail? */ call suffixed_name_$new_suffix (input_ent_name, "iodt", "", output_ent_name, code); if code ^= 0 then /* still, let's have a look */ go to path_error; end; /* Pathname case */ else if arg = "-bf" | arg = "-brief" then SERROR_CONTROL = "01"b; else if arg = "-lg" | arg = "-long" then SERROR_CONTROL = "10"b; else if arg = "-severity" | arg = "-sv" then do; if argx >= argc then do; call com_err_ (error_table_$noarg, prog_name, "After ""^a"".", arg); go to severity_5_failure; end; argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, code); fb35 = cv_dec_check_ (arg, code); if code ^= 0 | fb35 < 0 | fb35 > 5 then do; call com_err_ (error_table_$bad_conversion, prog_name, "Severity must be an integer in the range 0 - 5, not ""^a"".", arg); go to severity_5_failure; end; MIN_PRINT_SEVERITY = fb35; end; else if arg = "-trace_on" | arg = "-tron" then TRACING = TRUE; else if arg = "-trace_off" | arg = "-trof" then TRACING = FALSE; else if arg = "-debug" | arg = "-db" then debug = TRUE; else do; code = error_table_$bad_opt; call com_err_ (code, prog_name, arg); go to severity_5_failure; end; end; /* argument processing loop */ if input_ent_name = "" then go to path_error; call initiate_file_ (input_dir_name, input_ent_name, R_ACCESS, input_ptr, bit_count, code); /* get ptr to input seg */ if input_ptr = null then do; call com_err_ (code, prog_name, "^a>^a", input_dir_name, input_ent_name); return; end; if bit_count = 0 then do; call com_err_ (error_table_$zero_length_seg, prog_name, "^a>^a", input_dir_name, input_ent_name); go to finish; end; /* get ptr to channel definition table */ call initiate_file_ ((sc_stat_$sysdir), "cdt", R_ACCESS, cdtp, (0), code); if code ^= 0 then do; call com_err_ (code, prog_name, "Accessing cdt. Channel name checks will not be performed."); end; /* get scratch segments */ call get_temp_segments_ (prog_name, temp_ptrs, code); /* make temp output seg */ if code ^= 0 then do; call com_err_ (code, prog_name, "Getting temp segments."); go to finish; end; /* Get pointers to the various tables. For now let the table sizes be maximum. */ ithp = temp_ptrs (1); /* set ptr to header */ ltp = temp_ptrs (2); /* get ptr to line id table */ idtp = temp_ptrs (3); /* get ptr to iod device table */ mdtp = temp_ptrs (4); /* get ptr to minor device table */ dctp = temp_ptrs (5); /* get ptr to device class table */ qgtp = temp_ptrs (6); /* get ptr to queue group table */ ifitp = temp_ptrs (7); /* get ptr to forms info tables */ forms_groups_ptr = temp_ptrs (8); /* get ptr to temp storage for forms elements */ iod_forms_info_tab.n_groups=101; forms_elements_ptr = addr (forms_groups.name (101)); /* leave room for 100 Forms_info groups */ iod_forms_info_tab.n_groups=0; text_strings_ptr = temp_ptrs (9); /* get ptr to text strings area */ text_strings_array_ptr = addr (text_strings.chars); misc_data_ptr = temp_ptrs (10); /* initialize to common state */ iod_tables_hdr.max_queues = -1; iod_tables_hdr.grace_time = -1; line_device_names_count, q_group_device_names_count = 0; idtep, mdtep, qgtep, dctep, ltep, fep = null (); forms_element_validated, q_group.is_default_minor (*), q_group.is_default_device_class (*), default_minor_device_defined, default_print_defined, default_punch_defined, temp_token_value_used = FALSE; device_class_forms, minor_device_forms = "0"b; error_string = ""; /* set up for lex_string_ */ call translator_temp_$get_segment ((prog_name), translator_temp_ptr, code); if translator_temp_ptr = null () then do; call com_err_ (code, prog_name, "From translator_temp_$get_segment"); go to severity_5_failure; end; if ^already_called then do; CTL_CHARS = substr (collate (), 1, 8) || substr (collate (), 10, 24); BREAKS = CTL_CHARS || ",:;"; call lex_string_$init_lex_delims (LEX_QUOTE_OPEN, LEX_QUOTE_CLOSE, LEX_COMMENT_OPEN, LEX_COMMENT_CLOSE, LEX_STATEMENT_DELIMITER, "10"b, BREAKS, CTL_CHARS, LEXDLM, LEXCTL); already_called = TRUE; end; if TRACING | debug then call ioa_ ("calling lex_string_$lex"); call lex_string_$lex (input_ptr, divide (bit_count, 9, 21, 0), 0, translator_temp_ptr, "1000"b, LEX_QUOTE_OPEN, LEX_QUOTE_CLOSE, LEX_COMMENT_OPEN, LEX_COMMENT_CLOSE, LEX_STATEMENT_DELIMITER, BREAKS, CTL_CHARS, LEXDLM, LEXCTL, stmtp, Pthis_token, code); if code ^= 0 then do; call com_err_ (code, prog_name, "Lexing ^a>^a.", input_dir_name, input_ent_name); go to finish; end; /* Go to it! */ Pstmt = stmtp; temp_token_value = stmt_value; if TRACING | debug then call ioa_ ("calling SEMANTIC_ANALYSYS"); call SEMANTIC_ANALYSIS (); if TRACING | debug then call ioa_ ("SEMANTIC_ANALYSYS done"); if MERROR_SEVERITY <= 2 then do; if debug then call ioa_ ("Cross checking table."); call cross_check_table; end; if MERROR_SEVERITY <= 2 then do; if debug then call ioa_ ("Building forms table."); if debug then call ioa_ ("Building output table."); call build_output_table; end; if MERROR_SEVERITY > 2 then call com_err_ (0, prog_name, "Translation failed."); iod_tables_compiler_severity_ = MERROR_SEVERITY; go to finish; severity_5_failure: iod_tables_compiler_severity_ = 5; finish: call clean_up; return; %page; clean_up: proc; /* cleanup handler -- makes sure anything we initiated gets terminated, anything we allocated gets freed */ if input_ptr ^= null then call terminate_file_ (input_ptr, (0), TERM_FILE_TERM, (0)); input_ptr = null; if acl_info_ptr ^= null then call tssi_$clean_up_segment (acl_info_ptr); acl_info_ptr = null; if output_ptr ^= null then call terminate_file_ (output_ptr, (0), TERM_FILE_TRUNC_BC_TERM, (0)); output_ptr = null; if translator_temp_ptr ^= null then call translator_temp_$release_all_segments (translator_temp_ptr, (0)); translator_temp_ptr = null; if temp_ptrs (1) ^= null then call release_temp_segments_ (prog_name, temp_ptrs, code); temp_ptrs (*) = null; if cdtp ^= null then call terminate_file_ (cdtp, (0), TERM_FILE_TERM, (0)); cdtp = null; return; end clean_up; %page; /* Since this is a single pass compiler, there is no guarantee that all names of entries will be known when they are encountered in the input file. Thus we will cross check all of the variables at the end of the input file. */ cross_check_table: proc; dcl (full_name, full_name2) char (32); /* for error display */ dcl (minor_kw, minor_kw2) char (32); /* for error display */ dcl major_name char (32); dcl price_name char (32); dcl price float bin; dcl temp_list bit (360) aligned; /* a temporary copy of dcte.device_list */ dcl starting_element_index fixed bin; dcl error_statement_no fixed bin; dcl error_device_name char (32); dcl error_entry_type char (32); dcl error_entry_type_id char (32); /* validate that each 'device' referenced under the Line keywords is a) defined as a Device b) has a attach type of 'variable' */ line_device_index (*) = 0; /* mark all as invalid til found */ do i = 1 to line_device_names_count; /* all names found */ do j = 1 to iod_device_tab.n_devices; /* all available devices */ /* If name matches and the device was defined with a variable line, save index into device table for the entry. If the name matches but the device was not defined with a variable line, save the index but negate it so we can tell later */ if iod_device_tab.entries (j).dev_id = line_device_names (i) then do; if iod_device_tab.entries (j).attach_type = ATTACH_TYPE_VARIABLE_LINE then line_device_index (i) = j; else line_device_index (i) = -j; go to next_line_dev; end; end; next_line_dev: end; do i = 1 to line_tab.n_lines; ltep = addr (line_tab.entries (i)); temp_list = lte.maj_dev_list; lte.maj_dev_list = ""b; /* clear so we can put in correct order */ j = index (temp_list, TRUE); do while (j ^= 0); if line_device_index (j) = 0 then /* not defined above */ call semant_error (12, "device", line_device_names (j), "line", lte.line_id); else do; if line_device_index (j) < 0 then call semant_error (25, idte.dev_id, lte.line_id); else do; substr (lte.maj_dev_list, line_device_index (j), 1) = TRUE; /* a good one */ substr (var_line_list, line_device_index (j), 1) = FALSE; /* this one was used */ end; end; substr (temp_list, j, 1) = FALSE; j = index (temp_list, TRUE); end; end; /* if any unused variable line keywords found, gripe */ if var_line_list then do; i = index (var_line_list, TRUE); do while (i ^= 0); call semant_error (26, iod_device_tab.dev_id (i)); substr (var_line_list, j, 1) = FALSE; i = index (var_line_list, TRUE); end; end; /* Validate the devices specified in the Request_type and device_class entries. */ /* Find the minor device index for each name in the device array. */ q_group.device_index (*) = 0; /* mark all as not found until we find them */ do i = 1 to q_group_device_names_count; /* loop thru devices */ cn = q_group.device_name (i); do j = 1 to iod_device_tab.n_devices; /* look for major device */ idtep = addr (iod_device_tab.entries (j)); if idte.dev_id = cn.first_name then do; /* found major device */ if cn.second_name = "" then do; /* must have a default minor */ if q_group.is_default_minor (idte.first_minor) then q_group.device_index (i) = idte.first_minor; else q_group.device_index (i) = -1; /* error, no default minor */ go to next_device; end; else do k = idte.first_minor to idte.last_minor; mdtep = addr (minor_device_tab.entries (k)); if mdte.dev_id = cn.second_name then do; /* found minor device */ q_group.device_index (i) = k; go to next_device; end; end; end; end; next_device: end; /* Transform the device_list of each device class so that each bit in the device list corresponds to an entry in the minor device table rather than an entry in the device array. */ do i = 1 to dev_class_tab.n_classes; /* loop thru device classes */ dctep = addr (dev_class_tab.entries (i)); if dcte.device_list = ""b then go to skip_this_entry; temp_list = dcte.device_list; dcte.device_list = ""b; j = index (temp_list, TRUE); do while (j ^= 0); if q_group.device_index (j) <= 0 then do; /* error detected above */ if q_group.device_index (j) = -1 then error_statement_no = 33; /* set error number */ else error_statement_no = 34; error_device_name = q_group.device_name (j).first_name; if q_group.device_name (j).second_name ^= "" then error_device_name = rtrim (error_device_name) || "." || q_group.device_name (j).second_name; error_entry_type_id = before (q_group_tab.name (dcte.qgte_index), " "); if q_group.is_default_device_class (i) then error_entry_type = "Request_type"; else do; error_entry_type = "device_class"; error_entry_type_id = rtrim (error_entry_type_id) || "." || dcte.id; end; call semant_error (error_statement_no, error_device_name, error_entry_type, error_entry_type_id); end; else substr (dcte.device_list, q_group.device_index (j), 1) = TRUE; substr (temp_list, j, 1) = FALSE; j = index (temp_list, TRUE); end; skip_this_entry: end; /* Validate the default types optionally specified for each minor device. */ do i = 1 to minor_device_tab.n_minor; /* loop thru minor devices */ if q_group.default_type (i).first_name ^= "" then do; /* default class specified */ cn = q_group.default_type (i); mdtep = addr (minor_device_tab.entries (i)); do j = 1 to q_group_tab.n_q_groups; /* look for the default_type */ qgtep = addr (q_group_tab.entries (j)); if cn.first_name = qgte.name then do; if cn.second_name = "" then /* no device class specified */ if q_group.is_default_device_class (qgte.first_dev_class) then /* ok, it's a default class */ mdte.default_dev_class = qgte.first_dev_class; else do; /* no default class for this q group */ error_statement_no = 35; /* set up error number */ go to bad_def_type; end; else do; /* look for second name of default_type */ do k = qgte.first_dev_class to qgte.last_dev_class while (dev_class_tab.id (k) ^= cn.second_name); end; if k > qgte.last_dev_class then go to def_type_not_found; mdte.default_dev_class = k; end; dctep = addr (dev_class_tab.entries (mdte.default_dev_class)); if ^substr (dcte.device_list, i, 1) then do; /* device not specified for default type */ error_statement_no = 36; go to bad_def_type; end; go to next_minor; end; end; def_type_not_found: error_statement_no = 37; bad_def_type: full_name2 = cn.first_name; if cn.second_name ^= "" then do; full_name2 = rtrim (full_name2) || "." || cn.second_name; minor_kw2 = "device_class"; end; else minor_kw2 = "Request_type"; full_name = before (iod_device_tab.dev_id (mdte.major_index), " "); if q_group.is_default_minor (i) then minor_kw = "Device"; else do; full_name = rtrim (full_name) || "." || mdte.dev_id; minor_kw = "minor_device"; end; if error_statement_no ^= 36 then call semant_error (error_statement_no, full_name2, minor_kw, full_name); else call semant_error (error_statement_no, full_name2, minor_kw, full_name, full_name, minor_kw2, full_name2); end; next_minor: end; /* make sure the optional request type parameters are defined correctly */ do i = 1 to q_group_tab.n_q_groups; qgtep = addr (q_group_tab.entries (i)); if qgte.max_queues = -1 then /* if not defined, use the Global value */ qgte.max_queues = iod_tables_hdr.max_queues; if qgte.default_queue = -1 then do; /* if not defined, use highest up to 3 */ if qgte.max_queues < 3 then qgte.default_queue = qgte.max_queues; else qgte.default_queue = 3; /* any queue 4 is low priority */ end; else if qgte.default_queue > qgte.max_queues then call semant_error (38, qgte.name); if qgte.page_charge.queue (1) ^= "" then do; /* was the page_charge keyword given? */ do j = 1 to hbound (qgte.page_charge.queue, 1); /* look at each price name */ price_name = qgte.page_charge.queue (j); if price_name = "UNDEFINED_PRICE" then do; /* it was blank */ if j > qgte.max_queues then qgte.page_charge.queue (j) = ""; /* not used */ else do; /* otherwise we need a real price name */ call semant_error (39, qgte.name); go to skip_charge1; end; end; else do; call system_info_$resource_price (price_name, price, code); if code ^= 0 then call semant_error (40, qgte.name, price_name); end; end; skip_charge1: end; if qgte.line_charge.queue (1) ^= "" then do; /* was the line_charge keyword given? */ do j = 1 to hbound (qgte.line_charge.queue, 1); /* look at each price name */ price_name = qgte.line_charge.queue (j); if price_name = "UNDEFINED_PRICE" then do; /* it was blank */ if j > qgte.max_queues then qgte.line_charge.queue (j) = ""; /* not used */ else do; /* otherwise we need a real price name */ call semant_error (39, qgte.name); go to skip_charge; end; end; else do; call system_info_$resource_price (price_name, price, code); if code ^= 0 then call semant_error (40, qgte.name, price_name); end; end; skip_charge: end; /* now let's make sure any forms information references are available. make sure forms table is defined if they are using forms */ if qgte.forms_table.total_chars ^= 0 then do; major_name = return_string (qgte.forms_table); do j = 1 to iod_forms_info_tab.n_groups while (major_name ^= forms_groups.name (j)); end; if j > iod_forms_info_tab.n_groups then call semant_error (12, "Forms_table", major_name, "Request_type", qgte.name); else do; starting_element_index = forms_groups (j).first_element_index; if qgte.default_form.total_chars ^= 0 then do; call parse_parms_string (addr (qgte.default_form)); do k = 1 to parms_count; l = forms_scan_for_element_name (starting_element_index, parms (k)); if l = -1 then call semant_error (12, "default forms element", parms (k), "Request_type", qgte.name); end; end; end; /* make sure any minor devices referred to by this request type also have forms tables defined for them */ do k = qgte.first_dev_class to qgte.last_dev_class; dctep = addr (dev_class_tab.entries (k)); do l = 1 to max_size; if substr (dcte.device_list, l, 1) then if ^substr (minor_device_forms, l, 1) then do; full_name = q_group_tab.entries.name (dcte.qgte_index); if q_group_tab.entries.name (dcte.qgte_index) ^= dcte.id then full_name = rtrim (full_name) || "." || dcte.id; mdtep = addr (minor_device_tab.entries (l)); idtep = addr (iod_device_tab.entries (mdte.major_index)); full_name2 = idte.dev_id; if full_name2 ^= mdte.dev_id then full_name2 = rtrim (full_name2) || "." || mdte.dev_id; call semant_error (53, full_name, full_name2); end; end; end; end; end; /* make sure we've got one of everything we need */ if iod_tables_hdr.max_queues = -1 then call semant_error (41); if iod_tables_hdr.grace_time = -1 then call semant_error (42); if iod_device_tab.n_devices = 0 then call semant_error (43); if q_group_tab.n_q_groups = 0 then call semant_error (44); if ^default_print_defined then call semant_error (45); if ^default_punch_defined then call semant_error (46); end cross_check_table; %page; build_output_table: proc; /* create permanent output seg and copy in the temp seg */ output_dir_name = get_wdir_ (); /* put output seg in working directory */ call tssi_$get_segment (output_dir_name, output_ent_name, output_ptr, acl_info_ptr, code); if code ^= 0 then do; output_error: call com_err_ (code, prog_name, "^a>^a", output_dir_name, output_ent_name); go to finish; end; /* copy the tables into the output seg */ output_ptr -> iod_tables_hdr = iod_tables_hdr; ithp = output_ptr; iod_tables_hdr.version = ""; /* mark it inconsistent while we're copying */ copy_ptr = adjust_ptr (addr (iod_tables_hdr.start_of_tables)); copy_ptr -> line_tab = line_tab; ltp = copy_ptr; line_tab.n_lines = line_tab.n_lines + 1; copy_ptr = adjust_ptr (addr (line_tab.entries (line_tab.n_lines))); line_tab.n_lines = line_tab.n_lines - 1; copy_ptr -> iod_device_tab = iod_device_tab; idtp = copy_ptr; iod_device_tab.n_devices = iod_device_tab.n_devices + 1; copy_ptr = adjust_ptr (addr (iod_device_tab.entries (iod_device_tab.n_devices))); iod_device_tab.n_devices = iod_device_tab.n_devices - 1; copy_ptr -> minor_device_tab = minor_device_tab; mdtp = copy_ptr; minor_device_tab.n_minor = minor_device_tab.n_minor + 1; copy_ptr = adjust_ptr (addr (minor_device_tab.entries (minor_device_tab.n_minor))); minor_device_tab.n_minor = minor_device_tab.n_minor - 1; copy_ptr -> q_group_tab = q_group_tab; qgtp = copy_ptr; q_group_tab.n_q_groups = q_group_tab.n_q_groups + 1; copy_ptr = adjust_ptr (addr (q_group_tab.entries (q_group_tab.n_q_groups))); q_group_tab.n_q_groups = q_group_tab.n_q_groups - 1; copy_ptr -> dev_class_tab = dev_class_tab; dctp = copy_ptr; dev_class_tab.n_classes = dev_class_tab.n_classes + 1; copy_ptr = adjust_ptr (addr (dev_class_tab.entries (dev_class_tab.n_classes))); dev_class_tab.n_classes = dev_class_tab.n_classes - 1; iod_forms_info_tab.element_data_block = forms_elements; iod_forms_info_tab.groups = forms_groups; copy_ptr -> iod_forms_info_tab = iod_forms_info_tab; ifitp = copy_ptr; iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups + 1; copy_ptr = adjust_ptr (addr (iod_forms_info_tab.groups (iod_forms_info_tab.n_groups))); iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups - 1; copy_ptr -> text_strings = text_strings; text_strings_ptr = copy_ptr; /* now fill in the header */ iod_tables_hdr.line_tab_offset = fixed (rel (ltp), 18); iod_tables_hdr.device_tab_offset = fixed (rel (idtp), 18); iod_tables_hdr.minor_device_tab_offset = fixed (rel (mdtp), 18); iod_tables_hdr.q_group_tab_offset = fixed (rel (qgtp), 18); iod_tables_hdr.dev_class_tab_offset = fixed (rel (dctp), 18); iod_tables_hdr.forms_info_tab_offset = fixed (rel (ifitp), 18); iod_tables_hdr.text_strings_offset = fixed (rel (text_strings_ptr), 18); iod_tables_hdr.date_time_compiled = clock_ (); iod_tables_hdr.version = IODT_VERSION_5; text_strings_array_ptr = addr (text_strings.chars); text_strings.length = text_strings.length + 4; copy_ptr = addr (text_strings_array (text_strings.length)); /* get ptr 1 char beyond end of data */ bit_count = 36 * fixed (rel (copy_ptr), 18); /* compute bit count */ call tssi_$finish_segment (output_ptr, bit_count, "1000"b, acl_info_ptr, code); if code ^= 0 then go to output_error; output_ptr, acl_info_ptr = null; /* internal routine to make sure pointer is on an even word boundary */ adjust_ptr: proc (ptr_to_adjust) returns (ptr); dcl ptr_to_adjust ptr; if mod (fixed (rel (ptr_to_adjust), 18), 2) ^= 0 then return (addrel (ptr_to_adjust, 1)); else return (ptr_to_adjust); end adjust_ptr; end build_output_table; %page; /* Syntax Functions */ /* General syntax functions */ /* similar to the built-in syntax functions except they use different length limitations and special char strings */ name_routines: proc; dcl name_length fixed bin; dcl name_type fixed bin; name_32: entry returns (bit (1)); /* allow upper/lower case alpha, numeric, - & _ */ name_length = 32; name_type = 1; go to name_routines_common; name_24: entry returns (bit (1)); /* allow upper/lower case alpha, numeric, - & _ */ name_length = 24; name_type = 1; go to name_routines_common; name_path: entry returns (bit (1)); /* allow upper/lower case alpha, numeric & -_$<> */ name_length = 256; name_type = 2; go to name_routines_common; name_comm_line: entry returns (bit (1)); /* allow upper/lower case alpha, numeric & _.* / */ name_length = 32; name_type = 3; go to name_routines_common; name_user_id: entry returns (bit (1)); /* allow upper/lower case alpha, numeric & -_.* */ name_length = 30; name_type = 4; go to name_routines_common; name_32_multi: entry returns (bit (1)); /* allow upper/lower case alpha, numeric & _.- */ name_length = 32; name_type = 5; go to name_routines_common; name_routines_common: if token.Lvalue > 0 then do; if token.Lvalue <= name_length then do; if name_type = 1 then do; /* name_32 & name_24 */ if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_-") = 0 then return (TOKEN_GOOD); end; else if name_type = 2 then do; /* name_path */ if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "-_$<>") = 0 then return (TOKEN_GOOD); end; else if name_type = 3 then do; /* name_comm_line */ if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.*/") = 0 then return (TOKEN_GOOD); end; else if name_type = 4 then do; /* name_user_id */ if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.*") = 0 then return (TOKEN_GOOD); end; else if name_type = 5 then do; /* name_32_multi */ if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.-") = 0 then return (TOKEN_GOOD); end; end; end; return (TOKEN_BAD); end name_routines; %page; /* General action routines */ /* routines to store various strings in the text_strings area */ store_string_functions: proc; dcl string_to_store char (*); dcl 1 target unaligned like text_offset; dcl source_string char (source_string_len) based (source_string_ptr); dcl source_string_len fixed bin; dcl source_string_ptr ptr; dcl target_string char (source_string_len) based (target_string_ptr); dcl target_string_ptr ptr; dcl dupe_string_loc fixed bin; store_forms_escape_string: entry (target); /* copy the string in forms_escape_string_n into text_strings and save offset and length of the copied string in target structure values */ source_string_ptr = addr (forms_escape_string_n); source_string_len = forms_escape_string_index - 1; go to common; store_temp_token_value_string: entry (target); /* routine copies the temp_token_value string into text_strings and saves offset and length of the copied string in target structure values */ source_string_ptr = addrel (addr (temp_token_value), 1); source_string_len = length (temp_token_value); go to common; store_token_value_string: entry (target); /* routine copies the token_value string into text_strings and saves offset and length of the copied string in target structure values */ source_string_ptr = token.Pvalue; source_string_len = token.Lvalue; go to common; store_direct_string: entry (target, string_to_store); /* this routine stores the input string it is called with into text_strings and saves the offset and length of the string into target structure values */ source_string_ptr = addr (string_to_store); source_string_len = length (rtrim (string_to_store)); common: text_strings.length = text_strings.length + 1; target_string_ptr = addr (text_strings_array (text_strings.length)); text_strings.length = text_strings.length - 1; /* eliminate dupe strings by seeing if this exact string is already in the text_strings area. If not, we will add it. If it is, we will just record the starting location of the string already in the text_strings area as the location of this copy */ dupe_string_loc = index (text_strings.chars, source_string); if dupe_string_loc = 0 then do; /* new string */ target_string = source_string; /* copy string */ target.first_char = text_strings.length + 1; /* save where it starts */ text_strings.length = text_strings.length + source_string_len; /* bump count of string chars saved */ end; else do; /* dupe string */ target.first_char = dupe_string_loc; /* save where it starts */ end; target.total_chars = source_string_len; /* save length of string */ return; end store_string_functions; /* routine to return a string from the text string area */ return_string: proc (source_offsets) returns (char (*)); dcl 1 source_offsets unaligned like text_offset; if source_offsets.total_chars = 0 then return (""); else return (substr (text_strings.chars, source_offsets.first_char, source_offsets.total_chars)); end return_string; /* parse a comma delimited string into its components */ parse_parms_string: proc (data_offset_ptr); dcl data_offset_ptr ptr; /* ptr to text_offset data */ dcl 1 source_text_offsets unaligned like text_offset based (data_offset_ptr); temp_token_value = return_string (source_text_offsets); parms_count = 0; parms (*) = ""; loop: parms_count = parms_count + 1; parms (parms_count) = before (temp_token_value, ","); temp_token_value = after (temp_token_value, ","); if temp_token_value ^= "" then go to loop; end parse_parms_string; %page; /* global action routines */ store_global_grace_time: proc; if iod_tables_hdr.grace_time ^= -1 then call statement_error (4, "Time"); else iod_tables_hdr.grace_time = token.Nvalue * 60000000; end store_global_grace_time; store_global_max_queues: proc; if iod_tables_hdr.max_queues ^= -1 then call statement_error (4, "Max_queues"); else do; if token.Nvalue < 1 | token.Nvalue > 4 then call statement_error (6, "Max_queues", "4"); else iod_tables_hdr.max_queues = token.Nvalue; end; end store_global_max_queues; %page; /* syntax functions and action routines for Line keyword and it's subordinate keywords */ /* Syntax functions */ /* Action Routines */ /* create a new entry in the line table */ line_create_table_entry: proc; /* first see if line is currently defined in the table */ do i = 1 to line_tab.n_lines /* is line currently defined */ while (line_tab.line_id (i) ^= token_value); end; if i <= line_tab.n_lines then /* in table so complain */ call statement_error (10, "Line", token_value); /* Create entry in table for this line name. We will create a new entry for a duplicate name so we can check the rest of the substatements */ line_tab.n_lines = line_tab.n_lines + 1; ltep = addr (line_tab.entries (line_tab.n_lines)); /* now clear out the entry */ unspec (lte) = "0"b; lte.line_id = token_value; lte.chan_id = ""; lte.att_desc.first_char, lte.att_desc.total_chars = 0; lte.maj_dev_list = ""b; end line_create_table_entry; /* save line attach description */ line_save_att_desc: proc; if token.Lvalue > max_length_att_desc then call statement_error (15, "att_desc", max_length_att_desc_char); if lte.att_desc.total_chars ^= 0 then call statement_error (13, "att_desc", "Line", token_value); call store_token_value_string (lte.att_desc); end line_save_att_desc; /* save line comment */ line_save_comment: proc; if token.Lvalue > max_length_comment then call statement_error (15, "comment", max_length_comment_char); if lte.comment.total_chars ^= 0 then call statement_error (13, "comment", "Line", token_value); call store_token_value_string (lte.comment); end line_save_comment; /* make sure channel ID is valid and save it */ line_save_channel_id: proc; dcl channel_id fixed bin; dcl fnp_sw bit (1) aligned; /* validate that this is good channel ID */ if cdtp ^= null then do; call cdt_mgr_$find_cdt_channel (cdtp, (token_value), channel_id, fnp_sw, code); if code ^= 0 then call statement_error (14); end; if lte.chan_id ^= "" then call statement_error (13, "channel", "Line", (lte.line_id)); lte.chan_id = token_value; end line_save_channel_id; /* save line device name */ line_save_device: proc; /* see if this device name is already used in a line statement */ do i = 1 to line_device_names_count while (line_device_names (i) ^= token_value); end; if i > line_device_names_count then do; /* new device name */ if i > max_size then do; /* table too big */ call statement_error (16, max_size_char, "devices"); end; line_device_names_count = i; /* bump count of remembered devices */ line_device_names (i) = token_value; /* and save the new name */ end; /* set the lte entry to point to the device name in the temp list. We will reset to to the true device entry later */ substr (lte.maj_dev_list, i, 1) = TRUE; end line_save_device; /* validate that line table entry is complete */ line_validate_entry: proc; if lte.maj_dev_list = FALSE then call semant_error (18, "devices", "Line", lte.line_id); if lte.chan_id = "" then call semant_error (19, "channel", "Line", lte.line_id); if lte.att_desc.total_chars = 0 then call semant_error (19, "att_desc", "Line", lte.line_id); end line_validate_entry; %page; /* syntax functions for Device keyword and it's subordinate keywords */ /* the following action entries are for the Device keyword and it's device table */ /* create a new minor device table entry */ dev_create_minor_table_entry: proc; /* If we defined a default minor device because we already found some minor device statements, change its name from the default name to this name. If there is no default minor device defined yet, we start add this one to the chain of current minor devices */ if default_minor_device_defined then do; default_minor_device_defined = FALSE; call revert_default_minor_device; end; else call init_minor_device; end dev_create_minor_table_entry; /* create a new entry in the device table */ dev_create_table_entry: proc; /* see if this is valid device name and is currently undefined */ do i = 1 to iod_device_tab.n_devices /* is device already defined */ while (iod_device_tab.dev_id (i) ^= token_value); end; if i <= iod_device_tab.n_devices then /* it is in table so complain */ call statement_error (10, "Device", token_value); /* Create entry in table for this line name. We will create a new entry for a duplicate name so we can check the rest of the substatements */ iod_device_tab.n_devices = iod_device_tab.n_devices + 1; idtep = addr (iod_device_tab.entries (iod_device_tab.n_devices)); /* now clear out the entry */ unspec (idte) = "0"b; default_minor_device_defined = FALSE; idte.dev_id = token_value; idte.attach_name, idte.ctl_attach_name = ""; idte.driver_module.first_char, idte.driver_module.total_chars, idte.args.first_char, idte.args.total_chars, idte.head_sheet.first_char, idte.head_sheet.total_chars, idte.tail_sheet.first_char, idte.tail_sheet.total_chars = 0; idte.attach_type, idte.ctl_attach_type, idte.first_minor, idte.last_minor, idte.paper_type = -1; mdtep = null; end dev_create_table_entry; dev_save_args: proc; if idte.args.total_chars ^= 0 then call statement_error (13, "args", "Device", idte.dev_id); call store_token_value_string (idte.args); end dev_save_args; dev_save_attach_method: proc (device_or_terminal, type_attach); dcl device_or_terminal fixed bin; /* 1 = device entry */ /* 2 = control terminal attachment */ dcl type_attach fixed bin; dcl item_names (2, 4) char (13) int static options (constant) init ( "prph", "line", "dial_id", "variable line", "ctl_line", "ctl_dial_id", "ctl_source", ""); if device_or_terminal = 1 then do; /* device */ if idte.attach_type ^= -1 then do; /* already have attachment for this entry */ if idte.attach_type = type_attach then call statement_error (13, item_names (device_or_terminal, type_attach), "Device", idte.dev_id); else call statement_error (22, idte.dev_id); end; else do; if type_attach = ATTACH_TYPE_DIAL then call check_dial_id (token_value, "dial_id"); idte.attach_name = token_value; idte.attach_type = type_attach; if type_attach = ATTACH_TYPE_VARIABLE_LINE then substr (var_line_list, iod_device_tab.n_devices, 1) = TRUE; end; end; else do; /* control terminal attachment */ if idte.ctl_attach_type ^= -1 then do; /* already have attachment for this entry */ if idte.ctl_attach_type = type_attach then call statement_error (13, item_names (device_or_terminal, type_attach), "Device", idte.dev_id); else call statement_error (24, idte.dev_id); end; else do; if type_attach = CTL_ATTACH_TYPE_DIAL then call check_dial_id (token_value, "ctl_dial_id"); idte.ctl_attach_name = token_value; idte.ctl_attach_type = type_attach; if type_attach = CTL_ATTACH_TYPE_MC then substr (var_line_list, iod_device_tab.n_devices, 1) = TRUE; end; end; /* checks if a dial id is unique */ check_dial_id: proc (value_to_check, keyword_name); dcl value_to_check char (*); dcl keyword_name char (*); do i = 1 to iod_device_tab.n_devices; if iod_device_tab.attach_type (i) = ATTACH_TYPE_DIAL then if iod_device_tab.attach_name (i) = value_to_check then go to dial_id_dup; if iod_device_tab.ctl_attach_type (i) = CTL_ATTACH_TYPE_DIAL then if iod_device_tab.ctl_attach_name (i) = value_to_check then go to dial_id_dup; end; return; dial_id_dup: call statement_error (23, keyword_name, value_to_check, idte.dev_id); end check_dial_id; end dev_save_attach_method; /* save device or minor device comment */ dev_save_comment: proc; if token.Lvalue > max_length_comment then call statement_error (15, "comment", max_length_comment_char); /* if there is no minor device entry, the comment belongs in the device entry */ if mdtep = null () then do; if idte.comment.total_chars ^= 0 then call statement_error (13, "comment", "Device", idte.dev_id); call store_token_value_string (idte.comment); end; else do; if mdte.comment.total_chars ^= 0 then call statement_error (13, "comment", "minor_device", mdte.dev_id); call store_token_value_string (mdte.comment); end; end dev_save_comment; dev_save_default_form: proc; /* if no minor devices defined, then define the default */ if idte.first_minor = -1 then call init_default_minor_device; /* validate that this is the first default form entry for this minor device */ if mdte.default_form.total_chars ^= 0 then call statement_error (49, "default_form", "minor_device", mdte.dev_id, "Device", idte.dev_id); if temp_token_value_used then do; temp_token_value_used = FALSE; call store_temp_token_value_string (mdte.default_form); end; else call store_token_value_string (mdte.default_form); end dev_save_default_form; dev_save_default_type: proc; /* parse default_type name into it's two possible parts */ cn.first_name = before (token_value, "."); cn.second_name = after (token_value, "."); /* if there are no minor devices, create the default entry */ if idte.first_minor = -1 then call init_default_minor_device; /* otherwise check for duplicate entry for this device */ else do; if q_group.default_type (minor_device_tab.n_minor).first_name ^= "" then call statement_error (49, "default_type", "minor_device", mdte.dev_id, "Device", idte.dev_id); end; /* save the minor device name in temp storage for later use */ q_group.default_type (minor_device_tab.n_minor).first_name = cn.first_name; q_group.default_type (minor_device_tab.n_minor).second_name = cn.second_name; end dev_save_default_type; dev_save_driver_module: proc; if idte.driver_module.total_chars ^= 0 then do; call statement_error (13, "driver_module", "Device", idte.dev_id); end; call store_token_value_string (idte.driver_module); end dev_save_driver_module; dev_save_forms_validation: proc; if idte.forms_validation.total_chars ^= 0 then call statement_error (13, "forms_validation", "Device", idte.dev_id); call store_token_value_string (idte.forms_validation); end dev_save_forms_validation; dev_save_font_dir: proc; if idte.font_dir.total_chars ^= 0 then call statement_error (13, "font_dir", "Device", idte.dev_id); call store_token_value_string (idte.font_dir); end dev_save_font_dir; dev_save_forms_table: proc; if idte.forms_table.total_chars ^= 0 then call statement_error (13, "forms_table", "Device", idte.dev_id); call store_token_value_string (idte.forms_table); end dev_save_forms_table; dev_save_head_sheet: proc; if idte.head_sheet.total_chars ^= 0 then call statement_error (13, "head_sheet", "Device", idte.dev_id); call store_token_value_string (idte.head_sheet); end dev_save_head_sheet; dev_save_minor_args: proc; /* if no minor devices defined, then define the default */ if idte.first_minor = -1 then call init_default_minor_device; /* validate that this is the first minor args entry for this minor device */ if mdte.args.total_chars ^= 0 then call statement_error (49, "minor_args", "minor_device", mdte.dev_id, "Device", idte.dev_id); call store_token_value_string (mdte.args); end dev_save_minor_args; dev_save_paper_type: proc; if idte.paper_type ^= -1 then call statement_error (13, "paper_type", "Device", idte.dev_id); if token_value = "continuous" then idte.paper_type = PAPER_TYPE_CONTINUOUS; else if token_value = "single" then idte.paper_type = PAPER_TYPE_SINGLE; end dev_save_paper_type; dev_save_tail_sheet: proc; if idte.tail_sheet.total_chars ^= 0 then call statement_error (13, "tail_sheet", "Device", idte.dev_id); call store_token_value_string (idte.tail_sheet); end dev_save_tail_sheet; /* validate that a device entry is complete */ dev_validate_entry: proc; /* create a default minor device if none explicitely defined */ if idte.first_minor = -1 then call init_default_minor_device; /* make sure required elements are defined */ if idte.driver_module.total_chars = 0 then call semant_error (47, idte.dev_id); if idte.attach_type = 0 then call semant_error (48, idte.dev_id); /* make sure there is a cross-check between forms_table and default forms */ do i = idte.first_minor to idte.last_minor; mdtep = addr (minor_device_tab.entries (i)); if mdte.default_form.total_chars = 0 then do;/* no default form defined */ if idte.forms_table.total_chars ^= 0 then do; /* but a forms table defined */ if mdte.dev_id = idte.dev_id then call semant_error (19, "default_form", "Device", idte.dev_id); else call semant_error (19, "default_form", "minor_device", mdte.dev_id); end; end; else do; /* have default form defined */ if idte.forms_table.total_chars = 0 then/* but no forms table defined */ call semant_error (19, "forms_table", "Device", idte.dev_id); /* turn on bits for any minor devices which have forms_table entries defined */ substr (minor_device_forms, i, 1) = TRUE; end; end; end dev_validate_entry; init_default_minor_device: proc; default_minor_device_defined = TRUE; init_minor_device: entry; minor_device_tab.n_minor = minor_device_tab.n_minor + 1; if minor_device_tab.n_minor > max_size then do; call statement_error (16, max_size_char, "minor_device"); end; mdtep = addr (minor_device_tab.entries (minor_device_tab.n_minor)); unspec (mdte) = "0"b; if idte.first_minor = -1 then idte.first_minor = minor_device_tab.n_minor; idte.last_minor = minor_device_tab.n_minor; mdte.default_dev_class = 0; mdte.major_index = iod_device_tab.n_devices; mdte.args.first_char, mdte.args.total_chars, mdte.default_form.first_char, mdte.default_form.total_chars = 0; q_group.default_type (minor_device_tab.n_minor) = ""; if default_minor_device_defined then minor_name = idte.dev_id; else do; revert_default_minor_device: entry; minor_name = token_value; end; mdte.dev_id = substr (minor_name, 1, length (mdte.dev_id)); q_group.is_default_minor (minor_device_tab.n_minor) = default_minor_device_defined; end init_default_minor_device; %page; /* syntax and action functions for Request_type keyword and it's subordinate keywords */ /* Syntax */ access_class_ok: proc returns (bit (1)); /* validate authorization for validity. leave the validated result in the authorization_bits variable for later use */ call convert_authorization_$from_string (authorization_bits, token_value, code); return (code = 0); end access_class_ok; /* Action routines */ /* create a new entry in the request type table */ rqt_create_table_entry: proc; /* see if this is valid request type name and is currently undefined */ do i = 1 to q_group_tab.n_q_groups /* is line in table */ while (q_group_tab.name (i) ^= token_value); end; if i <= q_group_tab.n_q_groups then /* it is in table so complain */ call statement_error (10, "Request_Type", token_value); /* Create entry in table for this line name. We will create a new entry for a duplicate name so we can check the rest of the substatements */ q_group_tab.n_q_groups = q_group_tab.n_q_groups + 1; qgtep = addr (q_group_tab.entries (q_group_tab.n_q_groups)); /* now clear out the entry */ unspec (qgte) = "0"b; default_device_class_defined = FALSE; /* OFF until default class is defined by implication */ qgte.name = token_value; qgte.driver_id, qgte.generic_type, qgte.rqti_seg_name, qgte.line_charge.queue (*), qgte.page_charge.queue (*) = ""; qgte.accounting.first_char, qgte.accounting.total_chars, qgte.forms_validation.first_char, qgte.forms_validation.total_chars, qgte.default_form.first_char, qgte.default_form.total_chars, qgte.forms_table.first_char, qgte.forms_table.total_chars, qgte.font_dir.first_char, qgte.font_dir.total_chars = 0; qgte.default_generic_queue, qgte.default_queue, qgte.max_queues, qgte.first_dev_class, qgte.last_dev_class = -1; line_charge_keyword_used, page_charge_keyword_used = FALSE; dctep = null; end rqt_create_table_entry; rqt_save_access: proc (type); dcl type fixed bin; dcl error_string_names (3) char (16) int static options (constant) init ("max_access_class", "min_access_class", "min_banner"); /* create default access class if there is no class currently defined */ if qgte.first_dev_class = -1 then call rqt_create_default_device_class_entry; /* validate for dupe entry for this storage value */ if (type = 1 & dcte.max_access ^= (72)"1"b) | (type = 2 & dcte.min_access ^= (72)"1"b) | (type = 3 & dcte.min_banner ^= (72)"1"b) then do; call statement_error (13, error_string_names (type), "Request_type", qgte.name); end; /* the authorization_bits variable was set by an immediately preceeding call to access_class_ok. now store it. */ if type = 1 then /* max_access_class */ dcte.max_access = authorization_bits; else if type = 2 then /* min_access_class */ dcte.min_access = authorization_bits; else dcte.min_banner = authorization_bits; /* min_banner */ end rqt_save_access; rqt_save_accounting: proc; if qgte.accounting.total_chars ^= 0 then call statement_error (13, "accounting", "Request_type", qgte.name); call store_token_value_string (qgte.accounting); end rqt_save_accounting; rqt_save_charge: proc (type); dcl type fixed bin; dcl charge_type (3) char (11) int static options (constant) init ("line_charge", "page_charge", "card_charge"); if type = 1 | type = 3 then do; if line_charge_keyword_used then call statement_error (13, charge_type (type), "Request_type", qgte.name); qgte.line_charge.queue (*) = "UNDEFINED_PRICE"; line_charge_keyword_used = TRUE; end; else if type = 2 then do; if qgte.generic_type = "punch" then call statement_error (2, charge_type (type)); if page_charge_keyword_used then call statement_error (13, charge_type (type), "Request_type", qgte.name); qgte.page_charge.queue (*) = "UNDEFINED_PRICE"; page_charge_keyword_used = TRUE; end; saved_charge_type = type; saved_charge_cntr = 1; rqt_save_charge_continue: entry; if saved_charge_type = 1 | saved_charge_type = 3 then qgte.line_charge.queue (saved_charge_cntr) = token_value; else qgte.page_charge.queue (saved_charge_cntr) = token_value; if saved_charge_cntr < 4 then saved_charge_cntr = saved_charge_cntr + 1; end rqt_save_charge; /* save Request_type comment */ rqt_save_comment: proc; if token.Lvalue > max_length_comment then call statement_error (15, "comment", max_length_comment_char); if qgte.comment.total_chars ^= 0 then call statement_error (13, "comment", "Device", qgte.name); call store_token_value_string (qgte.comment); end rqt_save_comment; rqt_save_default_form: proc; /* look for dupe entry */ if qgte.default_form.total_chars ^= 0 then call statement_error (13, "default_form", "Request_type", qgte.name); if temp_token_value_used then do; temp_token_value_used = FALSE; call store_temp_token_value_string (qgte.default_form); end; else call store_token_value_string (qgte.default_form); end rqt_save_default_form; rqt_save_default_queue: proc; if qgte.default_queue ^= -1 then call statement_error (13, "default_queue", "Request_type", qgte.name); if token.Nvalue < 1 | token.Nvalue > 3 then call statement_error (6, "default_queue", "3"); else qgte.default_queue = token.Nvalue; end rqt_save_default_queue; rqt_save_device: proc; /* parse device name into it's two possible parts */ cn.first_name = before (token_value, "."); cn.second_name = after (token_value, "."); /* see device is already defined */ do i = 1 to q_group_device_names_count while (q_group.device_name (i).first_name ^= cn.first_name | q_group.device_name (i).second_name ^= cn.second_name); end; if qgte.first_dev_class = -1 then call rqt_create_default_device_class_entry; else do; if substr (dcte.device_list, i, 1) then call statement_error (17, token_value, "request_type", qgte.name); end; /* save the data */ substr (dcte.device_list, i, 1) = TRUE; if i > q_group_device_names_count then do; q_group_device_names_count = i; q_group.device_name.first_name (i) = cn.first_name; q_group.device_name.second_name (i) = cn.second_name; end; end rqt_save_device; rqt_save_driver_id: proc; dcl (person, project, instance) char (32) varying; if qgte.driver_id ^= "" then do; call statement_error (13, "driver_id", "Request_type", qgte.name); end; person = before (token_value, "."); project = after (token_value, "."); if project = "" then call statement_error (20); instance = after (project, "."); project = before (project, "."); if instance ^= "" then call statement_error (21); qgte.driver_id = person || "." || project || ".*"; end rqt_save_driver_id; rqt_save_forms_validation: proc; if qgte.forms_validation.total_chars ^= 0 then call statement_error (13, "forms_validation", "Request_type", qgte.name); call store_token_value_string (qgte.forms_validation); end rqt_save_forms_validation; rqt_save_font_dir: proc; if qgte.font_dir.total_chars ^= 0 then call statement_error (13, "font_dir", "Device", qgte.name); call store_token_value_string (qgte.font_dir); end rqt_save_font_dir; rqt_save_forms_table: proc; if qgte.forms_table.total_chars ^= 0 then call statement_error (13, "forms_table", "Device", qgte.name); call store_token_value_string (qgte.forms_table); end rqt_save_forms_table; rqt_save_generic_type: proc; if qgte.generic_type ^= "" then call statement_error (13, "generic_type", "Request_type", qgte.name); qgte.generic_type = token_value; if token_value = qgte.name then do; qgte.default_generic_queue = 1; if token_value = "printer" then default_print_defined = TRUE; else if token_value = "punch" then default_punch_defined = TRUE; end; end rqt_save_generic_type; rqt_save_max_queues: proc; if qgte.max_queues ^= -1 then call statement_error (13, "max_queues", "Request_type", qgte.name); if token.Nvalue < 1 | token.Nvalue > 4 then call statement_error (6, "max_queues", "4"); else qgte.max_queues = token.Nvalue; end rqt_save_max_queues; rqt_save_rqti_seg: proc; if qgte.rqti_seg_name ^= "" then call statement_error (13, "rqti_seg_name", "Request_type", qgte.name); qgte.rqti_seg_name = token_value; end rqt_save_rqti_seg; /* validate that a request type entry is complete */ rqt_validate_entry: proc; if qgte.first_dev_class = -1 then call rqt_create_default_device_class_entry; call rqt_check_device_class; if qgte.driver_id = "" then qgte.driver_id = "IO.SysDaemon.*"; if qgte.accounting.total_chars = 0 then call store_direct_string (qgte.accounting, "system"); if return_string (qgte.accounting) ^= "system" then do; if qgte.driver_id = "IO.SysDaemon" then call semant_error (28, qgte.name); end; else if after (qgte.driver_id, ".") ^= "SysDaemon.*" then call semant_error (29, qgte.name); if qgte.generic_type = "" then call semant_error (19, "generic_type", "Request_type", qgte.name); if qgte.forms_table.total_chars = 0 then do; /* no forms table defined */ if qgte.default_form.total_chars ^= 0 then /* but default form defined */ call semant_error (19, "forms_table", "Request_type", qgte.name); end; else do; /* forms table is defined */ if qgte.default_form.total_chars = 0 then /* but no default form defined */ call semant_error (19, "default_form", "Request_type", qgte.name); /* turn on bits to show which device classes have forms table entries */ do i = qgte.first_dev_class to qgte.last_dev_class; substr (device_class_forms, i, 1) = TRUE; end; end; end rqt_validate_entry; rqt_check_device_class: proc; /* fills in defaults if necessary */ if dcte.min_access = (72)"1"b then dcte.min_access = ""b; if dcte.min_banner = (72)"1"b then dcte.min_banner = dcte.min_access; if dcte.max_access = (72)"1"b then dcte.max_access = dcte.min_access; if dcte.device_list = ""b then call semant_error (18, "devices", "Request_type", qgte.name); end rqt_check_device_class; rqt_create_default_device_class_entry: proc; default_device_class_defined = TRUE; rqt_create_device_class_entry: entry; dev_class_tab.n_classes = dev_class_tab.n_classes + 1; if dev_class_tab.n_classes > max_size then do; call statement_error (16, max_size_char, "device_class"); end; dctep = addr (dev_class_tab.entries (dev_class_tab.n_classes)); unspec (dcte) = "0"b; if qgte.first_dev_class = -1 then qgte.first_dev_class = dev_class_tab.n_classes; qgte.last_dev_class = dev_class_tab.n_classes; dcte.qgte_index = q_group_tab.n_q_groups; dcte.max_access, dcte.min_access, dcte.min_banner = (72)"1"b; dcte.device_list = ""b; if default_device_class_defined then minor_name = qgte.name; else do; revert_default_class: entry; minor_name = token_value; end; dcte.id = minor_name; q_group.is_default_device_class (dev_class_tab.n_classes) = default_device_class_defined; end rqt_create_default_device_class_entry; %page; /* syntax functions for the Forms_table keyword and it's subordinate keywords */ forms_size_ok: proc returns (bit (1)); dcl number_float float bin (27); dcl type char (12); item_ok = TOKEN_GOOD; number_float = cv_float_ (token_value, code); /* try to convert */ forms_size_type = 1; /* assume inches */ /* if it didn't like the number to convert, probabily contains alpha chars defining the type of number specified. Reconvert the data up to the bad char and test the bad chars for valid conversion types. */ if code ^= 0 then do; number_float = convert (number_float, substr (token_value, 1, code - 1)); type = substr (token_value, code); if type = "in" | type = "i" | type = "inches" then forms_size_type = FACTOR_INCHES; else if type = "cm" | type = "c" | type = "centimeters" then forms_size_type = FACTOR_CENTIMETERS; else if type = "pt" | type = "p" | type = "points" then forms_size_type = FACTOR_POINTS; else if type = "lpi" | type = "LPI" then forms_size_type = FACTOR_LPI; else item_ok = TOKEN_BAD; end; if item_ok then do; if forms_size_type ^= FACTOR_LPI then forms_size_info = SIZE_FACTORS (forms_size_type) * number_float; else forms_size_info = SIZE_FACTORS (forms_size_type) / number_float; end; return (item_ok); end forms_size_ok; forms_type: proc returns (bit (1)); item_ok = TOKEN_GOOD; do i = lbound (FORMS_TYPE_STRINGS, 1) to hbound (FORMS_TYPE_STRINGS, 1) while (token_value ^= FORMS_TYPE_STRINGS (i)); end; if i > hbound (FORMS_TYPE_STRINGS, 1) then do; item_ok = TOKEN_BAD; token.Nvalue = 0; end; else token.Nvalue = i; return (item_ok); end forms_type; forms_tty_char_ok: proc returns (bit (1) aligned); dcl ALL_LOWERCASE char (26) defined ALL_VALID_CHARS_AND_NUMERIC pos (27); dcl ALL_UPPERCASE char (26) defined ALL_VALID_CHARS_AND_NUMERIC pos (1); dcl asc_mnemonic char (3); dcl i fixed bin; dcl asc_value (0:32) char (3) static options (constant) init ("nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", "bs ", "tab", "lf ", "vt ", "ff ", "cr ", "so ", "si ", "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", "can", "em ", "sub", "esc", "fs ", "gs ", "rs ", "us ", "sp "); if token.quoted_string & token.Lvalue = 1 then call return_tty_char (bin (unspec (token_value))); if token.Lvalue = 1 then do; if index (BREAKS, token_value) = 0 then call return_tty_char (bin (unspec (token_value))); end; if octal_char_ok () then return (TOKEN_GOOD); if token.Lvalue = 2 & substr (token_value, 1, 1) = "^" then do; i = index ("@abcdefghijklmnopqrstuvwxyz[\]^_", substr (token_value, 2, 1)); if i = 0 then i = index ("@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_", substr (token_value, 2, 1)); if i = 0 then return (TOKEN_BAD); call return_tty_char (i - 1); end; if token.Lvalue <= 3 then do; asc_mnemonic = translate (token_value, ALL_LOWERCASE, ALL_UPPERCASE); if asc_mnemonic = "del" then call return_tty_char (127); if asc_mnemonic = "nl " then call return_tty_char (10); if asc_mnemonic = "pad" then call return_tty_char (0); if asc_mnemonic = "ht" then call return_tty_char (9); do i = lbound (asc_value, 1) to hbound (asc_value, 1); if asc_value (i) = asc_mnemonic then call return_tty_char (i); end; end; return (TOKEN_BAD); return_tty_char: proc (a_value); dcl a_value fixed bin; token.Nvalue = a_value; go to nlret; end return_tty_char; nlret: return (TOKEN_GOOD); octal_char_ok: proc returns (bit (1) aligned); if token.Lvalue > 3 then return (TOKEN_BAD); token.Nvalue = cv_oct_check_ (token_value, code); return (code = 0); end octal_char_ok; end forms_tty_char_ok; %page; /* the following entries are for the Forms_table keyword and it's table */ /* add a synonym name to the current element entry */ forms_add_syn_element_name: proc; element_common.n_names = element_common.n_names + 1; call store_token_value_string (element_common.names (element_common.n_names)); end forms_add_syn_element_name; /* create a new element entry. since we are creating these entries in a temp segment, we know that the entire entry is zeros when we start */ forms_create_element_entry: proc; dcl element_offset fixed bin; dcl temp_fep ptr; call forms_validate_entry; /* validate last entry */ /* see if this name is already defined within the forms group. We will save the current element ptr (fep), then scan through the current element names to see if this one is unique; if not we will complain. In any case, we will create a new element ptr at the end of the current elements */ element_offset = forms_groups (iod_forms_info_tab.n_groups).first_element_index; i = forms_scan_for_element_name (element_offset, token_value); if i ^= -1 then call statement_error (50, token_value, return_string (element_common.names (i))); /* Create entry in table for this line name. We will create a new entry for a duplicate name so we can check the rest of the substatements */ temp_fep = addrel (addr (forms_elements (iod_forms_info_tab.n_words)), 1); if fep ^= null then element_common.next_element_index = iod_forms_info_tab.n_words + 1; else forms_groups (iod_forms_info_tab.n_groups).first_element_index = iod_forms_info_tab.n_words + 1; fep = temp_fep; /* now clear out the entry */ unspec (element_common) = "0"b; element_common.n_names = 1; call store_token_value_string (element_common.names (1)); element_common.type, element_common.next_element_index = -1; element_common.comment.first_char, element_common.comment.total_chars = 0; forms_element_validated = FALSE; end forms_create_element_entry; /* create a new entry in the group table */ forms_create_group_entry: proc; /* validate the last forms group if there is one */ call forms_validate_group; /* first see if line is currently defined in the table */ do i = 1 to iod_forms_info_tab.n_groups /* is forms group already defined */ while (forms_groups (i).name ^= token_value); end; if i <= iod_forms_info_tab.n_groups then /* it is in table so complain */ call statement_error (10, "Forms_table", token_value); /* Create entry in table for this line name. We will create a new entry for a duplicate name so we can check the rest of the substatements */ iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups + 1; /* now initialize the entry */ forms_groups (i).name = token_value; forms_groups (i).comment.first_char, forms_groups (i).comment.total_chars = 0; forms_groups (i).first_element_index = -1; fep = null; end forms_create_group_entry; forms_save_comment: proc; /* if there is an element entry open, save the comment there; else save in the group entry */ if fep ^= null () then do; if element_common.comment.first_char ^= 0 then call statement_error (13, "comment", "name", return_string (element_common.names (1))); call store_token_value_string (element_common.comment); end; else do; if forms_groups (iod_forms_info_tab.n_groups).comment.first_char ^= 0 then call statement_error (13, "comment", "Forms_info", forms_groups (iod_forms_info_tab.n_groups).name); call store_token_value_string (forms_groups (iod_forms_info_tab.n_groups).comment); end; end forms_save_comment; forms_save_size: proc (type); dcl type fixed bin; dcl type_strings (5) char (11) int static options (constant) init ("page_height", "page_width", "char_height", "char_width", "line_height"); dcl got_dupe bit (1); got_dupe = FALSE; if type = 1 | type = 3 | type = 5 then do; if orientation_element.height ^= 0 then got_dupe = TRUE; orientation_element.height = forms_size_info; orientation_element.factors (1) = forms_size_type; end; if type = 2 | type = 4 then do; if orientation_element.width ^= 0 then got_dupe = TRUE; orientation_element.width = forms_size_info; orientation_element.factors (2) = forms_size_type; end; if got_dupe then call statement_error (13, type_strings, "name", return_string (element_common.names (1))); end forms_save_size; forms_save_string: proc; dcl got_dupe bit (1); dcl use_token bit (1); use_token = "0"b; go to forms_save_string_common; forms_save_string_token: entry; use_token = "1"b; forms_save_string_common: got_dupe = "0"b; if element_common.type = TYPE_ORIENTATION /* orientation */ | element_common.type = TYPE_FONT_DESC /* font desc */ | element_common.type = TYPE_FONT_SIZE | element_common.type = TYPE_LINE_DESC /* line desc */ | element_common.type = TYPE_HOLES then do; if orientation_element.escape_string.total_chars ^= 0 then got_dupe = "1"b; if use_token then call store_token_value_string (orientation_element.escape_string); else call store_forms_escape_string (orientation_element.escape_string); end; else if element_common.type = TYPE_SPECIAL then do; /* special */ if special_element.special_string.total_chars ^= 0 then got_dupe = "1"b; if use_token then call store_token_value_string (special_element.special_string); else call store_forms_escape_string (special_element.special_string); end; else if element_common.type = TYPE_FONT_NAME | element_common.type = TYPE_PREAMBLE | element_common.type = TYPE_POSTAMBLE then do; if font_name_element.escape_string.total_chars ^= 0 then got_dupe = "1"b; if use_token then call store_token_value_string (font_name_element.escape_string); call store_forms_escape_string (font_name_element.escape_string); end; else if element_common.type = TYPE_USES then do; end; if got_dupe then call statement_error (13, "string", "name ", return_string (element_common.names (1))); end forms_save_string; forms_save_type: proc; if element_common.type ^= -1 then do; call statement_error (13, "type", "name", return_string (element_common.names (1))); return; end; element_common.type = token.Nvalue; end forms_save_type; forms_save_uses_name: proc; if element_common.type ^= -1 then call statement_error (13, "uses", "name", return_string (element_common.names (1))); element_common.type = TYPE_USES; uses_element.n_indices = 0; forms_save_uses_name_continue: entry; uses_element.n_indices = uses_element.n_indices + 1; call store_token_value_string (uses_element.name (uses_element.n_indices)); uses_element.index (uses_element.n_indices) = -1; end forms_save_uses_name; /* scan through the given forms table looking for specific element name */ forms_scan_for_element_name: proc (starting_index, seek_name) returns (fixed bin (17)); dcl starting_index fixed bin; dcl seek_name char (*); dcl element_index fixed bin; dcl element_name char (32); dcl i fixed bin; dcl my_fep ptr; element_index = starting_index; do while (element_index ^= -1); my_fep = addr (forms_elements (element_index)); do i = 1 to my_fep -> element_common.n_names; element_name = return_string (my_fep -> element_common.names (i)); if element_name = rtrim (seek_name) then go to return_element_index; end; element_index = my_fep -> element_common.next_element_index; end; return_element_index: return (element_index); end forms_scan_for_element_name; %page; /* validate that the current element entry isn't missing any required items */ forms_validate_entry: proc; dcl element_words fixed bin; if fep = null then return; /* no current element */ if forms_element_validated then return; /* already validated this element */ /* validate the element entry */ if element_common.type = -1 then do; call semant_error (19, "type", "name", return_string (element_common.names (1))); element_words = currentsize (element_common); end; else do; if element_common.type = TYPE_USES then do; /* check out "uses" */ if uses_element.n_indices = 0 then call semant_error (19, "uses", "name", return_string (element_common.names (1))); element_words = currentsize (uses_element); end; else if element_common.type = TYPE_ORIENTATION then do; /* check out "orientation" */ if orientation_element.height = 0 then call semant_error (19, "page_height", "name", return_string (element_common.names (1))); if orientation_element.width = 0 then call semant_error (19, "page_width", "name", return_string (element_common.names (1))); if orientation_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (orientation_element); end; else if element_common.type = TYPE_FONT_DESC then do; /* check out "font_name" */ if font_element.height = 0 then call semant_error (19, "char_height", "name", return_string (element_common.names (1))); if font_element.width = 0 then call semant_error (19, "char_width", "name", return_string (element_common.names (1))); if font_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (font_element); end; else if element_common.type = TYPE_FONT_SIZE then do; /* check out "font_name" */ if font_size_element.height = 0 then call semant_error (19, "char_height", "name", return_string (element_common.names (1))); if font_size_element.width = 0 then call semant_error (19, "char_width", "name", return_string (element_common.names (1))); if font_size_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (font_size_element); end; else if element_common.type = TYPE_LINE_DESC then do; /* check out "line_height" */ if line_element.height = 0 then call semant_error (19, "line_height", "name", return_string (element_common.names (1))); if line_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (line_element); end; else if element_common.type = TYPE_HOLES then do; /* check out "font_name" */ if holes_element.height = 0 & holes_element.width = 0 then call semant_error (52, return_string (element_common.names (1))); if holes_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (holes_element); end; else if element_common.type = TYPE_SPECIAL then do; /* check out "special" */ if special_element.special_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (special_element); end; else if element_common.type = TYPE_FONT_NAME then do; if font_name_element.escape_string.total_chars = 0 then call semant_error (19, "string", "name", return_string (element_common.names (1))); element_words = currentsize (font_name_element); end; else if element_common.type = TYPE_PREAMBLE then do; element_words = currentsize (preamble_element); end; else if element_common.type = TYPE_POSTAMBLE then do; element_words = currentsize (postamble_element); end; end; iod_forms_info_tab.n_words = iod_forms_info_tab.n_words + element_words; forms_element_validated = TRUE; end forms_validate_entry; /* validate the current group of forms elements */ forms_validate_group: proc; dcl (element_index, starting_element_index) fixed bin; dcl my_fep ptr; dcl i fixed bin; /* nothing to do if no groups defined yet */ if iod_forms_info_tab.n_groups = 0 then return; /* first validate the last element entry if there is one */ call forms_validate_entry; /* now validate all the forms elements within this group */ if forms_groups (iod_forms_info_tab.n_groups).first_element_index = -1 then do; call semant_error (18, "forms elements", "Forms_table", forms_groups (iod_forms_info_tab.n_groups).name); end; else do; element_index, starting_element_index = forms_groups (iod_forms_info_tab.n_groups).first_element_index; do while (element_index ^= -1); my_fep = addr (forms_elements (element_index)); if my_fep -> element_common.type = TYPE_USES then do; do i = 1 to my_fep -> uses_element.n_indices; my_fep -> uses_element.index (i) = forms_scan_for_element_name (starting_element_index, return_string (my_fep -> uses_element.name (i))); if my_fep -> uses_element.index (i) = -1 then call semant_error (12, "uses element", my_fep -> uses_element.name (i), "name", return_string (my_fep -> element_common.names (1))); end; end; element_index = my_fep -> element_common.next_element_index; end; end; end forms_validate_group; append_token_value_string: proc; dcl i fixed bin; dcl c char (1); do i = 1 to token.Lvalue; c = substr (token_value, i, 1); call insert_single_char (rank (c)); end; return; end append_token_value_string; insert_single_char: proc (n); dcl n fixed bin (18); forms_escape_string_n (forms_escape_string_index) = n; forms_escape_string_index = forms_escape_string_index + 1; return; end insert_single_char; %page; statement_error: proc options (variable); dcl arg_count fixed bin; dcl arg_lens (7) fixed bin (21); dcl arg_ptrs (7) ptr; dcl error_num fixed bin based (arg_ptrs (1)); dcl i fixed bin; dcl parm1 char (arg_lens (2)) based (arg_ptrs (2)); dcl parm2 char (arg_lens (3)) based (arg_ptrs (3)); dcl parm3 char (arg_lens (4)) based (arg_ptrs (4)); dcl parm4 char (arg_lens (5)) based (arg_ptrs (5)); dcl parm5 char (arg_lens (6)) based (arg_ptrs (6)); dcl parm6 char (arg_lens (7)) based (arg_ptrs (7)); dcl dummy_string char (1); dcl (stmt_ptr, token_ptr) ptr; stmt_ptr = token.Pstmt; token_ptr = Pthis_token; go to error_common; /* semant_error: entry (error_num, parm1, ..., parm6); */ semant_error: entry options (variable); stmt_ptr, token_ptr = null; error_common: arg_lens (*) = 0; arg_ptrs (*) = addr (dummy_string); call cu_$arg_count (arg_count, code); do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptrs (i), arg_lens (i), code); end; if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)), MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL, (error_control_table.message (error_num)), (error_control_table.brief_message (error_num)), parm1, parm2, parm3, parm4, parm5, parm6); else do; MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity); SERROR_PRINTED (error_num) = TRUE; end; return; end statement_error; %page; dcl 1 error_control_table (53) aligned int static options (constant), 2 severity fixed bin (17) unal init ( 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 2, 4, 3, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 3, 3, 3, 3, 3, 3, 3 ), 2 Soutput_stmt bit (1) unal init ( "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b ), 2 message char (120) varying init ( "End of input encountered before End statement.", /* 1 */ "Keyword ""^a"" unrecognized or out of order.", /* 2 */ "Syntax error.", /* 3 */ "Global ""^a"" keyword appears more than once.",/* 4 */ "Bad numeric parameter (^a).", /* 5 */ "^a must be between 1 and ^a.", /* 6 */ "Grace time must be positive.", /* 7 */ "The name ""^a"" contains an invalid char.", /* 8 */ "Name ""^a"" is too long.", /* 9 */ "^a ""^a"" has already been defined.", /* 10 */ "^a ""^a"" has not been defined.", /* 11 */ "The ^a ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 12 */ "Keyword ""^a"" appears more than once for ""^a: ^a;"".", /* 13 < */ "Channel not found in CDT. Possible error.", /* 14 */ "Data for ""^a"" exceeds ^a chars.", /* 15 */ "Limit of ^a ^a exceeded. Translation aborted.", /* 16 */ "The ^a device has been specified more that once for ^a.", /* 17 */ "No ^a specified for ""^a: ^a""", /* 18 */ "No ^a keyword found for ""^a: ^a;"".", /* 19 */ "Specified driver userid doesn't contain project name.", /* 20 */ "Specified driver userid contains more than two components.", /* 21 */ "Two of the mutually exclusive prph, line and dial_id keywords have been specified for device ""^a"".", /* 22 */ "Specified ""^a: ^a;"" for Device ""^a"" matches a previous dial_id or ctl_dial_id.", /* 23 */ "Two of the mutually exclusive ctl_line, ctl_dial_id and ctl_source keywords have been specified for device ""^a"".", /* 24 */ "Device ""^a"" does not have the ""line: variable;"" statement needed for line ""^a"".", /* 25 */ "Device ""^a"" uses a ""line: variable;"" statement, but has no corresponding Line entry.", /* 26 */ "The full name of ^a ""^a.^a"" exceeds 32 characters.", /* 27 */ "Non-system accounting specified for IO.SysDaemon in Request_type ""^a"".", /* 28 */ "System accounting specified for other than *.SysDaemon in Request_type ""^a"".", /* 29 */ "", /* 30 */ "One or more device class subkeywords appeared before the first device_class keyword for ""Request_type: ^a;"".", /* 31 */ "^a name ""^a"" appears more than once for ^a ""^a"".", /* 32 */ "The device ""^a"" specified for ""^a: ^a;"" is missing a minor device component.", /* 33 */ "The device ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 34 */ "The default_type ""^a"" specified for ""^a: ^a;"" is missing a minor device component.", /* 35 */ "The default_type ""^a"" has been specified for ""^a: ^a;"" but device ""^a"" has not been specified for ""^a: ^a;"".", /* 36 */ "The default_type ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 37 */ "Specified default_queue is greater than max_queues for Request_type ""^a"".", /* 38 */ "There must be one price name defined for each possible queue. Request_type ""^a"".", /* 39 */ "Request_type ""^a"". There is no price defined for ""^a"" in the system price table.", /* 40 */ "Max_queues not specified.", /* 41 */ "Time has not been specified.", /* 42 */ "No Device keywords have been specified.", /* 43 */ "No Request_type keywords have been specified.",/* 44 */ "No default Request_type has been specified for the ""printer"" generic type.", /* 45 */ "No default Request_type has been specified for the ""punch"" generic type.", /* 46 */ "No driver_module has been specified for Device ""^a"".", /* 47 */ "No prph, line or dial_id has been specified for Device ""^a"".", /* 48 */ "Keyword ""^a"" appears more than once for ""^a: ^a;"", ""^a: ^a;"".", /* 49 */ "The ""name: ^a;"" statement has already been used in ""Forms_table: ^a;"".", /* 50 */ "The ^a statement has too many elements, only ^a allowed.", /* 51 */ "Either page_height and/or page_width must be specified for ""name: ^a"".", /* 52 */ "Request_type ""^a"" cannot be used by Device ""^a"" since Device entry is missing a forms_table entry." /* 53 */ ), 2 brief_message char (36) varying init ( "", /* 1 */ "^a", /* 2 */ "", /* 3 */ "^a", /* 4 */ "^a", /* 5 */ "^a", /* 6 */ "", /* 7 */ "^a", /* 8 */ "^a", /* 9 */ "^a ^a", /* 10 */ "^a ^a", /* 11 */ "^a of ""^a"" for ""^a: ^a"" not defined.", /* 12 */ "Multiple ^a for ""^a: ^a;""", /* 13 */ "", /* 14 */ "^a too long", /* 15 */ "", /* 16 */ "^a ^a", /* 17 */ "^a ""^a: ^a""", /* 18 */ "^a ""^a: ^a;""", /* 19 */ "", /* 20 */ "", /* 21 */ "^a", /* 22 */ """^a: ^a"" ""^a""", /* 23 */ "^a", /* 24 */ """^a"" for Line ""^a"".", /* 25 */ """^a"" for Line ""^a"".", /* 26 */ "^a name ""^a.^a"".", /* 27 */ """^a""", /* 28 */ """^a""", /* 29 */ "", /* 30 */ "^a ""^a""", /* 31 */ "^a ""^a"" ^a ""^a""", /* 32 */ """^a"" ""^a:^a;""", /* 33 */ """^a"" ""^a:^a;""", /* 34 */ """^a"" ""^a:^a;""", /* 35 */ "^a ""^a: ^a;"" ^a ""^a: ^a;""", /* 36 */ "^a ""^a: ^a;""", /* 37 */ """^a""", /* 38 */ """^a""", /* 39 */ """^a"" ""^a""", /* 40 */ "", /* 41 */ "", /* 42 */ "", /* 43 */ "", /* 44 */ "", /* 45 */ "", /* 46 */ """^a""", /* 47 */ """^a""", /* 48 */ """^a"" ""^a: ^a;"" ""^a: ^a;""", /* 49 */ """name: ^a;"" ""Forms_table: ^a;""", /* 50 */ "^a", /* 51 */ "name: ^a", /* 52 */ "Request_type ""^a"", Device ""^a""" /* 53 */ ); %page; %include access_mode_values; %page; %include device_class; %page; %include iod_forms_info_tab; %page; %include iod_constants; %page; %include iod_device_tab; %page; %include iod_line_tab; %page; %include iod_tables_hdr; %page; %include q_group_tab; %page; %include terminate_file;  iodc_.pl1 03/15/89 0841.8r w 03/15/89 0800.1 743238 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ iodc_: procedure; /* This is the central procedure of the I/O Daemon Coordinator. * It has various entries which are woken up by event calls. */ /* Coded by Robert S. Coren in August 1973 */ /* Modified for the Access Isolation Mechanism by J. Stern, December 1974 */ /* Modified by J. Stern, 11/25/75 */ /* Modified by J. C. Whitmore, 4/78, to support max queues per request type and save more descriptor flags */ /* Modified by J. C. Whitmore, 7/78, for extended driver commands and queue priority functions */ /* Modified by J. C. Whitmore, 11/78, for version 3 iod_tables format and start using coord version numbers */ /* Modified by J. C. Whitmore, 5/80, to mark priority requests in the queue */ /* Modified by Benson I. Margulies 1980*12*29 for unaligned system_dir argument and variable iod_table segname. */ /* Modified January 1984 by C. Marker Added probe as a valid command in test mode. */ /* Modified December 1984 by Keith Loepere to set dir_quota. */ /* Modified January 1985 by Keith Loepere to be smarter about same. */ /* Modified February 23, 1985 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(87-02-04,Gilcrease), approve(87-02-04,MCR7610), audit(87-02-18,Farley), install(87-03-25,MR12.1-1013): Correct call to internal subroutine for the NEXT command. 2) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. END HISTORY COMMENTS */ dcl a_ptr ptr; /* pointer passed as argument to most entries */ /* External entries */ dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl com_err_ entry options (variable); dcl convert_ipc_code_ entry (fixed bin (35)); dcl debug entry; dcl delete_$path entry (char (*) aligned, char (*) aligned, bit (6), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)); dcl find_next_request_ entry (fixed bin, ptr) returns (bit (1) aligned); dcl find_next_request_$init entry (ptr); dcl free_oldest_request_$cleanup entry; dcl free_oldest_request_$force entry; dcl free_oldest_request_$init entry (ptr); dcl get_authorization_ entry returns (bit (72) aligned); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_process_id_ entry returns (bit (36) aligned); dcl get_ring_ entry returns (fixed bin (6)); dcl get_system_free_area_ entry (ptr); dcl hcs_$chname_seg entry (ptr, char (*) aligned, char (*), fixed bin (35)); dcl hcs_$create_branch_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char (*) aligned, char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_ring_brackets entry (char (*) aligned, char (*) aligned, (3) fixed bin (3), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iod_overseer_$coord_ready entry; dcl iodc_$command_level entry; dcl iodc_$free_device entry (ptr, fixed bin (35)); dcl iodc_message_ entry (bit (3) aligned, fixed bin (35), char (*)); dcl iodc_message_$loud entry (bit (3) aligned, fixed bin (35), char (*)); dcl iodc_message_$init entry; dcl iodd_$iodd_init entry (char (*) aligned, bit (1) aligned); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$mask_ev_calls entry (fixed bin (35)); dcl ipc_$unmask_ev_calls entry (fixed bin (35)); dcl logout entry; dcl match_request_id_ entry (fixed bin (71), char (*) aligned) returns (bit (1) aligned); dcl message_segment_$create entry (char (*) aligned, char (*) aligned, fixed bin (35)); dcl message_segment_$delete entry (char (*) aligned, char (*) aligned, fixed bin (35)); dcl message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35)); dcl message_segment_$ms_acl_add entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)); dcl message_segment_$read_message_index entry (fixed bin, pointer, pointer, fixed bin (35)); dcl message_segment_$open entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (35)); dcl message_segment_$check_salv_bit_index entry (fixed bin, bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl message_segment_$update_message_index entry (fixed bin, fixed bin (24), bit (72) aligned, ptr, fixed bin (35)); dcl new_proc entry; dcl print_devices entry options (variable); dcl privileged_make_seg_ entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr, fixed bin (35)); dcl probe entry (); dcl save_request_ entry (ptr, ptr); dcl save_request_$init entry (ptr); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl signal_ entry (char (*)); dcl system_info_$access_ceiling entry (bit (72) aligned); dcl system_privilege_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl unique_bits_ entry returns (bit (70)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl unthread_descriptor_ entry (ptr); dcl unthread_descriptor_$init entry (ptr); /* Automatic storage */ dcl ack_chan fixed bin (71); dcl area_flag fixed bin; dcl auth bit (72) aligned; /* process access authorization */ dcl bc fixed bin (24); /* bit count */ dcl chan_name fixed bin (71); dcl cmd char (24) aligned; dcl code fixed bin (35); dcl code2 fixed bin (35); dcl copy_ptr ptr; /* pointer to copy of descriptor */ dcl copy_words fixed bin; /* size of copy_template array */ dcl cwtp ptr; /* ptr to coord_working_tables */ dcl dcx fixed bin; /* index of a device_class entry */ dcl desc_off fixed bin (18); /* offset of a request descriptor */ dcl desc_ptr ptr; /* pointer to a request descriptor */ dcl dev_id char (32) aligned; dcl dir_quota fixed bin; dcl dr_ptr ptr; dcl entry_type fixed bin; dcl ev_info_ptr ptr; dcl finish fixed bin; dcl fwx fixed bin; dcl i fixed bin; dcl idtx fixed bin; /* iod device table index */ dcl iodc_data_ptr ptr; dcl iwtp ptr; /* ptr to iod_working_tables */ dcl iwtrb (3) fixed bin (3); /* ring brackets for iod_working_tables */ dcl len fixed bin; dcl line char (80); dcl lwx fixed bin; dcl mask_code fixed bin (35); /* status code from ipc_$unmask_ev_calls */ dcl match_dir char (168) aligned; dcl match_ent char (32) aligned; dcl mdtx fixed bin; /* minor device table index */ dcl message_len fixed bin; /* length (in bits) of based_message */ dcl ms_id bit (72) aligned; /* message id */ dcl nc fixed bin; dcl new_driver_id char (32) aligned; /* person/project id of new driver */ dcl new_idx fixed bin; dcl new_iwtp ptr; /* ptr to new copy of iod_working_tables */ dcl next_ptr ptr; /* pointer to next request descriptor */ dcl nseries fixed bin; /* number of series in series_info */ dcl nx fixed bin; dcl out_len fixed bin; /* length of error message */ dcl out_msg char (200); dcl proc_id bit (36) aligned; dcl q fixed bin; dcl q_idx fixed bin; /* index of queue message seg. */ dcl q_name char (32) aligned; dcl quota fixed bin; dcl retry fixed bin; dcl reqp ptr; dcl seg_name char (32) aligned; dcl sender_class char (32) aligned; /* name of device class of sender of driver signal */ dcl sender_device char (32) aligned; /* name of device run by sender of a driver signal */ dcl sender_id char (32) aligned; dcl seq_id fixed bin (35); dcl series_id fixed bin (35); dcl series_sw bit (1) aligned; dcl sig_type fixed bin; dcl sip ptr; /* ptr to series_info structure */ dcl start fixed bin; dcl subdir char (168) aligned;/* used to hold pathnames of subdirs of sysdir */ dcl system_high bit (72) aligned; /* system high authorization */ dcl unbit bit (1) aligned; dcl user_id char (32) aligned; dcl wlp ptr; dcl x fixed bin; /* Internal static storage */ dcl areap ptr int static; /* ptr to sys_area */ dcl driver_sig_chan fixed bin (71) int static; /* name of channel over which signals from */ /* driver processes will come */ dcl static_idtp int static ptr; /* pointer to io daemon device table */ dcl static_mdtp int static ptr; /* pointer to minor device table */ dcl driver_cmd_chan fixed bin (71) int static; /* IPC channel for driver to signal commands which */ /* are read through the coord_comm.ms seg */ dcl recursion_flag fixed bin int static; /* used to prevent recursive faults */ dcl scu_msg char (120) int static init (""); dcl sysdir char (168) aligned int static; dcl testing bit (1) int static; dcl quit_flag bit (1) int static; dcl err_label label int static; dcl return_label label int static; /* for returning in test environment */ dcl comm_mseg_idx fixed bin int static; /* message segment index for coord_comm.ms */ dcl sysdir_len fixed bin int static; /* length of pathname in sysdir */ dcl sysdir_class bit (72) aligned int static; /* access class of sysdir */ dcl initialized bit (1) aligned int static; /* turned on when coord initialization is complete */ dcl coord_proc_id bit (36) int static; /* coordinator's process id */ dcl new_driver_series int static; /* first sequence number for new driver */ dcl com_level fixed bin int static; /* command level depth */ dcl n_acl fixed bin int static; /* External static */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$bad_segment fixed bin (35) ext static; dcl error_table_$invalid_move_qmax fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$namedup fixed bin (35) ext static; dcl error_table_$pathlong fixed bin (35) ext static; dcl error_table_$argerr fixed bin (35) ext static; dcl error_table_$invalid_lock_reset fixed bin (35) ext static; dcl error_table_$segknown fixed bin (35) ext static; dcl error_table_$request_not_recognized fixed bin (35) ext static; dcl error_table_$ai_above_allowed_max fixed bin (35) ext static; dcl error_table_$ai_restricted fixed bin (35) ext static; dcl iox_$user_input ptr ext; dcl iox_$user_io ptr ext static; %page; /* Constants */ dcl io_coordinator_version char (8) int static options (constant) init ("3.2"); dcl driver_command fixed bin int static options (constant) init (100); dcl id char (16) int static options (constant) init ("io_coordinator"); dcl new_driver fixed bin int static options (constant) init (200); dcl priority fixed bin int static options (constant) init (2); dcl NL char (1) int static options (constant) init (" "); /* Conditions */ dcl any_other condition; dcl quit condition; dcl cleanup condition; dcl area condition; /* these guys are just used to pass addresses to ipc_$decl_ev_call_chn */ dcl free_oldest_request_$free_oldest_request_ fixed bin ext static; dcl iodc_$new_driver fixed bin ext static; dcl iodc_$driver_signal fixed bin ext static; dcl iodc_$driver_command fixed bin ext static; /* Based storage */ dcl based_message bit (message_len) aligned based; dcl copy_template (copy_words) fixed bin based; /* for segment copying */ dcl sys_area area (65560) based (areap); /* system area */ /* Builtins */ dcl (addr, before, divide, empty, fixed, length, ltrim, max, mod, null, ptr, rel, rtrim, stac, string, substr, unspec) builtin; %page; /* Structure declarations */ dcl 1 ev_info based (ev_info_ptr), 2 channel fixed bin (71), 2 message fixed bin (71), 2 sending_proc bit (36); dcl 1 acl (3) aligned int static, 2 ac_name char (32), 2 modes bit (36), 2 pad bit (36) init ((3) (36)"0"b), 2 code fixed bin (35); dcl 1 dir_acl (2) aligned int static, 2 ac_name char (32), 2 modes bit (36), 2 code fixed bin (35); dcl 1 driver_mmi aligned like mseg_message_info; dcl 1 msg_mmi aligned like mseg_message_info; dcl 1 coord_static int static aligned like iodc_static; /* space for iodc_static */ dcl 1 branch_info aligned int static like create_branch_info; dcl 1 ms_acl aligned, /* for setting extended acl on message segment */ 2 acc_name char (32), 2 mode bit (36), 2 exmode bit (36), 2 reterr fixed bin (35); dcl 1 series_info (nseries) aligned based (sip), /* for restart_status command */ 2 count fixed bin, 2 first fixed bin, 2 last fixed bin, 2 dcx fixed bin; dcl 1 option aligned, /* control options for the next_req driver request */ 2 dev bit (1) unal, 2 q bit (1) unal, 2 user bit (1) unal, 2 id bit (1) unal, 2 et bit (1) unal, 2 pn bit (1) unal, 2 pad bit (30) unal; %page; iodc_init: entry (dir, test_bit, test_iod_tables); /* Main entry point for I/O Coordinator */ /* Initializes I/O Coordinator and waits for drivers. */ dcl dir char (*); dcl test_bit bit (1) aligned; dcl test_iod_tables char (*); call iodc_message_$init (); /* set up stream attachments */ call ioa_ ("I/O Coordinator Version: ^a", io_coordinator_version); sysdir = dir; sysdir_len = length (rtrim (sysdir)); if sysdir_len > 136 then do; call com_err_ (error_table_$pathlong, "iodc_init", "Cannot append max size device name to ^a.", sysdir); go to forget_it; end; subdir = substr (sysdir, 1, sysdir_len) || ">coord_dir"; /* construct pathname of coord_dir */ testing = test_bit; return_label = back; err_label = forget_it; stat_p = addr (coord_static); call get_system_free_area_ (areap); /* set this once for temp allocations */ new_driver_series = 0; com_level = -1; initialized = "0"b; quit_flag = "0"b; on quit call quit_handler; call iox_$control (iox_$user_io, "quit_enable", null, code); recursion_flag = 0; on cleanup call clean_up; /* unmask, drop timer, etc. */ on any_other call iodc_handler; /* set up acl for data segs and directories */ n_acl = 2; dir_acl (1).ac_name, acl (1).ac_name = get_group_id_$tag_star (); /* make sure this process always has access */ dir_acl (1).modes, acl (1).modes = "111"b; dir_acl (2).ac_name, acl (2).ac_name = "*.*.*"; dir_acl (2).modes, acl (2).modes = "100"b; /* First thing to do is check the saved list left by the last coordinator for segments to be deleted. To do this we need two data bases: req_desc_seg, and request_seg. */ call free_oldest_request_$init (stat_p); call unthread_descriptor_$init (stat_p); call initiate (subdir, "req_desc_seg", iodc_static.descr_seg_ptr, code); if code ^= 0 then no_purge: call com_err_ (0, "iodc_init", "Warning -- Cannot get old saved list. Some deletions may not be performed."); else do; call initiate (subdir, "request_seg", iodc_static.req_seg_ptr, code); if code ^= 0 then go to no_purge; iodc_static.save_first_req_p = addr (req_desc_seg.first_saved); iodc_static.first_req_done = req_desc_seg.first_saved; do while (iodc_static.first_req_done ^= 0); call free_oldest_request_$cleanup; end; end; /* delete coord_dir to make sure it gets recreated with proper access class */ call delete_$path (sysdir, "coord_dir", "101101"b, "", code); if code ^= 0 then if code ^= error_table_$noentry then do; call com_err_ (code, "iodc_init", "Deleting coord_dir"); go to forget_it; end; /* get access class of sysdir and process authorization */ call hcs_$get_access_class (sysdir, "", sysdir_class, code); if code ^= 0 then do; call com_err_ (code, "iodc_init", sysdir); go to forget_it; end; auth = get_authorization_ (); if ^testing then do; call system_info_$access_ceiling (system_high); if ^aim_check_$equal (system_high, auth) then call com_err_ (0, "iodc_init", "Warning -- Coordinator authorization is not ""system_high""."); end; /* make a subdirectory to hold the coordinator's writable data segs (i.e. segs modified after initialization) */ /* this subdirectory will be upgraded (if necessary) to the coordinator's authorization */ /* if upgraded, a quota of 250/25 records will be assigned */ branch_info.version = create_branch_version_2; /* initialize branch info structure */ branch_info.dir_sw = "1"b; branch_info.copy_sw = "0"b; branch_info.chase_sw = "1"b; branch_info.priv_upgrade_sw = "0"b; branch_info.mbz1 = ""b; branch_info.mode = "101"b; branch_info.mbz2 = ""b; branch_info.rings (1), branch_info.rings (2), branch_info.rings (3) = get_ring_ (); branch_info.userid = acl (1).ac_name; branch_info.bitcnt = 0; call make_dir ("coord_dir", auth, 250, 25, code); if code ^= 0 then do; call com_err_ (code, "iodc_init", "^a>^a", sysdir, "coord_dir"); go to forget_it; end; /* set up data segments residing in sysdir */ seg_name = "iodc_data"; call make (sysdir, seg_name, iodc_data_ptr, code); if code ^= 0 then do; no_init: call com_err_ (code, "iodc_init", "Could not initiate(create) ^a", seg_name); forget_it: call ioa_$ioa_stream ("error_output", "Process cannot be initialized."); return; end; if test_bit & test_iod_tables ^= "" then seg_name = test_iod_tables; else seg_name = "iod_tables"; /* get ptr to most recently compiled iod tables */ call initiate (sysdir, seg_name, ithp, code); if code ^= 0 then go to no_init; copy_words = divide (bc, 36, 24, 0); /* remember number of words */ if iod_tables_hdr.version ^= IODT_VERSION_5 then do; call com_err_ (0, "iodc_init", "Wrong version number for iod_tables."); go to forget_it; end; /* now get the last iod_working_tables used to see if anything has changed. */ iwtp = null; seg_name = "iod_working_tables"; call initiate (sysdir, seg_name, iwtp, code); if code ^= 0 then if code = error_table_$noentry then go to update; else go to no_init; /* If version number has changed, iod_working_tables is to be ignored. Fake a new table update. If the version numbers are the same, then see if iod_tables is newer. If so update the working tables with the new tables */ if iwtp -> iod_tables_hdr.version ^= IODT_VERSION_5 then go to update; if iod_tables_hdr.date_time_compiled > iwtp -> iod_tables_hdr.date_time_compiled then do; /* new tables, must update the working tables */ update: seg_name = unique_chars_ (unique_bits_ ()); /* create unique name segment */ call make (sysdir, seg_name, new_iwtp, code); if code ^= 0 then go to no_init; iwtrb (1) = branch_info.rings (1); /* set up ring brackets for working tables */ iwtrb (2), iwtrb (3) = 5; /* make available through ring 5 */ call hcs_$set_ring_brackets (sysdir, seg_name, iwtrb, code); if code ^= 0 then do; call com_err_ (code, "iodc_init", "Attempting to set ring brackets of ^a", seg_name); go to forget_it; end; new_iwtp -> copy_template = ithp -> copy_template; /* copy in iod_tables */ if iwtp ^= null then do; call hcs_$delentry_seg (iwtp, code); /* delete old working tables */ if code ^= 0 then do; call com_err_ (code, "iodc_init", "Attempting to delete iod_working_tables"); go to forget_it; end; end; call hcs_$chname_seg (new_iwtp, seg_name, "iod_working_tables", code); /* change name of new working tables */ if code ^= 0 then do; call com_err_ (code, "iodc_init", "Attempting to change name of iod_working_tables"); go to forget_it; end; iwtp = new_iwtp; end; call hcs_$terminate_noname (ithp, code); /* set up segments in "coord_dir" */ seg_name = "coord_working_tables"; /* make coordinator's private copy of iod_tables */ call make (subdir, seg_name, cwtp, code); if code ^= 0 then go to no_init; cwtp -> copy_template = iwtp -> copy_template; call hcs_$terminate_noname (iwtp, code); seg_name = "waiting_list"; call make (subdir, seg_name, iodc_static.wait_list_ptr, code); if code ^= 0 then go to no_init; seg_name = "req_desc_seg"; call make (subdir, "req_desc_seg", iodc_static.descr_seg_ptr, code); if code ^= 0 then go to no_init; descr_area = empty; seg_name = "request_seg"; call make (subdir, "request_seg", iodc_static.req_seg_ptr, code); if code ^= 0 then go to no_init; req_area = empty; /* initialize table pointers and other static info */ static_idtp = ptr (cwtp, cwtp -> iod_tables_hdr.device_tab_offset); static_mdtp = ptr (cwtp, cwtp -> iod_tables_hdr.minor_device_tab_offset); text_strings_ptr = ptr (cwtp, cwtp -> iod_tables_hdr.text_strings_offset); iodc_static.qgtp = ptr (cwtp, cwtp -> iod_tables_hdr.q_group_tab_offset); iodc_static.dctp = ptr (cwtp, cwtp -> iod_tables_hdr.dev_class_tab_offset); iodc_static.time_interval = cwtp -> iod_tables_hdr.grace_time; iodc_static.max_q = cwtp -> iod_tables_hdr.max_queues; iodc_static.first_req_done, iodc_static.last_req_done = 0; iodc_static.save_first_req_p = addr (req_desc_seg.first_saved); req_desc_seg.first_saved = 0; /* set up message segment for new driver messages */ call message_segment_$delete (sysdir, "coord_comm.ms", code); /* delete old message seg, if any */ if code ^= 0 then if code ^= error_table_$noentry then do; /* could not delete it */ call com_err_ (code, "iodc_init", "Attempting to delete coord_comm.ms"); go to forget_it; end; seg_name = "coord_comm.ms"; /* for error message */ call message_segment_$create (sysdir, "coord_comm.ms", code); /* create new message seg */ if code ^= 0 then go to no_init; /* give up */ call message_segment_$open (sysdir, "coord_comm.ms", comm_mseg_idx, code); /* open it */ if code ^= 0 then go to no_init; /* give up */ /* place the userid for each queue group on the message segment acl */ ms_acl.mode = "101"b; /* want "rw" real access */ ms_acl.exmode = "1"b; /* want "a" extended access */ do q = 1 to iodc_static.qgtp -> q_group_tab.n_q_groups; /* loop through queue groups */ qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (q)); /* get ptr to q group entry */ if qgte.driver_id ^= acl (1).ac_name then do; /* don't change coord's access */ ms_acl.acc_name = qgte.driver_id; call message_segment_$ms_acl_add (sysdir, "coord_comm.ms", addr (ms_acl), 1, code); if code ^= 0 then do; if code = error_table_$argerr then code = ms_acl.reterr; call com_err_ (code, "iodc_init", "Adding to acl of coord_comm.ms"); go to forget_it; end; end; qgte.open = 0; /* initialize this while we're here */ end; /* initialize other coordinator procedures */ call find_next_request_$init (stat_p); call save_request_$init (stat_p); /* free all devices, i.e. delete all device dirs and segs */ do idtx = 1 to static_idtp -> iod_device_tab.n_devices; idtep = addr (static_idtp -> iod_device_tab.entries (idtx)); idte.process_id = ""b; call iodc_$free_device (idtep, code); if code ^= 0 then /* failed to delete device directory */ go to forget_it; end; /* initialize the device class table */ do dcx = 1 to iodc_static.dctp -> dev_class_tab.n_classes; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); dcte.pending_request, dcte.restart_req = 0; end; /* change initial acl so it will work for driver segs. */ n_acl = 3; acl (n_acl).modes = "101"b; /* set up drivers' event channels */ /* new-driver signal will have lower priority so coming-up message */ /* can't beat previous logout message for same device */ call ipc_$create_ev_chn (chan_name, code); if code ^= 0 then do; no_ipc: call convert_ipc_code_ (code); call com_err_ (code, "iodc_init", "IPC error setting up event channels."); go to forget_it; end; call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$new_driver), null, 3, code); if code ^= 0 then go to no_ipc; iodc_data.init_event_channel = chan_name; call ipc_$create_ev_chn (chan_name, code); if code ^= 0 then go to no_ipc; call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$driver_signal), null, 1, code); if code ^= 0 then go to no_ipc; driver_sig_chan = chan_name; call ipc_$create_ev_chn (chan_name, code); if code ^= 0 then go to no_ipc; call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$driver_command), null, 2, code); if code ^= 0 then go to no_ipc; driver_cmd_chan = chan_name; /* and timer channel for freeing "saved" requests */ call ipc_$create_ev_chn (iodc_static.timer_chan, code); if code ^= 0 then go to no_ipc; call ipc_$decl_ev_call_chn (iodc_static.timer_chan, addr (free_oldest_request_$free_oldest_request_), null, 1, code); if code ^= 0 then go to no_ipc; /* OK, let the show begin ... */ coord_proc_id, iodc_data.proc_id = get_process_id_ (); initialized = "1"b; call iodc_message_ ("010"b, 0, "I/O Coordinator initialized"); call iod_overseer_$coord_ready; /* drivers can now get started */ call iodc_$command_level; back: call clean_up; return; /* return to overseer (only in test mode) */ clean_up: proc; call timer_manager_$reset_alarm_wakeup (iodc_static.timer_chan); /* through with this */ call ipc_$drain_chn (iodc_static.timer_chan, code); call iox_$control (iox_$user_io, "start", null (), code); call ipc_$unmask_ev_calls (code2); call ipc_$delete_ev_chn (iodc_static.timer_chan, code2); call ipc_$delete_ev_chn (driver_cmd_chan, code2); call ipc_$delete_ev_chn (driver_sig_chan, code2); call ipc_$delete_ev_chn (iodc_data.init_event_channel, code2); return; end clean_up; %page; make: proc (dirname, entname, p, code); dcl dirname char (*) aligned; dcl entname char (*) aligned; dcl p ptr; dcl code fixed bin (35); dcl hcs_$replace_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned, fixed bin (35)); if testing then call hcs_$make_seg (dirname, entname, "", 01111b, p, code); else call privileged_make_seg_ (dirname, entname, "", 01111b, p, code); if code ^= 0 then if code ^= error_table_$namedup then if code ^= error_table_$segknown then return; call hcs_$replace_acl (dirname, entname, addr (acl), n_acl, "0"b, code); return; end; /* ********************************************************** */ make_dir: proc (ename, aclass, aquota, adir_quota, code); dcl ename char (*) aligned; dcl aclass bit (72) aligned; /* access class of directory */ dcl aquota fixed bin; /* quota on directory */ dcl adir_quota fixed bin; dcl code fixed bin (35); dcl hcs_$replace_dir_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1), fixed bin (35)); branch_info.access_class = aclass; if aim_check_$equal (aclass, sysdir_class) then branch_info.quota, branch_info.dir_quota = 0; else do; branch_info.quota = aquota; /* need quota if dir is upgraded */ branch_info.dir_quota = adir_quota; end; create_branch: call hcs_$create_branch_ (sysdir, ename, addr (branch_info), code); if code = error_table_$invalid_move_qmax then if branch_info.dir_quota = 0 then return; else do; /* try create without dir quota */ branch_info.dir_quota = 0; go to create_branch; end; if code ^= 0 then return; call hcs_$replace_dir_acl (sysdir, ename, addr (dir_acl), 2, "0"b, code); end make_dir; /* ********************************************************** */ initiate: proc (dir, ent, p, code); dcl dir char (*) aligned; dcl ent char (*) aligned; dcl p ptr; dcl code fixed bin (35); if testing then /* don't use system_privilege_ in test mode */ call hcs_$initiate_count (dir, ent, "", bc, 0, p, code); else call system_privilege_$initiate_count (dir, ent, "", bc, 0, p, code); if code = error_table_$segknown then code = 0; end initiate; %page; driver_signal: entry (a_ptr); /* This entry receives the wakeup from a driver process that has * just finished a request (or otherwise become ready for work), * or has just received a "restart", "save", or "logout" command. * The code in the event message will tell us which. */ mask_code = -1; on cleanup begin; if mask_code = 0 then call ipc_$unmask_ev_calls (code2); end; call ipc_$mask_ev_calls (mask_code); ev_info_ptr = a_ptr; err_label = iodc_return; proc_id = ev_info.sending_proc; /* find out which driver sent signal and make sure it's legitimate */ mdtx = addr (ev_info.message) -> ev_msg.minor_dev_index; /* get minor device index */ call identify_sender (code); if code ^= 0 then go to bad_signal; /* reject the signal */ /* find out what kind of signal it was, and branch accordingly */ sig_type = addr (ev_info.message) -> ev_msg.code; if sig_type < 0 | sig_type > 5 /* Uh oh */ then do; call ioa_$rsnnl ("Driver signal rejected from device ^a (bad code: ^d)", out_msg, out_len, sender_device, sig_type); bad_signal: call iodc_message_ ("101"b, 0, out_msg); go to iodc_return; end; go to sig_label (sig_type); /* **************************************************** */ identify_sender: proc (code); dcl code fixed bin (35); if mdtx < 0 | mdtx > static_mdtp -> minor_device_tab.n_minor /* a bum index */ then do; out_msg = "Driver signal rejected (bad device index)"; code = error_table_$request_not_recognized; return; end; mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); /* get ptr to minor device entry */ idtx = mdte.major_index; /* get major device index for this minor device */ idtep = addr (static_idtp -> iod_device_tab.entries (idtx)); /* get ptr to major device entry */ if idte.process_id ^= ev_info.sending_proc /* whoever sent signal does not own the device */ then do; out_msg = "Driver signal rejected (device not assigned to process)"; code = error_table_$request_not_recognized; return; end; if mdte.active ^= 1 then do; /* device isn't active, cannot accept signal */ out_msg = "Driver signal rejected (minor device not active)"; code = error_table_$request_not_recognized; return; end; dr_ptr = mdte.driver_ptr; /* pick up ptr to driver status segment */ dcx = mdte.dev_class_index; /* pick up index of device class entry */ dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); /* get ptr to device class entry */ qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); sender_device = get_device_name (); /* keep signal sender's device name handy */ sender_class = get_class_name (); /* and device class name too */ code = 0; return; end identify_sender; /* ********************************************************** */ get_device_name: proc returns (char (32) aligned); dcl name char (32) aligned; if idte.last_minor > idte.first_minor /* if more than one minor */ | idte.dev_id ^= mdte.dev_id then /* or if minor name is different, add it on */ name = rtrim (idte.dev_id) || "." || mdte.dev_id; else name = idte.dev_id; return (name); end get_device_name; /* ********************************************************** */ get_class_name: proc returns (char (32) aligned); dcl name char (32) aligned; if qgte.last_dev_class > qgte.first_dev_class /* if more than one device class */ | qgte.name ^= dcte.id then /* or if device class name is different, add it on */ name = rtrim (qgte.name) || "." || dcte.id; else name = qgte.name; return (name); end get_class_name; %page; sig_label (0): sig_label (1): /* Come here on normal driver signal. (sig_type = 0) => driver done with request (sig_type = 1) => driver wants a new request (and is done with any current request) */ /* find out if driver just finished a request */ if mdte.current_request ^= 0 then do; /* yes, we've got a descriptor */ /* copy updated portions */ desc_ptr = ptr (iodc_static.descr_seg_ptr, mdte.current_request); copy_ptr = addr (dr_ptr -> driver_status.descriptor); if ^(copy_ptr -> request_descriptor.finished | copy_ptr -> request_descriptor.cancelled) then go to iodc_return; /* don't screw up active request */ call update_descriptor; mdte.current_request = 0; /* if it hasn't been saved yet, save it */ call save_request_ (desc_ptr, dctep); end; if sig_type = 0 then go to iodc_return; /* driver doesn't want a new request */ /* is there a request hanging? */ if dcte.pending_request ^= 0 then do; desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.pending_request); dcte.pending_request = desc_ptr -> request_descriptor.next_pending; end; /* are we in a restart cycle ? */ else if dcte.restart_req ^= 0 then do; /* in restart cycle */ desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.restart_req); call unthread_descriptor_ (desc_ptr); /* will be moved to end of saved list */ desc_ptr -> request_descriptor.restarted = "1"b; desc_ptr -> request_descriptor.prev_seq_id = desc_ptr -> request_descriptor.seq_id; dcte.restart_req = 0; /* reset indicator til we find another */ /* if restarting a series, find the next request to restart next time around */ if desc_ptr -> request_descriptor.series_restart then do; series_id = divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0); desc_off = desc_ptr -> request_descriptor.next_done; do while (desc_off ^= 0); /* look for next request to restart */ next_ptr = ptr (iodc_static.descr_seg_ptr, desc_off); /* if this is part of the series */ if divide (next_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id then do; next_ptr -> request_descriptor.saved = "1"b; /* should be on already, make sure */ next_ptr -> request_descriptor.series_restart = "1"b; /* so should this */ dcte.restart_req = desc_off; /* we'll do this one next time */ desc_off = 0; /* drop out of loop */ end; else desc_off = next_ptr -> request_descriptor.next_done; end; end; end; else do; /* Now we must get a brand new request from one of the queues */ area_flag = 0; /* indicates area condition not raised yet */ on area call area_handler; allocate request_descriptor in (descr_area) set (desc_ptr); revert area; unspec (desc_ptr -> request_descriptor) = ""b; if ^find_next_request_ (dcx, desc_ptr) then do; /* we didn't get one */ free desc_ptr -> request_descriptor in (descr_area); if dr_ptr -> driver_status.acknowledge then do; /* must tell driver anyway */ call hcs_$wakeup (idte.process_id, dr_ptr -> driver_status.driver_chan, 0, code); if code ^= 0 then call check_wakeup_code (code); end; go to iodc_return; end; end; /* Okay, let's send it! */ desc_ptr -> request_descriptor.seq_id = mdte.seq_id + 1; desc_ptr -> request_descriptor.finished = "0"b; addr (dr_ptr -> driver_status.descriptor) -> request_descriptor = desc_ptr -> request_descriptor; addr (dr_ptr -> driver_status.descriptor) -> request_descriptor.saved = "0"b; /* see if driver wants it saved */ message_len = desc_ptr -> mseg_message_info.ms_len; addr (dr_ptr -> driver_status.message) -> based_message = desc_ptr -> mseg_message_info.ms_ptr -> based_message; desc_off = fixed (rel (desc_ptr), 18); if ^stac (addr (dr_ptr -> driver_status.request_pending), coord_proc_id) then do; /* driver no longer wants request */ make_pending: desc_ptr -> request_descriptor.next_pending = dcte.pending_request; dcte.pending_request = desc_off; go to iodc_return; end; call hcs_$wakeup (idte.process_id, dr_ptr -> driver_status.driver_chan, 0, code); if code ^= 0 then do; call check_wakeup_code (code); go to make_pending; end; mdte.current_request = desc_off; if mod (desc_ptr -> request_descriptor.seq_id, 10000) = 9999 then do; new_series: new_driver_series = new_driver_series + 10000; mdte.seq_id = new_driver_series; call ioa_$rsnnl ("Device ^a switched to series ^d.", out_msg, out_len, sender_device, new_driver_series); call iodc_message_ ("100"b, 0, out_msg); end; else mdte.seq_id = desc_ptr -> request_descriptor.seq_id; /* all done, go home */ iodc_return: call ipc_$unmask_ev_calls (code); recursion_flag = 0; return; /* ***************************************************** */ /* This procedure updates a few items in the coord's copy of a descriptor from the driver's copy. */ update_descriptor: proc; desc_ptr -> request_descriptor.driver_data = copy_ptr -> request_descriptor.driver_data; desc_ptr -> request_descriptor.cancelled = copy_ptr -> request_descriptor.cancelled; desc_ptr -> request_descriptor.dont_delete = copy_ptr -> request_descriptor.dont_delete; if ^desc_ptr -> request_descriptor.saved then /* if still in queue we may keep it there */ desc_ptr -> request_descriptor.keep_in_queue = copy_ptr -> request_descriptor.keep_in_queue; desc_ptr -> request_descriptor.saved = /* hold request if saved or deferred by driver command */ copy_ptr -> request_descriptor.saved | copy_ptr -> request_descriptor.keep_in_queue; end update_descriptor; %page; sig_label (2): series_sw = "1"b; ack_chan = 0; seq_id = addr (ev_info.message) -> ev_msg.seq_id; go to restart_or_save; sig_label (3): series_sw = "1"b; ack_chan = 0; seq_id = addr (ev_info.message) -> ev_msg.seq_id; restart_or_save: /* Here for "restart _n"(2) or "save _n"(3) command given to driver. For "restart" we will record that requests for the device class have been restarted, and look for the request from which to restart. For "save" we will simply scan through setting "saved" bit in all requests done of specified series. */ if sig_type = save then cmd = "Save"; /* set up for messages */ else cmd = "Restart"; call ioa_$rsnnl ("^a command received from device ^a", out_msg, out_len, cmd, idte.dev_id); call iodc_message_ ("110"b, 0, out_msg); series_id = divide (seq_id, 10000, 35, 0); do desc_off = iodc_static.first_req_done repeat desc_ptr -> request_descriptor.next_done while (desc_off ^= 0); desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off); if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id then /* right series? */ if desc_ptr -> request_descriptor.seq_id >= seq_id then /* right request or next one in series? */ if desc_ptr -> request_descriptor.dev_class_index = dcx then /* is it ours? */ go to found_desc; /* WHEW! Now make decisions for this one */ else do; /* A restart or save of a given series is logically only allowed to be performed by a driver of the same device class that the series was originally done under. However, a driver with multiple minor devices has one device class for each minor device. Therefore, even if the minor device that actually sent the wakeup does not have the matching device class, we will allow it so long as one of the other minor devices of the same driver process does have the matching device class. */ if idte.last_minor > idte.first_minor then /* more than one minor device */ do mdtx = idte.first_minor to idte.last_minor; /* look for one with right device class */ mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); if mdte.active = 1 then if mdte.dev_class_index = desc_ptr -> request_descriptor.dev_class_index then do; sender_device = get_device_name (); dctep = addr (iodc_static.dctp -> dev_class_tab.entries (mdte.dev_class_index)); qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); sender_class = get_class_name (); go to found_desc; end; end; call ioa_$rsnnl ( "^a rejected. Sender device class does not match that of specified request.", out_msg, out_len, cmd); call iodc_message_ ("110"b, 0, out_msg); code = error_table_$action_not_performed; call driver_ack (code, 0); /* tell driver */ go to iodc_return; end; end; /* come here if the specified sequence id was not found and neither were any higher sequence ids in the same series. */ call ioa_$rsnnl ("No saved requests from number ^d", out_msg, out_len, seq_id); call iodc_message_ ("101"b, 0, out_msg); code = error_table_$noentry; go to tell_driver; found_desc: if sig_type = restart then /* restart only */ if dcte.restart_req ^= 0 then do; call ioa_$rsnnl ("Restart already in progress for request type ^a", out_msg, out_len, sender_class); call iodc_message_ ("101"b, 0, out_msg); code = error_table_$namedup; /* duplicate request for restart */ go to tell_driver; end; if desc_ptr -> request_descriptor.seq_id > seq_id then do; call ioa_$rsnnl ("Request ^d is gone.", out_msg, out_len, seq_id); call iodc_message_ ("001"b, 0, out_msg); code = error_table_$noentry; /* for single restart error message */ if ^series_sw then go to tell_driver; /* stop now if no series */ end; code = 0; /* we will do a restart now, tell driver OK */ seq_id = desc_ptr -> request_descriptor.seq_id; /* say we started at this request */ call ioa_$rsnnl ("^a ^[from^;of^] request ^d initiated for request type ^a", out_msg, out_len, cmd, series_sw, seq_id, sender_class); call iodc_message_ ("110"b, 0, out_msg); if sig_type = restart then /* establish restart cycle */ dcte.restart_req = desc_off; /* for both restart and save, turn on "saved" indicators */ desc_ptr -> request_descriptor.saved = "1"b; if series_sw then do; if sig_type = restart then desc_ptr -> request_descriptor.series_restart = "1"b; /* this triggers the sequence for next req cmd */ do desc_off = desc_ptr -> request_descriptor.next_done repeat desc_ptr -> request_descriptor.next_done while (desc_off ^= 0); desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off); if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id then do; desc_ptr -> request_descriptor.saved = "1"b; if sig_type = restart then desc_ptr -> request_descriptor.series_restart = "1"b; end; end; end; /* if the series restarted or saved is in use, give driver a new series */ do mdtx = 1 to static_mdtp -> minor_device_tab.n_minor; /* see if series is in use */ mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); if mdte.active = 1 then if divide (mdte.seq_id, 10000, 35, 0) = series_id then do; idtep = addr (static_idtp -> iod_device_tab.entries (mdte.major_index)); sender_device = get_device_name (); call driver_ack (0, seq_id); /* be sure driver gets OK */ go to new_series; end; end; tell_driver: call driver_ack (code, seq_id); /* tell what happened and which request number */ go to iodc_return; /* ============= */ /* ********************************************************** */ driver_ack: proc (code, num); dcl code fixed bin (35); dcl num fixed bin (35); dcl ec fixed bin (35); if ack_chan = 0 then return; /* if nothing defined, quit */ addr (event_message) -> ack_msg.code = code; addr (event_message) -> ack_msg.num = num; call hcs_$wakeup (proc_id, ack_chan, event_message, ec); if ec ^= 0 then call iodc_message_ ("101"b, code, "Unable to acknowledge driver command."); return; end driver_ack; %page; sig_label (4): /* This branch is taken when a driver process has received a "logout" command. It frees the major device assigned to the driver process. */ call iodc_$free_device (idtep, code); if code = 0 then do; call ioa_$rsnnl ("Driver logout for device ^a", out_msg, out_len, idte.dev_id); call iodc_message_ ("100"b, 0, out_msg); end; go to iodc_return; /* ********************************************************** */ sig_label (5): /* This branch is taken when the driver wants to get the event channel needed to send commands through coord_comm.ms, which is only given to live drivers */ event_message = driver_cmd_chan; call hcs_$wakeup (proc_id, dr_ptr -> driver_status.driver_chan, event_message, code); if code ^= 0 then call check_wakeup_code (code); go to iodc_return; %page; free_device: entry (a_idtep, a_code); /* This entry frees a major device for subsequent use by another driver. */ /* The process id assigned to the device is zeroed, and each minor device is marked inactive */ /* The major device directory and all contained driver status segments are deleted. */ /* If an unfinished request is found for a minor device, that request is made pending for the associated device class and marked as "continued". */ dcl a_idtep ptr; /* device table entry ptr */ dcl a_code fixed bin (35); idtep = a_idtep; /* loop thru minor devices making each inactive */ do mdtx = idte.first_minor to idte.last_minor; mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); if idte.process_id ^= ""b then if mdte.active = 1 then if mdte.current_request ^= 0 then do; /* could be an unfinished request */ dctep = addr (iodc_static.dctp -> dev_class_tab.entries (mdte.dev_class_index)); desc_ptr = ptr (iodc_static.descr_seg_ptr, mdte.current_request); copy_ptr = addr (mdte.driver_ptr -> driver_status.descriptor); call update_descriptor; if copy_ptr -> request_descriptor.finished | copy_ptr -> request_descriptor.cancelled then /* consider it done */ call save_request_ (desc_ptr, dctep); else do; /* not finished, make request pending */ desc_ptr -> request_descriptor.next_pending = dcte.pending_request; dcte.pending_request = fixed (rel (desc_ptr), 18); desc_ptr -> request_descriptor.continued = "1"b; /* this request is not brand new */ desc_ptr -> request_descriptor.contd_seq_id = desc_ptr -> request_descriptor.seq_id; end; mdte.current_request = 0; end; mdte.active = 0; end; idte.lock, idte.process_id = ""b; call delete_$path (sysdir, idte.dev_id, "101101"b, "", code); /* delete major device dir */ if code ^= 0 then if code ^= error_table_$noentry then do; call ioa_$rsnnl ("Deleting ^a>^a. Cannot free device.", out_msg, out_len, sysdir, idte.dev_id); call iodc_message_ ("101"b, code, out_msg); end; else code = 0; a_code = code; return; %page; new_driver: entry (a_ptr); /* This entry gets a wakeup from a driver that's just come up. We * must allocate a structure for it and alert it that we're ready for it * to operate. */ entry_type = new_driver; go to read_comm_msg; driver_command: entry (a_ptr); /* this entry uses some similar code to the new driver entry, but is used by a driver to signal commands which need more space than an event message can provide */ entry_type = driver_command; read_comm_msg: ack_chan = 0; /* define this as not known for now */ mask_code = -1; on cleanup begin; call driver_ack (error_table_$action_not_performed, 0); /* break driver loose */ if mask_code = 0 then call ipc_$unmask_ev_calls (code2); end; call ipc_$mask_ev_calls (mask_code); err_label = iodc_return; ev_info_ptr = a_ptr; proc_id = ev_info.sending_proc; /* The event message for the new driver wakeup should contain a message id. */ /* The message id identifies a message placed in coord_comm.ms by the driver */ ms_id = unspec (ev_info.message); unspec (driver_mmi) = ""b; driver_mmi.version = MSEG_MESSAGE_INFO_V1; driver_mmi.ms_id = ms_id; driver_mmi.message_code = MSEG_READ_SPECIFIED; call message_segment_$read_message_index (comm_mseg_idx, areap, addr (driver_mmi), code); if code ^= 0 then do; call iodc_message_ ("101"b, code, "Attempting to read driver message from coord_comm.ms"); go to iodc_return; end; call message_segment_$delete_index (comm_mseg_idx, ms_id, code); /* delete the message */ if code ^= 0 then call iodc_message_ ("101"b, code, "Deleting coord_comm.ms driver message"); if entry_type = new_driver then go to make_new_driver; /* otherwise, this is a driver command .. so get set up for it */ %page; comm_ptr = driver_mmi.ms_ptr; /* set pointer to message for easy reference */ ack_chan = iodd_comm.ack_chan; /* this is how we tell what happened */ err_label = abort_driver_cmd; /* be sure we jolt driver on errors */ mdtx = iodd_comm.minor_idx; /* see who the driver says he is */ call identify_sender (code); if code ^= 0 then do; bad_req: call driver_ack (code, 0); /* don't let the driver hang */ go to iodc_return; end; sig_type = iodd_comm.type; /* this is the command code */ if sig_type = save | sig_type = restart then do; /* for save and restart commands */ seq_id = iodd_comm.request_no; if iodd_comm.type_ext = ""b then series_sw = ""b; else series_sw = "1"b; go to restart_or_save; /* join the main part */ end; if sig_type = restart_q then go to restart_queue; /* for restart_q command */ if sig_type = next_req then go to next_request; code = error_table_$request_not_recognized; go to bad_req; abort_driver_cmd: call driver_ack (error_table_$action_not_performed, 0); go to iodc_return; %page; make_new_driver: new_driver_id = driver_mmi.sender_id; /* get person/project name of new driver */ i = length (rtrim (new_driver_id)); /* locate tag portion of group id */ substr (new_driver_id, i) = "*"; /* any tag is ok */ auth = driver_mmi.sender_authorization; /* get authorization of new driver */ new_driver_msg_p = driver_mmi.ms_ptr; chan_name = new_driver_msg.wakeup_chan; /* pick up channel on which to wakeup driver */ /* find out what device class the new driver wants */ /* make sure the driver's authorization is right for the device class */ dcx = new_driver_msg.dev_class_index; /* get index of desired device class */ if dcx < 1 | dcx > iodc_static.dctp -> dev_class_tab.n_classes /* bad index */ then do; code = 1; call ioa_$rsnnl ("New driver rejected: ^a (bad device class index)", out_msg, out_len, new_driver_id); bad_new_driver: call iodc_message_ ("100"b, 0, out_msg); go to wake_driver; end; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); /* get dev class table entry ptr */ qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); /* get q group tab entry ptr */ sender_class = get_class_name (); /* get device class name */ if ^aim_check_$greater_or_equal (auth, dcte.max_access) then do; /* insufficient authorization */ code = 2; call ioa_$rsnnl ("New driver rejected: ^a (wrong authorization for device class ^a)", out_msg, out_len, new_driver_id, sender_class); go to bad_new_driver; end; /* make sure driver's userid is right for queue group */ if qgte.driver_id ^= new_driver_id then do; /* wrong userid */ code = 3; call ioa_$rsnnl ("New driver rejected: ^a (invalid userid for ^a queue group)", out_msg, out_len, new_driver_id, qgte.name); go to bad_new_driver; end; /* now find out which device the new driver wants */ /* make sure that its valid for the device class and that its not already in use */ mdtx = new_driver_msg.device_index; if mdtx < 1 | mdtx > static_mdtp -> minor_device_tab.n_minor /* bad index */ then do; code = 4; call ioa_$rsnnl ("New driver rejected: ^a (bad minor device index)", out_msg, out_len, new_driver_id); go to bad_new_driver; end; mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); idtx = mdte.major_index; /* get major device index */ idtep = addr (static_idtp -> iod_device_tab.entries (idtx)); sender_device = get_device_name (); /* pick up major device name */ if ^substr (dcte.device_list, mdtx, 1) then do; /* device not valid for this class */ code = 5; call ioa_$rsnnl ("New driver rejected: ^a (device ^a invalid for device class ^a)", out_msg, out_len, new_driver_id, sender_device, sender_class); go to bad_new_driver; end; if idte.process_id ^= ""b then /* major device is already assigned */ if idte.process_id ^= proc_id then do; /* but not to this process */ call set_lock_$lock (idte.lock, 0, code); /* see if lock is still valid */ if code = 0 | code = error_table_$invalid_lock_reset then do; /* bad lock so free the device */ call iodc_$free_device (idtep, code); if code ^= 0 then do; code = 10; go to wake_driver; end; end; else do; /* lock was good, can't give new driver this device */ code = 6; call ioa_$rsnnl ("New driver rejected: ^a (device ^a assigned to other process)", out_msg, out_len, new_driver_id, idte.dev_id); go to bad_new_driver; end; end; else if mdte.active ^= 0 then do; /* we already gave him this one */ code = 7; call ioa_$rsnnl ("New driver rejected: ^a (device ^a already active)", out_msg, out_len, new_driver_id, sender_device); go to bad_new_driver; end; /* if the message segment queues have not yet been opened for this group, then open them */ if qgte.open = 0 then /* queues have not been opened */ do q = 1 to qgte.max_queues; /* open them */ qgte.last_read (q) = "0"b; call ioa_$rsnnl ("^a_^d.ms", q_name, out_len, qgte.name, q); call message_segment_$open (sysdir, q_name, q_idx, code); if code ^= 0 then do; if code = error_table_$noentry then call ioa_$rsnnl ("Queue ^d for request type ^a missing.", out_msg, out_len, q, dcte.id) ; else call ioa_$rsnnl ("Could not open ^a>^a", out_msg, out_len, sysdir, q_name); call iodc_message_ ("101"b, code, out_msg); code = 8; go to wake_driver; end; call message_segment_$check_salv_bit_index (q_idx, "1"b, unbit, code); if unbit then do; call ioa_$rsnnl ("Message segment ^a was salvaged. Some requests may have been lost.", out_msg, out_len, q_name); call iodc_message_ ("110"b, 0, out_msg); end; qgte.mseg_index (q) = q_idx; /* save the message segment index */ end; /* If the major device was not previously assigned, we must create */ /* a directory to hold all driver status segments for the major device. */ /* This directory will be upgraded (if necessary) to the authorization of the new driver. */ /* If upgraded, a quota of 2 records per minor device will be assigned. The dir_quota will be a min of 5, or 1/6 page per segment. */ if idte.process_id = ""b then do; /* device not previously assigned */ quota = 2 * (idte.last_minor - idte.first_minor + 1); /* 2 records per minor device */ dir_quota = max (5, divide (idte.last_minor - idte.first_minor + 1, 6, 17)); call make_dir (idte.dev_id, auth, quota, dir_quota, code); if code ^= 0 then do; /* failed to create dir */ call ioa_$rsnnl ("Cannot create directory for device ^a", out_msg, out_len, idte.dev_id); call iodc_message_ ("101"b, code, out_msg); /* tell the operator */ code = 9; go to wake_driver; end; end; /* now we're ready to set up driver status segment */ subdir = sysdir; substr (subdir, sysdir_len + 1, 1) = ">"; substr (subdir, sysdir_len + 2) = idte.dev_id; /* construct dir name */ acl (n_acl).ac_name = new_driver_id; /* put driver on the acl of driver status seg */ call make (subdir, mdte.dev_id, dr_ptr, code); if code ^= 0 then do; call ioa_$rsnnl ("Cannot create driver status segment for device ^a", out_msg, out_len, sender_device) ; call iodc_message_ ("101"b, code, out_msg); code = 10; go to wake_driver; end; /* set up driver status segment contents */ unspec (dr_ptr -> driver_status) = "0"b; dr_ptr -> driver_status.req_type_label = sender_class; dr_ptr -> driver_status.dev_name_label = sender_device; dr_ptr -> driver_status.device_id = mdte.dev_id; dr_ptr -> driver_status.device_class_id = dcte.id; dr_ptr -> driver_status.coord_chan = driver_sig_chan; dr_ptr -> driver_status.request_pending = "0"b; dr_ptr -> driver_status.dev_index = mdtx; dr_ptr -> driver_status.maj_index = idtx; dr_ptr -> driver_status.dev_class_index = dcx; dr_ptr -> driver_status.minor_args = mdte.args; dr_ptr -> driver_status.min_banner = dcte.min_banner; dr_ptr -> driver_status.rqti_ptr = null; dr_ptr -> driver_status.dev_out_iocbp = null; dr_ptr -> driver_status.dev_in_iocbp = null; dr_ptr -> driver_status.dev_out_stream = ""; dr_ptr -> driver_status.dev_in_stream = ""; dr_ptr -> driver_status.forms_validation_ptr = null; dr_ptr -> driver_status.dev_ptr1 = null; dr_ptr -> driver_status.dev_ctl_ptr = null; /* modify coordinator data bases to reflect new driver */ qgte.open = 1; idte.lock = new_driver_msg.lock_id; idte.process_id = proc_id; mdte.dev_class_index = dcx; mdte.active = 1; mdte.driver_ptr = dr_ptr; mdte.current_request = 0; new_driver_series = new_driver_series + 10000; mdte.seq_id = new_driver_series; call ioa_$rsnnl ("New driver for device ^a, request type ^a (series = ^d)", out_msg, out_len, sender_device, sender_class, new_driver_series); ; call iodc_message_ ("100"b, 0, out_msg); wake_driver: /* tell the guy all about it */ event_message = 0; addr (event_message) -> ev_msg.code = code; call hcs_$wakeup (proc_id, chan_name, event_message, code); if code ^= 0 then call check_wakeup_code (code); go to iodc_return; %page; restart_queue: /* go back to the head of the queues for this driver, flush any normal waiting requests from the wait list, but leave all priority requests */ wlp = iodc_static.wait_list_ptr; qgte.last_read (*) = ""b; /* next time read the first message */ do dcx = qgte.first_dev_class to qgte.last_dev_class; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); do q = 1 to 4; /* look at all possible queues */ nx = dcte.first_waiting (q); /* get first waiting list index for this queue */ if nx ^= 0 then do; /* do we need to check? */ lwx, fwx = 0; /* get ready to re-thread the list */ do x = nx repeat nx while (nx ^= 0); nx = wlp -> waiting_list.next (x); /* advance the forward thread */ if wlp -> waiting_list.state (x) = priority then do; if fwx = 0 then fwx = x; else wlp -> waiting_list.next (lwx) = x; /* add to tail of list */ lwx = x; /* advance the tail marker */ wlp -> waiting_list.next (x) = 0; /* mark this as the end */ end; else do; /* this is a normal entry, drop it */ if x = wlp -> waiting_list.last_used then do; /* drop the high water mark */ wlp -> waiting_list.next (x) = 0; wlp -> waiting_list.last_used = wlp -> waiting_list.last_used - 1; end; else do; /* add to the free list */ wlp -> waiting_list.next (x) = wlp -> waiting_list.first_free; wlp -> waiting_list.first_free = x; end; wlp -> waiting_list.state (x) = 0; /* clear any garbage */ wlp -> waiting_list.ms_id (x) = ""b; wlp -> waiting_list.orig_q (x) = 0; dcte.n_waiting = dcte.n_waiting - 1; /* reduce the count */ end; end; dcte.first_waiting (q) = fwx; dcte.last_waiting (q) = lwx; end; end; end; call driver_ack (0, 0); go to iodc_return; %page; next_request: /* Here a driver has requested the coord to make a certain request high priority. This is done by searching the driver's queues for a request which matches given parameters. Then the message_id and queue number data are threaded into the drivers queue 1 waiting list, behind any other priority requests */ if iodd_comm.queue_no = 0 then do; /* do we look in each possible queue? */ start = 1; finish = qgte.max_queues; end; else start, finish = iodd_comm.queue_no; /* just look in the given queue */ if start < 1 | finish > qgte.max_queues then do; /* bad to start with */ code = error_table_$action_not_performed; go to bad_req; end; user_id = iodd_comm.user_id; string (option) = iodd_comm.type_ext; if option.et then do; /* use this as precedence */ option.pn = ""b; /* in case both were set */ match_dir = ""; match_ent = iodd_comm.data; /* get the entry name we will look for */ end; else if option.pn then do; call expand_pathname_ (iodd_comm.data, match_dir, match_ent, code); if code ^= 0 then go to bad_req; end; else do; match_dir, match_ent = ""; /* clear the names */ if ^option.id then do; code = error_table_$action_not_performed; go to bad_req; end; end; /* now look for a request matching user, segment and/or request_id */ code = 0; /* clear, then watch for aim errors */ do q = start to finish; q_idx = qgte.mseg_index (q); /* get the message segment index for reading */ ms_id = ""b; /* start at the begining of the queue */ retry = 0; retry1: unspec (msg_mmi) = ""b; msg_mmi.version = MSEG_MESSAGE_INFO_V1; msg_mmi.message_code = MSEG_READ_FIRST; call message_segment_$read_message_index (q_idx, areap, addr (msg_mmi), code2); if code2 ^= 0 then /* normal test should be cheap */ if code2 = error_table_$bad_segment /* message seg was salvaged */ then if retry = 0 then do; /* try once more */ retry = 1; go to retry1; end; do while (code2 = 0); ms_id = msg_mmi.ms_id; /* record the last message read */ reqp = msg_mmi.ms_ptr; /* get pointer to request */ sender_id = msg_mmi.sender_id; /* see who put it there */ len = length (rtrim (sender_id)); /* get its size */ sender_id = substr (sender_id, 1, len - 2); /* strip off the tag */ if sender_id ^= user_id then go to next_msg; /* user didn't match, skip the request */ if option.et then if match_ent ^= reqp -> queue_msg_hdr.ename then go to next_msg; if option.pn then do; if match_ent ^= reqp -> queue_msg_hdr.ename then go to next_msg; if match_dir ^= reqp -> queue_msg_hdr.dirname then go to next_msg; end; if option.id then if ^match_request_id_ (reqp -> queue_msg_hdr.msg_time, iodd_comm.req_id) then go to next_msg; /* We have a matching request, see if the driver can run it */ auth = msg_mmi.sender_authorization; if ^aim_check_$greater_or_equal (auth, dcte.min_access) then /* below minimum? */ code = error_table_$ai_restricted; else if aim_check_$greater_or_equal (dcte.max_access, auth) then do; /* not above max */ reqp -> queue_msg_hdr.state = STATE_ELIGIBLE; retry = 0; retry3: call message_segment_$update_message_index (q_idx, msg_mmi.ms_len, ms_id, reqp, code2); if code2 ^= 0 then do; /* normal test should be cheap */ if code2 = error_table_$bad_segment /* message seg was salvaged */ then if retry = 0 then do; /* try once more */ retry = 1; go to retry3; end; go to next_msg; end; go to found_next_request; /* OK, put it into the waiting list */ end; else code = error_table_$ai_above_allowed_max; /* if driver can't see the request, pretend we didn't see it either */ next_msg: free reqp -> queue_msg_hdr in (sys_area); /* free the old request */ retry = 0; retry2: unspec (msg_mmi) = ""b; msg_mmi.version = MSEG_MESSAGE_INFO_V1; msg_mmi.ms_id = ms_id; msg_mmi.message_code = MSEG_READ_AFTER_SPECIFIED; call message_segment_$read_message_index (q_idx, areap, addr (msg_mmi), code2); if code2 ^= 0 then /* normal test should be cheap */ if code2 = error_table_$bad_segment/* message seg was salvaged */ then if retry = 0 then do; /* try once more */ retry = 1; go to retry2; end; end; end; /* No matching request was found or it was out of aim range */ if code = 0 then code = error_table_$noentry; go to bad_req; found_next_request: free reqp -> queue_msg_hdr in (sys_area); /* we are done with the text for now */ /* thread the request info into the waiting list */ wlp = iodc_static.wait_list_ptr; if wlp -> waiting_list.first_free > 0 then do; new_idx = wlp -> waiting_list.first_free; /* pick off a free entry */ wlp -> waiting_list.first_free = wlp -> waiting_list.next (new_idx); /* move the list back */ end; else do; /* list is full, extend it */ if wlp -> waiting_list.last_used = max_wl_size then do; call iodc_message_ ("101"b, 0, "Waiting_list full."); code = error_table_$action_not_performed; go to bad_req; end; new_idx = wlp -> waiting_list.last_used + 1; /* allocate the next entry */ wlp -> waiting_list.last_used = new_idx;/* record the usage */ end; wlp -> waiting_list.next (new_idx) = 0; /* fill in the new entry */ wlp -> waiting_list.state (new_idx) = priority; wlp -> waiting_list.ms_id (new_idx) = ms_id; wlp -> waiting_list.orig_q (new_idx) = q; nx = dcte.first_waiting (1); /* find queue 1 waiting list */ if nx > 0 then do; /* is there a real list? */ lwx = 0; /* last good entry not found yet */ do x = nx repeat nx while (nx ^= 0); nx = wlp -> waiting_list.next (x); /* offset of next in the chain */ if wlp -> waiting_list.state (x) ^= priority then do; /* found last of the priority entries */ nx = 0; /* stop the loop */ wlp -> waiting_list.next (new_idx) = x; /* put new one in front */ if lwx = 0 then dcte.first_waiting (1) = new_idx; /* if this was the first one */ else wlp -> waiting_list.next (lwx) = new_idx; /* link the last one to the new one */ end; else if nx = 0 then do; /* last entry was also priority */ wlp -> waiting_list.next (x) = new_idx; /* put this on the end */ dcte.last_waiting (1) = new_idx; /* update the last pointer for chaining to end */ end; lwx = x; /* save the last index of skipped request */ end; end; else dcte.first_waiting (1), dcte.last_waiting (1) = new_idx; /* no list, so start one */ dcte.n_waiting = dcte.n_waiting + 1; call driver_ack (0, 0); /* tell driver we found it */ go to iodc_return; %page; proc_dies: /* Come here for new process after disaster */ call ioa_$rsnnl ("^a^/New coordinator process will be created. All device drivers will be reinitialized.", out_msg, out_len, out_msg); call iodc_message_$loud ("001"b, code, out_msg); /* put machine conditions if any in log */ if scu_msg ^= "" then call iodc_message_ ("100"b, code, scu_msg); call new_proc; %page; quit_handler: proc; /* Entered when coordinator receives QUIT. */ dcl mask_code fixed bin (35); if quit_flag then if ^testing then do; /* don't stack quits */ call com_err_ (0, "io_coordinator", "QUIT already pending."); return; end; mask_code = -1; on cleanup begin; if mask_code = 0 then call ipc_$unmask_ev_calls (code2); end; call ipc_$mask_ev_calls (mask_code); quit_flag = "1"b; call ioa_ ("QUIT received."); call iox_$control (iox_$user_input, "resetread", null (), code); call iodc_$command_level; quit_flag = "0"b; call ipc_$unmask_ev_calls (code2); call iox_$control (iox_$user_io, "start", null, code); return; end quit_handler; %page; command_level: entry; /* This is the IO Coordinator command processor. It is called by the quit handler and also by the unclaimed signal handler when in test mode. */ com_level = com_level + 1; mask_code = -1; on cleanup begin; com_level = com_level - 1; if mask_code = 0 then call ipc_$unmask_ev_calls (code2); end; if com_level > 0 then /* don't ask for a command just after initialization */ ask: call ioa_ ("Enter command.^[ (level ^d)^;^s^]", (com_level > 1), com_level); if mask_code = 0 then do; call ipc_$unmask_ev_calls (code2); mask_code = -1; end; line = ""; call iox_$get_line (iox_$user_input, addr (line), length (line), nc, code); line = ltrim (rtrim (line, NL || " ")); /* trim spaces and NL chars */ cmd = before (line, " "); /* command is the first part */ if cmd = "" | cmd = "." then go to ask; call ipc_$mask_ev_calls (mask_code); if cmd = "help" then do; /* HELP COMMAND */ call ioa_ ("list, logout, print_devices, restart_status, start, term, wait_status"); if testing then call ioa_ ("**Test: debug, probe, driver, pi, return"); go to ask; end; if cmd = "start" /* START COMMAND */ then if com_level > 0 then do; com_level = com_level - 1; if mask_code = 0 then call ipc_$unmask_ev_calls (code2); return; end; else do; call com_err_ (0, "io_coordinator", "Coordinator already started."); go to ask; end; if cmd = "return" then /* RETURN COMMAND */ if testing then go to return_label; else go to bad_cmd; if cmd = "debug" /* DEBUG COMMAND */ then if testing then do; call debug; go to ask; end; if cmd = "probe" | cmd = "pb" /* PROBE COMMAND */ then if testing then do; call probe; go to ask; end; if cmd = "pi" /* PI COMMAND */ then if testing then do; call signal_ ("program_interrupt"); go to ask; end; if cmd = "logout" /* LOGOUT COMMAND */ then if testing then go to return_label; else call logout; if ^initialized then go to bad_cmd; /* other commands only valid after initialization */ if cmd = "print_devices" then do; /* PRINT_DEVICES COMMAND */ call print_devices ("-dir", sysdir); go to ask; end; if cmd = "list" then do; /* LIST COMMAND */ i = 0; do idtx = 1 to static_idtp -> iod_device_tab.n_devices; idtep = addr (static_idtp -> iod_device_tab.entries (idtx)); if idte.process_id ^= ""b then do mdtx = idte.first_minor to idte.last_minor; mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx)); if mdte.active = 1 then do; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (mdte.dev_class_index)); qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); sender_device = get_device_name (); sender_class = get_class_name (); call ioa_ ("device ^a is active, request type ^a, request ^d", sender_device, sender_class, mdte.seq_id); i = i + 1; end; end; end; if i = 0 then call ioa_ ("No active devices"); go to ask; end; if cmd = "restart_status" /* RESTART_STATUS COMMAND */ then do; nseries = divide (new_driver_series, 10000, 35, 0); if nseries = 0 then go to no_restartable; allocate series_info in (sys_area); series_info (*).count = 0; desc_off = iodc_static.first_req_done; do while (desc_off ^= 0); /* scan the saved list */ desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off); series_id = divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0); if series_info (series_id).count = 0 then do; /* first request of this series */ series_info (series_id).first = desc_ptr -> request_descriptor.seq_id; series_info (series_id).dcx = desc_ptr -> request_descriptor.dev_class_index; end; series_info (series_id).last = desc_ptr -> request_descriptor.seq_id; series_info (series_id).count = series_info (series_id).count + 1; desc_off = desc_ptr -> request_descriptor.next_done; end; i = 0; do series_id = 1 to nseries; /* now let's see what we found */ if series_info (series_id).count > 0 then do; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (series_info (series_id).dcx)); qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); sender_class = get_class_name (); /* get type/class name for series */ call ioa_ ("^d restartable request(s) from ^d to ^d (^a)", series_info (series_id).count, series_info (series_id).first, series_info (series_id).last, sender_class); if dcte.restart_req ^= 0 then do; /* restart in progress for device class */ desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.restart_req); if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id then call ioa_ (" restart in progress at request ^d", desc_ptr -> request_descriptor.seq_id); end; i = i + 1; /* count number of series */ end; end; free series_info in (sys_area); if i = 0 then no_restartable: call ioa_ ("No restartable requests."); go to ask; end; if cmd = "wait_status" | /* WAIT_STATUS COMMAND */ cmd = "defer_status" then do; /* old command name */ i = 0; do q = 1 to iodc_static.qgtp -> q_group_tab.n_q_groups; qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (q)); if qgte.open = 1 then do dcx = qgte.first_dev_class to qgte.last_dev_class; dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); if dcte.n_waiting ^= 0 then do; sender_class = get_class_name (); call ioa_ ("^d request(s) waiting for device class ^a", dcte.n_waiting, sender_class); i = i + 1; end; end; end; if i = 0 then call ioa_ ("No waiting requests"); go to ask; end; if cmd = "term" /* TERM COMMAND */ then if com_level > 0 then go to not_after_quit; else do; /* operator asked to terminate driver */ dev_id = ltrim (substr (line, 5)); if dev_id = "" then do; call ioa_ ("Name of major device missing: term "); go to ask; end; do idtx = 1 to static_idtp -> iod_device_tab.n_devices; idtep = addr (static_idtp -> iod_device_tab.entries (idtx)); if idte.dev_id = dev_id then do; call iodc_$free_device (idtep, code); go to ask; end; end; call com_err_ (0, "io_coordinator", "Unrecognized device name: ^a", dev_id); go to ask; end; if cmd = "driver" then /* DRIVER COMMAND */ if testing then if com_level > 0 then go to not_after_quit; else do; if mask_code = 0 then do; call ipc_$unmask_ev_calls (code2); mask_code = -1; end; call iodd_$iodd_init (sysdir, "1"b); go to ask; end; bad_cmd: call com_err_ (0, "io_coordinator", "Invalid response -- ^a", line); go to ask; not_after_quit: if testing then call com_err_ (0, id, "Specified command can only be used at command level 0: ^a", cmd); else call com_err_ (0, id, "Specified command cannot be used after a QUIT: ^a", cmd); go to ask; %page; area_handler: proc; /* Handler for area condition when allocating a descriptor. * If it happens once, free a descriptor and try again. If * it still fails, area is screwed up, and we're in trouble. */ if area_flag ^= 0 then do; out_msg = "Multiple area condition in request descriptor segment."; go to proc_dies; /* blow */ end; area_flag = 1; /* watch for recursion */ call free_oldest_request_$force; /* do our best to get some space */ return; end; %page; check_wakeup_code: proc (wcode); /* Another little internal procedure, this one to check the return code from hcs_$wakeup */ dcl wcode fixed bin (35); dcl wp ptr; dcl code fixed bin (35); dcl 1 two based aligned, 2 word1 fixed bin, 2 word2 fixed bin; if wcode = 2 then call ioa_$rsnnl ("Invalid arguments to hcs_$wakeup.", out_msg, out_len); else if wcode = 1 | wcode = 3 then do; call ioa_$rsnnl ("Driver for device ^a is gone.", out_msg, out_len, idte.dev_id); call iodc_$free_device (idtep, code); /* driver is gone, free device */ end; else do; wp = addr (dr_ptr -> driver_status.driver_chan); call ioa_$rsnnl ("^w ^w", out_msg, out_len, wp -> two.word1, wp -> two.word2); end; if wcode < 4 then wcode = 0; call iodc_message_$loud ("101"b, wcode, out_msg); return; end; %page; iodc_handler: proc; /* Unclaimed signal handler for I/O Coordinator */ dcl conname char (32); dcl ec fixed bin (35); dcl ap ptr; dcl mp ptr; dcl m_len fixed bin; dcl cond_mess char (m_len) based (mp); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr); dcl ioa_$ioa_stream_nnl entry options (variable); dcl w (8) fixed bin based (scup); /* for storing scu data on recursion */ dcl 1 local_condition_info aligned like condition_info; local_condition_info.version = condition_info_version_1; /* version of condition_info structure */ call find_condition_info_ (null, addr (local_condition_info), ec); conname = local_condition_info.condition_name; if conname = "command_question" then return; if conname = "command_error" then return; if conname = "cput" then do; pass_on: call continue_to_signal_ (ec); return; end; if conname = "alrm" then go to pass_on; if conname = "finish" then go to pass_on; if testing then if conname = "program_interrupt" then go to pass_on; else if conname = "mme2" then go to pass_on; call get_system_free_area_ (ap); call condition_interpreter_ (ap, mp, m_len, 3, local_condition_info.mc_ptr, conname, local_condition_info.wc_ptr, local_condition_info.info_ptr); /* now we've got message to send to err_output and log */ if m_len > 0 then do; call ioa_$ioa_stream_nnl ("error_output", "io_coordinator: "); call iodc_message_ ("101"b, 0, cond_mess); end; if testing then do; call iodc_$command_level; /* give tester a chance to do something */ return; end; if recursion_flag ^= 0 then do; /* Bad news indeed */ call ioa_$rsnnl ("Condition ^a signalled while handling unclaimed signal.", out_msg, out_len, conname) ; /* try to save scu data so we can check what happened some day */ if local_condition_info.mc_ptr ^= null then do; scup = addr (local_condition_info.mc_ptr -> mc.scu); code = local_condition_info.mc_ptr -> mc.errcode; call ioa_$rsnnl ("^/scu: ^w ^w ^w ^w^/^5x^w ^w ^w ^w", scu_msg, out_len, w (1), w (2), w (3), w (4), w (5), w (6), w (7), w (8)); end; else do; code = 0; scu_msg = ""; end; go to proc_dies; end; recursion_flag = 1; go to err_label; end; %page; %include condition_info; %page; %include create_branch_info; %page; %include device_class; %page; %include driver_status; %page; %include iod_device_tab; %page; %include iod_event_message; %page; %include iod_tables_hdr; %page; %include iodc_data; %page; %include iodc_static; %page; %include iodc_wait_list; %page; %include iodd_comm; %page; %include mc; %page; %include mseg_message_info; %page; %include new_driver_msg; %page; %include q_group_tab; %page; %include queue_msg_hdr; %page; %include request_descriptor; end iodc_;  iodc_message_.pl1 11/15/82 1834.0rew 11/15/82 1507.1 34587 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ iodc_message_: proc (a_severity, err_code, message); /* Procedure for writing error and other messages for the I/O coordinator, both * on the log and to "users" (i.e. on error_output and user_output). */ /* Coded August 1973 by Robert S. Coren */ /* Modified by J. Stern, 2/10/75 to combine with iod_set_streams_ */ /* Modified by J. Stern, 12/4/75 to eliminate log output except through mrd_ */ dcl a_severity bit (3) aligned; /* bit 0 = log, bit 1 = user_output, bit 2 = error_output */ dcl err_code fixed bin (35); dcl message char (*); dcl severity bit (3) aligned; dcl short char (8) aligned; dcl long char (100) aligned; dcl out_msg char (300) aligned; dcl out_len fixed bin; dcl time_string char (16) aligned; dcl bells char (10) int static init ((10)""); /* BEL (007) chars */ dcl stars char (30) int static init ((30)"*"); dcl bell_out char (10); dcl (star1, star2) char (31); dcl nl char (1) int static init (" "); /* new-line char. */ dcl clock_ entry returns (fixed bin (71)); dcl date_time_ entry (fixed bin (71), char (*) aligned); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl ioa_ entry options (variable); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl substr builtin; star1, star2, bell_out = ""; join: if err_code ^= 0 then do; call convert_status_code_ (err_code, short, long); call ioa_$rsnnl ("^a^/^a", out_msg, out_len, long, message); end; else out_msg = message; severity = a_severity; if no_log then /* don't write on log_output */ if substr (severity, 1, 1) then do; substr (severity, 1, 1) = "0"b; if substr (severity, 2, 2) then; /* message was not for log_output only */ else substr (severity, 2, 1) = "1"b; /* write it on user_output */ end; if substr (severity, 1, 1) then call ioa_$ioa_stream ("log_output", "^a^a^a", star1, out_msg, star2); if substr (severity, 2, 1) then call ioa_ ("^a^a^a^a", bell_out, star1, out_msg, star2); if substr (severity, 3, 1) then call ioa_$ioa_stream ("error_output", "^a^a^a^a", bell_out, star1, out_msg, star2); return; loud: entry (a_severity, err_code, message); star1 = stars || nl; star2 = nl || stars; bell_out = bells; go to join; init: entry; /* This entry, formerly called iod_set_streams_, makes sure that * appropriate stream attachments are made through the message coordinator * if it is being used. */ dcl get_at_entry_ entry (char (*), char (*) aligned, char (*) aligned, char (*), fixed bin (35)); dcl ios_$attach entry (char (*), char (*), char (*) aligned, char (*), bit (72) aligned); dcl code fixed bin (35); dcl dev_id char (32) aligned; dcl dim_name char (32) aligned; dcl ig char (4); dcl stat bit (72) aligned; dcl no_log bit (1) int static; /* ON if not using log_output */ call get_at_entry_ ("user_i/o", dim_name, dev_id, ig, code); if dim_name = "mrd_" then do; call ios_$attach ("error_i/o", "mrd_", dev_id, "", stat); call ios_$attach ("log_i/o", "mrd_", dev_id, "", stat); call ios_$attach ("error_output", "syn", "error_i/o", "w", stat); call ios_$attach ("log_output", "syn", "log_i/o", "w", stat); no_log = "0"b; end; else no_log = "1"b; return; end iodc_message_;  print_devices.pl1 10/28/88 1351.7rew 10/28/88 1233.8 77769 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_devices: proc; /* This command prints a list of devices for each request type handled by the IO daemon as determined by inspecting the iod_working_tables segment. If more than one device class is defined for a request type, then the device classes are treated separately. For each request type, the associated driver access name and authorization is printed. An asterisk is placed immediately before a device name if the corresponding request type (device class) is the default for the device. */ /* Written by J. Stern, 5/9/75 */ /* Modified by J. C. Whitmore, 4/78, for new iod_tables format */ /* Modified by J. C. Whitmore, 10/78, to use version 3 iod_tables */ /* Modified by E. N. Kittlitz, 6/81, to use version 4 iod_tables */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. Also displays comments store in the major and minor device entries. Display columns are based on length of longest entry for each column. END HISTORY COMMENTS */ dcl argp ptr; /* ptr to arg */ dcl arglen fixed bin; /* length of arg */ dcl arg char (arglen) based (argp); /* command argument */ dcl bfsw bit (1) aligned; /* ON for brief option */ dcl rqt_found bit (1) aligned; /* ON if desired request type found */ dcl an_found bit (1) aligned; /* ON if desired access name found */ dcl select bit (1) aligned; /* ON if selecting subset of request types */ dcl match bit (1) aligned; /* ON if request type or access name matched */ dcl accname char (32) aligned; /* access name */ dcl req_type char (32) aligned; /* request type name */ dcl rqt_name char (32) aligned; /* request type name */ dcl dev_name char (32) aligned; /* device name */ dcl sysdir char (168) aligned;/* directory containing iod_working_tables */ dcl ent_name char (32) aligned; dcl (i, j, k) fixed bin; dcl did_len fixed bin; /* driver id length */ dcl code fixed bin (35); /* error code */ dcl star char (1) aligned; /* to indicate default request type for device */ dcl count fixed bin; /* count of queue groups printed */ dcl nargs fixed bin; dcl system_high bit (72) aligned; /* system high access authorization */ dcl auth_string char (170); /* authorization string */ dcl whoami char (13) aligned int static init ("print_devices"); dcl error_table_$badopt fixed bin (35) ext; dcl (addr, substr, ptr, null, before, rtrim, length) builtin; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl com_err_ entry options (variable); dcl expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)); dcl hcs_$initiate entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl system_info_$access_ceiling entry (bit (72) aligned); %page; /* initialize control argument defaults */ bfsw = "0"b; an_found, rqt_found = "1"b; accname, req_type = ""; sysdir = ">daemon_dir_dir>io_daemon_dir"; /* look for arguments */ call cu_$arg_count (nargs); do i = 1 to nargs; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then go to noarg; if arg = "-bf" | arg = "-brief" then bfsw = "1"b; else if arg = "-an" | arg = "-access_name" then do; i = i + 1; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then do; noarg: call com_err_ (code, whoami); return; end; accname = arg; an_found = "0"b; end; else if arg = "-rqt" | arg = "-request_type" then do; i = i + 1; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then go to noarg; req_type = arg; rqt_found = "0"b; end; else if arg = "-dir" | arg = "-directory" then do; i = i + 1; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then go to noarg; call expand_pathname_ (arg, sysdir, ent_name, code); /* take apart and put it back together */ if code ^= 0 then do; call com_err_ (code, whoami, arg); return; end; if sysdir = ">" then sysdir = ">" || ent_name; else sysdir = rtrim (sysdir) || ">" || ent_name; end; else do; call com_err_ (error_table_$badopt, whoami, arg); return; end; end; select = ^(an_found & rqt_found); /* get a pointer to the iod_working_tables */ call hcs_$initiate (sysdir, "iod_working_tables", "", 0, 1, ithp, code); if ithp = null then do; call com_err_ (code, whoami, "^a>iod_working_tables", sysdir); return; end; if iod_tables_hdr.version ^= IODT_VERSION_5 then do; call com_err_ (0, whoami, "Wrong version number for iod_working_tables."); return; end; idtp = ptr (ithp, iod_tables_hdr.device_tab_offset); mdtp = ptr (ithp, iod_tables_hdr.minor_device_tab_offset); dctp = ptr (ithp, iod_tables_hdr.dev_class_tab_offset); qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset); /* print the table */ call system_info_$access_ceiling (system_high); count = 0; do i = 1 to q_group_tab.n_q_groups; qgtep = addr (q_group_tab.entries (i)); did_len = length (before (qgte.driver_id, ".*")); /* compiler ensures it ends with ".*" */ if select then do; match = "1"b; if req_type ^= "" then if req_type = qgte.name then rqt_found = "1"b; else match = "0"b; if accname ^= "" then if accname = substr (qgte.driver_id, 1, did_len) then an_found = "1"b; else match = "0"b; if ^match then go to next; end; do j = qgte.first_dev_class to qgte.last_dev_class; dctep = addr (dev_class_tab.entries (j)); do k = 1 to minor_device_tab.n_minor; count = count + 1; if substr (dcte.device_list, k, 1) then do; mdtep = addr (minor_device_tab.entries (k)); idtep = addr (iod_device_tab.entries (mdte.major_index)); dev_name = idte.dev_id; if idte.last_minor > idte.first_minor | dev_name ^= mdte.dev_id then dev_name = rtrim (dev_name) || "." || mdte.dev_id; if mdte.default_dev_class = j then star = "*"; else star = " "; if count = 1 then if ^bfsw then call ioa_ ("^/ Device^-^-Request type^-Access name^/"); if substr (dcte.device_list, 1, k - 1) = ""b then do; rqt_name = qgte.name; if qgte.last_dev_class > qgte.first_dev_class | rqt_name ^= dcte.id then rqt_name = rtrim (rqt_name) || "." || dcte.id; auth_string = ""; call convert_authorization_$to_string_short (dcte.max_access, auth_string, code); if auth_string ^= "" then if dcte.max_access = system_high then auth_string = "system_high"; call ioa_ ("^1a ^18a^20a^20a^a", star, dev_name, rqt_name, substr (qgte.driver_id, 1, did_len), auth_string); end; else call ioa_ ("^1a ^a", star, dev_name); end; end; end; next: end; if ^rqt_found then call com_err_ (0, whoami, "Request type not found: ^a", req_type); if ^an_found then call com_err_ (0, whoami, "Access name not found: ^a", accname); if rqt_found & an_found then if count = 0 then call com_err_ (0, whoami, "No devices."); else call ioa_ (""); /* throw in an extra blank line */ call hcs_$terminate_noname (ithp, code); %page; %include device_class; %page; %include iod_device_tab; %page; %include iod_tables_hdr; %page; %include q_group_tab; end print_devices;  print_iod_tables.pl1 10/03/89 1002.6rew 10/03/89 0952.9 198036 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ print_iod_tables: piodt: proc; /* This command decodes and prints the contents of an object segment produced by the iod_tables_compiler. The format of the printed output corresponds exactly to the source language accepted by iod_tables_compiler. Thus, if output is directed to a file, the resulting file can be compiled. */ /* Written by J. Stern, 1/31/75 */ /* Modified by J. Stern, 12/9/75 */ /* Modified by J. C. Whitmore, April 1978, for new iodt version and keywords. */ /* Modified by J. C. Whitmore, 10/78, for version 3 and line tables */ /* Modified by E. N. Kittlitz 6/81, for rate-structures */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. This includes the addition of the forms table entries. 2) change(89-09-18,Brunelle), approve(89-09-18,MCR8129), audit(89-09-29,Beattie), install(89-10-03,MR12.3-1083): Correct display of line_charge and page_charge to that it is compatible with the iod_tables_compiler. Also correct the following unreported problems: 1) outputting forms_table instead of forms_info in each forms specification in device and request type; 2) add missing size value for holes type specifications. END HISTORY COMMENTS */ /* External Procedures & Variables */ dcl com_err_ entry () options (variable); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); 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 date_time_ entry (fixed bin (71), char (*)); dcl error_table_$badarg fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl ioa_$rsnpnnl entry () options (variable); dcl requote_string_ entry (char (*)) returns (char (*)); dcl system_info_$access_ceiling entry (bit (72) aligned); dcl (addr, divide, hbound, index, length, null, ptr, rank, rtrim, search, substr) builtin; dcl cleanup condition; /* Internal Static */ dcl NO_ATTACH_TYPE fixed bin int static options (constant) init (-1); dcl QUOTE_SPACE_HTAB char (3) int static options (constant) init (""" "); dcl whoami char (16) aligned int static init ("print_iod_tables"); /* Internal Automatic */ dcl (i, j, k, group) fixed bin; /* loop variables */ dcl arg char (arglen) based (argp); /* command argument */ dcl argcount fixed bin; dcl arglen fixed bin (21); /* length of arg */ dcl argp ptr; /* ptr to arg */ dcl brief_mode bit (1); dcl code fixed bin (35); /* error code */ dcl date char (24); /* the date in ascii */ dcl dir char (168); /* directory pathname */ dcl ent char (32); /* entry name */ dcl keyword char (20); /* holds a keyword */ dcl string char (128) var; dcl text_strings_array (text_strings.length) char (1) unaligned based (text_strings_array_ptr); dcl text_strings_array_ptr ptr; %page; brief_mode = "1"b; /* start in brief mode */ call cu_$arg_count (argcount, code); call cu_$arg_ptr (1, argp, arglen, code); /* get pathname arg */ if code ^= 0 then do; call com_err_ (error_table_$noarg, whoami); return; end; call expand_pathname_ (arg, dir, ent, code); if code ^= 0 then do; call com_err_ (code, whoami, arg); return; end; ithp = null; on cleanup go to finish; call hcs_$initiate (dir, ent, "", 0, 0, ithp, code); /* get segment ptr */ if ithp = null then do; call com_err_ (code, whoami, "^a>^a", dir, ent); return; end; if iod_tables_hdr.version ^= IODT_VERSION_5 then do; call com_err_ (0, whoami, "Wrong version number for ^a.", ent); go to finish; end; call date_time_ (date_time_compiled, date); /* keep compilation date handy */ do i = 2 to argcount; call cu_$arg_ptr (i, argp, arglen, code); if arg = "-brief" | arg = "-bf" then brief_mode = "1"b; else if arg = "-long" | arg = "-lg" then brief_mode = "0"b; else do; call com_err_ (error_table_$badarg, whoami, "Argument (^a).", arg); go to finish; end; end; /* start with a little background information */ call ioa_ ("^//* Listing of segment ^a>^a */ /* compiled on: ^a */ /* object segment version number: ^a */", dir, ent, date, iod_tables_hdr.version); /* Global parameters are next */ call ioa_ ("^2//* Global parameters */"); call ioa_ ("^/Time:^-^-^d;", divide (grace_time, 60000000, 35, 0)); call ioa_ ("^/Max_queues:^-^d;", iod_tables_hdr.max_queues); /* get ptrs to the various tables */ ltp = ptr (ithp, iod_tables_hdr.line_tab_offset); idtp = ptr (ithp, iod_tables_hdr.device_tab_offset); mdtp = ptr (ithp, iod_tables_hdr.minor_device_tab_offset); qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset); dctp = ptr (ithp, iod_tables_hdr.dev_class_tab_offset); ifitp = ptr (ithp, iod_tables_hdr.forms_info_tab_offset); text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset); text_strings_array_ptr = addr (text_strings.chars); %page; if line_tab.n_lines > 0 then /* if we have line descriptions */ call print_line_table_entries; /* then print them */ call print_device_entries; /* print the device descriptions */ call print_request_type_entries; /* print the request type descriptions */ if iod_forms_info_tab.n_groups > 0 then /* if we have forms data */ call print_forms_info; /* then print it */ call ioa_ ("^2/End;"); finish: if ithp ^= null then call hcs_$terminate_noname (ithp, code); return; %page; print_line_table_entries: proc; call ioa_ ("^2//* Lines */"); do i = 1 to line_tab.n_lines; ltep = addr (line_tab.entries (i)); call ioa_ ("^/Line:^2-^a;", lte.line_id); if lte.comment.total_chars > 0 then call ioa_ (" comment:^-^a;", display_string (lte.comment, "0"b, "0"b)); call ioa_ (" channel:^-^a;", lte.chan_id); /* ZZZ */ call ioa_ (" att_desc:^-^a;", requote_string_ (extract_string (lte.att_desc))); do k = 1 to iod_device_tab.n_devices; if substr (lte.maj_dev_list, k, 1) then do; idtep = addr (iod_device_tab.entries (k)); call ioa_ (" device:^2-^a;", idte.dev_id); end; end; end; end print_line_table_entries; %page; print_device_entries: proc; call ioa_ ("^2//* Devices */"); do i = 1 to iod_device_tab.n_devices; idtep = addr (iod_device_tab.entries (i)); call ioa_ ("^/Device:^-^-^a;", idte.dev_id); if idte.comment.total_chars > 0 then call ioa_ (" comment:^-^a;", display_string (idte.comment, "0"b, "0"b)); call ioa_ (" driver_module:^-^a;", display_string (idte.driver_module, "0"b, "0"b)); /* ZZZ */ if idte.args.total_chars ^= 0 then call ioa_ (" args:^-^-^a;", display_string (idte.args, "0"b, "1"b)); if idte.attach_type ^= NO_ATTACH_TYPE then do; if idte.attach_type = ATTACH_TYPE_IOM then keyword = "prph"; else if idte.attach_type = ATTACH_TYPE_TTY then keyword = "line"; else if idte.attach_type = ATTACH_TYPE_DIAL then keyword = "dial_id"; else if idte.attach_type = ATTACH_TYPE_VARIABLE_LINE then keyword = "line"; call ioa_ (" ^a:^2-^a;", keyword, idte.attach_name); end; if idte.ctl_attach_type ^= NO_ATTACH_TYPE then do; if idte.ctl_attach_type = CTL_ATTACH_TYPE_TTY then keyword = "ctl_line"; else if idte.ctl_attach_type = CTL_ATTACH_TYPE_DIAL then keyword = "ctl_dial_id"; else if idte.ctl_attach_type = CTL_ATTACH_TYPE_MC then keyword = "ctl_source"; call ioa_ (" ^a:^-^a;", keyword, idte.ctl_attach_name); end; if idte.head_sheet.total_chars ^= 0 then call ioa_ (" head_sheet:^-^a;", display_string (idte.head_sheet, "0"b, "0"b)); if idte.tail_sheet.total_chars ^= 0 then call ioa_ (" tail_sheet:^-^a;", display_string (idte.tail_sheet, "0"b, "0"b)); if idte.paper_type > 0 then do; if idte.paper_type = PAPER_TYPE_SINGLE then keyword = "single"; else keyword = "continuous"; call ioa_ (" paper_type:^-^a;", keyword); end; if idte.forms_table.total_chars ^= 0 then call ioa_ (" forms_info:^-^a;", extract_string (idte.forms_table)); if idte.forms_validation.total_chars ^= 0 then call ioa_ (" forms_validation:^-^a;", extract_string (idte.forms_validation)); if idte.font_dir.total_chars ^= 0 then call ioa_ (" font_dir:^-^a;", extract_string (idte.font_dir)); do j = idte.first_minor to idte.last_minor; mdtep = addr (minor_device_tab.entries (j)); if idte.last_minor > idte.first_minor | mdte.dev_id ^= idte.dev_id then call ioa_ ("^/ minor_device:^-^a;", mdte.dev_id); if mdte.comment.total_chars > 0 then call ioa_ (" comment:^-^a;", display_string (mdte.comment, "0"b, "0"b)); if mdte.args.total_chars ^= 0 then call ioa_ (" minor_args:^-^a;", display_string (mdte.args, "0"b, "1"b)); if mdte.default_form.total_chars ^= 0 then call ioa_ (" default_form:^-^a;", display_string (mdte.default_form, "0"b, "0"b)); if mdte.default_dev_class ^= 0 then do; dctep = addr (dev_class_tab.entries (mdte.default_dev_class)); qgtep = addr (q_group_tab.entries (dcte.qgte_index)); if qgte.last_dev_class > qgte.first_dev_class | dcte.id ^= qgte.name | dcte.min_banner ^= ""b then call ioa_ (" default_type:^-^a;", rtrim (qgte.name) || "." || rtrim (dcte.id)); else call ioa_ (" default_type:^-^a;", qgte.name); end; end; end; end print_device_entries; %page; print_request_type_entries: proc; call ioa_ ("^2//* Request types */"); do i = 1 to q_group_tab.n_q_groups; qgtep = addr (q_group_tab.entries (i)); call ioa_ ("^/Request_type:^-^a;", qgte.name); if qgte.comment.total_chars > 0 then call ioa_ (" comment:^-^a;", display_string (qgte.comment, "0"b, "0"b)); call ioa_ (" generic_type:^-^a;", qgte.generic_type); /* ZZZ */ j = length (rtrim (qgte.driver_id)) - 2; /* drop the ".*" put there by iodtc */ call ioa_ (" driver_userid:^-^a;", substr (qgte.driver_id, 1, j)); call ioa_ (" accounting:^-^a;", display_string (qgte.accounting, "0"b, "0"b)); if qgte.rqti_seg_name ^= "" then call ioa_ (" rqti_seg:^-^a;", qgte.rqti_seg_name); if qgte.forms_validation.total_chars ^= 0 then call ioa_ (" forms_validation:^-^a;", display_string (qgte.forms_validation, "0"b, "0"b)); if qgte.font_dir.total_chars ^= 0 then call ioa_ (" font_dir:^-^a;", display_string (qgte.font_dir, "0"b, "0"b)); if qgte.forms_table.total_chars ^= 0 then call ioa_ (" forms_info:^-^a;", display_string (qgte.forms_table, "0"b, "0"b)); if qgte.default_form.total_chars ^= 0 then call ioa_ (" default_form:^-^a;", display_string (qgte.default_form, "0"b, "0"b)); if qgte.max_queues ^= iod_tables_hdr.max_queues then call ioa_ (" max_queues:^-^d;", qgte.max_queues); call ioa_ (" default_queue:^-^d;", qgte.default_queue); if qgte.line_charge.queue (1) ^= "" then do; /* if not default charges, print price names */ string = ""; do k = 1 to qgte.max_queues; string = string || rtrim (qgte.line_charge.queue (k)) || ","; end; k = length (string) - 1; /* omit the last comma-space */ call ioa_ (" line_charge:^-^a;", substr (string, 1, k)); end; if qgte.page_charge.queue (1) ^= "" then do; /* if not default charges, print price names */ string = ""; do k = 1 to qgte.max_queues; string = string || rtrim (qgte.page_charge.queue (k)) || ","; end; k = length (string) - 1; call ioa_ (" page_charge:^-^a;", substr (string, 1, k)); end; do j = qgte.first_dev_class to qgte.last_dev_class; dctep = addr (dev_class_tab.entries (j)); if qgte.last_dev_class > qgte.first_dev_class | dcte.id ^= qgte.name then call ioa_ (" device_class:^-^a;", dcte.id); if dcte.max_access | dcte.min_access | dcte.min_banner then do; /* don't bother if all zero */ call ioa_ (" min_access_class:^-^a;", get_access_class_string (dcte.min_access)); call ioa_ (" max_access_class:^-^a;", get_access_class_string (dcte.max_access)); call ioa_ (" min_banner:^-^a;", get_access_class_string (dcte.min_banner)); end; do k = 1 to minor_device_tab.n_minor; if substr (dcte.device_list, k, 1) then do; mdtep = addr (minor_device_tab.entries (k)); idtep = addr (iod_device_tab.entries (mdte.major_index)); if idte.last_minor > idte.first_minor | mdte.dev_id ^= idte.dev_id then call ioa_ (" device:^-^-^a;", rtrim (idte.dev_id) || "." || rtrim (mdte.dev_id)); else call ioa_ (" device:^-^-^a;", idte.dev_id); end; end; end; end; end print_request_type_entries; %page; print_forms_info: proc; call ioa_ ("^2//* Forms Information */"); /* process one group at a time */ do group = 1 to iod_forms_info_tab.n_groups; call ioa_ ("^/Forms_table:^-^a;", iod_forms_info_tab (group).name); if iod_forms_info_tab (group).comment.total_chars ^= 0 then call ioa_ (" comment:^-^a;", display_string (iod_forms_info_tab (group).comment, "0"b, "1"b)); /* set up ptr to 1st element for this group */ fep = addr (iod_forms_info_tab.element_data_block (iod_forms_info_tab (group).first_element_index)); element_display_loop: string = extract_string (element_common.names (1)); if element_common.n_names > 1 then do; do j = 2 to element_common.n_names; string = string || ","; string = string || extract_string (element_common.names (j)); end; end; call ioa_ ("^/ name:^2-^a;", output_the_string ((string))); if element_common.comment.total_chars ^= 0 then call ioa_ (" comment:^-^a;", display_string (element_common.comment, "0"b, "1"b)); if element_common.type = TYPE_USES then do; /* uses */ string = ""; do j = 1 to uses_element.n_indices; if j ^= 1 then string = string || ","; string = string || extract_string (uses_element.name (j)); end; call ioa_ (" uses:^2-^a;", string); end; else do; call ioa_ (" type:^2-^a;", FORMS_TYPE_STRINGS (element_common.type)); if element_common.type = TYPE_SPECIAL then do; call ioa_ (" string:^2-^a;", display_string (special_element.special_string, "0"b, "0"b)); end; else if element_common.type = TYPE_FONT_NAME | element_common.type = TYPE_PREAMBLE | element_common.type = TYPE_POSTAMBLE then do; if orientation_element.escape_string.total_chars ^= 0 then call ioa_ (" string:^2-^a;", display_string (orientation_element.escape_string, "1"b, "0"b)); end; else if element_common.type = TYPE_ORIENTATION | element_common.type = TYPE_HOLES | element_common.type = TYPE_FONT_DESC | element_common.type = TYPE_LINE_DESC then do; if element_common.type = TYPE_ORIENTATION | element_common.type = TYPE_HOLES then do; call display_forms_size (orientation_element.height, "page_height", orientation_element.factors (1)); call display_forms_size (orientation_element.width, "page_width", orientation_element.factors (2)); end; else if element_common.type = TYPE_FONT_DESC then do; call display_forms_size (orientation_element.height, "char_height", orientation_element.factors (1)); call display_forms_size (orientation_element.width, "char_width", orientation_element.factors (2)); end; else if element_common.type = TYPE_LINE_DESC then do; call display_forms_size (orientation_element.height, "line_height", orientation_element.factors (1)); call display_forms_size (orientation_element.width, "line_width", orientation_element.factors (2)); end; if orientation_element.escape_string.total_chars ^= 0 then call ioa_ (" string:^2-^a;", display_string (orientation_element.escape_string, "1"b, "0"b)); end; end; if element_common.next_element_index ^= -1 then do; fep = addr (iod_forms_info_tab.element_data_block (element_common.next_element_index)); go to element_display_loop; end; end; end print_forms_info; %page; extract_string: proc (target_offset) returns (char (*)); dcl 1 target_offset like text_offset; if target_offset.total_chars = 0 then return (""); else return (substr (text_strings.chars, target_offset.first_char, target_offset.total_chars)); end extract_string; get_access_class_string: proc (access_class) returns (char (200) aligned); /* procedure which takes a binary access class and returns an ascii access class string. */ dcl access_class bit (72) aligned; /* binary access class */ dcl ac_string char (200); /* string representation of above */ dcl system_high bit (72) aligned; /* access class for system_high */ dcl 1 dblword aligned based (addr (access_class)), /* for error message */ 2 word1 fixed bin (35), 2 word2 fixed bin (35); call convert_authorization_$to_string_short (access_class, ac_string, code); if code ^= 0 then call com_err_ (code, whoami, "Access class = ^w ^w", word1, word2); else if ac_string = "" then ac_string = "system_low"; if length (rtrim (ac_string)) > 30 then do; /* if long, check for system_high */ call system_info_$access_ceiling (system_high); /* get binary ceiling */ if access_class = system_high then ac_string = "system_high"; /* this is cleaner */ end; return (ac_string); end get_access_class_string; %page; display_forms_size: proc (item, item_title, factor); dcl item float bin unaligned; dcl item_title char (*); dcl factor fixed bin unaligned; dcl temp_string char (10) varying; if item = -1 then return; if item = 0 then return; if factor ^= FACTOR_LPI then call ioa_$rsnpnnl ("^.2f", temp_string, (0), item / SIZE_FACTORS (factor)); else call ioa_$rsnpnnl ("^.2f", temp_string, (0), SIZE_FACTORS (factor) / item); temp_string = rtrim (temp_string, "0"); temp_string = rtrim (temp_string, "."); call ioa_ (" ^a:^-^a^[in^;cm^;pt^;lpi^];", item_title, temp_string, factor); end display_forms_size; output_the_string: proc (string_to_check) returns (char (*)); dcl string_to_check char (*); if index (rtrim (string_to_check), " ") = 0 then return (rtrim (string_to_check)); else return (requote_string_ (rtrim (string_to_check))); end output_the_string; %page; display_string: proc (string_data, special_process, force_requote) returns (char (*)); dcl special_process bit (1); dcl force_requote bit (1); dcl 1 string_data unaligned like text_offset; dcl input_string char (input_string_len) based (input_string_ptr); dcl input_string_len fixed bin; dcl input_string_ptr ptr; dcl return_string char (1024) varying; dcl (i, j) fixed bin; return_string = ""; input_string_ptr = addr (text_strings_array (string_data.first_char)); input_string_len = string_data.total_chars; if ^special_process then do; if search (input_string, QUOTE_SPACE_HTAB) ^= 0 | force_requote then return_string = requote_string_ (input_string); else return_string = input_string; end; else do i = 1 to input_string_len; call count_text; if j > 1 then do; return_string = return_string || requote_string_ (substr (input_string, i, j)); i = i + j - 1; end; else return_string = return_string || tchar (substr (input_string, i, 1)); return_string = return_string || " "; end; return (return_string); count_text: proc; do j = i to input_string_len while (rank (substr (input_string, j, 1)) >= 32 & rank (substr (input_string, j, 1)) <= 126); end; j = j - i; end count_text; end display_string; /* return prettyest representation of a character */ tchar: proc (c) returns (char (4) var); dcl c char (1); dcl i fixed bin; dcl temp char (4); dcl asc_value (0:32) char (3) static options (constant) init ("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS ", "TAB", "LF ", "VT ", "FF ", "CR ", "SO ", "SI ", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "EM ", "SUB", "ESC", "FS ", "GS ", "RS ", "US ", "SP "); i = rank (c); if i <= hbound (asc_value, 1) then return (rtrim (asc_value (i))); if i > 126 then do; if i = 127 then return ("DEL"); call ioa_$rsnnl ("^o", temp, (0), i); return (temp); end; if index ("0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ", c) > 0 then return (c); if c = """" then return (""""""""""); else return ("""" || c || """"); end tchar; %page; %include device_class; %page; %include iod_forms_info_tab; %page; %include iod_constants; %page; %include iod_device_tab; %page; %include iod_line_tab; %page; %include iod_tables_hdr; %page; %include q_group_tab; end print_iod_tables;  print_line_ids.pl1 10/28/88 1351.7rew 10/28/88 1233.8 46503 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_line_ids: prt: proc; /* This command prints a list of line ids handled by the IO daemon as determined by inspecting the "iod_working_tables" segment. For each line id, the associated channel is printed. */ /* Written by J. C. Whitmore, 10/78, modeled after print_request_types.pl1 */ /* Modified by E. N. Kittlitz, 6/81, to use version_4 iod_tables_hdr */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. Also displays comments store in the line table entry. Display columns are based on length of longest entry for each column. END HISTORY COMMENTS */ dcl argp ptr; /* ptr to arg */ dcl arglen fixed bin; /* length of arg */ dcl arg char (arglen) based (argp); /* command argument */ dcl bfsw bit (1) aligned; /* ON for brief option */ dcl sysdir char (168) aligned;/* directory containing iod_working_tables */ dcl ent_name char (32) aligned; dcl i fixed bin; dcl code fixed bin (35); /* error code */ dcl nargs fixed bin; dcl (max_chan_id, max_line_id) fixed bin; dcl whoami char (19) aligned int static options (constant) init ("print_line_ids"); dcl error_table_$badopt fixed bin (35) ext; dcl (addr, null, length, ptr, rtrim, substr) builtin; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)); dcl hcs_$initiate entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); %page; /* initialize control argument defaults */ bfsw = "0"b; sysdir = ">daemon_dir_dir>io_daemon_dir"; /* look for arguments */ call cu_$arg_count (nargs); do i = 1 to nargs; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then go to noarg; if arg = "-bf" | arg = "-brief" then bfsw = "1"b; else if arg = "-dir" | arg = "-directory" then do; i = i + 1; call cu_$arg_ptr (i, argp, arglen, code); if code ^= 0 then do; noarg: call com_err_ (code, whoami); return; end; call expand_pathname_ (arg, sysdir, ent_name, code); /* take apart and put it back together */ if code ^= 0 then do; call com_err_ (code, whoami, arg); return; end; if sysdir = ">" then sysdir = ">" || ent_name; else sysdir = rtrim (sysdir) || ">" || ent_name; end; else do; call com_err_ (error_table_$badopt, whoami, arg); return; end; end; /* get a pointer to the line table */ call hcs_$initiate (sysdir, "iod_working_tables", "", 0, 1, ithp, code); if ithp = null then do; call com_err_ (code, whoami, "^a>iod_working_tables", sysdir); return; end; if iod_tables_hdr.version ^= IODT_VERSION_5 then do; call com_err_ (0, whoami, "Wrong version number for iod_working_tables."); return; end; ltp = ptr (ithp, iod_tables_hdr.line_tab_offset); text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset); /* first find the lengths for the longest line_id & chan_id */ max_line_id = 7; max_chan_id = 7; do i = 1 to line_tab.n_lines; ltep = addr (line_tab.entries (i)); if length (rtrim (lte.line_id)) > max_line_id then max_line_id = length (rtrim (lte.line_id)); if length (rtrim (lte.chan_id)) > max_chan_id then max_chan_id = length (rtrim (lte.chan_id)); end; /* now print the table */ do i = 1 to line_tab.n_lines; ltep = addr (line_tab.entries (i)); if i = 1 then if ^bfsw then call ioa_ ("^/Line ID^vxChannel^vxComment^/", max_line_id - 7 + 2, max_chan_id - 7 + 2); call ioa_ ("^va ^va ^a", max_line_id, lte.line_id, max_chan_id, lte.chan_id, substr (text_strings.chars, lte.comment.first_char, lte.comment.total_chars)); end; if line_tab.n_lines > 0 then call ioa_ (""); /* throw in an extra blank line */ else call ioa_ ("No line ids specified in iod_working_tables."); call hcs_$terminate_noname (ithp, code); %page; %include iod_line_tab; %include iod_tables_hdr; end print_line_ids;  save_request_.pl1 10/28/88 1351.7rew 10/28/88 1233.7 76950 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ save_request_: proc (descr_ptr, dev_class_ptr); /* This procedure is used to thread a completed request onto the end of the "saved" * list, and delete the request message from the appropriate queue. * If it happens to be the one most recently read from that queue, we will have to update * that information before deleting it. */ /* Coded August 1973 by Robert S. Coren */ /* Modified by J. Stern, 12/27/74 */ /* Modified by J. Stern, 11/25/75 */ /* Modified by J. C. Whitmore, 4/78, to use the keep_in_queue flag */ /* Modified by J. C. Whitmore, 7/78, to mark deferred requests in the queue */ /* Modified by J. C. Whitmore, 5/80, to not add user deleted requests to the saved list */ /* Modified by C. Marker, 02/23/85, to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911), audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199): Upgraded to handle version 5 I/O daemon tables. END HISTORY COMMENTS */ dcl descr_ptr ptr; /* pointer to descriptor being threaded */ dcl dev_class_ptr ptr; /* pointer to entry for this request's device class */ dcl code fixed bin (35); dcl desc_p ptr; dcl desc_off fixed bin (18); dcl rest_p ptr; dcl err_msg char (64); dcl err_len fixed bin; dcl last_ptr ptr; /* pointer to previous descriptor in list */ dcl mseg_idx fixed bin; dcl q fixed bin; dcl retry fixed bin; dcl msg_id bit (72) aligned; /* id of message from the current descr */ dcl msg_p ptr; /* pointer to the message text in request area */ dcl msg_len fixed bin (18); dcl based_offset fixed bin (18) based; dcl deferred fixed bin int static options (constant) init (1); dcl error_table_$bad_segment fixed bin (35) ext; dcl error_table_$no_message fixed bin (35) ext; dcl (addr, fixed, ptr, rel, divide) builtin; dcl clock_ entry returns (fixed bin (71)); dcl ioa_$rsnnl entry options (variable); dcl iodc_message_ entry (bit (3) aligned, fixed bin (35), char (*)); dcl message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35)); dcl message_segment_$update_message_index entry (fixed bin, fixed bin (18), bit (72) aligned, ptr, fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2) aligned, fixed bin (71)); %page; dctep = dev_class_ptr; /* copy pointer args */ desc_p = descr_ptr; desc_off = fixed (rel (desc_p), 18); qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); q = desc_p -> request_descriptor.q; mseg_idx = qgte.mseg_index (q); msg_p = desc_p -> request_descriptor.ms_ptr; msg_len = desc_p -> request_descriptor.ms_len; msg_id = desc_p -> request_descriptor.ms_id; if desc_p -> request_descriptor.keep_in_queue then do; /* this is highest priority action */ msg_p -> queue_msg_hdr.state = deferred;/* mark the request as deferred */ retry = 0; update: call message_segment_$update_message_index (mseg_idx, msg_len, msg_id, msg_p, code); if code ^= 0 then if code ^= error_table_$no_message then if code = error_table_$bad_segment /* message seg was salvaged */ then do; if retry = 0 then do; /* try once more */ retry = 1; go to update; end; go to no_update; end; else do; no_update: call ioa_$rsnnl ("Could not update message in queue ^d of request type ^a.", err_msg, err_len, q, qgte.name); call iodc_message_ ("101"b, code, err_msg); end; free msg_p -> queue_msg_hdr in (req_area); free desc_p -> request_descriptor in (req_desc_seg.descr_area); return; /* this one is done, like we never saw it */ end; else if desc_p -> request_descriptor.cancelled then do; /* if it was "cancelled", we will not really save it, rather the reverse */ call delete_from_queue (code); free msg_p -> queue_msg_hdr in (req_area); free desc_p -> request_descriptor in (req_desc_seg.descr_area); end; else do; /* If not deferred or cancelled, we must add it to the saved list */ desc_p -> request_descriptor.finished = "1"b; /* be sure the descriptor is right */ desc_p -> request_descriptor.continued = "0"b; desc_p -> request_descriptor.series_restart = "0"b; desc_p -> request_descriptor.priority_request = "0"b; if dcte.restart_req ^= 0 then do; /* restart in progress */ /* see if this request should be added to series */ rest_p = ptr (iodc_static.descr_seg_ptr, dcte.restart_req); if rest_p -> request_descriptor.series_restart then do; /* it was a series, check more */ if divide (rest_p -> request_descriptor.seq_id, 10000, 35, 0) = divide (desc_p -> request_descriptor.seq_id, 10000, 35, 0) then do; /* same series */ desc_p -> request_descriptor.saved = "1"b; /* make sure it stays around */ desc_p -> request_descriptor.series_restart = "1"b; /* mark as part of series */ end; end; end; /* remove the message from the queue, indicating that from the users view it is done */ call delete_from_queue (code); if code ^= 0 then if code = error_table_$no_message then do; /* already gone? Maybe the user deleted it. */ if ^desc_p -> request_descriptor.restarted then do; /* if restarted, we deleted it earlier */ /* otherwise, assume the user deleted the message and flush it */ free msg_p -> queue_msg_hdr in (req_area); free desc_p -> request_descriptor in (req_desc_seg.descr_area); return; end; end; /* set time done and set up alarm to delete it later */ desc_p -> request_descriptor.time_done = clock_ (); if ^(desc_p -> request_descriptor.saved) then call timer_manager_$alarm_wakeup (iodc_static.time_interval, "10"b, iodc_static.timer_chan); if iodc_static.last_req_done = 0 then do; /* if no requests in the list, point head of list at this one */ desc_p -> request_descriptor.prev_done, desc_p -> request_descriptor.next_done = 0; iodc_static.first_req_done = desc_off; iodc_static.save_first_req_p -> based_offset = desc_off; /* also store in req_desc_seg for reinit */ end; else do; /* Yes, chain them together */ desc_p -> request_descriptor.next_done = 0; /* this is the end of the chain */ desc_p -> request_descriptor.prev_done = last_req_done; last_ptr = ptr (iodc_static.descr_seg_ptr, iodc_static.last_req_done); /* get ptr to previous descr */ last_ptr -> request_descriptor.next_done = desc_off; /* make it point to this one */ end; iodc_static.last_req_done = desc_off; end; return; %page; delete_from_queue: proc (code); dcl code fixed bin (35); retry = 0; delete: call message_segment_$delete_index (mseg_idx, msg_id, code); if code ^= 0 then if code ^= error_table_$no_message then if code = error_table_$bad_segment /* message seg was salvaged */ then do; if retry = 0 then do; /* try once more */ retry = 1; go to delete; end; go to fatal_err2; end; else do; /* trouble deleting from queue; to avoid further problems, */ /* drop the queue */ fatal_err2: call ioa_$rsnnl ("Could not delete message from queue ^d of request type ^a. Queue will be dropped", err_msg, err_len, q, qgte.name); call iodc_message_ ("101"b, code, err_msg); qgte.mseg_index (q) = 0; end; return; end delete_from_queue; init: entry (a_ptr); dcl a_ptr ptr; stat_p = a_ptr; return; %page; %include device_class; %page; %include iod_tables_hdr; %page; %include iodc_static; %page; %include mseg_message_info; %page; %include q_group_tab; %page; %include queue_msg_hdr; %page; %include request_descriptor; end save_request_;  test_io_daemon.pl1 11/15/82 1834.0rew 11/15/82 1507.4 39420 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* command interface for IOD testing */ /* format: style2 */ /* History: Coded Fall 1980 Benson I. Margulies */ test_io_daemon: procedure options (variable); declare iod_overseer_$test_path entry (char (*), char (*)); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); declare com_err_ entry options (variable); declare absolute_pathname_ entry (char (*), char (*), fixed bin (35)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); declare n_args fixed bin; declare code fixed bin (35); declare dir char (168); declare entryname char (32); declare got_pn bit (1); declare got_dr bit (1); declare current_argument fixed bin; declare arg_ptr pointer; declare arg_len fixed bin (21); declare argument char (arg_len) based (arg_ptr); declare ME char (14) init ("test_io_daemon") int static options (constant); declare Default_entryname char (32) init ("iod_tables") int static options (constant); declare ( error_table_$noarg, error_table_$badopt, error_table_$too_many_args, error_table_$inconsistent ) fixed bin (35) ext static; call cu_$arg_count (n_args, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; if n_args = 0 then do; call com_err_ (0, ME, "Usage: test_io_daemon {IOD_TABLE_PATH} {-directory TEST_DIR_PATH}."); return; end; got_pn, got_dr = ""b; current_argument = 0; do while (current_argument < n_args); current_argument = current_argument + 1; call cu_$arg_ptr (current_argument, arg_ptr, arg_len, (0)); /* we know how many arguments */ if index (argument, "-") ^= 1 then do; /* noncontrol */ if got_pn then do; call com_err_ (error_table_$too_many_args, ME, "Only one pathname may be given, ^a was in error.", argument); return; end; if got_dr then goto pn_and_dr_given; call expand_pathname_ (argument, dir, entryname, code); if code ^= 0 then do; call com_err_ (code, ME, "^a.", argument); return; end; got_pn = "1"b; end; /* only one possible noncontrol */ else do; /* control argument */ if argument = "-directory" | argument = "-dr" then do; if got_dr then do; call com_err_ (error_table_$inconsistent, ME, "-directory may only be given once."); return; end; if got_pn then do; pn_and_dr_given: call com_err_ (error_table_$inconsistent, ME, "-directory may not be given with a pathname."); return; end; if current_argument = n_args then do; call com_err_ (error_table_$noarg, ME, "A directory pathname must be given with ^a.", argument); return; end; current_argument = current_argument + 1; call cu_$arg_ptr (current_argument, arg_ptr, arg_len, (0)); if substr (argument, 1, 1) = "-" then do; /* no path */ call com_err_ (error_table_$noarg, ME, "A pathname must be given following -directory. Control argument ^a was in error." , argument); return; end; call absolute_pathname_ (argument, dir, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", argument); return; end; entryname = Default_entryname; got_dr = "1"b; end; /* processing -dir */ else do; /* bad control arg */ call com_err_ (error_table_$badopt, ME, "Control argument ^a not recognized.", argument); return; end; end; /* control args */ end; /* arg loop */ call iod_overseer_$test_path (dir, entryname); return; end test_io_daemon;  unthread_descriptor_.pl1 03/14/85 0831.6r 03/13/85 1025.6 15138 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ unthread_descriptor_: proc (a_ptr); /* A little procedure to unthread request descriptors */ /* Modified: February 26, 1985 by C. Marker to use version 5 message segments */ dcl a_ptr ptr; dcl desc_ptr ptr; dcl prev_ptr ptr; dcl prev_off fixed bin (18); dcl next_ptr ptr; dcl next_off fixed bin (18); dcl based_offset fixed bin (18) based; dcl ptr builtin; /* */ desc_ptr = a_ptr; next_off = desc_ptr -> request_descriptor.next_done; prev_off = desc_ptr -> request_descriptor.prev_done; if prev_off = 0 then do; /* this was first on list */ iodc_static.first_req_done = next_off; iodc_static.save_first_req_p -> based_offset = next_off; end; else do; prev_ptr = ptr (desc_ptr, prev_off); prev_ptr -> request_descriptor.next_done = next_off; end; if next_off ^= 0 then do; next_ptr = ptr (desc_ptr, next_off); next_ptr -> request_descriptor.prev_done = prev_off; end; else iodc_static.last_req_done = prev_off; return; init: entry (a_ptr); stat_p = a_ptr; return; /* */ %include iodc_static; %page; %include mseg_message_info; %page; %include request_descriptor; end unthread_descriptor_; 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