g115_.alm 02/23/78 1042.6rew 02/23/78 1038.9 13599 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** "Interface Module Transfer Vector for the "g115 printer Interface Module " modified 07-22-77 by Bob Franklin to add resetread,resetwrite,abort entries. entry g115_module g115_module: tra *+1,6 go to proper transfer instruction tra |[g115_attach] tra |[g115_detach] tra |[g115_read] tra |[g115_write] tra |[g115_cntrl] abort call tra |[g115_order] tra |[g115_cntrl] resetread call tra |[g115_cntrl] resetwrite call tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[g115_modes] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] end  g115_as_.pl1 02/23/78 1042.6rew 02/23/78 1039.5 36513 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_as_: proc; /* g115_as_ - procedure to interface answering service when it needs to work the g115 or mds2400. tty_index entry must be called first to establish a data structure for the device. the other entries rely on the presence of this data structure */ /* coded 07/11/75 by Bob Adsit */ dcl (t_twx, asw, dflag, state, istate, aoffset, anelem, anelemt) fixed bin; dcl process_id bit (36) aligned, save_trim bit (1); dcl (bufp, orderp) ptr; dcl null builtin; dcl (device, order, new_mode, old_mode) char (*); dcl (rcard varying, bcard based (bufp)) char (80); dcl event fixed bin (71); dcl code fixed bin (35); dcl error_table_$not_attached fixed bin (35) ext; dcl 1 modes aligned, 2 len fixed bin, 2 str char (256); dcl g115_util_$set_ptr entry (ptr), g115_util_$get_data_ptr entry (fixed bin) returns (ptr), g115_util_$conv_card entry (char (*) varying), g115_control_$init entry (char (*), fixed bin, fixed bin (35)), g115_control_$detach entry (fixed bin, fixed bin(35)), g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)), g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)), hcs_$tty_index entry (char (*), fixed bin, fixed bin, fixed bin (35)), hcs_$tty_event entry (fixed bin, fixed bin(71), fixed bin, fixed bin(35)), hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin(35)), hcs_$tty_state entry (fixed bin, fixed bin, fixed bin(35)), hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin(35)), hcs_$tty_detach_new_proc entry (fixed bin, bit (36) aligned, fixed bin, fixed bin (35)); %include g115_data; as_index: entry (device, t_twx, state, code); call hcs_$tty_index (device, t_twx, state, code); if code ^= 0 then return; call g115_control_$init (device, t_twx, code); return; as_event: entry (t_twx, event, state, code); call init_device; g115_data.as_ev_chan = event; call hcs_$tty_event (t_twx, event, state, code); return; as_order: entry (t_twx, order, orderp, state, code); call hcs_$tty_order (t_twx, order, orderp, state, code); return; as_changemode: entry (t_twx, new_mode, old_mode, code); modes.len = length (modes.str); modes.str = new_mode; call hcs_$tty_order (t_twx, "modes", addr (modes), istate, code); old_mode = modes.str; return; as_state: entry (t_twx, state, code); call hcs_$tty_state (t_twx, state, code); return; as_abort: entry (t_twx, asw, state, code); call hcs_$tty_abort (t_twx, asw, state, code); return; as_detach: entry (t_twx, dflag, state, code); call init_device; call g115_control_$detach (t_twx, code); state = 1; return; as_detach_new_proc: entry (t_twx, process_id, state, code); call hcs_$tty_detach_new_proc (t_twx, process_id, state, code); return; as_read: entry (t_twx, bufp, aoffset, anelem, anelemt, state, code); call init_device; call g115_util_$conv_card (rcard); /* get and convert a card for the as */ bcard = rcard; /* return it */ anelemt = length (rcard); return; as_write: as_write_force: entry (t_twx, bufp, aoffset, anelem, anelemt, state, code); call init_device; call g115_io_$write (t_twx, bufp, aoffset, anelem, anelemt, code); return; init_device: proc; data_ptr = g115_util_$get_data_ptr (t_twx); if data_ptr = null then do; code = error_table_$not_attached; go to error; end; g115_data.no_block = "1"b; call g115_util_$set_ptr (data_ptr); state = 5; code = 0; return; end; error: return; end;  g115_control_.pl1 02/23/78 1042.6rew 02/23/78 1038.1 158139 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_control_: proc; /* g115_control_ - Main control procedure for the g115_ DIM. This routine controls attaching and detaching of the device and the order and mode calls. Attaching includes a step which waits for the device to become ready, called listening. */ /* Coded April 26, 1974 Mike Grady */ /* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */ /* modified 04/10/77 by Bob Franklin to fix bugs, add order codes of start, quit_disable, and quit_enable. */ /* Modified 2/78 by J. C. Whitmore to use new prt_conv_info.incl.pl1 */ dcl (dev_index, nelemt, j, lmode, k, state, new_line_type, msg_len) fixed bin, periph_type based (order_ptr) fixed bin, code fixed bin (35), (error_table_$undefined_order_request, error_table_$ionmat, error_table_$bad_mode, error_table_$bad_arg, error_table_$inconsistent, error_table_$noalloc) fixed bin (35) ext, ostring char (120) varying, (request, new_mode, old_mode, dev_name) char (*), (order_ptr, sysareap int static, msg_ptr) ptr, (addr, bool, null, rel) builtin, (area, storage) condition; dcl g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl NL char (1) init (" "), VT_or_FF char (2) init (" "); dcl g115_conv_$g115_conv_ fixed bin ext; dcl sys_area area based (sysareap); dcl 1 page_labels based (order_ptr) aligned, /* structure used in "page_labels" call */ 2 top_label char (136), /* label for top of page */ 2 bottom_label char (136); /* label for bottom of page */ dcl 1 counts based (order_ptr) aligned, /* structure used in "get_count" call */ 2 line fixed bin, /* line number */ 2 page_length fixed bin, /* length of page */ 2 lmarg fixed bin, /* left margin indentation */ 2 rmarg fixed bin, /* line length */ 2 line_count fixed bin, /* count of lines printed */ 2 page_count fixed bin; /* count of pages printed */ dcl 1 info_structure aligned based (order_ptr), 2 ev_chan fixed bin (71), 2 input_available bit (1); dcl 1 modes aligned, 2 len fixed bin, 2 str char (256); dcl 1 chan_info aligned, 2 id char (4), 2 baud_rate fixed bin (17) unal, 2 line_type fixed bin (17) unal, 2 pad bit (36), 2 tty_type fixed bin; dcl g115_util_$get_ptr entry returns (ptr), g115_util_$set_ptr entry (ptr), g115_util_$get_data_ptr entry (fixed bin) returns (ptr), g115_util_$link_data_ptr entry (ptr), g115_util_$unlink_data_ptr entry (fixed bin) returns (ptr), g115_util_$block entry (fixed bin (35)), g115_message_$read entry (ptr, fixed bin, fixed bin (35)), hcs_$tty_index entry (char (*), fixed bin, fixed bin, fixed bin (35)), hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)), hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35)), hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)), hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)), ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)), get_system_free_area_ entry returns (ptr); dcl hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); %include g115_data; %include g115_msg; %include g115_stat; /* */ init: entry (dev_name, dev_index, code); /* called to establish a g115_data structure for the device */ data_ptr = g115_util_$get_data_ptr (dev_index); if data_ptr = null then do; /* first call for this device */ on condition (storage) call clean; /* establish handlers to catch area package signals */ on condition (area) call clean; sysareap = get_system_free_area_ (); /* get pointer to system free segment */ allocate g115_data in (sys_area) set (data_ptr); /* allocate the global data base */ unspec (g115_data) = "0"b; call g115_util_$link_data_ptr (data_ptr); /* link into chain - new g115_data structure */ revert condition (area); revert condition (storage); end; g115_data.dev_name = dev_name; g115_data.twx = dev_index; g115_data.write_split, g115_data.punch, g115_data.teleprinter = "0"b; g115_data.write_compress = "1"b; g115_data.mask_sw = bool (rel (addr (g115_data.output_buffer1)), rel (addr (g115_data.output_buffer2)), "0110"b); g115_data.wait_list.nchan = 2; call ipc_$create_ev_chn (g115_data.wait_list.hcs_ev_chan, code); /* create ring 0 event channel */ if code ^= 0 then return; call ipc_$create_ev_chn (g115_data.wait_list.timeout_chan, code); if code ^= 0 then return; pcip = addr (g115_data.conv_info); pci.cv_proc = addr (g115_conv_$g115_conv_); pci.phys_line_length = 132; pci.phys_page_length = 66; pci.lpi = 6; /* assume 6 lines per inch */ call g115_util_$set_ptr (data_ptr); call order (dev_index, "reset", null, code); pci.line = 1; /* the final initialization of pci */ /* all other variables xeroed by "unspec" above */ do slot_ptr = addr (g115_data.output_buffer1 (1)), addr (g115_data.output_buffer2 (1)); g115_hdr.full_cc, g115_hdr.msg_type, g115_hdr.sub_type, g115_hdr.aux_bit_count, g115_hdr.null_ct, g115_hdr.text_char_count = 0; g115_msg.soh = g115_stat.soh_char; g115_msg.fmt_code = g115_stat.service_noaux; g115_msg.addr_code = g115_stat.addr_code_char; g115_msg.op_code.ascii_pad = "00"b; g115_msg.op_code.use = "1"b; g115_msg.op_code.ack, g115_msg.op_code.cmd = "0"b; g115_msg.id_code = g115_stat.id_code_char; g115_msg.stx = g115_stat.stx_char; g115_msg.etx = g115_stat.etx_char; end; slot_ptr = addr (g115_data.input_buffer (1)); g115_hdr.full_cc, g115_hdr.text_char_count = 0; code = 0; /* no error */ ret: return; clean: proc; code = error_table_$noalloc; go to ret; end clean; /* */ modes: entry (dev_index, new_mode, old_mode, code); code = 0; data_ptr = g115_util_$get_ptr (); pcip = addr (g115_data.conv_info); ostring = ""; /* Initialize current modes. */ pcip = addr (g115_data.conv_info); /* Get pointer to conversion info. */ call add_bit ("noskip,", pci.overflow_off); /* Insert noskip mode. */ call add_bit ("single,", pci.single_space); /* Insert single space mode. */ call add_bit ("non_edited,", pci.non_edited); /* Insert non-edited mode. */ call add_bit ("truncate,", pci.truncate); /* Insert truncate mode. */ call add_bit ("trim,", g115_data.trim); /* Insert trim mode. */ call add_num ("ll", pci.rmarg); /* Insert line length mode. */ call add_num (",in", pci.lmarg); /* Insert indent mode. */ call add_num (",pl", pci.page_length); /* Insert page length mode. */ ostring = ostring || "."; /* Place period at end of string. */ old_mode = ostring; /* Return old mode settings. */ add_num: proc (m, n); /* internal proc to add numeric mode to ostring */ dcl m char (*), /* mode name */ n fixed bin; /* number to be converted */ dcl number pic "zzzzz9", /* for converting number */ i fixed bin; /* offset of first nonblank character */ ostring = ostring || m; /* Insert mode name in ostring. */ number = n; /* Zap! You're converted. */ i = verify (number, " "); /* Search for nonblank. */ ostring = ostring || substr (number, i); /* Insert number in ostring. */ return; add_bit: entry (m, b); /* internal proc to add on/off mode to ostring */ dcl b bit (1); /* mode bit */ if ^b then ostring = ostring || "^"; /* If bit off, add NOT sign. */ ostring = ostring || m; /* Insert mode name in ostring. */ return; end add_num; j = verify (reverse (new_mode), " .;"); /* Search backwards over final breaks. */ if j = 0 then return; /* If no meat on the bones, just return. */ lmode = length (new_mode) - j + 1; /* Compute length to be examined. */ do k = 1 repeat k + j while (k < lmode); /* Step through new modes. */ j = search (substr (new_mode, k), ",;. "); /* Search for break character. */ if j = 0 then j = lmode - k + 2; /* If no breaks, take remaining length. */ if test ("default") then do; /* Default should be first and only mode. */ pci.modes = "0"b; /* Reset all mode bits. */ pci.top_label_length, pci.bot_label_length = 0; /* Reset labels. */ pci.rmarg = pci.phys_line_length; /* Reset line and page lengths. */ pci.lmarg = 0; pci.page_length = pci.phys_page_length - pci.lpi; end; else if tests ("noskip", pci.overflow_off) then; /* If page overflow to be ignored ... */ else if tests ("single", pci.single_space) then; /* If single spacing to be forced ... */ else if tests ("non_edited", pci.non_edited) then; /* If non-edited mode to be forced ... */ else if tests ("truncate", pci.truncate) then; /* If long lines to be truncated ... */ else if tests ("trim", g115_data.trim) then; /* If setting/resetting trim mode ... */ else if testn ("ll", pci.rmarg) then; /* If changing line length ... */ else if testn ("in", pci.lmarg) then; /* If changing indentation ... */ else if testn ("pl", pci.page_length) then; /* If changing page length ... */ else /* If unrecognized key ... */ code = error_table_$bad_mode; end; pci.rmarg = min (pci.rmarg, pci.phys_line_length); /* Insure that line is not too long. */ pci.lmarg = min (pci.lmarg, pci.rmarg); /* Left margin must be to left of right margin. */ if pci.overflow_off then do; /* Check for "noskip" mode set. */ pci.top_label_length, /* "noskip" and page labels are inconsistent. */ pci.bot_label_length = 0; pci.sheets_per_page = 1; /* One sheet per page in noskip mode. */ pci.page_length = pci.phys_page_length - pci.lpi; /* Reset logical page length. */ end; else /* If "^noskip" mode ... */ pci.sheets_per_page = divide (pci.page_length + (pci.lpi - 1) + pci.phys_page_length, pci.phys_page_length, 17, 0); /* Compute physical sheets of paper per page. */ return; test: proc (s) returns (bit (1) aligned); /* internal proc to test for mode key */ dcl s char (*) aligned; /* mode key */ return (substr (new_mode, k, length (s)) = s); /* Return success or failure. */ tests: entry (s, t) returns (bit (1) aligned); /* entry to test for mode or ^mode */ dcl t bit (1) unal; /* key or ^key flag */ if substr (new_mode, k, length (s)) = s then do; /* If key found ... */ t = "1"b; /* Set flag to true. */ return ("1"b); /* And return. */ end; else if substr (new_mode, k+1, length (s)) = s then if substr (new_mode, k, 1) = "^" then do; t = "0"b; /* If ^key found, set flag to false. */ return ("1"b); /* And return. */ end; return ("0"b); /* Key not found. */ testn: entry (s, i) returns (bit (1) aligned); /* internal proc to set numeric mode */ dcl i fixed bin; /* numeric mode */ if substr (new_mode, k, length (s)) = s then do; /* If key found ... */ i = convert (i, substr (new_mode, k + 2, j - 3)); /* Return converted number. */ return ("1"b); end; return ("0"b); end test; /* */ order: entry (dev_index, request, order_ptr, code); data_ptr = g115_util_$get_ptr (); /* get ptr to dcms' global data base */ code = 0; /* initialize return argument */ pcip = addr (g115_data.conv_info); if request = "set_periph" then do; /* request to set target periph type */ g115_data.teleprinter = "0"b; /* init to default to printer */ g115_data.punch = "0"b; if order_ptr = null then return; /* cant continue */ if periph_type = 3 then g115_data.teleprinter = "1"b; if periph_type = 4 then g115_data.punch = "1"b; end; else if request = "read_status" then do; /* request to get read status */ info_structure.ev_chan = g115_data.hcs_ev_chan; /* return ev chn on which read will return */ info_structure.input_available = "0"b; /* none yet */ msg_ptr = addr (g115_data.input_buffer); /* set ptr */ if msg_ptr -> g115_hdr.full_cc ^= 0 then do; /* input is ready */ info_structure.input_available = "1"b; /* go to it daemons */ return; end; call g115_message_$read (msg_ptr, msg_len, code); /* read any ring-0 data */ if msg_len = 0 then return; if msg_ptr -> g115_hdr.full_cc ^= 0 then /* go some real data */ info_structure.input_available = "1"b; return; end; else if request = "inside_page" then /* Space to top of inside page. */ call write_nl (2); else if request = "outside_page" then /* Space to top of outside page */ call write_nl (4); else if request = "end_of_page" then /* Position at end of page, below bottom label */ call write_nl (3); else if request = "page_labels" then do; /* set page top and bottom labels */ if order_ptr = null () then do; /* If null, reset labels. */ pci.top_label_length, pci.bot_label_length = 0; end; else if pci.overflow_off then /* Cannot have labels with overflow off. */ code = error_table_$inconsistent; else do; /* Set the labels. */ pci.top_label_line = page_labels.top_label; call set_label (pci.top_label_line, pci.top_label_length); pci.bot_label_line = page_labels.bottom_label; call set_label (pci.bot_label_line, pci.bot_label_length); end; end; else if request = "reset" then do; /* Reset modes and counts. */ pci.lmarg = 0; pci.rmarg = pci.phys_line_length; pci.page_length = pci.phys_page_length - pci.lpi; pci.sheets_per_page = 1; pci.line_count = 0; pci.page_count = 0; pci.func = 0; pci.modes = "0"b; pci.top_label_line = ""; pci.bot_label_line = ""; pci.top_label_length = 0; pci.bot_label_length = 0; end; else if request = "get_count" then do; /* Get lengths and counts. */ counts.line = pci.line; counts.page_length = pci.page_length; counts.lmarg = pci.lmarg; counts.rmarg = pci.rmarg; counts.line_count = pci.line_count; counts.page_count = pci.page_count * pci.sheets_per_page; end; else if request = "start" then call hcs_$tty_order (dev_index, "start", null, state, code); /* pass it on */ else if request = "quit_enable" then do; call hcs_$tty_order (dev_index, "quit_enable", null, state, code); end; else if request = "quit_disable" then do; call hcs_$tty_order (dev_index, "quit_disable", null, state, code); end; else code = error_table_$undefined_order_request; /* unrecognized order call */ return; write_nl: proc (f); dcl f fixed bin; /* function code */ pci.func = f; /* Set correct function code. */ call g115_io_$write (g115_data.twx, addr (NL), 0, length (NL), nelemt, code); pci.func = 0; /* Make sure function code reset. */ if code ^= 0 then return; return; end write_nl; set_label: proc (line, lth); dcl line char (136) aligned, /* label line */ lth fixed bin; /* label length */ if line = "" then lth = 0; /* If line is all blank, length is zero. */ else if search (line, VT_or_FF) ^= 0 then do; /* Do not allow VT or FF. */ lth = 0; /* Set length to zero. */ code = error_table_$bad_arg; end; else do; lth = 136 + 1 - verify (reverse (line), " "); end; return; end set_label; /* */ attach: entry (dev_name, dev_index, code); /* entry to get device started */ call hcs_$tty_index (dev_name, dev_index, state, code); if code ^= 0 then return; call init (dev_name, dev_index, code); /* allocate and initialize g115_data structure */ if code ^= 0 then return; data_ptr = g115_util_$get_data_ptr (dev_index); if data_ptr = null then do; code = error_table_$ionmat; return; end; call g115_util_$set_ptr (data_ptr); call hcs_$tty_event (dev_index, g115_data.hcs_ev_chan, state, code); /* pass the call event to ring 0 */ if code ^= 0 then return; call hcs_$tty_order (dev_index, "info", addr (chan_info), state, code); if chan_info.line_type ^= 6 & chan_info.line_type ^= 7 then do; /* not set right */ new_line_type = 6; /* set to hardwired type */ call hcs_$tty_order (dev_index, "set_line_type", addr (new_line_type), state, code); if code ^= 0 then return; end; call hcs_$tty_order (dev_index, "listen", null, state, code); do while (state ^= 5); call g115_util_$block (code); call hcs_$tty_state (dev_index, state, code); end; modes.len = length (modes.str); modes.str = "rawo,rawi,hndlquit"; call hcs_$tty_order (dev_index, "modes", addr (modes), state, code); call hcs_$tty_order (dev_index, "quit_enable", null, state, code); return; detach: entry (dev_index, code); code = 0; data_ptr = g115_util_$unlink_data_ptr (dev_index); if data_ptr = null then return; /* nothing to free */ free g115_data in (sys_area); call hcs_$tty_detach (dev_index, 1, state, code); return; end;  g115_conv_.alm 02/23/78 1042.6rew 02/23/78 1038.9 34272 " G115_CONV_ - Conversion for G115 remote printer. " coded 12/12/74 by Noel I. Morris " last modified 6/23/75 by Noel I. Morris " modified 04/10/77 by Bob Franklin to change top of inside page char " and dont slew on punch " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " This module performs the necessary conversion for printing on the " G115 remote printer. " " The manner in which this procedure is utilized is described in detail " in the listing of prt_conv_. " " A media code character will be inserted at the beginning of each " output line. This character must have been placed in pci.temp " before this procedure is called. name g115_conv_ segdef g115_conv_ temp char place for slew and record separator characters g115_conv_: tra g115_send_init tra g115_send_chars tra g115_send_slew_pattern tra g115_send_slew_count " include prt_conv_info " g115_send_init: mlr (pr),(pr) insert media code at beginning of line desc9a lb|pci.temp,1 .. desc9a bb|0,1 .. ldq 1,dl bump output pointer by 1 character a9bd bb|0,ql .. tra sb|0 return to caller " g115_send_chars: spaceloop: eaq 0,2 white space count in QU tmoz nospace skip if no white space sbx2 64,du can take only 64 at a time tmoz *+2 .. ldq 64,du if more, take 64 to begin with cmpq 4,du if fewer than 4 spaces, tmi blankout insert blanks instead mlr (),(pr) insert blank and dup char desc9a dupblank,2 .. desc9a bb|0,2 .. mlr (qu),(pr) insert dup count character desc9a duptab-1(3),1 .. desc9a bb|0(2),1 .. ldq 3,dl step output pointer a9bd bb|0,ql .. tra spaceloop loop blankout: mlr (),(pr,rl),fill(040) insert requisite number of blanks desc9a *,0 .. desc9a bb|0,qu .. a9bd bb|0,qu bump output pointer tra spaceloop and loop nospace: mlr (pr,rl),(pr,rl) copy characters into output desc9a bp|0,au .. desc9a bb|0,au .. a9bd bp|0,au step input and output pointers a9bd bb|0,au .. eax2 0 clear white space counter tra sb|0 return to caller dupblank: vfd a9/ ,o9/037 duptab: aci "0123456789[#@:>?" aci " ABCDEFGHI&.](<\" aci "^JKLMNOPQR-$*);'" aci "+/STUVWXYZ_,%=""!" " g115_send_slew_pattern: eax7 0 initialize for search rpt nslew/2,2,tze search for slew characters cmpa slew,7 .. xec -1,7 get correct carriage control stslew: orq separator follow by separator character eax7 2 will really have two ldx6 lb|pci.temp look at mc supplied cmpx6 =o117000,du for punch? tze *+3 yes - drop slew from q cmpx6 =o116000,du for teleprinter? tnz *+3 no, all is well eax7 1 teleprinter mc, no slew qls 9 drop slew from q stq char and store mlr (pr,rl),(pr,rl) copy into output desc9a char,x7 .. desc9a bb|0,x7 .. a9bd bb|0,7 .. tra sb|0 return to caller slew: vfd 27/,o9/0 FF ldq =1a ,du vfd 27/,o9/013 top of inside page ldq =1a ,du changed from A (101 octal) to space for Mohawk printer vfd 27/,o9/011 top of outside page ldq =1aB,du equ nslew,*-slew separator: vfd 9/,o9/036 " g115_send_slew_count: eaq 0,al count in QU sbla 15,dl decrement A by 15 tmoz *+2 can only take 15 lines at a time ldq 15,du if > 15, take 15 for now ldq skip,qu get correct skip character tra stslew join common code skip: aci "0" aci "1" aci "2" aci "3" aci "4" aci "5" aci "6" aci "7" aci "8" aci "9" aci "[" aci "#" aci "@" aci ":" aci ">" aci "?" end  g115_dim_.pl1 02/23/78 1042.6rew 02/23/78 1039.6 83475 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_dim_: proc; /* DIM for g115 remote batch terminals, interfaces with g115 DCM */ /* Coded 11/20/73 by Mike Grady */ /* modified 06-10-75 by Bob Adsit to move line_control to MCS/355 */ /* modified 07-22-77 by Bob Franklin to add entries for resetread, resetwrite, and abort calls which are all treated as no-ops. */ dcl (stream_name, type, device, mode, disposal, order_type) char (*), (t_twx, attach_type, aoffset, anelem, anelemt) fixed bin, (new_mode, old_mode) char (*), rcard char (80) varying, bcard based (bufp) char (length (rcard)), rstatus bit (72) aligned, sareap ptr int static, sarea area based (sareap), code fixed bin (35), sp ptr, bufp ptr, orderp ptr; dcl g115_control_$attach entry (char (*), fixed bin, fixed bin (35)), g115_control_$order entry (fixed bin, char (*), ptr, fixed bin (35)), g115_control_$modes entry (fixed bin, char (*), char (*), fixed bin (35)), g115_control_$detach entry (fixed bin, fixed bin (35)), g115_util_$set_ptr entry (ptr), g115_util_$get_data_ptr entry (fixed bin) returns (ptr), g115_util_$conv_card entry (char (*) varying), g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)), g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)), get_system_free_area_ entry returns (ptr); dcl (null, addr) builtin; dcl (area, storage) condition; dcl (error_table_$ionmat, error_table_$bad_mode, error_table_$multiple_io_attachment, error_table_$noalloc, error_table_$invalid_read, error_table_$invalid_write, error_table_$device_end, error_table_$not_attached) fixed bin (35) ext; dcl sdbp ptr; /* pointer to stream data block */ dcl 1 g115_dim_sdb aligned based (sdbp), /* stream data block */ 2 outer_mod_name char (32), /* = "g115_" */ 2 device_namep ptr init (addr (g115_dim_sdb.device_name)), /* points to device name */ 2 device_type fixed bin, 2 device_name, 3 next_ptr ptr init (null), 3 name_size fixed bin init (32), 3 name char (32); dcl dim_data_ptr ptr int static init (null); /* pointer to dim_data */ dcl 1 g115_dim_data aligned based (dim_data_ptr), 2 twx fixed bin, 2 dev_name char (6), 2 attach_count fixed bin; %include io_status; %include g115_data; /* */ g115_attach: entry (stream_name, type, device, mode, rstatus, sdbp); /* attach printer */ call set_attach_type; /* call subr to set type from mode */ if sdbp ^= null then /* error stream already attached */ call return_status (error_table_$ionmat, "0"b); if dim_data_ptr = null then do; /* first init for this device */ call g115_control_$attach (device, t_twx, code); /* index this device */ if code ^= 0 then call return_status (code, "1"b); /* error from attachment, bad */ sareap = get_system_free_area_ (); /* grab ptr to free area */ on condition (area) call return_status (error_table_$noalloc, "1"b); on condition (storage) call return_status (error_table_$noalloc, "1"b); allocate g115_dim_data in (sarea) set (dim_data_ptr); revert condition (area); revert condition (storage); g115_dim_data.twx = t_twx; /* save twx for future calls */ g115_dim_data.dev_name = device; /* save name for future attaches */ g115_dim_data.attach_count = 0; /* init this */ end; if device ^= g115_dim_data.dev_name then /* error, only one device at a time */ call return_status (error_table_$multiple_io_attachment, "1"b); on condition (area) call return_status (error_table_$noalloc, "1"b); on condition (storage) call return_status (error_table_$noalloc, "1"b); allocate g115_dim_sdb in (sarea) set (sdbp); /* allocate an sdb for this stream */ revert condition (area); revert condition (storage); g115_dim_sdb.outer_mod_name = type; /* set outer mod name */ g115_dim_sdb.device_type = attach_type; /* record attach type */ g115_dim_sdb.name = device; /* set device name in here also */ g115_dim_data.attach_count = g115_dim_data.attach_count + 1; /* count up attaches */ call return_status (0, "0"b); /* done, return zero code */ /* */ g115_read: entry (sdbp, bufp, aoffset, anelem, anelemt, rstatus); /* entry to read */ call check_attachment; if g115_dim_sdb.device_type = 2 | /* not a readable device */ g115_dim_sdb.device_type = 4 then call return_status (error_table_$invalid_read, "0"b); if g115_dim_sdb.device_type = 3 then do; /* special for teleprinter read */ call g115_util_$conv_card (rcard); /* convert card */ bcard = rcard; /* return to user */ anelemt = length (rcard); /* set len */ call return_status (0, "0"b); /* done */ end; call g115_io_$read (g115_dim_data.twx, bufp, aoffset, anelem, anelemt, code); /* pass on read */ if code = error_table_$device_end then call return_status (1, "0"b); call return_status (code, "0"b); g115_write: entry (sdbp, bufp, aoffset, anelem, anelemt, rstatus); /* write here */ call check_attachment; if g115_dim_sdb.device_type < 2 then /* not a writeable device */ call return_status (error_table_$invalid_write, "0"b); call g115_control_$order (g115_dim_data.twx, "set_periph", addr (g115_dim_sdb.device_type), code); /* set the device type for the write */ call g115_io_$write (g115_dim_data.twx, bufp, aoffset, anelem, anelemt, code); call return_status (code, "0"b); /* done */ /* */ g115_modes: entry (sdbp, new_mode, old_mode, rstatus); call check_attachment; call g115_control_$modes (g115_dim_data.twx, new_mode, old_mode, code); call return_status (code, "0"b); g115_order: entry (sdbp, order_type, orderp, rstatus); /* order call stuff */ call check_attachment; call g115_control_$order (g115_dim_data.twx, order_type, orderp, code); /* easy, pass it along */ call return_status (code, "0"b); /* return code if any */ g115_detach: entry (sdbp, device, disposal, rstatus); /* entry to detach device */ call check_attachment; g115_dim_data.attach_count = g115_dim_data.attach_count - 1; /* count down for detach */ code = 0; if g115_dim_data.attach_count = 0 then /* if no streams attached now, dump device */ call g115_control_$detach (g115_dim_data.twx, code); call return_status (code, "1"b); /* return code, if any and detach */ g115_cntrl: entry (sdbp, rstatus); /* resetread, resetwrite, abort ignored */ call check_attachment; code = 0; call return_status (code, "0"b); /* */ /* internal proc to return status as real ios status */ return_status: proc (rcode, rdet_bit); dcl rcode fixed bin (35), rdet_bit bit (1); sp = addr (status); status_bits = "0"b; /* clear to init */ if rcode = 1 then do; /* if 1 set eod */ rcode = 0; status.end_of_data = "1"b; end; status.ioname_detached = rdet_bit; /* set det bit in status word */ status.code = rcode; if rdet_bit then do; /* if we are detaching then do */ if sdbp ^= null then do; /* free sdb if allocated */ free g115_dim_sdb in (sarea); sdbp = null; end; if dim_data_ptr ^= null then /* check dim_data */ if g115_dim_data.attach_count = 0 then do; /* no more streams attached, free block */ free g115_dim_data in (sarea); dim_data_ptr = null; end; end; rstatus = status_bits; /* copy back status */ go to ret; /* nonlocal goto to exit */ end; ret: return; /* internal procedure to check correctness of call to g115_dim_$... */ check_attachment: proc; if dim_data_ptr = null | sdbp = null then /* error - no previous attach call */ call return_status (error_table_$not_attached, "0"b); if g115_dim_sdb.name ^= g115_dim_data.dev_name then /* device names do not match */ call return_status (error_table_$multiple_io_attachment, "0"b); data_ptr = g115_util_$get_data_ptr (g115_dim_data.twx); if data_ptr = null then /* no g115_data structure for this device */ call return_status (error_table_$not_attached, "0"b); call g115_util_$set_ptr (data_ptr); g115_data.no_block = "0"b; /* turn off no block flag */ return; end; set_attach_type: proc; attach_type = 0; /* set default to none */ if index (mode, "teleprinter") ^= 0 then attach_type = 3; else if index (mode, "reader") ^= 0 then attach_type = 1; else if index (mode, "printer") ^= 0 then attach_type = 2; else if index (mode, "punch") ^= 0 then attach_type = 4; else if mode = "" then attach_type = 3; if attach_type = 0 then /* wrong mode, gripe */ call return_status (error_table_$bad_mode, "1"b); return; end; end;  g115_input_proc_.pl1 02/23/78 1042.6rew 02/23/78 1039.7 40626 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_input_proc_: proc (slot_ptr, bufp, nelem, nelemt, code); /* input processor, rewritten 8/14/75 by Mike Grady */ /* modified by Bob Franklin 04/10/77 to fix bugs */ dcl (i, j, k, ct, uct, inelem, nelem, nelemt) fixed bin, code fixed bin (35), (bufp, rbufp) ptr, bchars char (82) based (addr (g115_msg.text (g115_hdr.read_offset))), ccard char (80) varying init ((80)" "), card char (80) varying init ((80)" "), blanks char (80) init ((80)" "), outstr char (1000) based (rbufp), chara (0:1000) char (1) based (rbufp); dcl (rs, cc, char) char (1), nl char (1) init (" "); dcl debug entry options (variable); dcl g115_util_$get_ptr entry returns (ptr); %include g115_data; %include g115_msg; %include g115_stat; dcl g115_ascii_to_bits (0:63) bit (9) unaligned int static init ( "000010000"b, "000111111"b, "000111110"b, "000001011"b, "000101011"b, "000111100"b, "000011010"b, "000101111"b, "000011101"b, "000101101"b, "000101100"b, "000110000"b, "000111011"b, "000101010"b, "000011011"b, "000110001"b, "000000000"b, "000000001"b, "000000010"b, "000000011"b, "000000100"b, "000000101"b, "000000110"b, "000000111"b, "000001000"b, "000001001"b, "000001101"b, "000101110"b, "000011110"b, "000111101"b, "000001110"b, "000001111"b, "000001100"b, "000010001"b, "000010010"b, "000010011"b, "000010100"b, "000010101"b, "000010110"b, "000010111"b, "000011000"b, "000011001"b, "000100001"b, "000100010"b, "000100011"b, "000100100"b, "000100101"b, "000100110"b, "000100111"b, "000101000"b, "000101001"b, "000110010"b, "000110011"b, "000110100"b, "000110101"b, "000110110"b, "000110111"b, "000111000"b, "000111001"b, "000001010"b, "000011111"b, "000011100"b, "000100000"b, "000111010"b); data_ptr = g115_util_$get_ptr (); unspec (rs) = g115_stat.rs_char; unspec (cc) = g115_stat.comp_char; nelemt, code = 0; rbufp = bufp; inelem = nelem; do while (g115_hdr.full_cc > 0); /* loop reading all in message */ i = index (bchars, rs); /* find rs at end of card */ ccard = substr (bchars, 2, i-2); /* take all between mc and rs */ g115_hdr.read_offset = g115_hdr.read_offset + i; /* skip over that */ card = ""; j = 1; /* init ptr to packed card */ k = index (ccard, cc); /* see if any compression chars in card */ do while (k > 0); /* loop de-compressing card */ card = card || substr (ccard, j, k-1); /* copy all up to compression char */ char = substr (ccard, j+k-2, 1); /* pickup repeated char */ uct = fixed (unspec (substr (ccard, j+k, 1)), 17); /* get count */ uct = fixed (g115_ascii_to_bits (uct - 32), 17); /* get real count */ do ct = 1 to uct; /* loop unpacking chars */ card = card || char; /* unpack a char */ end; j = j + k + 1; /* bump ptr up to next virgin piece */ k = index (substr (ccard, j), cc); /* look for next cc */ end; card = card || substr (ccard, j, i-2-j+1); /* copy remainder of card */ card = card || substr (blanks, 1); g115_hdr.full_cc = g115_hdr.full_cc - 80; /* decrement card count in message */ if substr (card, 1, 6) = "***EOF" then do; /* found eof marker card */ code = 2; /* set funny code */ return; end; if g115_data.trim then /* trimming blanks off end then */ ct = 80 - verify (reverse (card), " ") + 1; /* get real count for card */ else ct = 80; /* full card to be returned */ if inelem < ct + 1 then do; /* not enough room to return all */ ct = inelem; substr (outstr, 1, ct) = substr (card, 1, ct); nelemt = nelemt + ct; return; end; substr (outstr, 1, ct + 1) = substr (card, 1, ct) || nl; /* return whats wanted plus nl */ nelemt = nelemt + ct + 1; /* amt returned */ inelem = inelem - ct - 1; /* amt left in buffer */ rbufp = addr (chara (ct+1)); /* bump ptr */ if inelem = 0 then return; end; code = 1; /* still need more input from 115 */ return; end;  g115_io_.pl1 02/23/78 1042.6rew 02/23/78 1039.8 115830 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_io_: proc; /* This procedure handles the logical reading and writing of data to the g115 remote computer. */ /* Coded 5/2/74 by Mike Grady */ /* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */ /* modified 04/10/77 by Bob Franklin to: fix bugs, add upper_case only conversion table,turn off teleprinter, reset pci.pos,etc */ dcl (twx, i, offset, nelem, nelemt, nel, nelt, neltx) fixed bin, (wp, readp, curp, nextp, msg_ptr, to_ptr, from_ptr, wksp) ptr, (msg_len, inelem, tidx) fixed bin, code fixed bin (35), (fc, mc) bit (9), nrdp (0:1000) char (1) based (readp) unal, bchr char (neltx) based unal; dcl g115_message_$read entry (ptr, fixed bin, fixed bin (35)), g115_message_$write entry (ptr, fixed bin (35)), g115_input_proc_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)), prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr), g115_util_$get_ptr entry returns (ptr), g115_util_$block entry (fixed bin (35)); dcl (null, rel, bool) builtin; dcl (error_table_$not_attached, error_table_$device_end, error_table_$unable_to_do_io) fixed bin (35) ext; dcl temp_line (40) fixed bin, temp_count fixed bin, temp_filled bit (1) init ("0"b); dcl string (128) char based (wksp) unal; dcl string1 (128) fixed bin (8) unal based; dcl (left_to_print, nelt_to_print, j) fixed bin; dcl wksp1 ptr; dcl buffer_print char (4000); dcl tptr ptr; dcl table (0:127) bit (9) unaligned int static init ( "000000000"b, /* 000 null */ "000000001"b, /* 001 soh */ "000000010"b, /* 002 stx */ "000000011"b, /* 003 etx */ "000000100"b, /* 004 eot */ "000000101"b, /* 005 enq */ "000000110"b, /* 006 ack */ "000000111"b, /* 007 bel */ "000001000"b, /* 010 bc */ "000001001"b, /* 011 ht */ "000001010"b, /* 012 nl */ "000001011"b, /* 013 vt */ "000001100"b, /* 014 */ "000001101"b, /* 015 cr */ "000001110"b, /* 016 */ "000001111"b, /* 017 */ "000010000"b, /* 020 dle */ "000010001"b, /* 021 dc1 */ "000010010"b, /* 022 dc2 */ "000010011"b, /* 023 dc3 */ "000010100"b, /* 024 dc4 */ "000010101"b, /* 025 nak */ "000010110"b, /* 026 syn */ "000010111"b, /* 027 etb */ "000011000"b, /* 030 can */ "000011001"b, /* 031 em */ "000011010"b, /* 032 sub */ "000011011"b, /* 033 esc */ "000011100"b, /* 034 fs */ "000011101"b, /* 035 gs */ "000011110"b, /* 036 rs */ "000011111"b, /* 037 */ "000100000"b, /* 040 blank */ "000100001"b, /* 041 ! */ "000100010"b, /* 042 " */ "000100011"b, /* 043 pound sign */ "000100100"b, /* 044 dollar */ "000100101"b, /* 045 percent */ "000100110"b, /* 046 ampersand */ "000100111"b, /* 047 accent */ "000101000"b, /* 050 ( */ "000101001"b, /* 051 ) */ "000101010"b, /* 052 asterisk */ "000101011"b, /* 053 plus */ "000101100"b, /* 054 comma */ "000101101"b, /* 055 minus */ "000101110"b, /* 056 period */ "000101111"b, /* 057 slash */ "000110000"b, /* 060 zero */ "000110001"b, /* 061 1 */ "000110010"b, /* 062 2 */ "000110011"b, /* 063 3 */ "000110100"b, /* 064 4 */ "000110101"b, /* 065 5 */ "000110110"b, /* 066 6 */ "000110111"b, /* 067 7 */ "000111000"b, /* 070 8 */ "000111001"b, /* 071 9 */ "000111010"b, /* 072 colon */ "000111011"b, /* 073 semicolon */ "000111100"b, /* 074 less than */ "000111101"b, /* 075 = */ "000111110"b, /* 076 > */ "000111111"b, /* 077 question */ "001000000"b, /* 100 at sign */ "001000001"b, /* 101 A */ "001000010"b, /* 102 B */ "001000011"b, /* 103 C */ "001000100"b, /* 104 D */ "001000101"b, /* 105 E */ "001000110"b, /* 106 F */ "001000111"b, /* 107 G */ "001001000"b, /* 110 H */ "001001001"b, /* 111 I */ "001001010"b, /* 112 J */ "001001011"b, /* 113 K */ "001001100"b, /* 114 L */ "001001101"b, /* 115 M */ "001001110"b, /* 116 N */ "001001111"b, /* 117 O */ "001010000"b, /* 120 P */ "001010001"b, /* 121 Q */ "001010010"b, /* 122 R */ "001010011"b, /* 123 S */ "001010100"b, /* 124 T */ "001010101"b, /* 125 U */ "001010110"b, /* 126 V */ "001010111"b, /* 127 W */ "001011000"b, /* 130 X */ "001011001"b, /* 131 Y */ "001011010"b, /* 132 Z */ "001011011"b, /* 133 [ */ "001011100"b, /* 134 slash */ "001011101"b, /* 135 ] */ "001011110"b, /* 136 up arrow */ "001011111"b, /* 137 _ */ "000111111"b, /* 140 = 077 = ? */ "001000001"b, /* 141 = 101 = A */ "001000010"b, /* 142 = 102 = B */ "001000011"b, /* 143 = 103 = C */ "001000100"b, /* 144 = 104 = D */ "001000101"b, /* 145 = 1-5 = E */ "001000110"b, /* 146 = 106 = F */ "001000111"b, /* 147 = 107 = G */ "001001000"b, /* 150 = 110 = H */ "001001001"b, /* 151 = 111 = I */ "001001010"b, /* 152 = 112 = J */ "001001011"b, /* 153 = 113 = K */ "001001100"b, /* 154 = 114 = L */ "001001101"b, /* 155 = 115 = M */ "001001110"b, /* 156 = 116 = N */ "001001111"b, /* 157 = 117 = O */ "001010000"b, /* 160 = 120 = P */ "001010001"b, /* 161 = 121 = Q */ "001010010"b, /* 162 = 122 = R */ "001010011"b, /* 163 = 123 = S */ "001010100"b, /* 164 = 124 = T */ "001010101"b, /* 165 = 125 = U */ "001010110"b, /* 166 = 126 = V */ "001010111"b, /* 167 = 127 = W */ "001011000"b, /* 170 = 130 = X */ "001011001"b, /* 171 = 131 = Y */ "001011010"b, /* 172 = 132 = Z */ "000101000"b, /* 173 = 050 = ( */ "001011110"b, /* 174 = 136 = up arrow */ "000101001"b, /* 175 = 051 = ) */ "000111111"b, /* 176 = 077 = ? */ "000111111"b /* 177 = 077 = ? */ ); %include g115_data; %include g115_msg; %include g115_stat; write: entry (twx, wp, offset, nelem, nelemt, code); code, nelemt = 0; /* init return stuff */ if nelem = 0 then return; data_ptr = g115_util_$get_ptr (); /* get data ptr */ if g115_data.twx ^= twx then do; /* error, wrong device */ code = error_table_$not_attached; return; end; pcip = addr (g115_data.conv_info); if g115_data.teleprinter then do; /* telelprinter in use now */ pci.pos = 0; /* darn trailer leaves it at 132 */ mc = g115_stat.teleprinter_mc; /* set media code */ fc = g115_stat.special_c; /* set format code to special compressed */ end; else if g115_data.write_compress then do; /* wants compressed records */ g115_data.write_split = "0"b; /* and not split records */ fc = g115_stat.info_ns_c; /* set format code to information no split compressed */ if g115_data.punch then mc = g115_stat.punch_mc; else mc = g115_stat.printer_mc; end; else do; bad_type: code = error_table_$unable_to_do_io; return; end; wksp = addr (wp -> nrdp (offset)); tptr = addr (table); /* set to convert */ i = 0; left_to_print = nelem; loop: if left_to_print > 0 then do; /* process until done */ wksp1 = addr (buffer_print); if left_to_print > 4000 then nelt_to_print = 4000; /* don't print more than buffer size */ else nelt_to_print = left_to_print; do j = 1 to nelt_to_print; wksp1 -> string (j) = wksp -> string (i+j); end; left_to_print = left_to_print - nelt_to_print; /* keep counts up-to-date */ i = i + nelt_to_print; inelem = nelt_to_print; curp = addr (g115_data.output_buffer1); /* get addr of first output buffer */ nextp = null; /* no next buffer yet */ call fill_buffer (curp, code); /* fill first buffer */ if code ^= 0 then return; /* must be error, return */ next_write: /* loop here to write next buffer */ if curp = null then go to finished_write; /* no next, all done */ call g115_message_$write (curp, code); /* write the buffer */ if code ^= 0 then return; /* any error, punt */ nextp = switch_buffers (curp); /* get ptr to new buffer */ call fill_buffer (nextp, code); /* fill this buffer */ if code = 1 then nextp = null; /* no more data to write */ else if code ^= 0 then return; /* must be error */ curp = nextp; /* set next to current */ nextp = null; /* next is gone */ go to next_write; /* loop back and write */ finished_write: go to loop; end; g115_data.teleprinter = "0"b; /* turn off teleprinter */ nelemt = nelem; code = 0; xit: return; read: entry (twx, wp, offset, nelem, nelemt, code); code, nelemt = 0; /* init return stuff */ nel = nelem; nelt = 0; readp = wp; if nelem = 0 then return; /* nothing to do for now */ data_ptr = g115_util_$get_ptr (); /* get the data ptr */ if g115_data.twx ^= twx then do; /* not this one today */ code = error_table_$not_attached; return; end; msg_ptr = addr (g115_data.input_buffer); /* get pointer to buffer */ if msg_ptr -> g115_hdr.full_cc ^= 0 then go to process; next_read: /* loop here reading data */ if g115_data.no_block then do; /* answering service read */ call g115_message_$read (msg_ptr, msg_len, code); /* read data cards */ if code ^= 0 then return; if msg_len = 0 then goto finished_read; end; else call get_message; /* read in the data msg */ process: call g115_input_proc_ (msg_ptr, readp, nel, neltx, code); /* convert input msgs */ readp = addr (nrdp (neltx)); nelt = nelt + neltx; nel = nel - neltx; if code = 1 then /* more input needed */ go to next_read; /* read some more */ else if code = 2 then code = error_table_$device_end; finished_read: nelemt = nelt; return; switch_buffers: proc (old_ptr) returns (ptr); dcl (old_ptr, new_ptr) ptr, (old_offset, new_offset) bit (18); old_offset = rel (old_ptr); /* get the offset */ new_offset = bool (old_offset, g115_data.mask_sw, "0110"b); new_ptr = ptr (old_ptr, new_offset); return (new_ptr); end; get_message: proc ; gloop: call g115_message_$read (msg_ptr, msg_len, code); /* read in message */ if code ^= 0 then go to xit; if msg_len ^= 0 then return; call g115_util_$block (code); if code ^= 0 then go to xit; go to gloop; end; fill_buffer: proc (optr, code); /* proc to fill one output buffer */ dcl optr ptr, code fixed bin (35); code = 0; if inelem = 0 & ^temp_filled then do; /* we have processed all data */ code = 1; return; end; pci.temp = mc; /* set media code for g115_conv_ */ optr -> g115_hdr.null_ct = 0; optr -> g115_hdr.text_char_count = 0; /* clear count to init */ optr -> g115_msg.fmt_code = fc; /* fill in fmt code in message */ optr -> g115_msg.op_code.cmd = g115_stat.no_op; /* no op on std write request */ tidx = 1; /* init to first in data */ do while (inelem > 0 | temp_filled); /* pump output till done */ if temp_filled then neltx = temp_count; /* process temp first */ else call prt_conv_ (wksp1, inelem, addr (temp_line), neltx, pcip); /* get next temp */ if (tidx - 1) + neltx > g115_stat.max_msg_len then do; /* enough for this buffer */ temp_filled = "1"b; /* indicate that for next time */ temp_count = neltx; go to fill_done; end; else temp_filled = "0"b; to_ptr = addr (optr -> g115_msg.text (tidx)); /* set to ptr */ from_ptr = addr (temp_line); /* set from ptr */ to_ptr -> bchr = from_ptr -> bchr; /* copy converted string */ tidx = tidx + neltx; end; fill_done: optr -> g115_hdr.text_char_count = tidx -1; /* set count */ optr -> g115_msg.etx = g115_stat.etx_char; return; end; end;  g115_message_.pl1 02/23/78 1042.6rew 02/23/78 1040.0 131445 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_message_: proc; /* this procedure handles the actual read and writing of the data to the MDS2400 via hcs_$tty calls. */ /* Coded 4/30/74 by Mike Grady */ /* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */ /* modified 04/10/77 by Bob Franklin to fix many bugs. Now multiple blocks must be unpacked on input in g115_message, special control records must be ignored, etc. Ignore Quit error on Writes. */ dcl msg_ptr ptr, msg_len fixed bin, input_ptr ptr, put_ptr ptr, msg_ct fixed bin, msg_ct1 fixed bin, offset fixed bin, out_try fixed bin, last_char_was_rs bit (1), parity bit (1), i fixed bin, state fixed bin, error_type fixed bin, fmt_index fixed bin, temp_full_cc fixed bin, code fixed bin (35); dcl debug entry options (variable); dcl quit_code fixed bin (35) int static init (3000005); /* quit occurred */ dcl 1 info aligned, 2 pad fixed bin (71), 2 output_pending bit (1); dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl hcs_$tty_write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)), hphcs_$tty_write_force entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)), hcs_$tty_read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)), hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)), hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)), g115_util_$get_ptr entry returns (ptr), g115_util_$block entry (fixed bin (35)), ipc_$mask_ev_calls entry (fixed bin (35)), ipc_$unmask_ev_calls entry (fixed bin (35)), timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)), timer_manager_$reset_alarm_wakeup entry (fixed bin (71)), error_table_$buffer_big ext fixed bin (35); dcl str_ptr1 ptr; dcl after_etx fixed bin; dcl read_chars char (msg_len) based (input_ptr) unal, string char (g115_hdr.total_left) based (str_ptr) unal, str_ptr pointer, char char (1), (unspec, index) builtin; dcl 1 aux_ctl (0:7) aligned int static, 2 split bit (1) init ("1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b), 2 compress bit (1) init ("1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b); %include g115_data; %include g115_msg; %include g115_stat; write: entry (msg_ptr, code); /* This procedure writes messages to the MDS2400 and will do retries if hcs_$tty_write could not write any chars */ data_ptr = g115_util_$get_ptr (); /* get data ptr for us */ code = 0; /* set error code to 0 */ out_try = 0; /* clear number of trys */ msg_ct1 = msg_ptr -> g115_hdr.text_char_count + 8; /* get actual length of message */ msg_ptr -> g115_msg.seq_code = "0"b; /* set the xmt seq code in msg */ put_ptr = addr (msg_ptr -> g115_msg); /* get addr for tty_write */ if g115_data.no_block then do; /* force output for answering service */ call hcs_$tty_event (g115_data.twx, g115_data.hcs_ev_chan, state, code); /* replace with our chan for block */ call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code); if code ^= 0 then return; do while (info.output_pending); /* if told to wait */ call ipc_$mask_ev_calls (code); /* stop as for a sec */ call timer_manager_$alarm_wakeup (3, "11"b, g115_data.wait_list.timeout_chan); call g115_util_$block (code); /* wait for device */ call ipc_$unmask_ev_calls ((0)); /* reset mask */ if code ^= 0 then return; call timer_manager_$reset_alarm_wakeup (g115_data.wait_list.timeout_chan); /* made it */ call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code); end; call hcs_$tty_event (g115_data.twx, g115_data.as_ev_chan, state, code); /* return as ev can to tty_dim */ call hphcs_$tty_write_force (g115_data.twx, put_ptr, 0, msg_ct1, msg_ct, state, code); return; end; offset = 0; try_again: call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code); if code ^= 0 then return; do while (info.output_pending); block_it: call g115_util_$block (code); call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code); end; retry: call hcs_$tty_write (g115_data.twx, put_ptr, offset, msg_ct1, msg_ct, state, code); if code = quit_code then go to retry; /* ignore quit error0its been reset */ if code ^= 0 then return; /* really terrible error has occured */ if msg_ct1 = msg_ct then return; /* all data was sent by ring 0 */ if msg_ct = 0 then go to block_it; /* whoops - nothing written */ msg_ct1 = msg_ct1 - msg_ct; /* try to send remainder */ offset = offset + msg_ct; go to try_again; read: entry (msg_ptr, msg_len, code); /* entry to read and check messages from the MDS2400 */ data_ptr = g115_util_$get_ptr (); /* get data ptr */ check_1: code = 0; parity = "0"b; msg_ptr = addr (g115_data.input_buffer); /* init the buffer ptr */ input_ptr = addr (msg_ptr -> g115_msg); slot_ptr = msg_ptr; if g115_hdr.last_rs ^= 0 then go to partial_card; /* whoops - a mess */ if g115_hdr.total_left ^= 0 then go to process_1; /* don't need to read, just unblock */ rloop: if g115_hdr.total_left > 459 then return; call hcs_$tty_read (g115_data.twx, input_ptr, g115_hdr.total_left, 460 - g115_hdr.total_left, msg_len, state, code); if code ^= 0 then return; if g115_hdr.last_rs ^= 0 then do; /* must delete imbedded header */ if msg_len = 0 then do; if g115_hdr.total_left = 0 then do; /* may want to go blocked */ block: call g115_util_$block (code); if code ^= 0 then return; go to rloop; end; if after_etx = 0 then go to block; /* partial line */ end; after_etx = after_etx + msg_len - 7; /* actual number to move */ g115_hdr.total_left = g115_hdr.total_left + msg_len; str_ptr1 = addr (g115_msg.text (g115_hdr.soh_offset - g115_hdr.last_rs -9)); str_ptr = addr (g115_msg.text (g115_hdr.soh_offset - g115_hdr.last_rs)); substr (str_ptr1 -> string, 1, after_etx) = substr (str_ptr -> string, 1, after_etx); last_char_was_rs = "1"b; g115_hdr.total_left = g115_hdr.total_left - 9; /* adjust for missing header */ g115_hdr.text_offset = -6; unspec (char) = g115_stat.etx_char; str_ptr = addr (g115_msg.text (g115_hdr.text_offset)); msg_len = index (substr (string, 1, g115_hdr.total_left), char); if msg_len = 0 then return; go to enter; end; g115_hdr.total_left = g115_hdr.total_left + msg_len; g115_hdr.soh_offset = -6; g115_hdr.text_offset = 0; if msg_len = 0 then return; /* no data yet, so done */ process_1: unspec (char) = g115_stat.etx_char; str_ptr = addr (g115_msg.text (g115_hdr.soh_offset)); if g115_hdr.total_left < 9 then go to move_read; /* need more characters */ msg_len = index (substr (string, 1, g115_hdr.total_left), char); if msg_len = 0 then go to move_read; /* can't find ETX, need more characters */ enter: call check_message_format (code); /* check the message */ if code ^= 0 then do; /* format check failed - throw away message */ g115_hdr.total_left = 0; g115_hdr.last_rs = 0; call ioa_ ("g115_message_: code = ^d", error_type); return; end; if g115_hdr.msg_type = 1 then go to check_1; /* skip service messages */ if g115_hdr.msg_type = 2 then do; /* skip special control records temporarily */ g115_hdr.full_cc = g115_hdr.full_cc - 80; /* don't forget its been incr */ go to check_1; end; g115_hdr.read_offset = g115_hdr.text_offset; if g115_hdr.text_offset = -6 then g115_hdr.text_offset = g115_hdr.soh_offset + 7; return; move_read: /* move remainder to top then read */ substr (input_ptr -> string, 1, g115_hdr.total_left) = substr (str_ptr -> string, 1, g115_hdr.total_left); go to rloop; partial_card: after_etx = g115_hdr.total_left; /* save it for later */ g115_hdr.total_left = g115_hdr.soh_offset - g115_hdr.last_rs + g115_hdr.total_left-1; /* total chars to move down */ str_ptr = addr (g115_msg.text (g115_hdr.last_rs+1)); go to move_read; /* now move it down */ check_message_format: proc (code); /* This procedure checks the format of a g115 message and returns an index specifying the type of message read. It also sets the variables in the message slot referring to that message. */ dcl code fixed bin (35); code = 0; error_type = 0; if g115_hdr.last_rs ^= 0 then do; /* get back in sync */ g115_hdr.text_char_count = msg_len - 1; g115_hdr.last_rs = 0; g115_hdr.total_left = g115_hdr.total_left - msg_len - 1; g115_hdr.soh_offset = msg_len - 5; go to enter1; end; g115_hdr.aux_bit_count, g115_hdr.null_ct, g115_hdr.text_char_count = 0; g115_hdr.read_split, g115_hdr.read_compression = "0"b; /* check SOH character */ if g115_msg.text (g115_hdr.soh_offset) ^= g115_stat.soh_char then do; error_type = 19; go to CHECK_RETURN; end; /* check format code */ fmt_index = bin (substr (g115_msg.text (g115_hdr.soh_offset+1), 5, 5), 17); /* compute format index */ if fmt_index < 1 | fmt_index > 11 /* illegal value */ then go to FMT_CODE_CHECK (1); go to FMT_CODE_CHECK (fmt_index); FMT_CODE_CHECK (2): /* service message, no auxilliary fields */ g115_hdr.msg_type = 1; g115_hdr.sub_type = 1; g115_hdr.total_left = g115_hdr.total_left - 9; g115_hdr.soh_offset = g115_hdr.soh_offset + 9; /* skip message */ go to END_FMT_CODE_CHECK; FMT_CODE_CHECK (3): /* service message, auxilliary field */ g115_hdr.msg_type = 1; g115_hdr.sub_type = 2; g115_hdr.aux_bit_count = 9; if bit (substr (g115_msg.text (g115_hdr.text_offset - 4), 7, 3)) = g115_stat.select then do; i = fixed (substr (g115_msg.text (g115_hdr.text_offset-2), 4, 6), 17); g115_data.write_split = aux_ctl (i).split; /* set split option */ g115_data.write_compress = aux_ctl (i).compress; /* set compression option */ end; g115_hdr.total_left = g115_hdr.total_left - 10; g115_hdr.soh_offset = g115_hdr.soh_offset + 10; /* skip message */ msg_len = 0; go to END_FMT_CODE_CHECK; FMT_CODE_CHECK (4): /* special control record; no split, no compression */ g115_hdr.read_split, g115_hdr.read_compression = "0"b; g115_hdr.msg_type = 2; g115_hdr.sub_type = 1; go to fcp7; FMT_CODE_CHECK (5): /* special control record; no split, compression */ g115_hdr.read_split = "0"b; g115_hdr.read_compression = "1"b; g115_hdr.msg_type = 2; g115_hdr.sub_type = 2; go to fcp7; FMT_CODE_CHECK (8): /* information message; no split, no compression */ g115_hdr.read_split, g115_hdr.read_compression = "0"b; g115_hdr.msg_type = 3; g115_hdr.sub_type = 1; go to fcp7; FMT_CODE_CHECK (9): /* information message; no split, compression */ g115_hdr.read_split = "0"b; g115_hdr.read_compression = "1"b; g115_hdr.msg_type = 3; g115_hdr.sub_type = 2; go to fcp7; FMT_CODE_CHECK (10): /* information message; split, no compression */ g115_hdr.read_split = "1"b; g115_hdr.read_compression = "0"b; g115_hdr.msg_type = 3; g115_hdr.sub_type = 3; go to fcp7; FMT_CODE_CHECK (11): /* information message; split, compression */ g115_hdr.read_split, g115_hdr.read_compression = "1"b; g115_hdr.msg_type = 3; g115_hdr.sub_type = 4; fcp7: g115_hdr.text_offset = g115_hdr.soh_offset + 7; go to END_FMT_CODE_CHECK; FMT_CODE_CHECK (1): /* error in fmt code */ FMT_CODE_CHECK (6): FMT_CODE_CHECK (7): error_type = 6; go to CHECK_RETURN; END_FMT_CODE_CHECK: if fmt_index < 4 then return; g115_hdr.soh_offset = g115_hdr.soh_offset + msg_len + 1; g115_hdr.total_left = g115_hdr.total_left - msg_len - 1; g115_hdr.text_char_count = msg_len - 8; enter1: temp_full_cc = 0; /* set text length */ do; /* service messages don't reach here */ if g115_hdr.text_char_count > 0 /* message contains text */ then if ^g115_hdr.read_split then do; /* message is not split */ if g115_msg.text (g115_hdr.text_offset) ^= g115_stat.bin_mc_char & g115_msg.text (g115_hdr.text_offset) ^= g115_stat.bcd_mc_char then do; /* first text char not media code */ error_type = 17; go to CHECK_RETURN; end; if g115_msg.text (g115_hdr.text_char_count + g115_hdr.text_offset - 1) ^= g115_stat.rs_char then do; error_type = 18; /* error, last text char not record separator */ go to CHECK_RETURN; end; last_char_was_rs = "1"b; /* had to be */ end; do i = 1 to g115_hdr.text_char_count; /* compute real text char count */ if g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.bcd_mc_char | g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.bin_mc_char then do; if last_char_was_rs then /* if was rs then dont count mc */ last_char_was_rs = "0"b; end; else /* char is not media code */ if last_char_was_rs then do; /* error, missing media code */ error_type = 19; go to CHECK_RETURN; end; if g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.rs_char then do; /* record separators don't count */ g115_hdr.last_rs = i; /* save position of last rs */ temp_full_cc = temp_full_cc + 80; last_char_was_rs = "1"b; /* remember */ end; end; if g115_hdr.last_rs = g115_hdr.text_char_count then g115_hdr.last_rs = 0; if g115_hdr.last_rs ^= 0 then do; /* check special case of prev last_rs */ if g115_hdr.text_offset = -6 then g115_hdr.last_rs = g115_hdr.last_rs - 7; end; g115_hdr.full_cc = temp_full_cc; /* set value in message slot */ end; CHECK_RETURN: if error_type ^= 0 then code = 1; /* some error in message */ return; end; end;  g115_util_.pl1 02/23/78 1042.6rew 02/23/78 1040.2 42831 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_util_: proc; /* utilities procedure for the g115 DCM */ /* coded 11/8/73 by Mike Grady */ /* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */ dcl a_ptr ptr, dev_index fixed bin, icode fixed bin (35), code fixed bin (35); dcl int_data_ptr ptr int static; dcl head_data_ptr ptr int static init (null); dcl null builtin; dcl (save_trim, loopsw) bit (1); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl 1 event_info aligned, /* wakeup information */ 2 channel_id fixed bin (71) aligned, /* channel over which to send wakeup */ 2 message char (8) aligned, /* event message */ 2 sender bit (36) aligned, /* process id of sending process */ 2 origin, 3 dev_signal bit (18) unaligned, /* ON if event occurred as result of i/o interrupt */ 3 ring bit (18) unaligned, /* sender's validation level */ 2 data_ptr ptr aligned; /* pointer to answer service data (answer table) */ dcl (acard, card varying, rcard varying) char (80), i fixed bin; dcl (lower_case init ("abcdefghijklmnopqrstuvwxyz"), upper_case init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") ) char (26) int static; dcl g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl error_table_$device_end fixed bin (35) ext, error_table_$net_timeout fixed bin (35) ext; %include g115_data; /* */ get_ptr: entry returns (ptr); /* entry to set the data_ptr */ return (int_data_ptr); /* thats it */ set_ptr: entry (a_ptr); /* entry to init the data_ptr */ int_data_ptr = a_ptr; /* copy to int static */ return; block: entry (code); data_ptr = int_data_ptr; call ipc_$block (addr (g115_data.wait_list), addr (event_info), code); if event_info.message = "alarm___" then code = error_table_$net_timeout; else code = 0; return; get_data_ptr: entry (dev_index) returns (ptr); /* entry to search the g115_data structure chain */ data_ptr = head_data_ptr; do while (data_ptr ^= null); if g115_data.twx = dev_index then return (data_ptr); /* found dev_index structure */ data_ptr = g115_data.next_data_ptr; /* advance to next structure */ end; return (null); /* no structure found for dev_index */ link_data_ptr: entry (a_ptr); /* entry to add a new g115_data structure to the chain */ data_ptr = a_ptr; g115_data.next_data_ptr = head_data_ptr; /* set forward link in chain */ head_data_ptr = data_ptr; return; unlink_data_ptr: entry (dev_index) returns (ptr); /* entry to remove g115_data structure from the chain */ data_ptr = head_data_ptr; do while (data_ptr ^= null); if g115_data.twx = dev_index then do; /* found dev_index structure */ if head_data_ptr = data_ptr /* head of chain */ then head_data_ptr = g115_data.next_data_ptr; /* must be adjusted */ else int_data_ptr -> g115_data.next_data_ptr = g115_data.next_data_ptr; /* preserve forward link */ return (data_ptr); end; int_data_ptr = data_ptr; data_ptr = g115_data.next_data_ptr; /* advance to next structure */ end; return (null); /* no structure found for dev_index */ conv_card: entry (rcard); /* entry to convert one card image to lower case and do backslash escape processing. also appends new_line */ save_trim = g115_data.trim; /* save trim mode */ g115_data.trim = "0"b; /* no trim wanted */ loopsw = "1"b; do while (loopsw); call g115_io_$read (g115_data.twx, addr (acard), 0, 80, i, icode); if icode ^= error_table_$device_end then loopsw = "0"b; end; g115_data.trim = save_trim; if g115_data.no_block & i = 0 then return; /* none yet */ i = 80 - verify (reverse (acard), " ") + 1; /* find first non blank */ card = substr (acard, 1, i); /* copy interesting part of card */ card = translate (card, lower_case, upper_case); /* change all upper case to lower */ i = index (card, "\"); /* look for upper case escapes */ do while (i > 0); /* loop processing all of them */ card = substr (card, 1, i-1) || translate (substr (card, i+1, 1), upper_case, lower_case) || substr (card, i+2); /* copy card dropping "\" and changeing char */ i = index (card, "\"); /* look for next one */ end; rcard = card || " "; /* copy to return arg, adding nl */ return; end;  g115_output_request_.pl1 02/23/78 1042.6rew 02/23/78 1040.3 320985 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ g115_output_request_: proc (a_stream_name, a_element_size, a_stat_p, a_banner_proc, a_code); /* General procedure for doing output for an I/O daemon device driver */ /* Rewritten from old procedure "io_daemon" in August 1973 by Robert S. Coren */ /* Modified in March 1975 by J.C. Whitmore during driver restructuring */ /* Modified in December 1975 by M. A. Braida to include new restart capabilities and update the accounting mechanism */ /* modified 05/76 by THVV for set_kst_attributes & force deactivation */ /* Modified 06/76 by J. C. Whitmore to fix translate hardware bug */ /* Modified June 1976 by J. L. Homan to accommodate charging by line count instead of block count. */ /* modified July 1976 by THVV for message notification */ /* modified April 1977 by Bob Franklin to output request message to slave */ dcl a_stream_name char (*); /* stream to write the output on */ dcl a_element_size fixed bin; /* number of bits in each stream element */ dcl a_stat_p ptr; /* the value of stat_p from caller */ dcl a_banner_proc entry; /* procedure to be called for head and tail banners */ dcl a_code fixed bin (35); /* error code....used for driver_fatal_error */ /* AUTOMATIC */ dcl abort_msg char (256) var; /* string for bad error messages */ dcl access_class bit (72) aligned; /* access class of user file */ dcl auth bit (72) aligned; /* authorization used to set banner access class */ dcl auth_string char (680); /* string form of auth */ dcl banner_proc entry variable options (variable); /* proc to be called for messages */ dcl bitcnt fixed bin (24); dcl code fixed bin (35); dcl curl fixed bin (24); dcl errlen fixed bin; dcl fac fixed bin; dcl l fixed bin; dcl mode fixed bin (5); dcl more_components bit (1) aligned; /* we expect more MSF components */ dcl mult_ind fixed bin; dcl mult_no fixed bin (24); dcl new_clock fixed bin (71); dcl new_cpu fixed bin (52); dcl new_pp fixed bin; dcl new_waits fixed bin (35); dcl old_cpu fixed bin (52); dcl old_pp fixed bin; dcl old_waits fixed bin (35); dcl save_code fixed bin (35); dcl tpe fixed bin (2); dcl val fixed bin; /* for validation level */ dcl (lng2, nelt, nret) fixed bin; dcl dest char (12) aligned; dcl ename char (32) aligned; /* entry name of file for output */ dcl mailname char (32) aligned; dcl err_mess char (200) var; dcl full_path char (168) aligned; dcl gt char (1); /* > for directory names */ dcl header_found bit (1); dcl header_sw bit (1); dcl last char (20); dcl mes_space char (100) aligned; dcl msf_sw bit (1) aligned; dcl pverb char (5) aligned ; dcl req_stream char (32); dcl short_mes char (8) aligned; dcl status bit (72) aligned; /* error code returned by i/o system */ dcl user_dir char (168) aligned; /* directory containing users' segment */ dcl (tailsw, chgsw) bit (1) aligned; /* indicate whether to print out a tail sheet, or to charge */ dcl comp_dir char (168) aligned; /* MSF component directory name */ dcl comp_name char (32) aligned; /* entry name of the MSF component */ dcl dir_len fixed bin; /* length of component directory name */ dcl segp ptr; dcl fcbp ptr; dcl desc_ptr ptr; dcl dr_ptr ptr; /* pointer to driver status segment */ dcl driver_data_p ptr; /* INTERNAL STATIC */ dcl bits_per_page fixed bin int static options (constant) init (36864); dcl header fixed bin int static options (constant) init (1); /* value for header wanted */ dcl tail fixed bin int static options (constant) init (2); /* value for tail wanted */ dcl error_msg fixed bin int static options (constant) init (3); /* value for print error message */ dcl stars char (40) int static options (constant) aligned init ((40)"*"); /* For error messages */ dcl privileged bit (1) static init ("1"b); /* TRUE if we can call hphcs_ */ dcl first_call bit (1) static init ("1"b); /* TRUE on first call */ dcl fault_mess char (32) aligned int static; dcl fault_name char (32) aligned int static; dcl err_label label int static; /* point of return from condition handler */ dcl request_data_p ptr int static; /* ptr to REQUEST for set_single_copy entrry */ dcl NL char (1) int static options (constant) init (" "); dcl tab_nl_vt_ff char (4) int static options (constant) init (" "); /* ht, nl, vert tab and form feed chars */ /* EXTERNAL STATIC */ dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$dirseg ext static fixed bin (35); dcl error_table_$ai_restricted ext static fixed bin (35); /* EXTERNAL ENTRIES */ dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl check_fs_errcode_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl clock_ ext entry returns (fixed bin (71)); /* gets clock time */ dcl com_err_ entry options (variable); dcl convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl cpu_time_and_paging_ entry (fixed bin (35), fixed bin (52), fixed bin); dcl date_time_ entry (fixed bin (71), char (*) aligned); dcl hphcs_$set_kst_attributes entry (fixed bin, ptr, fixed bin (35)); dcl phcs_$deactivate entry (ptr, fixed bin (35)); dcl hcs_$fs_get_mode ext entry (ptr, fixed bin (5), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)); dcl hcs_$get_access_class entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin, ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl io_daemon_account_ entry (ptr, ptr); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ios_$order entry (char (*), char (*), ptr, bit (72) aligned); dcl ios_$write entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl read_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl send_mail_$access_class entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned, fixed bin (35)); /* BASED VARIABLES */ dcl fbpart fixed bin (35) based (addr (status)); /* STRUCTURES */ dcl 1 bla aligned, /* Info returned by status & status_long */ 2 (type bit (2), nnames bit (16), nrp bit (18)) unal, 2 (dtm, dtu) bit (36), 2 (mode bit (5), pad1 bit (13), records bit (18)) unal, 2 (dtd, dtem, acct) bit (36), 2 (curlen bit (12), bitcnt bit (24)) unal, 2 ((did, mdid) bit (4), copysw bit (1), pad2 bit (9), rbs (0:2) bit (6)) unal, 2 uid bit (36); dcl 1 ksta like kst_attributes aligned; dcl 1 print_driver_data aligned based (driver_data_p), /* defines driver data of request_descriptor */ 2 copies_done fixed bin (17) unal, /* number of copies already printed */ 2 copies_charged fixed bin (17) unal, /* number of copies already charged */ 2 pad fixed bin; dcl 1 counts aligned, /* Structure returned by "get_count" order */ 2 curline fixed bin, 2 maxline fixed bin, 2 indent fixed bin, 2 page_width fixed bin, 2 line_count fixed bin, 2 page_count fixed bin; /* BUILTINS */ dcl (addr, bit, divide, fixed, length, null, substr, verify, reverse, translate) builtin; dcl (baseno, binary, string, unspec) builtin; /* CONDITIONS */ dcl (cleanup, linkage_error, daemon_again, daemon_again_slave, daemon_kill, daemon_cancel) condition; /* INCLUDE FILES */ %include output_request_data; %include driver_status; %include mseg_return_args; %include dprint_msg; %include request_descriptor; %include iodd_static; %include kst_attributes; %include send_mail_info; /* */ /* copy arguments and initialize pointers and control switches */ stat_p = a_stat_p; string (ksta) = "0"b; if first_call then do; /* Conduct an experiment to see about hphcs_ */ on linkage_error begin; privileged = "0"b; go to tough; end; call hphcs_$set_kst_attributes (binary (baseno (stat_p), 18), addr (ksta), (0)); /* This is a NOP - structure is 0 */ tough: revert linkage_error; /* If we get here we are privileged */ first_call = "0"b; /* Now we know */ ksta.set.tpd, ksta.value.tpd = "1"b; /* Dont put on bulkstore just for lil ole me */ ksta.set.explicit_deactivate_ok, ksta.value.explicit_deactivate_ok = "1"b; ksta.set.allow_write = "1"b; /* Dont let me wreck user seg by accident */ ksta.set.tus, ksta.value.tus = "1"b; /* Save a vtoc write */ end; banner_proc = a_banner_proc; req_stream = a_stream_name; fac = a_element_size; a_code = 0; /* set to zero for now */ dr_ptr = iodd_static.driver_ptr; /* get ptr to the current driver status seg */ desc_ptr = addr (dr_ptr -> driver_status.descriptor); /* and to the request descriptor */ ms_arg_ptr = desc_ptr; /* first part of desciptor is ms_return_args */ dmp = addr (dr_ptr -> driver_status.message); /* set dprint_msg default pointer */ request_data_p = addr (REQUEST); /* get ready to handle "single copy" request */ driver_data_p = addr (desc_ptr -> request_descriptor.driver_data); /* get ptr to printer_driver_data */ on cleanup call clean_proc; /* establish a cleanup handler */ err_label = abort_request; /* Set up master structure used by this pgm. */ REQUEST.requestor = mseg_return_args.sender_id; REQUEST.continued = desc_ptr -> request_descriptor.continued; REQUEST.restarted = desc_ptr -> request_descriptor.restarted; REQUEST.separator = "1"b; /* we always want a print separator first time */ REQUEST.device_name = dr_ptr -> driver_status.dev_name_label; REQUEST.request_type = dr_ptr -> driver_status.req_type_label; REQUEST.queue = desc_ptr -> request_descriptor.q; REQUEST.request_no = desc_ptr -> request_descriptor.seq_id; /* coord assigned the number */ REQUEST.restart_no = desc_ptr -> request_descriptor.prev_seq_id; /* previous number of request (0 = not restarted) */ REQUEST.contd_no = desc_ptr -> request_descriptor.contd_seq_id; /* previous number of continued request (0 = not continued) */ REQUEST.dpmp = dmp; REQUEST.delete = dprint_msg.delete_sw; if ^REQUEST.continued then print_driver_data.copies_done = 0; /* no copies assumed, unless continued */ /* if none completed, it's not continued */ else if print_driver_data.copies_done < 1 then REQUEST.continued = "0"b; REQUEST.copies = dprint_msg.copies; REQUEST.notify = (dprint_msg.notify = 1); REQUEST.total_charge = 0e0; l = length (REQUEST.requestor) + 1 - 2 - verify (reverse (REQUEST.requestor), " "); mailname = substr (REQUEST.requestor, 1, l); unspec (send_mail_info) = "0"b; send_mail_info.version = 1; send_mail_info.wakeup = "1"b; send_mail_info.always_add = "1"b; send_mail_info.sent_from = REQUEST.request_type; if dprint_msg.output_module = 1 then do; REQUEST.punsw = 0; pverb = "print"; end; else do; REQUEST.punsw = 1; pverb = "punch"; end; /* Find the access class to use for the banner */ if aim_check_$greater (mseg_return_args.sender_authorization, dr_ptr -> driver_status.min_banner) then auth = mseg_return_args.sender_authorization; else auth = dr_ptr -> driver_status.min_banner; /* mark the output with auth */ call convert_authorization_$to_string (auth, auth_string, code); /* get string form */ if code ^= 0 then call fatal_error; /* this is real bad */ l = 681 - verify (reverse (auth_string), " "); /* how long is the string */ if l < 681 then /* quick test for blank string */ if l > 132 then do; /* too long for normal output..check for short form */ call convert_authorization_$from_string (access_class, "system_high", code); if code ^= 0 then call fatal_error; if aim_check_$equal (auth, access_class) then auth_string = "SYSTEM HIGH"; /* this is shorter */ end; REQUEST.access_class_string = auth_string; /* save all we can for the label */ /* get pathname of file for header and error messages */ user_dir = dprint_msg.dirname; ename = dprint_msg.ename; if substr (user_dir, 1, 4) = "> " then gt = " "; else gt = ">"; call ioa_$rsnnl ("^a^a^a", full_path, lng2, user_dir, gt, ename); REQUEST.full_path = translate (full_path, "", tab_nl_vt_ff); /* force a page fault on the table - HARDWARE BUG WRITEAROUND */ full_path = translate (full_path, "", tab_nl_vt_ff); /* remove bad chars for banner */ dprint_msg.destination = translate (dprint_msg.destination, "", tab_nl_vt_ff); dprint_msg.heading = translate (dprint_msg.heading, "", tab_nl_vt_ff); REQUEST.full_path = full_path; /* save the clean copy */ segp, fcbp = null; /* ready for an early restart */ REQUEST.line_count = 0; REQUEST.page_count = 0; /* we now know enough to be able to restart this request if desired */ repr_start: header_found, header_sw, msf_sw = "0"b; tailsw, chgsw = "0"b; /* initialize accounting switches */ old_cpu, bitcnt, nelt = 0; /* just in case they get used before being set */ REQUEST.time_start_request = clock_ (); call date_time_ (REQUEST.time_start_request, REQUEST.date_time_start_request); REQUEST.cpu_time = 0; /* reset the usage data */ REQUEST.real_time = 0; REQUEST.page_waits = 0; REQUEST.pre_pages = 0; REQUEST.bit_count = 0; REQUEST.charge = 0e0; REQUEST.copy_no = print_driver_data.copies_done + 1; /* initialize copy-counter */ REQUEST.output_mode = ""; header_found = "1"b; /* we now have enough info to print a head/tail banner */ on daemon_again begin; /* to restart the current request.... */ call restart_request ("master"); /* talking to master terminal */ go to repr_start; end; on daemon_again_slave begin; /* to restart the current request.... */ call restart_request ("slave"); /* talking to slave terminal */ go to repr_start; end; on daemon_kill go to flush_request; /* flush the current request */ on daemon_cancel go to flush_request; /* likewise, the cancelled flag has been set */ iodd_static.request_in_progress = "1"b; /* ready to accept kill, cancel etc. */ call clean_proc; /* see if we need to terminate after restart */ err_mess = ""; /* no message until it is set */ header_sw = "0"b; /* so we'll get header now and on reprint */ /* record the event of processing this request */ if REQUEST.separator then do; /* only have to log the request once */ dest = dprint_msg.destination; /* keep this locally */ if dest = "" then last = ""; /* set up "destination" part of log msg */ else call ioa_$rsnnl (" (to ^a)", last, l, dest); if iodd_static.slave.active then do; /* tell slave */ call ioa_$ioa_stream (iodd_static.slave_output, "Request ^d.^d: ^a", REQUEST.request_no, REQUEST.queue, pverb); call ioa_$ioa_stream (iodd_static.slave_output, " ^a ", full_path); call ioa_$ioa_stream (iodd_static.slave_output, " for ^a^a", REQUEST.requestor, last); end; call ioa_$ioa_stream (iodd_static.log_stream, "Request ^d.^d: ^a ^a for ^a^a", REQUEST.request_no, REQUEST.queue, pverb, full_path, REQUEST.requestor, last); end; call cpu_time_and_paging_ (old_waits, old_cpu, old_pp); /* keep time and page waits for accounting */ /* check the requestor's access to the pathname he specified */ val = mseg_return_args.level; call check_user_access (user_dir, ename, code); /* use the internal proc to do the work */ if code ^= 0 then call fatal_error; /* it won't return to here */ err_mess = full_path; /* let this sit here in case of error */ call hcs_$status_minf (user_dir, ename, 1, tpe, mult_no, code); /* see what kind of a thing it is */ if code ^= 0 then call fatal_error; if tpe = 2 then /* directory */ if mult_no < 1 then do; /* it was a directory */ code = error_table_$dirseg; call fatal_error; end; else do; /* it is a multi_segment file - handle different */ call msf_manager_$open (user_dir, ename, fcbp, code); if code ^= 0 then do; err_mess = "Could not open multi-segment file "||full_path; call fatal_error; end; msf_sw = "1"b; /* indicate that it is an MSF */ end; else do; /* it is an ordinary segment */ call hcs_$initiate_count (user_dir, ename, "", bitcnt, 1, segp, code); if segp = null then do; err_mess = "Cannot initiate "||full_path; call fatal_error; end; msf_sw = "0"b; /* it is not an MSF, make it clear */ if privileged /* If we can be nice, we will */ then call hphcs_$set_kst_attributes (binary (baseno (segp), 18), addr (ksta), (0)); end; /* Now we are ready to output the number of copies the user requested. */ /* The structure of the loop and internal procedures is set to handle */ /* different access and bitcounts per MSF component. */ do while (REQUEST.copies >= REQUEST.copy_no); /* once around for each copy */ call banner_proc (req_stream, header, addr (REQUEST), code); /* print header banner */ if code ^= 0 then do; /* I/O error trying to print header */ call driver_fatal_error (code, "I/O ERROR -- trying to print header."); go to clean_out; /* abort this request completely */ end; REQUEST.separator = "0"b; /* separator bar was for first banner only */ header_sw, tailsw = "1"b; /* header was ok, do tail */ more_components = "1"b; /* get ready for MSF components of this copy */ /* The banner_proc set the user's output modes based on REQUEST.dpmp ... we just write the stream as it stands */ if ^msf_sw then do; /* the normal case is the segment */ call output_segment (user_dir, ename, segp); /* internal proc does the work */ end; else do mult_ind = 0 by 1 while (more_components); /* MSF - go through each component starting with 0 */ call msf_manager_$get_ptr (fcbp, mult_ind, "0"b, segp, bitcnt, code); if segp = null then do; if code = error_table_$noentry then more_components = "0"b; /* we are done */ else do; /* try for more after other errors */ call ioa_$rsnnl ("Could not get pointer to ^a>^d", err_mess, errlen, full_path, mult_ind); call error_write (code, err_mess); more_components = "1"b; /* just to be safe */ end; go to next_component; end; /* we got a pointer to something...where is it */ /* and does the requestor have access to it? */ call hcs_$fs_get_path_name (segp, comp_dir, dir_len, comp_name, code); if code ^= 0 then do; err_mess = "Could not get MSF component pathname."; call error_write (code, err_mess); go to next_component; end; call check_user_access (comp_dir, comp_name, code); if code ^= 0 then do; /* he tried to pull a fast one and got caught */ err_mess = err_mess || " " || substr (comp_dir, 1, dir_len) || ">" || comp_name; call error_write (code, err_mess); /* most of err_mess was set by check_user_access */ end; else do; /* He made it through the obstacles */ if privileged /* .. do it (gently if possible) */ then call hphcs_$set_kst_attributes (binary (baseno (segp), 18), addr (ksta), (0)); call output_segment (comp_dir, comp_name, segp); if privileged then call phcs_$deactivate (segp, (0)); end; next_component: end; /* look for the next MSF component */ if REQUEST.copies > print_driver_data.copies_charged then do; /* user honestly deserves these charges */ chgsw = "1"b; print_driver_data.copies_charged = print_driver_data.copies_charged + 1; end; else chgsw = "0"b; call charge_for_work; /* do the accounting so we can put price on tail */ call banner_proc (req_stream, tail, addr (REQUEST), code); /* this will put on the tail banner */ if code ^= 0 then do; /* some type of error..don't do it again */ call driver_fatal_error (code, "I/O ERROR -- attempting to write tail banner."); go to clean_out; end; print_driver_data.copies_done = print_driver_data.copies_done + 1; REQUEST.copy_no = REQUEST.copy_no + 1; /* get ready for next copy */ REQUEST.time_start_request = new_clock; /* from accounting */ old_cpu = new_cpu; old_waits = new_waits; old_pp = new_pp; REQUEST.bit_count = 0; /* restart bit count */ header_sw, tailsw = "0"b; call ios_$order (req_stream, "runout", null, status); /* make device disgorge */ end; /* done with this copy...check for more in while loop */ if REQUEST.notify then do; call ioa_$rsnnl ("^aed ^a $^.2f queue ^d ^a ^d", abort_msg, l, pverb, REQUEST.full_path, REQUEST.total_charge, REQUEST.queue, REQUEST.device_name, REQUEST.request_no); call send_mail_$access_class (mailname, substr (abort_msg, 1, l), addr (send_mail_info), mseg_return_args.sender_authorization, code); end; clean_out: /* get ready for the next users' request */ call ios_$order (req_stream, "runout", null, status); /* make device disgorge */ call clean_proc; /* get junk out of the address space */ iodd_static.request_in_progress = "0"b; /* no more commands can be effective */ return; /* =================================================================================== */ /* This is where the condition handlers "go to" when something has gone wrong */ flush_request: /* signal handler jumps back here */ fault_name = "Operator aborted listing"; /* message for kill and cancel */ abort_request: /* unclaimed signals transfer to here */ if fault_name = "seg_fault_error" & iodd_static.segptr = segp then chgsw = "1"b; /* if user causes the fault then charge him for work */ else chgsw = "0"b; if REQUEST.delete ^= 0 then fault_mess = "; segment will not be deleted"; else fault_mess = ""; desc_ptr -> request_descriptor.dont_delete = "1"b; /* like we said */ call ioa_$rsnnl ("^a during processing of request^a.", err_mess, l, fault_name, fault_mess); code = 0; call fatal_error; /* this will clean things up a bit */ go to clean_out; /* fatal_error will actually make the transfer */ /* */ /* ***** INTERNAL PROCEDURES ***** */ charge_for_work: proc; /* Accounting section, done at end of processing each copy of output. */ counts.line_count = 0; /* Clear these items so that if the order is unknown.. */ counts.page_count = 0; /* .. (like if card dim doesn't do them) we still go */ call ios_$order (req_stream, "get_count", addr (counts), status); new_clock = clock_ (); call cpu_time_and_paging_ (new_waits, new_cpu, new_pp); if counts.line_count > 0 then REQUEST.line_count = counts.line_count; else REQUEST.line_count = divide (REQUEST.bit_count+699, 700, 24, 0); /* Use block count if dim returns zero line count */ REQUEST.page_count = counts.page_count; if REQUEST.time_start_request = 0 | old_cpu = 0 then go to no_charge; /* don't give huge erroneous times */ if chgsw then do; /* charge him */ REQUEST.cpu_time = new_cpu - old_cpu; /* REQUEST.bit_count was set when chgsw was */ REQUEST.real_time = new_clock - REQUEST.time_start_request; REQUEST.page_waits = fixed (new_waits - old_waits, 35); REQUEST.pre_pages = fixed (new_pp - old_pp, 35); call io_daemon_account_ (dr_ptr -> driver_status.acct_ptr, addr (REQUEST)); end; else do; /* tell user he wasn't charged */ no_charge: REQUEST.charge = 0e0; /* reset any undefined values */ REQUEST.cpu_time = 0; REQUEST.real_time = 0; REQUEST.page_waits = 0; REQUEST.pre_pages = 0; end; REQUEST.total_charge = REQUEST.total_charge + REQUEST.charge; return; end charge_for_work; /* ======================================================================================== */ check_user_access: proc (user_dir, ename, ec); /* Internal procedure to check that the requestor has at least "r" access to the specified segment */ dcl user_dir char (*) aligned; dcl ename char (*) aligned; dcl code fixed bin (35); dcl ec fixed bin (35); call hcs_$get_user_effmode (user_dir, ename, REQUEST.requestor, val, mode, code); if code ^= 0 then do; err_mess = "Unable to get user's mode to segment."; ec = code; return; end; if (bit (mode, 5) & "01000"b) = "0"b then do; err_mess = "User does not have read access on segment."; ec = error_table_$moderr; return; end; call hcs_$get_access_class (user_dir, ename, access_class, code); if code ^= 0 then do; err_mess = "Unable to get access class of segment."; ec = code; return; end; if ^ read_allowed_ (mseg_return_args.sender_authorization, access_class) then do; ec = error_table_$ai_restricted; err_mess = "User not allowed to read segment."; return; end; ec = 0; /* ok, user passed the checks */ return; end check_user_access; /* ======================================================================================== */ fatal_error: proc; /* This is an internal procedure only to make the flow of control cleaner in the main procedure. */ save_code = code; /* keep current error for reporting */ if ^header_sw & header_found then do; call banner_proc (req_stream, header, addr (REQUEST), code); if code = 0 then header_sw, tailsw = "1"b; /* all was well */ else header_sw, tailsw = "0"b; /* just to be sure */ end; call error_write (save_code, err_mess); call ioa_$ioa_stream (iodd_static.log_stream, "Processing of request terminated."); if iodd_static.slave.active then if iodd_static.slave.print_errors then call ioa_$ioa_stream (iodd_static.slave_output, "Processing of request terminated."); desc_ptr -> request_descriptor.dont_delete = "1"b; /* make sure we don't delete msf */ if tailsw then do; /* if we owe a tail banner, do it */ call charge_for_work; /* charge for good part that may have been done */ call banner_proc (req_stream, tail, addr (REQUEST), code); end; go to clean_out; /* we'll stop rather than returning */ end fatal_error; /* =========================================================================================== */ error_write: proc (code, message); /* for writing error messages to console & request stream */ dcl code fixed bin (35); dcl message char (*) varying; if code ^= 0 then call check_fs_errcode_ (code, short_mes, mes_space); else mes_space = ""; call ioa_$ioa_stream (iodd_static.log_stream, "io_daemon: ^a ^a", mes_space, message); call ioa_$rsnnl ("Unable to ^a ^a. ^a ^a", abort_msg, l, pverb, REQUEST.full_path, mes_space, message); call send_mail_$access_class (mailname, substr (abort_msg, 1, l), addr (send_mail_info), mseg_return_args.sender_authorization, (0)); if iodd_static.slave.active then if iodd_static.slave.print_errors then call ioa_$ioa_stream (iodd_static.slave_output, "io_daemon: ^a ^a", mes_space, message); if header_sw then do; /* if banner_proc does a "reset" line and page count is lost */ call ioa_$rsnnl ("^2/^a^/io_daemon: ^a ^a^/^a^|", abort_msg, l, stars, mes_space, message, stars); call banner_proc (req_stream, error_msg, addr (abort_msg), code); /* put out error msg to media */ end; return; end error_write; /* =============================================================================================== */ driver_fatal_error: proc (code, err_msg); /* Internal procedure to print messages when there is an IO error on the output stream */ dcl code fixed bin (35); dcl err_msg char (*); call com_err_ (code, "io_daemon", "^a ^/ Driver returning to command level.", err_msg); desc_ptr -> request_descriptor.dont_delete = "1"b; /* give a reprieve....in case */ a_code = code; /* report driver_fatal_error */ return; end driver_fatal_error; /* ======================================================================================== */ output_segment: proc (user_dir, ename, segp); /* This internal procedure checks the Daemon's access to the segment, then calculates the length as determined by bitcount and current length, then data is written. */ dcl user_dir char (*) aligned; dcl ename char (*) aligned; dcl segp ptr; iodd_static.segptr = segp; /* tell signal handler what segment we are using */ call hcs_$fs_get_mode (segp, mode, code); /* make sure daemon has access */ if code ^= 0 then do; err_mess = "I/O Daemon does not have access to segment."; call error_write (code, err_mess); REQUEST.copies = 1; /* don't do it again */ return; end; if (bit (mode, 5) & "01000"b) = "0"b then do; err_mess = "I/O daemon does not have read access on segment."; call error_write (0, err_mess); REQUEST.copies = 1; /* don't allow the error to be repeated */ return; end; /* find the current segment length in pages and in bits */ call hcs_$status_long (user_dir, ename, 1, addr (bla), null, code); if code ^= 0 then do; err_mess = "I/O Daemon cannot get length of segment."; call error_write (code, err_mess); REQUEST.copies = 1; /* don't do it again */ return; end; bitcnt = fixed (bla.bitcnt); /* relevant bits according to the user */ curl = fixed (bla.curlen, 12)*bits_per_page; /* calculate the current length in bits */ if bitcnt > curl then /* excess would be \000 anyway */ bitcnt = curl; /* we use this value for accounting */ nelt = divide (bitcnt, fac, 17, 0); /* see now many elements to write on the req_stream */ if nelt = 0 then do; code = 0; call ioa_$rsnnl ("^a>^a is a zero length segment.", err_mess, l, user_dir, ename); call error_write (code, err_mess); REQUEST.copies = 1; /* as said before */ return; end; REQUEST.bit_count = REQUEST.bit_count + bitcnt; /* update the amount of output */ call ios_$write (req_stream, segp, 0, nelt, nret, status); /* This is the actual output of segment */ if fbpart ^= 0 then do; /* I/O error */ call driver_fatal_error (fbpart, "I/O ERROR -- during user segment output."); go to clean_out; end; return; end output_segment; /* ======================================================================================== */ restart_request: proc (source); /* internal procedure used to question operator regarding the restart of current request */ dcl answer char (120); dcl cnt_msg char (10); /* space to specify a continued request */ dcl copies_good fixed bin (35); /* operator response to number of good copies */ dcl (input_stream, output_stream) char (32); dcl io_stat bit (72) aligned; dcl 1 st aligned based (addr (io_stat)), 2 code fixed bin (35), 2 junk bit (36); dcl pg_count_msg char (30); /* space to specify pages per copy */ dcl restrt_msg char (30); /* space that the request is to be restarted */ dcl source char (*); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); /* set up input/output stream for the master terminal */ if source = "master" then do; input_stream = iodd_static.input_stream; output_stream = "user_output"; end; /* set up input/output stream for the slave terminal */ else do; input_stream = iodd_static.slave.slave_input; output_stream = iodd_static.slave.slave_output; end; /* is there a need to query the operator? */ if REQUEST.punsw = 1 | print_driver_data.copies_done = 0 | REQUEST.copies = 1 then do; restrt_msg = ""; REQUEST.separator = "1"b; print_driver_data.copies_done = 0; end; else do; /* must query operator */ if REQUEST.page_count > 0 then /* is there a non zero page count? */ call ioa_$rsnnl (" (^d pages each)", pg_count_msg, nret, REQUEST.page_count); else pg_count_msg = ""; if REQUEST.continued then /* is this a continued request? */ cnt_msg = " (continued request)"; else cnt_msg = ""; ask_how_many_good: /* tell operator how many were done */ call ioa_$ioa_stream (output_stream, "^d of ^d copies^a were done^a. How many were good?", print_driver_data.copies_done, REQUEST.copies, pg_count_msg, cnt_msg); /* now let's see what the operator tells us */ call ios_$read (input_stream, addr (answer), 0, 10, nelt, io_stat); if st.code ^= 0 then do; copies_good = 0; go to tell_operator; end; if substr (answer, nelt, 1) = NL then answer = substr (answer, 1, nelt - 1); copies_good = cv_dec_check_ (answer, st.code); if st.code ^= 0 then do; /* was the answer a number? */ bad_no: call ioa_$ioa_stream (output_stream, "Please specify a number between 0 and ^d", print_driver_data.copies_done); go to ask_how_many_good; end; if copies_good < 0 | copies_good > print_driver_data.copies_done then go to bad_no; tell_operator: print_driver_data.copies_done = copies_good; /* update the record of finished copies */ if copies_good = 0 then REQUEST.separator = "1"b; call ioa_$rsnnl (" from copy number ^d", restrt_msg, nret, copies_good + 1); end; call ioa_$ioa_stream (output_stream, "Restarting request^a.", restrt_msg); return; end restart_request; /* ======================================================================================== */ clean_proc: proc; iodd_static.segptr = null; /* tell signal handler we are done with it */ if fcbp ^= null then call msf_manager_$close (fcbp); else if segp ^= null then do; if privileged then call phcs_$deactivate (segp, (0)); call hcs_$terminate_noname (segp, code); end; segp, fcbp = null; /* because this is used for several functions */ return; end clean_proc; error_during_request: entry (cond); /* for coming back after signal */ dcl cond char (*); fault_name = cond; go to err_label; set_single_copy: entry; /* to abort multiple copies if the single command must be used */ request_data_p -> ordata.copies = 1; /* make it fall out of the loop after tail sheet */ return; end g115_output_request_; 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