isolts_.pl1 10/14/88 1324.3r w 10/14/88 1311.0 455607 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ isolts_: proc; /* isolts_ - the I_S_olated O_nL_ine T_est S_ystem (ISOLTS) driver initially coded by James A. Bush 6/78 Modified 09/80 by R. Fakoury to make the operator message more understandable, to correct a bug when displaying the last error, to request input after invalid responce, to add a delay between operator request reconfig messages and to force the end pass message to the terminal. Modified 8102 by R. Fakoury to allow margin/nomargin options and to add the display_error in the initial request. Modified 8112 by R. Fakoury to correct an oversight in the operator message sequence, to add new numbers to inv_tst_ids. Modified 02/04/83 by R. Fakoury to add new test ids to the invalid test list. Modified 03/83 by R. Fakoury to allow -type option to the display request and the type option to a pas option request. Also put temp cludge to increase the timeout time for prg892/893. Modified 03/83 by Rick Fakoury to add call to tolts_util_$get_ttl_date, and tolts_util_$opr_msg. Modified 03/83 by Rick Fakoury to remove the (non_quick) option from interpret_action and run_pas. Modified 08/17/83 by Rick Fakoury to allow partial config printing & correct an error in display error of one. Modified 09/21/83 by R. Fakoury to check for a config card with no cpu type and to modify dps8 reconfig instructions. Modified 10/83 by R.Fakoury to implement auditor suggested changes. Modified 11/84 by R. Fakoury to changes the call from tolts_pcd_$config to tolts_util_$find_card, make tst893 invalid, and to use the system includes files for cpu. */ /* External entries */ dcl tolts_util_$get_ttl_date entry (entry, char (6)); dcl tandd_$check_isolts_resources entry (fixed bin (5), fixed bin (5), fixed bin (5), fixed bin (35)); dcl tandd_$create_cpu_test_env entry (fixed bin (5), fixed bin (5), (4) bit (36), ptr, fixed bin (35)); dcl tandd_$destroy_cpu_test_env entry; dcl tandd_$interrupt_test_cpu entry (fixed bin (35)); dcl tolts_pcd_ entry (char (6), char (*)); dcl tolts_util_$find_card entry (char (4), ptr); dcl tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin); dcl tolts_util_$config entry (char (4), ptr, char (*) varying); dcl tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin); dcl tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35)); dcl tolts_util_$on_off entry (char (6), char (3), char (6)); dcl tolts_util_$opr_msg entry; dcl isolts_err_log_$init entry (fixed bin (35)); dcl isolts_err_log_$write entry (ptr, fixed bin, fixed bin, fixed bin (5), fixed bin (5)); dcl isolts_err_log_$display entry (fixed bin, fixed bin, bit (1)); dcl isolts_err_log_$dump entry (char (5), ptr, fixed bin (18), fixed bin, fixed bin (5), fixed bin (5)); dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin (18), fixed bin (18), bit (*)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl bcd_to_ascii_ entry (bit (*), char (*)); dcl tolts_alm_util_$ascii_to_bci_ entry (char (*) aligned, bit (*)); dcl continue_to_signal_ entry (fixed bin (35)); dcl (ioa_, signal, com_err_, ioa_$rsnnl, ioa_$nnl, opr_query_) entry options (variable); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); /* Automatic */ dcl code fixed bin (35); /* standard system error code */ dcl (cpu_tag, scu_tag, cpu_port) fixed bin (5); /* cpu and scu tags */ dcl switches (4) bit (36); /* read switch descrepency data */ dcl bf_sw bit (1) init ("0"b); /* brief option switch */ dcl (nxt_tst, new_tst) char (3); /* next test id for search */ dcl cpu_type char (4); dcl (term, trm, trm1, pas_sw, mess_in_prog, ntype, run, option, trace_sw, dump_in_prog, idump, car_nz) bit (1) init ("0"b); dcl out_str char (136) varying; dcl com_string char (132) aligned; dcl add_opt char (6); dcl tim char (12); dcl delay_iter fixed bin init (300); dcl ttl_date char (6); dcl d_type char (5); dcl args (32) char (28) varying; dcl (pgm_offset, first, last) fixed bin (18); dcl (cmd_cnt, delay, i, j, k, c_len, bcd_chars, mtype, mlen, count, limit) fixed bin; dcl (pip, wseg_p, t_ptr, awcp, mptr, hdr_p) ptr; /* Constants */ dcl (quit, cleanup, finish) condition; dcl pname char (6) static options (constant) init ("isolts"); dcl tags (0:7) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl first_pft char (3) static options (constant) init ("01c"); dcl pas_exec char (3) static options (constant) init ("061"); dcl inv_tst_ids (22) char (3) static options (constant) init ("781", "782", "783", "784", "891", "894", "895", "897", "899", "908", "920", "921", "922", "923", "924", "927", "928", "929", "930", "975", "980", "990"); dcl illegal_pas_opt (2) char (8) varying static options (constant) init ("cardin", "i/o"); dcl NL char (1) int static options (constant) init (" "); dcl pas_delay fixed bin static options (constant) init (2); dcl pft_delay fixed bin static options (constant) init (2); dcl p_err bit (1) int static init ("1"b); /* print error flag */ dcl df_iocbp ptr int static init (null); /* deck file iocb ptr */ dcl isolate_cpu bit (1) int static; /* cleanup flag */ dcl (cont_pas, restart, end_pas, eopt) label; /* target of non_local gotos */ dcl iox_$user_output ptr ext; dcl (addr, addrel, fixed, hbound, index, length, ltrim, mod, null, ptr, rel, rtrim, search, string, substr, time) builtin; /* Structures and based variables */ dcl 1 wseg based (wseg_p) aligned, /* structure definition of PAS2 layout */ 2 int_vectors (0:31) bit (72), /* 0 - 77 interrupt vectors */ 2 flt_vectors (0:31) bit (72), /* 100 - 177 fault vectors */ 2 pad1 (32) bit (72), 2 COW bit (36), /* 300 Connect operand word */ 2 pad2 (10) bit (36), 2 prt_out (30) bit (36), /* 313 - 350 printer output buffer */ 2 cons_in (21) bit (36), /* 351 - 375 console input buffer */ 2 pad3 (322) bit (36), 2 opt_save (25) bit (36), /* 1100 - 1130 options save area */ 2 pad4 (31) bit (36), 2 is_mbx, /* 1170 - 1177 ISOLTS mailbox area */ 3 control fixed bin (35), /* ISOLTS in control, if non-zero */ 3 service fixed bin (35), /* ISOLTS service requested flag, If non-zero */ 3 action_codes unaligned, /* service action codes */ 4 pad5 bit (21), 4 halt bit (1), /* bit 21 - halt imediately */ 4 pad6 bit (4), 4 ld_spgm bit (1), /* bit 26 - load slave mode program */ 4 ld_mpgm bit (1), /* bit 27 - load master mode program or PFT */ 4 wc_eop bit (1), /* bit 28 - write console, end of program */ 4 wc_opt bit (1), /* bit 29 - write console, option request flag */ 4 read bit (1), /* bit 30 - read console */ 4 wc_type bit (1), /* bit 31 - write console, type message */ 4 print bit (1), /* bit 32 - print message */ 4 err bit (1), /* bit 33 - error flag */ 4 pad7 bit (2), 3 pgm_name bit (36), /* word 3 - program name or ptr and wd count */ 3 pad8 (4) bit (36), 2 pad9 (64) bit (36), 2 wk_survey (16) bit (36), /* 1300 - 1317 working survey table */ 2 pad10 (3359) bit (36), 2 imw unaligned, /* 7757 - IOM interrupt multiplexor word */ 3 pad bit (18), 3 base bit (18), /* base address */ 2 sys_survey unaligned, /* 7760 - 7777 system survey table */ 3 iom0, /* IOM 0 mailbox and port */ 4 mbx bit (18), 4 port fixed bin, 3 iom1_3 (3) bit (36), /* same info for IOMs 1, 2, and 3 */ 3 console, /* info on system console */ 4 chan fixed bin (8), /* console channel number */ 4 pad bit (27), 4 cons_iom bit (36), /* iom number that console is on */ 3 printer, /* info about system printer */ 4 chan fixed bin (8), /* printer channel number */ 4 pad bit (27), 4 prt_iom bit (36), /* iom number that printer is on */ 3 cont_cpu, /* info about control cpu */ 4 f_vec bit (18), /* fault vector base address */ 4 port fixed bin, /* control cpu port number */ 3 hi_mem, /* info about highest addressable memory location */ 4 address fixed bin, 4 pad bit (18), 3 cpu_1, /* info about cpu # 1 */ 4 f_vec bit (18), /* fault vector base address */ 4 port fixed bin, /* cpu # 1 port number */ 3 cpu2_4 (3) bit (36), /* the same info for cpus 2, 3, and 4 */ 3 boot, /* info on boot device */ 4 chan fixed bin (8), /* boot tape chan number */ 4 pad bit (27), 4 iom bit (36), /* iom number that boot tape is on */ 2 exec (28672) bit (36), /* 10000 - 77777 PAS2 exec area */ 2 test_pgm (32768) bit (36); /* 100000 - 177777 slave program area */ dcl 1 slave_hdr based (hdr_p) aligned, /* slave program header template */ ( 2 pgm_num bit (36), /* pgm # in bcd (e.g. - pm700, pa864, ps955) */ 2 erlink bit (18), /* error linkage pointer */ 2 pgm_rev bit (18), /* program revision in bcd */ 2 p_int_tab bit (18), /* pseudo interrupt vector ptr */ 2 pgm_size bit (18), /* program size in words */ 2 tst_name bit (72), /* test name */ 2 num_tests bit (18), /* number of tests in program */ 2 xfer_p bit (18), /* transfer table pointer */ 2 cksum bit (36), /* check sum word before init. */ 2 program_name bit (108), /* program name */ 2 pad (9) bit (36) ) unaligned; /* pad area */ dcl 1 action like is_mbx.action_codes unaligned; /* copy of action flags */ dcl 1 pi like rsw_1_3.port_info based (pip) unaligned; dcl wseg1 (65536) fixed bin based (wseg_p); /* work seg as an array */ dcl bcd_str bit (bcd_chars * 6) based (mptr); /* bcd message input */ dcl add_wc (2) fixed bin unaligned based (awcp); /* address and word count */ %include config_cpu_card; %page; isolate_cpu = "0"b; /* reset cleanup flag */ on cleanup call clean_up; /* establish cleanup and */ on finish call clean_up; /* finish condition handlers */ call tolts_util_$get_ttl_date (isolts_, ttl_date); call tolts_util_$on_off (pname, "on", ttl_date); /* signon */ /* now get a pointer to our error message file */ call isolts_err_log_$init (code); if code ^= 0 then /* if problem */ go to t_off; /* wrap up and return */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Loop until user quits */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ term = "0"b; /* reset terminate cndition */ do while (^term); call ioa_ ("^/***enter ""test cpu "", "" display_error"", ""test pcd"", ""msg"", or ""quit """); /* Now find out what user wants to do */ ask: call tolts_util_$query ("??? ", com_string, c_len, args, cmd_cnt); if args (1) = "quit" | args (1) = "q" then /* user wants to quit */ term = "1"b; /* so let him */ else if args (1) = "msg" then /* user wants to send a msg to the operator */ call tolts_util_$opr_msg; else if args (1) = "display_error" | args (1) = "display" | args (1) = "derr" then do; /* display error message */ do i = 2 to cmd_cnt by 1; if args (i) = "-type" then do; p_err = "0"b; args (i) = ""; cmd_cnt = cmd_cnt - 1; end; end; cmd_cnt = cmd_cnt - 1; if ^display_log () then /* go display requested log entries */ bad_rsp: call com_err_ (0, pname, "invalid response - ""^a""", com_string); go to ask; end; else if cmd_cnt < 2 | args (1) ^= "test" then /* bad input */ go to bad_rsp; else if args (2) = "pcd" then do; /* user wants a list of avail. cpus and scus */ if cmd_cnt = 3 then call tolts_pcd_ ("isolts", (args (3))); else call tolts_pcd_ ("isolts", ""); end; else if args (2) ^= "cpu" then /* user goofed */ go to bad_rsp; else do; /* test cpu request */ trace_sw = "0"b; /* reset trace switch if set */ if cmd_cnt < 3 then /* not enough args */ go to bad_rsp; cpu_tag = search ("abcdefgh", args (3)); /* convert cpu tag to number */ if cpu_tag = 0 then /* not correct format */ go to bad_rsp; term = "0"b; scu_tag = -1; /* default, let hardcore decide */ if cmd_cnt > 3 then do; /* additional args */ trm = "0"b; /* reset flag */ do i = 4 to cmd_cnt; /* process rest of args */ if ^trm then /* if tag flag not set */ if args (i) = "-memory" | args (i) = "-mem" then trm = "1"b; /* set tag flag */ else if args (i) = "-brief" | args (i) = "-bf" then bf_sw = "1"b; /* set brief mode */ else if args (i) = "-trace" then /* user wants to trace action codes */ trace_sw = "1"b; /* set trace switch */ else go to bad_rsp; /* tell user about his typing problem */ else do; /* ok lets find the memory tag */ scu_tag = search ("abcdefgh", args (i)); if scu_tag = 0 then /* did not find tag */ go to bad_rsp; else scu_tag = scu_tag - 1; trm = "0"b; /* reset tag flag */ end; end; end; cpu_cardp = null; do while (^term); call tolts_util_$find_card ("cpu", cpu_cardp); if cpu_cardp = null then term = "1"b; else if cpu_card.tag = cpu_tag then do; if cpu_card.type ^= "l68" & substr (type, 1, 3) ^= "dps" then do; call ioa_ ("isolts_: unable to determine cpu type for cpu ^a", tags (cpu_tag - 1)); reask: call tolts_util_$query ("enter l68 or dps8 ", com_string, c_len, args, cmd_cnt); if args (1) = "l68 " | args (1) = "dps8" then cpu_type = args (1); else do; call ioa_ ("isolts_: invalid input pls reenter."); goto reask; end; end; else cpu_type = cpu_card.type; term = "1"b; end; end; cpu_tag = cpu_tag - 1; /* a = 0, h = 7, etc */ /* Now lets go to hardcore and check if we can get resources to run */ call tandd_$check_isolts_resources (cpu_tag, scu_tag, cpu_port, code); if code ^= 0 then do; /* can't get what we need */ call abort (code); /* go display config error */ go to cmd_loop; end; isolate_cpu = "1"b; /* set flag for cleanup handler */ /* now give the operator manual reconfiguration instructions */ if opr_com (cpu_tag, scu_tag) then /* if permission denied */ go to cmd_loop; /* then go release resources */ /* now go do actual reconfig and primitive cpu test */ call tandd_$create_cpu_test_env (cpu_tag, scu_tag, switches, wseg_p, code); if code ^= 0 then do; /* some problem */ call abort (code); /* go display config error */ go to cmd_loop; end; call ioa_ ("^/reconfiguration complete"); /* tell user */ hdr_p = addr (wseg.test_pgm); /* set test program header ptr */ wseg1 = 0; /* clear out our memory area */ restart = restart_label; /* set restart label */ /* now go run the pfts and pas2 */ restart_label: /* target of non-local gotos */ call run_pas; end; cmd_loop: call clean_up; /* go release resources if assigned */ end; /* user is all done we can wrap up now */ t_off: call tolts_util_$on_off (pname, "off", ttl_date); /* signoff */ return; %page; /* run_pas - internal procedure to run and do the test sequencing of the pfts and pas2 */ run_pas: proc; nxt_tst = first_pft; /* set up for first test */ awcp = addr (is_mbx.pgm_name); /* set up address/word count templete ptr */ cont_pas = continue_pas; /* set up continue label */ end_pas = end_tst; /* set up quit label */ pgm_offset = 0; /* preset loading offset for master mode program */ trm, pas_sw, mess_in_prog, ntype, run, option, car_nz = "0"b; /* reset flags */ dump_in_prog, idump = "0"b; /* quit_handler - quit condition handler for isolts */ on quit begin; /* establish quit condition handler */ if pas_sw then do; /* if not in primitives */ ntype = "0"b; /* force options type out */ string (action_codes) = "0"b; /* clear out any existing action code */ if dump_in_prog & ^idump then do; /* if dumping to file */ dump_in_prog = "0"b; /* abort dump and return to options */ go to eopt; end; if option then do; /* if we are in the option loop */ call ioa_ ("^/"); /* force new line */ car_nz = "0"b; go to eopt; end; action_codes.halt = "1"b; /* set halt imediate flag */ go to cont_pas; /* perform non local go to */ end; else call continue_to_signal_ (code); /* if not in pas2 pass it on */ end; call ioa_ ("^/start pft ^a^/", nxt_tst); do while (^trm); /* loop until user quits */ /* search for test page in file system */ call tolts_util_$search (df_iocbp, "pas." || nxt_tst, t_ptr, c_len, code); if code ^= 0 then do; /* if couldn't find test page */ call com_err_ (code, pname, "searching for pas.^a", nxt_tst); ntype = "0"b; string (action_codes) = "0"b; action_codes.halt = "1"b; go to cont_pas; end; /* load the core image into our work segment */ tout_retry: call gload_ (t_ptr, addrel (wseg_p, pgm_offset), 0, addr (gload_data), code); if code ^= 0 then do; /* problem durring load */ call com_err_ (code, pname, "^a^/attempting to load pas.^a", gload_data.diagnostic, nxt_tst); return; end; /* reset the isolts mailbox flags and set isolts control flag */ if ^pas_sw then /* if pft */ call set_survey; /* go set up system survey */ else do; delay = pas_delay; slave_hdr.cksum = gload_data.checksum; /* set up deck checksum in pgm header */ end; if nxt_tst = "892" | nxt_tst = "893" /* thesetests cause timeouts */ | nxt_tst = "955" then delay_iter = 600; /* increase the delay until fixed */ else delay_iter = 300; string (is_mbx.action_codes) = "0"b; /* reset all action flags */ is_mbx.pgm_name = "0"b; /* reset program name */ continue_pas: /* target of non local go tos */ if is_mbx.control = 0 then /* if flag is reset */ is_mbx.control = 65535; /* set it to indicate isolts in control */ is_mbx.service = 0; /* reset service requested flag */ if trace_sw then /* if tracing action codes */ if string (action_codes) ^= "0"b then /* and we have bit 21 set */ call itrace; /* go trace action code */ /* send interrupt to the cpu under test */ call tandd_$interrupt_test_cpu (code); if code ^= 0 then do; /* if couldn't interrupt */ call com_err_ (code, pname, "attempting to interrupt cpu ^a", tags (cpu_tag)); return; end; /* now go to sleep for awhile */ do i = 1 to 1000 while (is_mbx.service = 0); end; /* give pas2 a chance if intermediate I/O */ if is_mbx.service = 0 then /* if didn't make it give up processor */ wait: call sleep (delay); if is_mbx.service = 0 then do; /* if time out */ call ioa_ (" "); /* make sure we return to collum 1 */ if ^pas_sw & nxt_tst ^= pas_exec then do; /* if pft and not pas2 exec */ call com_err_ (0, pname, "time out after ^d seconds while executing PFT ^a", delay * delay_iter, nxt_tst); call com_err_ (0, pname, "check cpu ^a's maintenence panel and consult program listing to determine failure", tags (cpu_tag)); end; else if nxt_tst = pas_exec then /* hung up while initializing pas exec */ call com_err_ (0, pname, "time out after ^d seconds while initializing the pas2 executive", delay * delay_iter); else call com_err_ (0, pname, "time out after ^d seconds while executing pas2 test ^a", delay * delay_iter, nxt_tst); trm1 = "0"b; do while (^trm1); /* loop until user gets it right */ call tolts_util_$query ("respond ""quit (q)"", ""retry (r)"", or ""continue (c)"" - ", com_string, c_len, args, cmd_cnt); if args (1) = "quit" | args (1) = "q" then /* user wants to get out */ return; else if args (1) = "retry" | args (1) = "r" then /* user wants to retry test */ go to tout_retry; else if args (1) = "continue" | args (1) = "c" then /* wait some more */ go to wait; end; end; else do; string (action) = string (is_mbx.action_codes); /* copy action codes */ if trace_sw then /* if tracing action codes */ call itrace; /* go trace action code */ string (is_mbx.action_codes) = "0"b; /* and reset */ call interpret_action; /* do what the test wants */ end; end_tst: /* target of non-local gotos */ end; end run_pas; %page; /* interpret_action - internal procedure to interpret the isolts action flags */ interpret_action: proc; if action.ld_mpgm | action.ld_spgm then do; /* load next program request */ call complete_err_mess; /* go complete error message if one active */ call bcd_to_ascii_ (substr (pgm_name, 13, 18), new_tst); /* convert tst id to ascii */ if trace_sw then /* if user tracing action codes... */ call ioa_ ("load pgm^a", new_tst); /* tell him what we want to load */ do i = 1 to hbound (inv_tst_ids, 1) while (new_tst ^= inv_tst_ids (i)); end; /* check validity of test id */ if i <= hbound (inv_tst_ids, 1) then do; /* If this test is illegal for isolts */ ntype = "1"b; /* set flag so we don't type options message */ action_codes.halt = "1"b; /* set halt imediate flag */ go to cont_pas; /* perform non local goto */ end; if ^pas_sw & ^bf_sw then /* if PFT and not in brief mode ... */ call ioa_ ("*** end ^a, next ^a ***", nxt_tst, new_tst); /* display test seq for user */ nxt_tst = new_tst; /* pick up new test id and go find it */ if action.ld_spgm then /* if slave program to be loaded */ pgm_offset = fixed (rel (addr (wseg.test_pgm)), 18); /* set slave base */ else pgm_offset = 0; /* if master mode pgm then offset = 0 */ end; /* fall through and return */ else if action.wc_type | action.wc_eop | action.wc_opt then do; /* write console */ call complete_err_mess; /* go complete error message if one active */ mptr = ptr (wseg_p, add_wc (1)); bcd_chars = add_wc (2) * 6; /* get address and word count of message */ call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars); /* convert bcd */ if substr (out_str, 1, 1) = NL & length (out_str) > 2 then /* if new line strip it off */ out_str = substr (out_str, 2); if action.wc_type & length (out_str) >= 1 then /* if output to go on same line */ car_nz = "1"b; if action.wc_opt | action.wc_eop then option = "1"b; /* if option type request */ else option = "0"b; if ^ntype then do; /* if no type flag is on ignore message */ call ioa_$nnl ("^[^/^]^a^[^/^]", (car_nz & length (out_str) > 1), out_str, (^action.wc_opt & length (out_str) > 1 & ^option)); if length (out_str) > 1 then car_nz = "0"b; /* reset carriage position switch */ end; go to cont_pas; /* perform non local goto */ end; else if action.read then /* enter options request */ call enter_options; else if action.print then do; /* output message to printer */ mptr = ptr (wseg_p, add_wc (1)); mlen = add_wc (2); /* set word count of message */ if dump_in_prog then /* if we are getting dump reg info from pas2 */ call isolts_err_log_$dump (d_type, mptr, (mlen), 1, cpu_tag, scu_tag); else if action.err | mess_in_prog then do; /* if new error message or one in progress */ if mlen > 1 & mlen < 5 & ^mess_in_prog then do; /* must be end pass & ^message */ mptr = ptr (wseg_p, add_wc (1)); bcd_chars = add_wc (2) * 6; /* get address and word count of message */ call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars); /* convert bcd */ call ioa_ (" ^a", out_str); /* print on terminal */ go to cont_pas; end; else if action.err then do; /* if beginning of new message */ call complete_err_mess; /* complete old one */ mess_in_prog = "1"b; /* indicate an unfinished error message */ mtype = 1; /* set message type flag to start of message */ if ^run then do; /* if run option not in force */ call ioa_ ("^/*** an error has occurred ***^/"); /* let user know about error */ end; end; else mtype = 2; /* must be intermediate message */ call isolts_err_log_$write (mptr, mlen, mtype, cpu_tag, scu_tag); end; else do; /* write it to users terminal for now */ bcd_chars = mlen * 6; /* get word count of message */ call tolts_util_$bci_to_ascii (bcd_str, out_str, bcd_chars); /* convert bcd */ if ^bf_sw then do; /* if not in brief mode */ call ioa_ ("^[^/^]^a", car_nz, out_str); /* display message for user */ car_nz = "0"b; /* reset carriage position switch */ end; end; go to cont_pas; /* perform non local goto */ end; end interpret_action; %page; /* enter_options - internal procedure to enter pas2 or isolts options and check for legality */ enter_options: proc; add_opt = ""; /* pad additional option with blanks */ mptr = ptr (wseg_p, add_wc (1)); /* get ptr to return options string */ eopt = opt_mess; /* set enter options label */ if dump_in_prog then do; /* dumping and we get here, means we are ready to dump */ idump = "0"b; /* octal from the Multics side */ call isolts_err_log_$dump (d_type, addrel (wseg_p, first), last, 2, cpu_tag, scu_tag); /* dump it */ idump, ntype, dump_in_prog = "0"b; /* dump finsihed, reset flags */ go to opt_mess; /* and go to enter options */ end; if ntype then do; /* if we are forcing seq option */ ntype = "0"b; /* reset it so we don't come back */ bcd_chars = 6; call tolts_alm_util_$ascii_to_bci_ ("seq", bcd_str); /* convert ascii to bcd */ go to cont_pas; /* and return to pas2 exec */ end; reenter: call tolts_util_$query (" ", com_string, c_len, args, cmd_cnt); if cmd_cnt = 0 then do; /* if user typed NL char */ option = "0"b; /* reset options flag */ go to cont_pas; /* return to pas2 at point interrupted */ end; /* check for ISOLTS only options first */ if option then do; /* execute only if options request */ if ck_isolts_opt () then /* if isolts option, it has already been done */ go to opt_mess; /* go to options again */ else do; /* must be pas2 option, check them for legality */ k = 0; trm1 = "0"b; if cmd_cnt > 0 then do; do i = 1 to cmd_cnt while (^trm1); if length (args (i)) > 2 then do; if substr (args (i), 1, 3) = "prg" | substr (args (i), 1, 3) = "tst" then k = i; /* set flag for later */ end; else do j = 1 to hbound (illegal_pas_opt, 1) while (^trm1); if args (i) = illegal_pas_opt (j) then trm1 = "1"b; /* if illegal option */ end; end; end; if trm1 then do; /* if user has entered options not supported by ISOLTS */ call com_err_ (0, pname, "^a option not supported by ^a", args (i - 1), pname); opt_mess: call ioa_$nnl ("^a", out_str); go to reenter; end; if k ^= 0 then do; /* if "prgxxx" or "tstxxx" option specified */ do i = 1 to hbound (inv_tst_ids, 1) while (substr (args (k), 4, 3) ^= inv_tst_ids (i)); end; if i <= hbound (inv_tst_ids, 1) then do; /* found bad tst id */ call com_err_ (0, pname, "^a not supported by ^a", args (k), pname); go to opt_mess; /* let user try again */ end; end; if add_opt ^= "" then /* if additional option */ com_string = rtrim (com_string) || " " || add_opt; /* add it to end */ if index (com_string, "run") ^= 0 then /* if run option specified */ run = "1"b; if index (com_string, "halt") ^= 0 then run = "0"b; /* reset run if halt option */ if index (com_string, "reset") ^= 0 then do; /* if reset option */ run = "0"b; /* reset run flag */ p_err = "1"b; /* set print error flag */ end; option = "0"b; /* reset option flag */ end; end; bcd_chars = length (rtrim (com_string)); /* get exact options string length */ if mod (bcd_chars, 6) ^= 0 then /* if not already mod 6 */ bcd_chars = bcd_chars + (6 - mod (bcd_chars, 6)); /* make output mod 6 */ call tolts_alm_util_$ascii_to_bci_ (com_string, bcd_str); /* convert it to bcd */ go to cont_pas; /* perform non_local goto */ end enter_options; %page; /* clean_up - internal procedure to establish a cleanup and finish condition handler */ clean_up: proc; if isolate_cpu then do; /* if cleanup flag set */ call tandd_$destroy_cpu_test_env; isolate_cpu = "0"b; /* reset flag */ end; if df_iocbp ^= null then do; /* detach deck file if attached */ call iox_$close (df_iocbp, code); call iox_$detach_iocb (df_iocbp, code); df_iocbp = null; end; end clean_up; /* sw_mess_1, sw_mess_2 - subroutines to set up read switch error diagnostics */ sw_mess_1: proc (arg, mess); dcl (arg, mess) char (*); arg = rtrim (arg) || NL || mess; return; sw_mess_2: entry (arg, mess); arg = rtrim (arg) || NL || "memory " || tags (i) || " " || mess; return; end sw_mess_1; %page; /* sleep - internal procedure to put process to sleep for specified time period */ sleep: proc (t_delay); dcl (t_delay, i) fixed bin; dcl tm_delay fixed bin (71); tm_delay = t_delay; do i = 1 to delay_iter while (is_mbx.service = 0); /* loop until service requested or time out */ call timer_manager_$sleep (tm_delay, "11"b); /* sleep for specified seconds */ end; end sleep; /* complete_err_mess - internal subroutine to check if an error message is in progress and complete it */ complete_err_mess: proc; if ^pas_sw then /* if still in primitives */ if nxt_tst >= pas_exec then /* set pas switch if in pas exec or pas pgm */ pas_sw = "1"b; if mess_in_prog then do; /* if error message in progress */ mess_in_prog = "0"b; /* reset flag */ call isolts_err_log_$write (null, 0, 3, 0, 0); /* complete it */ end; end complete_err_mess; /* set_survey - internal procdure to set up system survey table */ set_survey: proc; delay = pft_delay; /* set up pft delay value */ iom0.mbx = "001400"b3; /* set up iom 0 mailbox address */ cont_cpu.f_vec, cpu_1.f_vec = "000100"b3; /* set up fault vector address */ iom0.port, cont_cpu.port, cpu_1.port = cpu_port; /* set port number */ imw.base = "001200"b3; /* set interrupt multiplexor base */ end set_survey; %page; /* itrace - internal procedure to trace action codes and time */ itrace: proc; tim = time; /* get current time */ call ioa_ ("^a.^a - action code = ^12.3b", substr (tim, 1, 4), substr (tim, 5, 3), string (action_codes)); end itrace; /* ck_isolts_opt - internal procedure to check and perform isolts only options */ ck_isolts_opt: proc returns (bit (1)); if args (1) = "quit" | args (1) = "q" then do; /* user wants to quit */ trm = "1"b; /* set terminate condition */ go to end_pas; /* perform non-local goto */ end; else if args (1) = "restart" then /* user wants to restart from PFTs */ go to restart; /* perform non-local goto */ else if args (1) = "itrace_on" | args (1) = "itn" then /* user wants to turn on trace */ trace_sw = "1"b; else if args (1) = "itrace_off" | args (1) = "itf" then /* user wants to turn trace off */ trace_sw = "0"b; else if args (1) = "type" | args (1) = "atype" then do; /* type messages */ p_err = "0"b; /* reset dprint error switch */ if args (1) = "type" then /* pas2 still thinks he */ add_opt = "print"; /* is going to printer */ else add_opt = "aprint"; end; else if args (1) = "print" | args (1) = "aprint" then do; /* dprint messages */ p_err = "1"b; /* set dprint error switch */ add_opt = args (1); /* set additional option */ end; else if args (1) = "test" & args (2) = "msg" then /* user wants to communicate with the operator */ call tolts_util_$opr_msg; else if args (1) = "display_error" | args (1) = "display" | args (1) = "derr" then do; /* display error message */ if ^display_log () then do; /* go display requested log entries */ inv_display: call com_err_ (0, pname, "invalid input - ""^a""", com_string); return ("1"b); /* reneter options */ end; end; else if args (1) = "E" then do; /* user wants to execute Multics command */ com_string = ltrim (substr (com_string, 2)); call cu_$cp (addr (com_string), length (com_string), code); /* execute Multics command */ end; else if args (1) = "cdump" | args (1) = "mdump" | args (1) = "xdump" | args (1) = "sdump" then do; first = 0; /* set defaults */ last = 65535; d_type = args (1); if cmd_cnt > 1 then do; /* if we have offset */ first = cv_oct_check_ ((args (2)), code); /* convert offset arg */ if code ^= 0 | first > 65535 then /* tell user what he typed wrong */ go to inv_display; last = last - first; /* adjust length */ if cmd_cnt > 2 then do; /* if length arg supplied */ last = cv_oct_check_ ((args (3)), code); if code ^= 0 | first + last > 65536 then /* tell user what he typed wrong */ go to inv_display; end; end; if args (1) = "cdump" then do; /* if console dump requested */ call ioa_ ("^/^a ""cdump"" from ^o to ^o of cpu ^a using memory ^a^/", pname, first, last + first, tags (cpu_tag), tags (scu_tag)); call dump_segment_ (iox_$user_output, addrel (wseg_p, first), 0, first, last, "01000000000"b); dump_in_prog = "0"b; /* entire cdump done from Multics side */ return ("1"b); /* return for next option */ end; else if args (1) = "sdump" then do; /* if slave dump to be taken */ first = fixed (rel (hdr_p), 17); /* set first to slave base */ last = fixed (slave_hdr.pgm_size, 17); /* dump this many words */ if last = 0 then do; /* no slave program loaded */ call ioa_ ("slave program not loaded"); /* tell user */ return ("1"b); /* and return for next option */ end; else if last > hbound (wseg.test_pgm, 1) then /* in case there is garbage here */ last = hbound (wseg.test_pgm, 1) - 1; /* set it to last loc in wseg */ end; dump_in_prog, ntype, idump = "1"b; /* set flags */ return ("0"b); /* let pas2 handle first part of dump */ end; else return ("0"b); /* not isolts option, go process pass options */ return ("1"b); /* isolts option has been processed */ end ck_isolts_opt; %page; /* opr_com - internal procedure to relay manual reconfiguration intructions to operator */ opr_com: proc (icpu, iscu) returns (bit (1)); dcl (icpu, iscu) fixed bin (5); dcl timer_manager$sleep entry (fixed bin (71), bit (2)); dcl d fixed bin (71) init (1); opr_query_info.q_sw = "1"b; /* must wait for opr to grant or deny permission */ opr_query_info.prim = "grant"; /* set primary expected response */ opr_query_info.alt = "deny"; /* set alternate expected response */ opr_query_info.r_comment = ""; call ioa_ ("asking operators permission to test cpu ""^a"" using memory ""^a""", tags (icpu), tags (iscu)); call opr_query_ (addr (opr_query_info), "permission asked to test cpu ""^a"" using memory ""^a""", tags (icpu), tags (iscu)); if opr_query_info.answer = "deny" then do; /* if opr doesn't want us to use cpu */ call ioa_ ("permission denied"); /* tell user the sad news */ return ("1"b); /* return and indicate denial */ end; call ioa_ ("permission granted"); /* operator says it ok to test cpu */ call ioa_ ("asking operator to manually reconfigure cpu ^a", tags (icpu)); opr_query_info.q_sw = "0"b; /* no operator response needed */ call opr_query_ (addr (opr_query_info), "execute the following manual reconfiguration on cpu ""^a"":", tags (icpu)); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ call opr_query_ (addr (opr_query_info), " 1. set all port and initialize enable switches and interlace switches to off."); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ if cpu_type = "dps8" then call opr_query_ (addr (opr_query_info), " 2. set the assignment switches for all ports to 000."); else if cpu_type = "l68 " then call opr_query_ (addr (opr_query_info), " 2. set all port assignment switches to 000 and the size switches to full"); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ if cpu_type = "dps8" then call opr_query_ (addr (opr_query_info), " 3. set store size switches to 2222."); else if cpu_type = "l68 " then call opr_query_ (addr (opr_query_info), " 3. remove the right free-edge connector on the 645pq wwb at slot ab28."); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ if cpu_type = "dps8" then call opr_query_ (addr (opr_query_info), " 4. verify that the mode switch is in vms."); else if cpu_type = "l68 " then call opr_query_ (addr (opr_query_info), " 4. install the ""cpu test"" on the right free-edge connector at slot ab28."); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ call opr_query_ (addr (opr_query_info), " 5. depress the initialize and clear push button."); call timer_manager_$sleep (d, "11"b); /* To prevent console messages from getting out of sync */ opr_query_info.q_sw = "1"b; /* must wait for opr response */ opr_query_info.prim = "done"; /* set primary expected response */ opr_query_info.alt = "unable"; /* set alternate response */ opr_query_info.r_comment = "when reconfiguration complete"; /* set response comment */ call opr_query_ (addr (opr_query_info), " 6. set the port enable switch ""on"" for port ""^a"".", tags (iscu)); if opr_query_info.answer = "unable" then do; call ioa_ ("having problems reconfiguring"); return ("1"b); end; else return ("0"b); /* return and indicate manual reconfig complete */ end opr_com; %page; /* display_log - internal procedure to display messages in the isolts_err_log */ display_log: proc returns (bit (1)); if cmd_cnt = 1 then /* if only last message wanted */ count, limit = 1; else if cmd_cnt >= 2 & cmd_cnt < 4 then /* count, limit or -all */ if args (2) = "-all" then /* print entire log */ count, limit = -1; else do; count = cv_dec_check_ ((args (2)), code); /* convert count */ if code ^= 0 then /* must be dec number */ return ("0"b); /* return error */ if cmd_cnt < 3 then /* no limit specified, set to 1 */ limit = 0; else do; limit = cv_dec_check_ ((args (3)), code); if code ^= 0 then /* must be dec number */ return ("0"b); /* return error */ end; end; else return ("0"b); /* no more than 3 args allowed, return error */ call isolts_err_log_$display (count, limit, p_err); /* display requested err messages */ return ("1"b); /* return with no error */ end display_log; %page; /* abort - internal subroutine to display reconfiguration error messages */ abort: proc (ecode); dcl ecode fixed bin (35); dcl (arg1, arg3, arg4) char (12); dcl arg2 char (128); dcl reconfig_err_message (17) char (64) static options (constant) init ("System dynamic reconfiguration in progress, try later", /* rcerr_isolts_locked */ "cpu tag ^a is illegal", /* rcerr_isolts_illegal_cpu */ "cpu ^a is online and unavailable for test", /* rcerr_isolts_cpu_online */ "cpu ^a is not configured", /* rcerr_isolts_no_config */ "there must be at least two online scus to run isolts", /* rcerr_isolts_two_scu */ "scu tag ^a is illegal", /* rcerr_isolts_illegal_scu */ "scu ^a is the bootload scu and cannot be used for testing", /* rcerr_isolts_bootload_scu */ "scu ^a is not online", /* rcerr_isolts_scu_not */ "requesting process is not running isolts", /* rcerr_isolts_not */ "cpu ^a responded to interrupt cell ^a at loc ^a", /* rcerr_isolts_wrong_cell */ "cpu ^a responded to an interrupt cell ^a on scu ^a", /* rcerr_isolts_wrong_scu */ "cpu ^a responded to an interrupt cell ^a on scu ^a at loc ^a", /* rcerr_isolts_wrong_scu_cell */ "cpu ^a failed to respond to an interrupt cell ^a interrupt", /* rcerr_isolts_no_response */ "the following switches on cpu ^a are set incorrectly: ^a", /* rcerr_isolts_bad_switches */ "a ""lda 2"" did not operate properly", /* rcerr_isolts_lda_fail */ "a ""lda 65536"" (64k) failed to produce a store fault", /* rcerr_isolts_no_str_flt */ "scu ^a has no interrupt mask register assigned to cpu ^a"); /* rcerr_isolts_no_mask */ call com_err_ (0, pname, "the following errors were detected while attempting reconfiguration:^/"); if ecode > 17 then /* if standard error code */ call com_err_ (ecode, pname, "attempting reconfiguration"); else do; /* reconfig error message */ arg1, arg2, arg3, arg4 = ""; /* initialize args */ if ecode > 9 & ecode < 14 then do; /* if codes 10 - 13 */ rswp = addr (switches (1)); /* set ptr to cpu switch data */ arg1 = tags (cpu_tag); /* set cpu tag arg */ call ioa_$rsnnl ("^d", arg2, i, rswp -> switch_w1.cell); /* set int cell number */ if ecode > 10 & ecode < 13 then /* if codes 11 or 12 */ arg3 = tags (scu_tag); /* set scu_tag */ end; go to etype (ecode); /* go set up correct message */ etype (2): /* rcerr_isolts_illegal_cpu */ etype (3): /* rcerr_isolts_cpu_online */ etype (4): /* rcerr_isolts_no_config */ arg1 = tags (cpu_tag); /* cpu tag only */ go to display_err; /* display message */ etype (6): /* rcerr_isolts_illegal_scu */ etype (7): /* rcerr_isolts_bootload_scu */ etype (8): /* rcerr_isolts_scu_not */ arg1 = tags (scu_tag); /* scu_tag only */ go to display_err; /* display message */ etype (10): /* rcerr_isolts_wrong_cell */ call ioa_$rsnnl ("^o", arg3, i, rswp -> switch_w1.offset); go to display_err; /* display message */ etype (12): /* rcerr_isolts_wrong_scu_cell */ call ioa_$rsnnl ("^o", arg4, i, rswp -> switch_w1.offset); go to display_err; /* display message */ etype (17): /* rcerr_isolts_no_mask */ arg1 = tags (scu_tag); arg2 = tags (cpu_tag); go to display_err; /* display message */ etype (14): /* rcerr_isolts_bad_swiches */ arg1 = tags (cpu_tag); rswp = addr (switches (2)); if cpu_type = "l68 " then do; if dps_rsw_2.fault_base then call sw_mess_1 (arg2, "fault base"); if dps_rsw_2.cpu_num ^= 0 then call sw_mess_1 (arg2, "processor number"); end; else if cpu_type = "dps8" then do; if dps8_rsw_2.fault_base then call sw_mess_1 (arg2, "fault base"); if dps8_rsw_2.cpu_num ^= 0 then call sw_mess_1 (arg2, "processor number"); end; rswp = addr (switches (4)); do i = 0 to 7; if i < 4 then pip = addr (addr (switches (1)) -> rsw_1_3.port_info (i)); else pip = addr (addr (switches (3)) -> rsw_1_3.port_info (i - 4)); if pi.port_assignment then call sw_mess_2 (arg2, "port assignment"); if pi.port_enable then call sw_mess_2 (arg2, "port enable"); if pi.initialize_enable then call sw_mess_2 (arg2, "initialize enable"); if pi.interlace_enable | rsw_4.four (i) then call sw_mess_2 (arg2, "interlace"); if pi.mem_size ^= 0 then call sw_mess_2 (arg2, "size"); if rsw_4.half (i) then call sw_mess_2 (arg2, "half/full"); end; go to display_err; /* display_message */ etype (1): /* rcerr_isolts_locked */ etype (5): /* rcerr_isolts_two_scu */ etype (9): /* rcerr_isolts_not */ etype (11): /* rcerr_isolts_wrong_scu */ etype (13): /* rcerr_isolts_no_response */ etype (15): /* rcerr_isolts_lda_fail */ etype (16): /* rcerr_isolts_no_str_flt */ display_err: call com_err_ (0, pname, reconfig_err_message (ecode), arg1, arg2, arg3, arg4); end; end abort; %page; %include rcerr; %include rsw; %include opr_query_info; %include gload_data; %page; /* BEGIN MESSAGE DOCUMENTATION Message: ..a: permission asked to test cpu using memory S: $beep T: $run M: . is asking permission to test the indicated cpu that is currently deconfigured from the system. The indicated memory will be usurped until a primitive test is made on the processor to verify switch settings and to assure that a memory address above 64k cannot be generated without a store fault occurring. After this primitive test is complete, all memory in the indicated SCU above 64k will be given back to the system. Until processor testing is completed, the reconfiguration data base is locked thereby not allowing dynamic reconfiguration of processors, memories, or bulk store. A: $info Message: ..a: respond "grant" or "deny". S: $beep T: $run M: . is expecting an operator response to either grant or deny permission to test the indicated processor. The indicated response must be made via the opr_query_response command. A: Operator must respond "grant" or "deny" via the opr_query_response command (or with the oqr entry in the admin ec; e.g. x oqr grant) to either grant or deny the test request. Message: ..a: execute the following manual reconfiguration on cpu : S: $beep T: $run M: . is asking the operator to manually reconfigure the indicated processor. A: $ignore Message: ..a: 1. set all port and initialize enable switches to off. S: $beep T: $run M: The first step of the manual reconfiguration instructions. A: $ignore Message: ..a: 2. set the assignment switches for all ports to 000. S: $beep T: $run M: The second step of the manual reconfiguration instructions. A: $ignore Message: ..a: 3. remove the right free-edge connector on the S: $beep T: $run M: The third step of the manual reconfiguration instructions. The indicated free-edge connector contains the port size plugs (maximum of 4) for the configured SCU ports. A: $ignore Message: ..a: 645pq wwb at slot 28l. S: $beep T: $run M: Continuation of above message. A: $ignore Message: ..a: 4. install the "cpu test" free-edge connector at slot 28l. S: $beep T: $run M: The fourth step of the manual reconfiguration instructions. The "cpu test" free-edge connector referred to is a special tool provided by Field Engingeering. It is simply a port free-edge connector with all 4 port groups wired for 64k. A: $ignore Message: ..a: 5. depress the initialize and clear push button. S: $beep T: $run M: The fifth step of the manual reconfiguration instructions. A: $ignore Message: ..a: 6. set the port enable switch on for port . S: $beep T: $run M: The sixth and last step of the manual reconfiguration instructions. A: $ignore Message: ..a: respond "done" when reconfiguration complete. S: $beep T: $run M: The indicated response must be made via the opr_query_response command. A: Operator must respond "done" via the opr_query_response command (x oqr done), when reconfiguration is complete. END MESSAGE DOCUMENTATION */ end isolts_;  isolts_err_log_.pl1 10/28/88 1413.0r w 10/28/88 1302.2 184734 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ isolts_err_log_: proc; /* isolts_err_log_ - a group of subroutines that maintain the isolts_err_log */ /* initially coded by James A. Bush 6/78 */ /* External entries */ dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl dprint_ entry (char (*), char (*), ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl user_info_ entry (char (*), char (*), char (*)); dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)); dcl get_default_wdir_ entry returns (char (168)); dcl (com_err_, ioa_$ioa_switch) entry options (variable); dcl clock_ entry returns (fixed bin (71)); dcl tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin); /* External static */ dcl error_table_$noentry fixed bin (35) ext; dcl iox_$user_output ptr ext; /* Automatic */ dcl (i, j, first, cnt, lim) fixed bin; /* do loop cnters */ dcl tlog char (24); dcl (uname, uproj, uacct) char (32); dcl out_str char (136) varying; dcl dump_str char (136); dcl cd_type char (5); dcl code fixed bin (35); dcl tptr ptr; dcl (term, first_printed) bit (1); dcl format bit (11); /* internal static */ dcl (efp, mep, imep, iocbp) ptr int static; /* ptr to our error file */ dcl hdir char (168) int static; dcl sname char (32) int static; dcl mes_begin bit (1) int static; /* message begin flag */ dcl (s_att, s_open) bit (1) int static init ("0"b); /* flags for file attachment and opening */ /* Entry parameters */ dcl rcode fixed bin (35); /* standard system error rcode */ dcl mptr ptr; /* ptr to message text */ dcl mlen fixed bin; /* word length of message */ dcl mtype fixed bin (2); /* type of message */ dcl (cput, scut) fixed bin (5); /* cpu and scu tags of cpu in error */ dcl a_cnt fixed bin; /* cnt of log entrieds to display */ dcl a_lim fixed bin; /* if not = 0 then the number to display from cnt */ dcl dp_sw bit (1); /* = "0"b then display on user's term, = "1"b then dprint */ dcl d_type char (5); /* type of dump */ /* Builtins */ dcl (addr, addrel, fixed, floor, length, null, ptr, substr, rel, rtrim, unspec) builtin; /* Structures */ dcl 1 ilog based (efp) aligned, /* definition of isolts_err_log */ 2 len fixed bin (35), /* length of message buffer area in chars */ 2 version fixed bin, /* version of this log (1) */ 2 first bit (18) unaligned, /* relative address of first message in log */ 2 last bit (18) unaligned, /* relative address of last message in log */ 2 init_wd char (4), /* = "INIT" if log has been initialized */ 2 time_init fixed bin (71), /* clock time log was initialized */ 2 nxt_seq fixed bin (35), /* next message sequence numbr */ 2 first_mess bit (1) unaligned, /* if = "0"b, log is empty */ 2 pad1 bit (35) unaligned, 2 buffer char (0 refer (ilog.len)), /* message buffer */ 2 end_buf char (1); /* end of error file */ dcl 1 ilog_mess based (mep) aligned, /* format of message entry */ (2 next bit (18), /* fwd and backward message threads */ 2 prev bit (18), 2 mess_complete bit (1), /* = "1"b if this is a completeed message */ 2 cpu_tag fixed bin (5), /* tag of cpu generating error message */ 2 scu_tag fixed bin (5), /* tag of scu being used for cpu test */ 2 pad1 bit (2), 2 type fixed bin (2), /* 1 = begin, 2 = intermediate, 3 = end message */ 2 txt_len fixed bin, /* length of message in characters */ 2 time_logged fixed bin (71), /* clock time message logged */ 2 seq_num fixed bin (35), /* message sequence number */ 2 next_full bit (18), /* ptr to nxt full message */ 2 pad2 bit (18), 2 text char (0 refer (ilog_mess.txt_len))) unaligned, /* message text */ 2 nxt_mess char (1); /* means of spacing to next message */ dcl 1 ilog_imess based (imep) aligned, /* format of intermediate message entry */ (2 next bit (18), /* fwd and backward message threads */ 2 prev bit (18), 2 pad1 bit (15), 2 type fixed bin (2), /* 1 = begin, 2 = intermediate, 3 = end message */ 2 txt_len fixed bin, /* length of message in characters */ 2 text char (0 refer (ilog_imess.txt_len))) unaligned, /* message text */ 2 nxt_imess char (1); /* means of spacing to next message */ /* Constants */ dcl cleanup condition; dcl pname char (6) int static options (constant) init ("isolts"); dcl tags (0 : 7) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl NL char (1) int static options (constant) init (" "); dcl NP char (1) int static options (constant) init (" "); /* init - entry to initiate or create at first reference the isolts_err_log */ init: entry (rcode); rcode = 0; /* preset return code */ mes_begin = "0"b; /* reset message begin flag */ hdir = get_default_wdir_ (); /* get our home dir name */ /* now get a pointer to our error message file */ call hcs_$initiate (hdir, "isolts_err_log", "", 0, 1, efp, code); if efp = null then /* if error */ if code = error_table_$noentry then do; /* does not exist */ call com_err_ (0, pname, "Creating ^a>isolts_err_log", hdir); call hcs_$make_seg (hdir, "isolts_err_log", "", 01010b, efp, code); if efp = null then do; /* you can't win */ call com_err_ (code, pname, "Attempting to create ^a>isolts_err_log", hdir); rcode = code; return; end; ilog_init: call hcs_$set_max_length_seg (efp, 65536, code); /* set max length to 64k */ if code ^= 0 then do; call com_err_ (code, pname, "Setting max length of ^a>isolts_err_log to 64k", hdir); rcode = code; return; end; call hcs_$set_bc_seg (efp, 65536 * 36, code); /* set bit cnt to 64k */ if code ^= 0 then do; call com_err_ (code, pname, "Setting bit cnt of ^a>isolts_err_log to 64k", hdir); rcode = code; return; end; /* now lets set up the log header */ ilog.len = (65536 - fixed (rel (addr (ilog.buffer)))) * 4; /* set buffer length */ ilog.version = 1; /* version of this log is 1 */ ilog.first, ilog.last = rel (addr (ilog.buffer)); /* set first and last message ptrs */ ilog.nxt_seq = 0; /* start with a sequence number of 0 */ ilog.buffer = ""; /* pad message buffer with blanks */ ilog.first_mess = "0"b; /* reset first message flag */ ilog.time_init = clock_ (); /* get clock time */ ilog.init_wd = "INIT"; /* set init word */ return; end; else do; call com_err_ (code, pname, "Initiating ^a>isolts_err_log", hdir); rcode = code; return; end; if ilog.init_wd ^= "INIT" then do; /* if error file inconsistant */ call com_err_ (0, pname, "^a>isolts_err_log is inconsistant, reinitializing", hdir); go to ilog_init; end; return; /* */ /* write - entry to write message entries into the isolts_err_log */ write: entry (mptr, mlen, mtype, cput, scut); go to mess_type (mtype); /* execute desired code */ mess_type (1): /* message begining */ mes_begin = "1"b; /* set message begining flag */ if ^ilog.first_mess then do; /* if we haven't written to log before... */ mep = addrel (efp, ilog.first); /* start at begining */ ilog_mess.prev = "0"b; /* and set prev ptr to 0 */ ilog.first_mess = "1"b; /* set first message flag */ end; else do; /* otherwise go to next message loc */ mep = addrel (efp, ptr (efp, ilog.last) -> ilog_mess.next_full); ilog_mess.prev = ilog.last; /* set prev ptr to last message complete */ end; ilog_mess.mess_complete = "0"b; /* reset message complete flag */ ilog_mess.time_logged = clock_ (); /* set the time */ ilog_mess.seq_num = ilog.nxt_seq; /* set sequence number */ if unspec (ilog.nxt_seq) = "377777777777"b3 then do; /* do not overflow seq number */ call com_err_ (0, pname, "Error message log sequence number has reached max value of ^d, resetting to 0", ilog.nxt_seq); ilog.nxt_seq = 0; /* reset sequence number */ end; else ilog.nxt_seq = ilog.nxt_seq + 1; /* otherwise just increment it by one */ ilog_mess.cpu_tag = cput; /* set cpu and scu tags */ ilog_mess.scu_tag = scut; ilog_mess.type = 1; /* set start message type */ ilog_mess.txt_len = cv_wmess (addr (ilog_mess.text)); /* go convert, and store message */ ilog_mess.next = rel (addr (ilog_mess.nxt_mess)); /* set next message ptr */ imep = null; /* and null out intermediate message ptr */ return; /* thats it */ mess_type (2): /* intemediate message */ if ^mes_begin then do; /* something is wrong */ call com_err_ (0, pname, "Attempting to write intermediate message entry before beginning of message"); return; end; if imep = null then do; /* if first intermediate message */ imep = addrel (efp, ilog_mess.next); /* set it */ ilog_imess.prev = rel (mep); /* set prev ptr to start message entry */ end; else do; /* else go from lst intermediate message */ tptr = addr (ilog_imess.nxt_imess); /* set temp ptr */ if wrap (tptr) then do; /* if buffer wrap around */ tptr = addrel (efp, ilog.first); /* reset temp ptr to start of buffer */ ilog_imess.next = rel (tptr); /* and change thread from last message */ end; tptr -> ilog_imess.prev = rel (imep); /* set prev thread */ imep = tptr; /* and copy ptr */ end; ilog_imess.type = 2; /* set intermediate type */ ilog_imess.txt_len = cv_wmess (addr (ilog_imess.text)); /* go convert and write message */ ilog_imess.next = rel (addr (ilog_imess.nxt_imess)); /* set next ptr */ return; /* and return */ mess_type (3): /* end message */ mes_begin = "0"b; /* reset message begin flag */ ilog_mess.mess_complete = "1"b; /* and set message complete flag */ if imep = null then do; /* if only 1 message entry in this message */ tptr = addr (ilog_mess.nxt_mess); ilog_mess.type = 3; /* set type in main messae to end */ end; else do; tptr = addr (ilog_imess.nxt_imess); /* if there were intermediate messages */ ilog_imess.type = 3; /* set type in intermeditate message to end */ end; if wrap (tptr) then do; /* check for wrap around */ ilog_mess.next_full = ilog.first; /* set next message back to start of buffer */ if imep ^= null then /* if intermediate messages */ ilog_imess.next = ilog.first; /* set thread to beginning of buffer */ else ilog_mess.next = ilog.first; /* otherwise set tread of maj. message */ end; else do; if substr (rel (tptr), 18, 1) then /* if odd address */ tptr = addrel (tptr, 1); /* make even */ ilog_mess.next_full = rel (tptr); /* no wrap nedded, set to next one in buffer */ end; ilog.last = rel (mep); /* set last pointer */ return; /* and return */ /* */ /* display - entry to display requested isolts_err_log entries either on user's terminal or queue a dprint */ display: entry (a_cnt, a_lim, dp_sw); if ^ilog.first_mess then do; /* log is empty */ call com_err_ (0, pname, "Error log file is empty"); return; end; cnt = a_cnt; /* copy parameters */ lim = a_lim; s_att, s_open = "0"b; /* reset flags */ if dp_sw then /* if user wants log entries dprinted... */ call attach_file ("ilog", "0"b); /* go attach print file */ else iocbp = iox_$user_output; /* else put it out to terminal */ on cleanup call clean_up; /* establish a cleanup handler */ if cnt = 0 then /* set defaults */ cnt = 1; else if cnt = -1 then cnt = 100000; /* set to big number to make sure we get all */ if lim = 0 | lim = -1 then lim = 1; else lim = cnt - lim; first_printed, term = "0"b; /* reset terminate condition, and first page flag */ mep, tptr = addrel (efp, ilog.last); /* preset ptrs */ do i = 1 by 1 while (i ^= cnt + 1 & ^term); /* go backwards to desired number of entries */ mep = tptr; /* set mep to last valid message */ if ilog_mess.prev = "0"b then /* if we come to first message */ term = "1"b; else tptr = addrel (efp, ilog_mess.prev); /* otherwise go to prev mess */ if tptr -> ilog_mess.next_full ^= rel (mep) | /* if threads do not match up */ ilog_mess.prev ^= rel (tptr) then term = "1"b; /* quit */ end; /* now go forward through desired number of message entries */ do j = i-2 to lim by -1; if ilog_mess.mess_complete then do; /* display only if complete message */ call date_time_ ((ilog_mess.time_logged), tlog); /* convert date and time */ /* output isolts message header first */ call ioa_$ioa_switch (iocbp, "^[^|^]^a error message sequence # ^d logged at ^a for cpu ^a using memory ^a", first_printed, pname, ilog_mess.seq_num, tlog, tags (ilog_mess.cpu_tag), tags (ilog_mess.scu_tag)); term = "0"b; first_printed = "1"b; /* set first page printed flag */ imep = mep; /* set ptr equal */ /* now output each message entry */ do while (^term); if imep = mep then do; /* if first message entry */ out_str = ilog_mess.text; /* copy message text */ if substr (out_str, 1, 1) = NP then /* if form feed */ out_str = substr (out_str, 2); /* get rid of it */ call ioa_$ioa_switch (iocbp, "^a", out_str); /* output primary message entry */ end; else call ioa_$ioa_switch (iocbp, "^a", ilog_imess.text); /* output inter. message entry */ if ilog_imess.type = 3 then /* if end message */ term = "1"b; /* this is the last text for this message */ else imep = addrel (efp, ilog_imess.next); /* increment intermediate message ptr */ end; end; mep = addrel (efp, ilog_mess.next_full); /* increment message ptr */ end; if dp_sw then /* if dprinting file */ call prt_queue ("ILOG", "0"b); /* go queue it up */ return; /* */ /* dump - entry to output dumps to a dump file for dprinting */ dump: entry (d_type, mptr, mlen, mtype, cput, scut); if mtype = 1 then do; /* output text a line at a time */ if ^s_att & ^s_open then do; /* if first time throutgh */ call attach_file (d_type, "1"b); /* attach and open print file */ on cleanup call clean_up; /* establish a cleanup condition handler */ call ioa_$ioa_switch (iocbp, "^3-*** ^a ^a of cpu ^a using memory ^a ***^/", pname, d_type, tags (cput), tags (scut)); /* output header line */ end; i = cv_wmess (addr (dump_str)); /* go convert message to ascii */ if substr (dump_str, 1, 1) = NP then /* if form feed */ dump_str = substr (dump_str, 2); /* get rid of it */ call ioa_$ioa_switch (iocbp, "^a", dump_str); /* and store in dump file */ end; else do; /* output requested octal dump to dump file */ call ioa_$ioa_switch (iocbp, "^2/"); /* skip 2 lines */ if d_type = "mdump" then do; cd_type = "MDUMP"; /* form dype in all caps */ format = "01000100000"b; /* rel address only, long form */ first = fixed (rel (mptr), 17); end; else if d_type = "sdump" then do; cd_type = "SDUMP"; format = "11000100000"b; /* abs and rel addresses, long form */ first = 0; /* relative address begines at 0 */ end; else do; cd_type = "XDUMP"; format = "11000100000"b; /* abs and rel addresses, long form */ first = 0; /* relative address begines at 0 */ end; call dump_segment_ (iocbp, mptr, 0, first, mlen, format); call prt_queue (cd_type, "1"b); end; return; /* */ /* cv_wmess - internal function subroutine to convert bci message, store, and return length */ cv_wmess: proc (str_ptr) returns (fixed bin); dcl str_ptr ptr; dcl in_str bit (mlen * 36) based (mptr); dcl bout_str char (136) based (str_ptr); call tolts_util_$bci_to_ascii (in_str, out_str, mlen * 6); /* convert message */ if substr (out_str, length (out_str), 1) = NL then /* if trailing newline... */ out_str = substr (out_str, 1, length (out_str) - 1); /* get rid of it */ if substr (out_str, 1, 1) = NL then /* if leading newline... */ out_str = substr (out_str, 2); /* get rid of it */ bout_str = out_str; /* copy results */ return (length (out_str)); /* and return length */ end cv_wmess; /* wrap - an internal function subroutine to check if the message buffer should be wrapped around */ wrap: proc (limp) returns (bit (1)); dcl limp ptr; if fixed (rel (addrel (limp, 40))) > fixed (rel (addr (ilog.end_buf))) then return ("1"b); /* buffer needs to be wraped */ else return ("0"b); /* no need to wrap */ end wrap; /* clean_up - internal procedure to close and detach err file */ clean_up: proc; if s_open then do; /* if file open */ call iox_$close (iocbp, code); s_open = "0"b; end; if s_att then do; /* if file attached */ call iox_$detach_iocb (iocbp, code); s_att = "0"b; iocbp = null; end; end clean_up; /* */ /* attach_file - internal procedure to attach and open stream file */ attach_file: proc (fname, ld_sw); dcl fname char (*); /* either ilog or dump */ dcl ld_sw bit (1); /* "0"b = ilog, "1"b = dump */ sname = unique_chars_ (""b) || "." || fname; /* form unique name */ hdir = get_default_wdir_ (); /* and get our home dir */ call iox_$attach_name ("err_file", iocbp, "vfile_ " || rtrim (hdir) || ">" || sname, null, code); if code ^= 0 then do; /* if some problem with attach */ call com_err_ (code, pname, "Attempting to attach ^[dump^;error log^] file - ^a>^a", ld_sw, hdir, sname); return; /* get out now */ end; s_att = "1"b; /* indicate our seg is attached */ call iox_$open (iocbp, 2, "0"b, code); /* open for stream output */ if code ^= 0 then do; call com_err_ (code, pname, "Attempting to open ^a>^a for stream_output", hdir, sname); call clean_up; /* go detach file */ return; end; s_open = "1"b; end attach_file; /* prt_queue - internal procedure to queue up a dprint request for a error log file or dump file */ prt_queue: proc (rname, ld_sw); dcl rname char (*); /* either "ERR RPT" or "ZDUMP" */ dcl ld_sw bit (1); call clean_up; /* close and detach file */ call user_info_ (uname, uproj, uacct); /* get users name and project */ out_str = rtrim (uname) || "." || rtrim (uproj); /* form desc line */ if length (out_str) < 10 then i = floor ((14 - length (out_str)) / 2); /* form center index */ else i = 1; /* if name to long, start at collum 1 */ dpap = addr (dprint_arg_buf); /* set dprint arg ptr */ dprint_arg.version = 1; /* set appropriate args */ dprint_arg.copies = 1; dprint_arg.delete = 1; dprint_arg.queue = 3; /* probably should be queue 1 */ dprint_arg.pt_pch = 1; dprint_arg.notify = 1; /* might want to make this 0 */ dprint_arg.output_module = 1; dprint_arg.dest = ""; substr (dprint_arg.dest, i) = out_str; /* set in person/project info */ if ld_sw then /* if printing dump file */ dprint_arg.heading = " for ISOLTS " || rname; else dprint_arg.heading = " for ISOLTS ER RPT"; call dprint_ (hdir, sname, dpap, code); /* queue it up */ call ioa_$ioa_switch (iox_$user_output, "^/^[dump^;error report^] file ^a has been queued for printing", ld_sw, sname); end prt_queue; % include dprint_arg; end isolts_err_log_;  mtdsim_.pl1 07/20/88 1306.3r w 07/19/88 1536.9 1649709 /****^ ************************************************************ * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1980. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ************************************************************ */ /* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules known as slave mode polt and slave mode molt (and eventually slave mode colt) originally coded by J. K. Rhodes 4Q/1977 extensive modification by J. A. Bush 9/78 code added to drive slave mode molts by J. A. Bush 2/79 initial release - MR7.0A Modified by J. A. Bush 12/79 for static mme handler and to handle new deckfile catalog format Modified by G. Haney & R. Fakoury 80/03/24 to handle mtar Modified by J. A. Bush 5/80 for several performance enhancements Modified by R. Fakoury 8/80 to handle the error return of "file not found" for a MME GCALL more cleanly. Modified by R. Fakoury 8/80 to handle dcw tally of 4096 correctly and to handle an incorrect density from rcp_. Modified by R. Fakoury 10/80 to set lostit_time = rcp_ max timeout. Modified by R. Fakoury 12/80 for colts implementation. Modified by R. Fakoury 10/81 to improve the quit handler. Modified by R. Fakoury 11/81 to attach the mpc for disk and tape mdrs. Modified by R. Fakoury 11/81 to dump the test exec when a machine fault is en countered. Modified by R. Fakoury 01/82 to allow more room for test colts test pages and to be more user friendly on bad test requests. Modified by R. Fakoury 03/17/82 to redesign mme allocr handler making it more effecient. Modified by R. Fakoury 04/82 to change mme feptype interface, to add a timer for colts attachments, add cleanner wrapup sequences for colts attach errors, and to add eurc pr54 support. Modified by R. Fakoury 09/30/82 to change illegal zero dcws to a valid single xfer dcw and output a message. Modified by R. Fakoury 11/01/82 to correct problem in Colts wrap-up & add 128 chan support. Modified by R. Fakoury 01/07/83 to increase the value of iom table words read from the fnp. Modified by R. Fakoury 01/21/83 to change the manner the tolts gets print train image to aggree with the way the system gets it. Modified by Rick Fakoury 03/16/83 to add a call to tolts_util_$get_ttl_date. Modified by R. Fakoury 09/83 to correct a 128chan bug. Modified by R. Fakoury 11/84 for hyperchan i/o. Modified by R.Fakoury 01/84 to accept multiple args & to implement a debugger for the slave execs. Modified by R Fakoury 04/84 to add a new field in sctcmp for DAU support, and to put a temp bypass for an ioi timing problem. Modified by R Fakoury 09/84 to correct a problem in get_px_tcx which caused io_sel to be invalid. Modified by R Fakoury & Benson Margulies 10/84 to correct problems encountered with new AS, to add more debugging functions, and to use convert_status_code instead of com_err. */ /****^ HISTORY COMMENTS: 1) change(85-02-01,Fakoury), approve(86-08-20,MCR7514), audit(86-12-09,Martinson), install(86-12-09,MR12.0-1235): implement the test nio request (Dipper/MCA) with add debug aides, implement extented status store, further correct a problem in get_px_tcx, prevent returning to the subexec after a fault dump, support of a test rsp request (responder/DN8) with added debug aides, to dump machine conditions and history regs, to increase the bar value, to increase the timeout time for printer mdrs, to correct a problem encountered while attempting an attach for colts, to correct poorly written error messages. 2) change(86-12-18,Fakoury), approve(86-12-18,MCR7514), audit(86-12-18,Martinson), install(86-12-19,MR12.0-1252): PBF to correct an error in MME POINTIT that returns the IO system type. 3) change(86-12-19,Fakoury), approve(86-12-19,MCR7514), audit(87-01-05,Martinson), install(87-01-05,MR12.0-1254): Modified to correct a problems in MME DATA. One problem was caused by a change in the mca driver interface and the other problem was in the trace function. 4) change(87-01-06,Fakoury), approve(87-01-06,MCR7514), audit(87-01-07,Martinson), install(87-01-08,MR12.0-1263): Corrected a Colt attachment problem by increasing the no responce count, corrected a problem in releasing the channel when a failure occurs. END HISTORY COMMENTS */ /* mtdsim_ - (Multics T & D Slave Interface Module) Procedure to drive the gcos T & D Modules known as slave mode polt and slave mode molt (and eventually slave mode colt) */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ mtdsim_: proc; /* External entries */ dcl bcd_to_ascii_ entry (bit (*) aligned, char (*)); dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed bin (35)); dcl convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (*), char (*)); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dial_manager_$privileged_attach entry (ptr, fixed bin (35)); dcl dial_manager_$release_channel entry (ptr, fixed bin (35)); dcl dial_manager_$release_channel_no_listen entry (ptr, fixed bin (35)); dcl dial_manager_$tandd_attach entry (ptr, fixed bin (35)); dcl db_fnp_eval_ entry (ptr, fixed bin, char (*), ptr, char (*), fixed bin, fixed bin (35)); dcl db_fnp_memory_$fetch entry (ptr, fixed bin, fixed bin, fixed bin, ptr, fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl hcs_$get_ips_mask entry (bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl (ioa_, ioa_$rsnnl) entry () options (variable); dcl ioi_$connect entry (fixed bin (12), fixed bin (18), fixed bin (35)); dcl ioi_$release_devices entry (fixed bin (12), fixed bin (35)); dcl ioi_$set_channel_required entry (fixed bin (12), fixed bin (3), fixed bin (6), fixed bin (35)); dcl ioi_$set_status entry (fixed bin (12), fixed bin (18), fixed bin (8), fixed bin (35)); dcl ioi_$suspend_devices entry (fixed bin (12), fixed bin (35)); dcl ioi_$timeout entry (fixed bin (12), fixed bin (52), fixed bin (35)); dcl ioi_$workspace entry (fixed bin (12), ptr, fixed bin, fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$read_ev_chn entry (fixed bin (71), fixed bin, ptr, fixed bin (35)); dcl mca_$attach_ipc entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35)); dcl mca_$detach_ipc entry (char (*), fixed bin, bit (1), fixed bin (35)); dcl mca_$detach_mca entry (fixed bin, fixed bin (35)); dcl mca_$load_ipc entry (fixed bin, fixed bin, bit (36), fixed bin (35)); dcl mca_$tandd_read_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35)); dcl mca_$tandd_write_data entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35)); dcl mca_$tandd_write_text entry (fixed bin, ptr, fixed bin, bit (36), fixed bin (35)); dcl mca_$reset entry (fixed bin, bit (36), fixed bin (35)); dcl opr_query_ entry () options (variable); dcl rcp_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)); dcl rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin (12), fixed bin (19) aligned, fixed bin (71) aligned, fixed bin, fixed bin (35)); dcl rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35)); dcl rcp_priv_$attach entry (char (*) aligned, ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)); dcl probe entry options (variable); dcl terminate_process_ entry (char (*), ptr); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*)); dcl tolts_alm_util_$enter_ccc_req_ entry (ptr, bit (36)); dcl tolts_alm_util_$enter_slave_ entry (ptr); dcl tolts_alm_util_$gen_ck_sum entry (ptr); dcl tolts_alrm_util_$quit entry; dcl tolts_device_info_ entry (ptr, fixed bin, fixed bin); dcl tolts_file_util_$close entry; dcl tolts_file_util_$open entry (fixed bin (35)); dcl tolts_file_util_$snap entry (ptr); dcl tolts_file_util_$wdump entry (ptr); dcl tolts_load_firmware_ entry (fixed bin, fixed bin (35)); dcl tolts_init_ entry (char (4), fixed bin (35)); dcl tolts_init_$clean_up entry; dcl tolts_init_$cr_event_chan entry (fixed bin (71), bit (1), entry, ptr, fixed bin, fixed bin (35)); dcl tolts_io_int_ entry; dcl tolts_qttyio_ entry (char (*), fixed bin); dcl tolts_qttyio_$dcw_list entry (ptr, fixed bin); dcl tolts_qttyio_$dcw_ptr entry (ptr, fixed bin, fixed bin); dcl tolts_qttyio_$rcw entry (ptr); dcl tolts_qttyio_$rs entry () options (variable); dcl tolts_util_$cata_sel entry (ptr, char (32), ptr, fixed bin (35)); dcl tolts_util_$find_card entry (char (4), ptr); dcl tolts_init_$gc_tod entry (bit (36)); dcl tolts_util_$get_ttl_date entry (entry, char (6)); dcl tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35)); /* AUTOMATIC */ dcl bufp ptr; dcl (nargs, return_value, c_len, n_dialed, len, tio, dealc_err, ev_occurred, i, j, mesg_len, ndcws, tally, t_err) fixed bin init (0); dcl (chan_name, io_module) char (32); dcl (error, c_error, mem_needed) fixed bin (35) init (0); dcl filename_idx fixed bin; dcl lvl_idx fixed bin; dcl imu_found bit (1) init ("0"b); dcl iom_found bit (1) init ("0"b); dcl iom fixed bin (3), chan fixed bin (6), tio_off fixed bin (18), timeout_time fixed bin (52) init (0); dcl cpu_time fixed bin (71); dcl wake_time fixed bin (71) init (500000); dcl mem_now fixed bin (19); dcl (pcwa, bcd_callname, gcos_tod) bit (36); dcl b18 bit (18); dcl bit_buf bit (72); dcl pad_char bit (6); dcl sb_data_idx fixed bin; dcl ws_data_idx fixed bin; dcl (argptr, train_ptr, tp, cltp, t_ptr, ioe_ptr, l_ptr, gcatp, info_ptr) ptr; dcl coment char (256), shortinfo char (8), lginfo char (100), message char (512), ac_name char (6); dcl workspace_move char (c_len * 4) based (bufp); /* INTERNAL STATIC */ dcl (gicm_count, io_sel, isc_cntdn, last_mme, mme_number, nr_cnt) fixed bin int static init (0); dcl (term, gndc_flag, found, gelbar, glb_brk, in_ccc, isc_ccc_rqt, mpc_io, trace_save, debug, debugging, rd_blk, flt_flag, alt_flag, q_flag, rd_flag, tcd, trace_io, trace, itr_run) bit (1) aligned int static init ("0"b); dcl tolts_active bit (1) aligned int static init ("0"b); /* flag for epilogue handler */ dcl db_addr fixed dec int static; dcl exec char (4) int static; dcl ttl_date char (6) int static; dcl (old_mask, new_mask) bit (36) aligned int static; dcl clt_sw char (32) varying int static; dcl io_block_len fixed bin; dcl (gicmp, icmp, mvp, ricmp, ticmp, wicmp) ptr int static init (null); dcl (l, k) fixed bin (6) int static; dcl code fixed bin (35) init (0) int static; dcl db_sv_wd bit (36) int static; dcl (gerout_num, icm_tally, fnp_addr, fnp_num, remote_inquiry_ic) fixed bin int static; dcl att_desc char (40) int static; dcl (mmep, genp) ptr int static; dcl (arglen, n_read) fixed bin (21) int static; dcl blk_lbl label int static; dcl emsg char (40) int static; dcl term_lbl label int static; dcl no_blk label int static; /* EXTERNAL STATIC */ dcl error_table_$bad_command_name fixed bin (35) ext static; dcl error_table_$force_unassign external fixed bin (35); dcl error_table_$resource_unavailable external fixed bin (35); dcl printer_images_$n_images fixed bin external; dcl printer_images_$image_base external; dcl printer_images_$image_offsets (10) fixed bin (18) external; dcl printer_images_$image_numbers (10) fixed bin external; dcl sys_info$alrm_mask bit (36) aligned ext; /* BASED */ dcl arg char (arglen) based (argptr); dcl data_move char (c_len * 4) based (mvp); dcl prt_image (64) char (288) based unaligned; dcl exec_wd (0:210000) bit (36) based (execp); dcl ioe (11) bit (36) based (ioe_ptr); dcl reg_move bit (36 * 8) based aligned; dcl fix_wd (2) fixed bin (18) unsigned unaligned based (genp); dcl sctwrk (12) bit (36) based (genp); dcl mme_call_w (0:11) bit (36) based (mmep) aligned; /* mme call template for full words */ dcl 1 mme_call_hw (0:11) based (mmep) aligned, /* mme template for half words */ (2 upper bit (18), 2 lower bit (18)) unaligned; dcl 1 mme_call_hf (0:11) based (mmep) aligned, /* mme template for fixed half words */ (2 upper fixed bin, 2 lower fixed bin) unaligned; /* STRUCTURES */ /* The following structure declaration defines the gcos slave prefix area as used by the slave mode execs. Only areas used by the execs have been defined, the remaining area is set to padx. For a full description of the gcos slave prefix area, refer to gcos manual DD19. */ dcl 1 spa based (execp) aligned, /* slave prefix area, 0 - 77 of slave pgm */ (2 user_fault (0:10) bit (36), /* 0 - 12 = user settable fault vectors */ 2 abort, /* 13 = used for aborting slave pgm */ 3 add bit (18), /* U = abort address */ 3 code bit (18), /* L = abort reason code */ 2 pad1 (5) bit (36), 2 glbtmr bit (36), /* 21 = gelbar mode timer setting */ 2 glbici, /* 22 = gelbar ic and i value */ 3 ic bit (18), /* U = instruction counter value */ 3 ind bit (18), /* L = indicator register */ 2 glbflt bit (36), /* 23 = gelbar fault vector */ 2 pad2 (3) bit (36), 2 wrapup_add bit (18), /* 27 = exec wrap up address */ 2 pad3 bit (18), 2 pad4 bit (36), 2 acc_fault bit (36), /* 31 = accumulated fault status word */ 2 enter, /* 32 = entry into exec always at this point */ 3 lreg bit (36), /* 32 = "lreg spa.regs" instruction */ 3 lbar, /* 33 = "lbar bar,du" instruction */ 4 bar bit (18), /* U = bar value to load */ 4 inst bit (18), /* L = "230203"b3 (lbar bar,du) */ 3 ret bit (36), /* 34 = "ret spa.enter.icivlu" instruction */ 3 icivlu, /* 35 = return ic and i value */ 4 ic bit (18), /* U = instruction counter */ 4 ind bit (18), /* L = indicator register */ 2 ccc_icivlu bit (36), /* 36 = ic and i storage while in courtesy call */ 2 pad5 bit (36), 2 regs like mc.regs, /* 40 = return register storage */ 2 ccc_regs like mc.regs, /* 50 = courtesy call register storage */ 2 pad6 (16) bit (36)) unaligned; dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl 1 ci aligned like condition_info; dcl 1 event_out static aligned like event_wait_info; dcl 1 flags aligned, 2 dialed_up bit (1) unal, 2 hung_up bit (1) unal, 2 control bit (1) unal, 2 pad bit (33) unaligned; dcl 1 cata based (io_info.catp) aligned, /* template for deckfile catalog */ 2 n fixed bin, /* number of entries */ 2 key (1 refer (cata.n)) char (24); /* array of key names */ dcl 1 mca_gcata (100) based (gcatp) aligned, (2 equip_type bit (36), 2 cat_index fixed bin, 2 nblk fixed bin (13), 2 dipper_flag bit (4), 2 filename, 3 filename bit (48), 3 diskette_prod_tab bit (12), 3 prog_tab bit (12)) unaligned; dcl 1 gcata (1000) based (gcatp) aligned, /* template for a gcos catalog entry */ (2 edit_rev bit (36), /* bcd edit name and rev */ 2 cat_index fixed bin, /* deckfile catalog index */ 2 pad1 bit (3), 2 nblk fixed bin (14), /* (same as cat_index) */ 2 ident bit (36), /* word 0 of ident blk */ 2 purpose bit (36)) unaligned; /* deck purpose (itr, mdr or fw) */ /* The following structure declaration defines the gcos 11 word I/O entry as used by the slave mode execs. Only areas used by the execs have been defined, the remaining area is set to padx. For a full description of the gcos I/O entry, refer to gcos manual DD14. */ dcl 1 io_entry based (ioe_ptr) aligned, /* :: */ (2 pad1 bit (36), /* word 0 unused */ 2 ext_sts fixed bin, /* extented status address */ 2 pad2 bit (18), 2 pad3 bit (5), 2 sct_add bit (13), /* system config table entry (test page index) */ 2 pad4 bit (18), 2 pad5 bit (36), 2 prim, /* primary device info */ 3 dev_cmd bit (6), /* device command */ 3 dev bit (6), /* punch indicator if not "00"b3 */ 3 pad6 bit (6), 3 io_cmd bit (6), /* iom command */ 3 pad7 bit (6), 3 record_count bit (6), /* idcw/pcw record count */ 2 first_dcw like dcw, /* first dcw relative to iom lal */ 2 pad8 bit (36), 2 second, /* secondary device info (the same as prim unless dual cmd) */ 3 dev_cmd bit (6), /* device command */ 3 prex bit (12), /* preselect index */ 3 io_cmd bit (6), /* iom command */ 3 pad9 bit (5), 3 ignore_term bit (1), /* ignore terminate int, report special int if on */ 3 record_count bit (6), /* idcw/pcw record count */ 2 dcw_ptr fixed bin, /* pointer to dcw list (offset to lal) */ 2 pad10 bit (18), 2 stat_p bit (18), /* ptr to place to store status */ 2 ccc_p bit (18), /* courtesy call ptr */ 2 pad11 bit (36)) unaligned; dcl 1 colts_op_flags aligned ext static, 2 colt_flag bit (1) unaligned init ("0"b), 2 dm_attach bit (1) unaligned init ("0"b), 2 dm_detach bit (1) unaligned init ("0"b), 2 sicm bit (1) unaligned init ("0"b), 2 gicm bit (1) unaligned init ("0"b); dcl 1 gicm based (gicmp) aligned, 2 cltp ptr init (null), 2 ricmp ptr init (null), 2 cc_addr bit (36), 2 st_addr fixed bin, 2 tally fixed bin (21); dcl 1 ricm like icm based (ricmp); dcl 1 wicm like icm based (wicmp); dcl 1 ticm like icm based (ticmp); dcl 1 icm based (icmp) aligned, (2 word_total bit (18), 2 rbuf_addr bit (18), 2 cksum bit (18), 2 test_id bit (18), 2 host_opcode bit (18), 2 fnp_opcode bit (18), 2 icm_buf (icm_tally) bit (36)) unaligned; dcl 1 info_struct based (info_ptr) aligned, 2 ev_chan fixed bin (71), 2 out_pend bit; /* constants */ dcl (quit, lockup, illop, illegal_modifier, illegal_opcode, illegal_procedure, store, program_interrupt, cleanup, tolts_error_) condition; dcl (addr, addrel, bin, bit, divide, fixed, index, length, null, rel, rtrim, string, substr, time, unspec) builtin; %page; /* enviornment initialization */ debug, debugging, q_flag, trace_io, trace = "0"b; exec = ""; call cu_$arg_count (nargs); call cu_$arg_ptr (1, argptr, arglen, code); if arg ^= "polt" & arg ^= "molt" & arg ^= "colt" then do; /* invalid executive */ call com_err_ (0, "mtdsim_", "Invalid executive code - ""^a""", exec); /* tell user */ return; end; exec = arg; term = "0"b; if nargs > 1 then do; do i = 2 to nargs; call cu_$arg_ptr (i, argptr, arglen, code); if arg = "-debug" | arg = "-db" then debug = "1"b; else if arg = "-quit" | arg = "-q" then q_flag = "1"b; /* user wants to return to command level on quits */ else if arg = "-trace" | arg = "-tc" then trace = "1"b; /* user wants mme trace */ else if arg = "-trace_cata_data" | arg = "-tcd" then tcd = "1"b; else if arg = "-tio" then trace_io = "1"b; else if arg = "-probe" | arg = "-pb" then call probe (mtdsim_); end; debugging = "1"b; end; last_mme, isc_cntdn, tio = 0; trace_save, in_ccc, isc_ccc_rqt, rd_blk, gelbar, glb_brk, itr_run = "0"b; /* reset flags */ gicm_count = 0; gicmp, ricmp, ticmp, wicmp = null; /* initialize colts pointers */ call tolts_init_ (exec, error); /* go init our enviornment and create slave seg */ if error ^= 0 then return; /* if error durring init */ on cleanup call clean_up; /* establish cleanup handler */ gndc_flag = "0"b; /* flag to prevent recursive courtsey calls */ call tolts_util_$get_ttl_date (mtdsim_, ttl_date); tolts_active = "1"b; /* set active flag for epilogue handler */ /* search for cm in file system (exec can be polt, molt, or colt) */ call tolts_util_$search (tolts_info.df_iocbp, substr (exec, 1, 1) || "lt." || exec || "cm", t_ptr, c_len, error); if error ^= 0 then do; /* if couldn't find cplt */ call com_err_ (error, exec, "searching for ^alt.^acm", substr (exec, 1, 1), exec); call tolts_init_$clean_up; /* go delete our event channels and slave seg */ return; end; call gload_ (t_ptr, execp, 0, addr (gload_data), error); /* load core image into our work segment */ if error ^= 0 then do; /* problem durring load */ call com_err_ (error, exec, "^a^/attempting to load ^alt.^acm", gload_data.diagnostic, substr (exec, 1, 1), exec); call tolts_init_$clean_up; /* go delete our event channels and slave seg */ return; end; if debugging then call ioa_ (" execp = ^p", execp); if debug then do; debug = "0"b; tolts_info.mult_ans = ""; /* clear out response */ db_query: call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address"); call message_wait; /* wait for user response */ if mult_ans ^= "" then do; db_addr = cv_oct_check_ ((rtrim (mult_ans)), code); if code ^= 0 | db_addr > 65535 then do; call ioa_ ("Debugger: invalid address supplied"); goto db_query; end; db_sv_wd = exec_wd (db_addr); exec_wd (db_addr) = "777650001000"b3; end; end; blk_lbl = block_disp; term_lbl = done; no_blk = no_blk_disp; spa.enter.lreg = rel (addr (spa.regs)) || "073200"b3; /* set lreg instruction (lreg spa.regs) */ if exec = "molt" then string (spa.enter.lbar) = "000630230203"b3; /* set initial lbar instruction (lbar =o630,du) */ else string (spa.enter.lbar) = "000201230203"b3; /* set initial lbar instruction (lbar =o200,du) */ spa.enter.ret = rel (addr (spa.enter.icivlu)) || "630200"b3; /* set return instruction (ret spa.enter.icivlu) */ spa.enter.icivlu.ic = gload_data.definition (1).offset; /* set initial entry point */ spa.enter.icivlu.ind = "0"b; /* initial entry indicators are zero */ on lockup begin; call ioa_ ("^a encountered a lockup fault ^[a dump will be taken^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on illop begin; call ioa_ ("^a encountered a illop fault ^[a dump will be taken ^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on illegal_modifier begin; call ioa_ ("^a encountered an illegal_modifier fault ^[a dump will be taken ^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on illegal_opcode begin; call ioa_ ("^a encountered an illegal_opcode fault ^[a dump will be taken ^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on illegal_procedure begin; call ioa_ ("^a encountered an illegal_procedure fault ^[a dump will be taken ^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on store begin; call ioa_ ("^a encountered a store fault ^[a dump will be taken ^]", exec, ^flt_flag); if ^flt_flag then call fault_dump; else call continue_to_signal_ (error); end; on tolts_error_ begin; call probe (mtdsim_); call clean_up; end; on quit begin; /* establish quit handler */ if ^q_flag then /* if normal operation */ call tolts_alrm_util_$quit; else call continue_to_signal_ (error); end; on program_interrupt begin; /* establish pi handler for debugging */ call hcs_$wakeup (tolts_info.process, tolts_info.quith_event, null, error); end; call tolts_qttyio_ ("??? ", 9); /* exec read for original data */ %page; /* this is the main program dispatcher */ term = "0"b; /* reset terminate condition */ do while (^term); /* loop until we are done */ block_disp: /* target of nonlocal gotos */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); if error ^= 0 then do; /* this is a fatal error, terminate our process */ call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if ^debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; /* no need to return, as we won't be back */ if tolts_info.wait_list.nchan > 1 then do; /* if we are waiting for > 1 event */ if event_out.channel_id ^= wait_list.wait_event_id (2) | event_out.channel_id ^= tolts_info.dm_event then do; /* if the wake up is not for the second channel */ ev_occurred = 0; /* initialize in case code ^= 0 */ call ipc_$read_ev_chn (wait_list.wait_event_id (2), ev_occurred, addr (event_out), code); /* check and see if the second channel is ready */ if code ^= 0 then do; call com_err_ (code, exec, "Error calling ipc_$read_ev_chn"); if debugging then signal tolts_error_; end; if ev_occurred ^= 1 then do; if nr_cnt < 20 then do; if debugging then call ioa_ ("nr_cnt = ^d", nr_cnt); wake_time = 500000; call timer_manager_$sleep (wake_time, "10"b); nr_cnt = nr_cnt + 1; call wake_disp; /* if the second channel hasn't awaken then wait */ end; else do; if substr (clt_sw, 3, 4) = "c000" then do; /* if exec chan - wrapup */ call tolts_qttyio_$rs (0, "^as: timeout error attempting attach of ^a", tolts_info.exec, clt_sw); /* notify the user */ call tolts_abort ("$c1"); /* then abort colts */ end; else do; call rel_tst_chan (l); colts_pages (l).in_use = "0"b; /* reset test page active */ call tolts_qttyio_$rs (0, "^as: timeout error attempting a tandd_attach of ^a", tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6)); colts_op_flags.colt_flag = "0"b; /* make use flag is reset so we don't go blocked */ colts_op_flags.sicm = "0"b; colts_op_flags.dm_attach = "0"b; if mme_call_hf (2).lower ^= 0 then do; /* cc requested */ exec_wd (mme_call_hf (2).upper) = "000000000004"b3; /* store error status */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */ end; colts_pages (l).status_word = "000000000002"b3; /* test channel - store status */ end; end; end; end; tolts_info.wait_list.nchan = tolts_info.wait_list.nchan - 1; /* else decrement the wait list */ chan_name, io_module = ""; n_dialed = 0; flags = ""b; call convert_dial_message_$return_io_module (event_out.message, chan_name, io_module, n_dialed, flags, code); /* convert the message into flags */ if code ^= 0 then do; call ioa_$rsnnl ("error attaching channel ^a", emsg, mesg_len, chan_name); call output_status_code (code, emsg); end; if trace_io then call ioa_ ("Channel ^a, IO Module ^a, N_dialed ^d, flags^[ dialed_up^]^[ hung_up^]^[ control^]", chan_name, io_module, n_dialed, flags.dialed_up, flags.hung_up, flags.control); if flags.control /* if control flag then error */ | (^flags.control /* or an informative message */ & ^flags.dialed_up & ^flags.control) then do; /* with no information */ if substr (clt_sw, 3, 4) = "c000" then do; /* if exec chan - wrapup */ call tolts_qttyio_$rs (0, "^as: control error attempting dial_manager_attach of ^a", tolts_info.exec, substr (clt_sw, 1, 6)); /* notify user */ call tolts_abort ("$c0"); /* then abort colts */ end; else do; call rel_tst_chan (l); colts_pages (l).in_use = "0"b; /* reset test page active */ call tolts_qttyio_$rs (0, "^as: control error attempting a tandd_attach of ^a", tolts_info.exec, substr (colts_pages (l).cdt_name, 1, 6)); colts_op_flags.colt_flag = "0"b; /* make use flag is reset so we don't go blocked */ colts_op_flags.sicm = "0"b; colts_op_flags.dm_attach = "0"b; if mme_call_hf (2).lower ^= 0 then do; /* cc requested */ exec_wd (mme_call_hf (2).upper) = "000000000002"b3; /* store error status */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (mme_call_hw (2).lower || "000000"b3)); /* enter cc request */ end; colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */ end; end; if flags.dialed_up & colts_op_flags.dm_attach then do; /* if the channel is dialed attaching */ call iox_$attach_name ((clt_sw), cltp, att_desc, null, code); /* create an io switch */ if code ^= 0 then goto sw_err; /* if error */ call iox_$open (cltp, 3, "0"b, code); /* open a switch */ if code ^= 0 then goto sw_err; /* if error */ call iox_$modes (cltp, "rawi,rawo", "", code); /* now set the modes for the channel */ if code ^= 0 then do; /* if error */ sw_err: if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel - wrapup */ call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */ call tolts_qttyio_$rs (0, "^as: ^a/ attempting a switch operation for ^a", tolts_info.exec, lginfo, clt_sw); /* and notify the user */ call tolts_abort ("$c1"); /* then abort colts */ end; else do; colts_pages (l).status_word = "000000000002"b3; /* else test channel - store status */ colts_pages (l).in_use = "0"b; end; end; if code = 0 then do; if substr (clt_sw, 3, 4) = "c000" then do;/* if exec channel */ tolts_info.fnp (k).exec_active = "1"b; /* set exec active */ fnp (k).fnp_execp = cltp; /* save iocb ptr */ exec_wd (remote_inquiry_ic) = "0000000500"b3 || "1"b || substr (bit (k), 2, 5); /* answer remote inquiry request */ end; else do; /* else a test channel */ colts_pages (l).chanp = cltp; /* save iocb ptr */ colts_pages (l).status_word = "000000000004"b3; /* store good status */ exec_wd (remote_inquiry_ic) = "0000000500"b3 || "0"b || substr (bit (l), 2, 5); /* answer remote inquiry request */ end; colts_op_flags.colt_flag = "0"b; /* reset colts flag */ colts_op_flags.dm_attach = "0"b; /* reset dial_manager attach flag */ remote_inquiry_ic = 0; /* reset remote inquiry ic */ end; end; end; if colts_op_flags.sicm then do; /* if an icm need to be sent to the fnp */ call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send it */ if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp colt exec ^a", tolts_info.exec, lginfo, fnp (k).fnp_execp); call tolts_abort ("$c1"); /* then abort colts */ end; gicmp = addr (gicm); /* else get ptr for return icm */ gicm_count = gicm_count + 1; /* inc position in the queue */ if gicm_count = 17 then do; /* if 17 - error */ call tolts_qttyio_$rs (0, "^as: execessive outstanding io's", tolts_info.exec); call tolts_abort ("$c2"); /* abort colts */ end; gicm.cltp = fnp (k).fnp_execp; /* save iocb ptr */ gicm.ricmp = ricmp; /* rtrn icm ptr */ gicm.tally = bin (wicm.word_total) + 1; /* tally */ if mme_call_hf (2).lower ^= 0 then do; /* cc requested */ gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save cc address */ gicm.st_addr = mme_call_hf (2).upper; /* save status address */ end; colts_op_flags.sicm = "0"b; /* reset send icm flag */ end; if tolts_info.special_fault then do; /* special int. fault from tolts_io_int_ */ tolts_info.special_fault = "0"b; call tolts_abort ("$b6"); end; else if tolts_info.exec_term_io_wait then term = "1"b; /* we are all done */ else if tolts_info.first_request_done then do; /* if we have something to do... */ no_blk_disp: /* target of non-local gotos */ if gicm_count ^= 0 then do; /* if outstanding icm */ alloc info_struct; /* alloc an info struct */ info_ptr = addr (info_struct); /* get its ptr */ if gicm.cltp ^= null then do; /* if slot is in use */ call iox_$control (gicm.cltp, "read_status", info_ptr, code); /* read the status */ if info_struct.out_pend then do; /* output ready */ call iox_$get_chars (gicm.cltp, gicm.ricmp, gicm.tally * 4, n_read, code); /* get the icm */ if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer from fnp", tolts_info.exec, lginfo); call tolts_abort ("$c1"); /* then abort colts */ end; if gicm.cc_addr ^= "0"b3 then do; /* if a courtesy call requested */ if fnp (k).fnp_execp = gicm.cltp then exec_wd (gicm.st_addr) = fnp (k).status_word; else exec_wd (gicm.st_addr) = colts_pages (l).status_word; call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (gicm.cc_addr)); /* enter ccc request */ end; gicm_count = gicm_count - 1; /* dec the count */ gicm.cltp = null; /* open up the slot */ gicm.ricmp = null; if gicm_count = 0 then do; /* delete unused gicms */ free gicm; gicmp = null; end; end; end; free info_struct; /* free the info structure */ end; if isc_ccc_rqt then do; /* if outstanding inter slave read ... */ if tolts_info.exec_dta_cnt = 0 then isc_cntdn = isc_cntdn - 1; /* but no data to xfer yet ... */ if isc_cntdn = 0 | tolts_info.exec_dta_cnt ^= 0 then do; /* if timeout or isc data avail */ isc_ccc_rqt = "0"b; /* reset isc courtesy call flag and enter courtesy call */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), (isc_queue.icivlu)); exec_wd (isc_queue.status_add + 1) = "0"b;/* dcw residue = zero */ if tolts_info.exec_dta_cnt = 0 then /* if no data to xfer... */ exec_wd (isc_queue.status_add) = "400006000000"b3; /* set status to timeout */ else call pop_isc (isc_queue.status_add, isc_queue.data_add); /* data to xfer */ end; end; if ^in_ccc & ^gndc_flag then /* if not in ccc */ if tolts_info.ccc_requests ^= 0 & ^gelbar then do; /* pay courtesy call first */ unspec (spa.ccc_regs) = addr (spa.regs) -> reg_move; /* move current regs into safe store */ spa.ccc_icivlu = string (spa.enter.icivlu); string (spa.enter.icivlu) = tolts_info.ccc_queue (1).icivlu; tolts_info.ccc_requests = tolts_info.ccc_requests - 1; /* decrement count */ do i = 1 to tolts_info.ccc_requests; tolts_info.ccc_queue.icivlu (i) = tolts_info.ccc_queue.icivlu (i + 1); /* move queue down */ end; in_ccc = "1"b; end; else if rd_blk then do; /* road blocked? */ if isc_ccc_rqt then call wake_disp; /* wakeup dispatcher */ rd_blk = "0"b; end; if trace | (trace_save & in_ccc) then /* if tracing mmes and dispatches */ call tolts_qttyio_$rs (10, "^a ^a ^12.3b^[, ^a^;^s^]^[, ^a ^6.3b^;^2s^]^[, ^a ^a ^12.3b, ^a ^12.3b^]", ctime (), "Dispatch to ici -", string (spa.enter.icivlu), in_ccc, "in courtesy call", gelbar, "in gelbar, BAR -", spa.enter.lbar.bar, glb_brk, "gelbar break,", "gb ici -", string (spa.glbici), "gbfv -", spa.glbflt); glb_brk = "0"b; /* reset gelbar break indicator if set */ gndc_flag = "0"b; if ^flt_flag then call tolts_alm_util_$enter_slave_ (addr (spa.enter)); /* enter slave program */ end; done: /* target of nonlocal goto */ end; if ^tolts_active then return; tolts_info.exec_term_io_wait = "1"b; /* make sure we quit */ call clean_up; /* go cleanup our enviornment */ return; /* and return to tolts command level */ %page; /* mme_fault - static condition handler for GCOS type mme faults */ mme_fault: entry (mcptr, cname, tptr1, tptr2, tcont); dcl (mcptr, tptr1, tptr2) ptr; dcl cname char (*); dcl tcont bit (1); dcl tags (1:8) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl fnp_state (0:4) char (7) static options (constant) init ("free ", "unknown", "down ", "booting", "up "); mcp = mcptr; /* get ptr to machine conditions */ scup = addr (mc.scu); /* get ptr to scu data */ unspec (spa.regs) = addr (mc.regs) -> reg_move; /* save the processor regs */ spa.enter.icivlu.ind = string (scu.ir); if gelbar then /* if in gelbar mode, pass fault on to gcos module */ call set_gelbar; /* we want return from this call */ mmep = addrel (execp, scu.ilc); /* set mme call ptr */ if substr (mme_call_w (0), 19, 10) ^= "0000000010"b then /* if not mme1 instruction... */ go to undefm; if in_ccc then if mme_call_hw (0).upper ^= "000016"b3 then do; call tolts_qttyio_$rs (0, "^as: Illegal mme in ccc (^12.3b) @ ^p", exec, mme_call_w (0), mmep); call tolts_abort ("$a4"); end; mme_number = mme_call_hf (0).upper; if (mme_number < -127 | mme_number > 31) /* if out of legal range */ | (mme_number < -66 & mme_number > -87) | (mme_number < -94 & mme_number > -127) then go to undefm; if trace | trace_save then do; /* if tracing mmes and dispatches */ if trace then do; /* if currently tracing */ if (mme_number = -1 & last_mme = -39) | (mme_number = -39 & last_mme = -1) | mme_number = last_mme then do; /* do not display idle loop */ trace_save = "1"b; /* save state and turn trace off */ trace = "0"b; /* idle loop */ end; end; else if mme_number ^= last_mme then do; /* if idle loop has ended */ trace = "1"b; /* turn back on trace */ trace_save = "0"b; end; end; last_mme = mme_number; /* save mme number for nxt time */ go to mme_typ (mme_number); /* process gcos mme */ %page; /* ********* MME ABSTIM ********* (absolute time) input registers: none mme abstim ------ return return registers: AR = time of day, 1/64 ms. since midnight */ mme_typ (-1): if trace then call tolts_qttyio_$rs (10, "^a MME ABSTIM @ ^p", ctime (), mmep); call tolts_init_$gc_tod (spa.regs.a); /* get current time of day */ call return_plus (1); /* ********* MME ACCWRT ********* (accounting file write, unused in Multics) input registers: x1 -> message address mme accwrt ------ return return registers: none */ mme_typ (-2): if trace then call tolts_qttyio_$rs (10, "^a MME ACCWRT @ ^p", ctime (), mmep); call return_plus (1); /* ********* MME ASGPAT ********* (assign peripheral allocation table, unused in Multics) input registers: X1 = sct (test page index mod 4), X4 = pat address (lal offset) mme asgpat ------ return return registers: X2 = sct word 1 (returned = 0) */ mme_typ (-5): if trace then call tolts_qttyio_$rs (10, "^a MME ASGPAT @ ^p", ctime (), mmep); spa.regs.x (2) = "0"b; /* set # modules to zero */ call return_plus (1); %page; /* ********************************************************************************* * alternate mtar device is defined as "alt sct addr = (page index) *4 + 512 * ********************************************************************************* */ /* ********* MME ALLOCR ********* (allocate peripheral) input registers: x1 = sct (test page index mod 4) x3 = chan number if new format mme allocr zero ficcdd,delaysct ficcdd ptr, sct value if delayed allocation zero sctwrk,mtardata ficcdd ptr to sct work area. mtardata is storage for (even) mtar r/w flag (molts only) zero alcflg,0 ptr to alcflg zero alcccp,dldcwp ptr to courtesy call routine, ptr to dcw for delayed allocation message ---- return error (mme call + 5) ---- return ask stranger permission (mme call + 6) ---- return not free (mme call + 7) ---- return allocated or usage count bumped (mme call + 8) ---- return shared device (mme call + 9) ---- return allocation in progress, wait (mme call + 10) return registers: X2 = error code on error (see set_sctwrk subroutine for error codes) * output in sctwrk (12 words): see the set_sctwrk subroutine */ mme_typ (-4): if trace then call tolts_qttyio_$rs (10, "^a MME ALLOCR @ ^p", ctime (), mmep); call get_px_sct ("ALLOCR", bin (spa.regs.x (1), 17), "0"b); /* get test page index */ call set_sctwrk (io_sel); /* go set up the sct work area */ if spa.regs.x (2) ^= "0"b then do; /* if some error from tolts_device_info_... */ if fixed (spa.regs.x (2)) = m_iv_iom then /* if invalid IOM number... */ spa.regs.x (2) = "0"b; /* correct error code */ call return_plus (5); /* take error return */ end; io_info_ptr = addr (pages (io_sel)); /* get ptr to this test page */ /* create an event call channel for tdio status events */ if ^io_info.ev_ch_ass then do; /* we we havn't done this already */ call tolts_init_$cr_event_chan (io_info.status_event, "1"b, tolts_io_int_, io_info_ptr, 2, error); if error ^= 0 then /* if error creating event call chan */ call tolts_abort ("$a9"); io_info.ev_ch_ass = "1"b; /* set event chan assigned flag */ end; if mme_call_hf (1).lower = 0 then do; /* if we havn't already attached perp... */ alt_flag, rd_flag = "0"b; /* make sure we start in a known state */ if io_info.devsct.type_code = "22"b3 /* if ccu as a reader */ & ^io_info.ccu_pun then rd_flag = "1"b; /* set read flag */ if ^io_info.alloc_wait & ^io_info.p_att then do; if io_info.io_type = mca_io_type & io_info.mca_attach_state = MCA_NOT_CONFIGURED then do; call mca_$attach_mca ((io_info.device_name), io_info.status_event, io_info.mca_ioi_idx, error); io_info.mca_attach_state = MCA_FREE; end; else do; attach: if ^alt_flag then do; /* if we want the primary or only channel */ call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a", att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name); call rcp_priv_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event, att_desc, io_info.rcp_id, error); end; else do; call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a", att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.alt_device_name); call rcp_priv_$attach (io_info.rcp_name, addr (io_info.alt_rcp_area (1)), io_info.status_event, att_desc, io_info.alt_rcp_id, error); end; if error ^= 0 then do; call output_status_code (error, "rcp attach error"); call dealcp_sub; /* go release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; if ^alt_flag then call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index, tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err); else call rcp_$check_attach (io_info.alt_rcp_id, addr (io_info.alt_rcp_area (1)), coment, io_info.alt_device_index, tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err); end; end; end; /* only one call to rcp_$check_attach here. If delayed allocation (tape or disk), RCP will signal (via the status call channel) tolts_io_int_, when an event has ocurred. tolts_io_int_ will check the rcp state flag and either return and let RCP work if attachment is incomplete or enter the courtesy call request and signal the dispatcher if the attachment is complete or if an error has occurred */ /* ********************************************* * check for mtar write permission denial * ********************************************* */ if io_info.io_type = mtar_io_type & (^io_info.p_att | io_info.alt_dev_flag) then do; if io_info.attach_err = error_table_$force_unassign then do; if ^alt_flag then disk_info_ptr = addr (io_info.rcp_area (1)); else disk_info_ptr = addr (io_info.alt_rcp_area (1)); if ^rd_flag then do; /* opr denied write request */ disk_info.write_flag = "0"b; /* read only */ rd_flag = "1"b; goto attach; end; else do; call output_status_code (io_info.attach_err, "ioi_assign error--check attach"); call dealcp_sub; /* go release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; end; end; if ^io_info.p_att | ^io_info.p2_att then do; if io_info.attach_err ^= 0 | error ^= 0 then do; if io_info.attach_err = error_table_$resource_unavailable then do; /* must have been busy */ spa.regs.x (2) = bit (dev_busy); /* set appropriate error code */ if ^io_info.dev_busy then do; /* only output device busy message once */ call tolts_qttyio_$rs (0, "^a device busy, allocation queued", io_info.test_hdr); io_info.dev_busy = "1"b; /* set flag so we only output message once */ end; call return_plus (7); /* return ic + 7 */ end; if io_info.io_type ^= mca_io_type then call output_status_code (io_info.attach_err, "ioi_assign error--check attach"); else call output_status_code (error, " mca assign error"); call dealcp_sub; /* go release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; if io_info.rcp_state ^= 0 /* return - allocation wait */ | (io_info.io_type = mca_io_type & io_info.mca_attach_state < MCA_ATTACHED) then do; io_info.alloc_wait = "1"b; /* set wait flag for tolts_io_int_ */ io_info.icivlu.ic = mme_call_hw (4).upper; /* save ccc ptr for tolts_io_int_ */ io_info.icivlu.ind = "0"b; call tolts_qttyio_$dcw_list (addrel (execp, mme_call_hf (4).lower), 0); tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */ call return_plus (10); /* return ic + 10, allocation wait */ end; if io_info.io_type = mdr_io_type & ^io_info.p2_att then /* if running mdrs */ if substr (io_info.device_name, 1, 3) = "tap" /* if tape */ | substr (io_info.device_name, 1, 3) = "dsk" then do; /* or disk */ io_info.p2_att = "1"b; /* set perph attach flag */ io_info.alt_rcp_id = io_info.rcp_id; /* mv rcp id to alt rcp id */ go to mme_typ (-4); /* we have the mpc now go get the dev */ end; if ^alt_flag then io_info.p_att = "1"b; /* set perp attach flag */ else io_info.p2_att = "1"b; io_info.dev_busy = "0"b; /* reset device busy flag */ end; /* *************************************************** * attach alternate device for mtar if required * *************************************************** */ if io_info.io_type = mtar_io_type & io_info.alt_dev_flag & io_info.p_att & ^io_info.p2_att then do; if rd_flag then do; /* sct requested permission equal to that of primary */ disk_info_ptr = addr (io_info.alt_rcp_area (1)); disk_info.write_flag = "0"b; rd_flag, alt_flag = "1"b; goto attach; end; else do; disk_info_ptr = addr (io_info.alt_rcp_area (1)); disk_info.write_flag = "1"b; rd_flag = "0"b; alt_flag = "1"b; goto attach; end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* set permission code for mtar */ /* The address for permission storage is in the lower half of (mme call + 2). */ /* appropriate permission is stored in the lower half of the target word, */ /* 0 = write permission, 8 = read permission */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if ^rd_flag then exec_wd (mme_call_hf (2).lower) = exec_wd (mme_call_hf (2).lower) & "777777000000"b3; else exec_wd (mme_call_hf (2).lower) = (exec_wd (mme_call_hf (2).lower)) | ("000000000010"b3); if io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then /* if tape device... */ call decode_den; /* go decode density info */ if io_info.io_type = mca_io_type then call get_temp_segment_ ("mca_workspace", io_info.workspace_ptr, error); else call ioi_$workspace (io_info.device_index, io_info.workspace_ptr, tolts_info.wks_sz, error); if error ^= 0 then do; call output_status_code (error, "workspace assign error"); call dealcp_sub; /* go release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; io_info.cur_wks_sz = tolts_info.wks_sz; /* set current value of workspace size */ if io_info.io_type ^= mca_io_type then do; ioi_wksp = io_info.workspace_ptr; call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_workspace.status)), 18), 1, error); if error ^= 0 then do; call output_status_code (error, "set_status error"); call dealcp_sub; /* go detach and release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; if io_info.nff then do; iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1; chan = fixed (substr (io_info.devsct.icc, 6, 6), 6); end; else do; iom = fixed (substr (io_info.devsct.icc, 1, 3), 3) + 1; chan = fixed (substr (io_info.devsct.icc, 4, 6), 6); end; call ioi_$set_channel_required (io_info.device_index, iom, chan, error); if error ^= 0 then do; call output_status_code (error, "set_channel error"); call dealcp_sub; /* go detach and release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; timeout_time = 30000000; /* set timeout to a minimum value of 30 sec */ if io_info.io_type = mdr_io_type & io_info.devsct.type_code = "001110"b then /* if mdr and 601/610 */ timeout_time = 390000000; /* set timeout to 6.5 mins */ else if io_info.io_type = itr_io_type /* if mdrs on an eurc */ & io_info.devsct.cr501_pr54 then timeout_time = 60000000; /* time_out = 1min */ else if io_info.io_type = mtar_io_type then timeout_time = 90000000; /* time_out = 1.5min */ io_info.lostit_time = /* set lostit time = time_out time + 1sec * 64 / 1000 */ divide ((timeout_time + 1000000) * 64, 1000, 35); call ioi_$timeout (io_info.device_index, timeout_time, error); if error ^= 0 then do; call output_status_code (error, "set timeout error"); call dealcp_sub; /* go release status event */ spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (5); /* take error return */ end; end; io_info.allocated = "1"b; call return_plus (8); /* return ic + 8 - good return */ %page; /* ********* MME CATA. ********* (Get itr or mdr deckfile catalog) input registers: qu = ICC * x1 = ptr to call seq (defined by cata_call structure (below) * x2 = max load address * x3 = test page base mme cata. ------ return if error ------ return if more or extenstion file follows ------ return if all read return registers: AL = words read in this call * Q-reg = error code * status word 1 bit 18 set for extension call */ dcl 1 cata_call based (genp) aligned, /* structure for mme cata and mme data */ (2 fdcwp bit (18), /* first dcw ptr */ 2 statp bit (18), /* ptr to status */ 2 patp bit (18), /* ptr to PAT entry */ 2 nblk fixed bin) unaligned; /* next catalog block */ mme_typ (-50): if trace | tcd then call tolts_qttyio_$rs (10, "^a MME CATA. @ ^p", ctime (), mmep); if substr (spa.regs.q, 7, 1) then /* if new format */ call get_px_tcx ("CATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */ else call get_px_tcx ("CATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */ if io_info.io_type = mca_io_type then do; if io_info.mcata_idx = 0 then do; call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata.nio.mca", addr (io_info.n_keys), error); if error ^= 0 then do; /* if we couldn't find catalog */ call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name); call return_plus (1); /* take error return */ end; call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (1)), io_info.catp, c_len, error); if error ^= 0 then do; /* if we couldn't find catalog */ call output_status_code (error, "searching for " || io_info.cata_keys (io_info.mcata_idx)); call return_plus (1); /* take error return */ end; do io_info.mcata_nkeys = 1 to cata.n; io_info.mcata_keys (io_info.mcata_nkeys) = cata.key (io_info.mcata_nkeys); end; io_info.mcata_idx = 1; end; io_info.cat_name = substr (io_info.mcata_keys (io_info.mcata_idx), 6, 7); end; if io_info.catx = 0 then do; /* only select catalog keys once */ call tolts_util_$cata_sel (tolts_info.df_iocbp, "cata." || io_info.cat_name, addr (io_info.n_keys), error); if error ^= 0 then do; /* if we couldn't find catalog */ call output_status_code (error, "selecting catalog subset of cata." || io_info.cat_name); call return_plus (1); /* take error return */ end; io_info.catx = io_info.n_keys; if io_info.io_type ^= mca_io_type & io_info.n_keys > 1 then do; /* multiple catalogs */ call tolts_qttyio_$rs (0, "^a Multiple catalog files (^d) for ^a ^a catalog.", io_info.test_hdr, io_info.n_keys, substr (io_info.cat_name, 5), substr (io_info.cat_name, 1, 3)); do io_info.catx = 1 to io_info.n_keys; i = search (substr (io_info.cata_keys (io_info.catx), 10), "."); call tolts_qttyio_$rs (0, "^a ^a catalog, ^[firmware rev ^a^] - ", substr (io_info.cata_keys (io_info.catx), 10, i - 1), substr (io_info.cata_keys (io_info.catx), 6, 3), (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"), substr (io_info.cata_keys (io_info.catx), 10 + i)); end; call tolts_qttyio_$rs (0, "^a^/^a", "Indicate which one is to be used by answering yes to", "one of the following catalog entrys:"); tolts_info.mult_ans = ""; /* clear out response */ do io_info.catx = 1 to io_info.n_keys while (mult_ans = "" | mult_ans = "no" | mult_ans = "n"); i = search (substr (io_info.cata_keys (io_info.catx), 10), "."); requery: call tolts_qttyio_$rs (19, "^a ^a catalog, ^[firmware rev ^a^] - ", substr (io_info.cata_keys (io_info.catx), 10, i - 1), substr (io_info.cata_keys (io_info.catx), 6, 3), (substr (io_info.cata_keys (io_info.catx), 6, 3) = "itr"), substr (io_info.cata_keys (io_info.catx), 10 + i)); call message_wait; /* wait for user response */ if tolts_info.mult_ans ^= "" & (mult_ans ^= "yes" & mult_ans ^= "y") & (mult_ans ^= "no" & mult_ans ^= "n") then do; call tolts_qttyio_ ("Please answer yes, no, or eom", 0); go to requery; /* go ask again */ end; end; io_info.catx = io_info.catx - 1; /* currect io_info.catx */ if io_info.catx > io_info.n_keys | (mult_ans ^= "yes" & mult_ans ^= "y") then call return_plus (1); /* take error return */ end; end; else if io_info.io_type = mca_io_type then do; if ^io_info.cata_cycle then io_info.cata_cycle = "1"b; /* first time thru */ else do; /* must be second pass */ if io_info.catx > 1 then /* if diskette catalog index > 1 */ io_info.catx = io_info.catx - 1; /* subtract 1 */ else do; /* else move to the mca cata index */ io_info.mcata_idx = io_info.mcata_idx + 1; io_info.catx = 0; /* reset the diskette catalog index */ end; io_info.cata_cycle = "0"b; end; spa.regs.a = "0"b; /* intialize words read to 0 */ end; if io_info.catx ^= 0 then do; call tolts_util_$search (tolts_info.df_iocbp, (io_info.cata_keys (io_info.catx)), io_info.catp, c_len, error); if error ^= 0 then do; /* if we couldn't find catalog */ call output_status_code (error, "searching for " || io_info.cata_keys (io_info.catx)); call return_plus (1); /* take error return */ end; genp = addrel (execp, spa.regs.x (1)); /* get ptr to slave call */ dcwp = addrel (execp, cata_call.fdcwp); /* get ptr to dcw */ gcatp = addrel (execp, dcw.address); /* get ptr to buffer */ if trace | tcd then call tolts_qttyio_$rs (10, "MME CATA.; loading catalog ""cata.^a"" @ ^p", io_info.cat_name, gcatp); do i = 1 to cata.n; /* give page all catalog entries */ if io_info.io_type = mca_io_type then do; unspec (mca_gcata (i)) = "0"b; /* reset this entry */ mca_gcata (i).cat_index, mca_gcata (i).nblk = i; /* set cata index & block number */ if index (cata.key (i), "HDR") ^= 0 then do; mca_gcata (i).dipper_flag = "0100"b; /* set header flag */ filename_idx = index (cata.key (i), after (cata.key (i), "HDR.")); /* get index of filename */ end; else if index (cata.key (i), "DIR") ^= 0 then do; mca_gcata (i).dipper_flag = "0101"b; /* set dir flag */ filename_idx = index (cata.key (i), "DIR"); /* get index of filename */ end; else if index (cata.key (i), "cata") ^= 0 then do; mca_gcata (i).dipper_flag = "0100"b; /* set cata flag */ filename_idx = index (cata.key (i), after (cata.key (i), "nio.")); /* get index of filename */ end; else filename_idx = index (cata.key (i), after (cata.key (i), "nio.")); /* get index of filename */ call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), filename_idx, 12), bit_buf); unspec (mca_gcata (i).filename) = bit_buf; end; else do; unspec (gcata (i)) = "0"b; /* clear element first */ j = length (rtrim (cata.key (i))); /* get true length of key */ ac_name = substr (cata.key (i), j - 6, 4) || substr (cata.key (i), j - 1, 2); call tolts_alm_util_$ascii_to_bcd_ (ac_name, gcata (i).edit_rev); /* set edit name an rev */ gcata (i).cat_index, gcata (i).nblk = i; /* set index */ if j < 13 then call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j, 6), gcata (i).ident); /* set ident */ else call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), j - 13, 6), gcata (i).ident); /* set ident */ if index (cata.key (i), ".") > 4 then /* if firmware */ call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 6), gcata (i).purpose); else do; call tolts_alm_util_$ascii_to_bcd_ (substr (cata.key (i), 1, 3), b18); substr (gcata (i).purpose, 19, 18) = b18; end; end; end; spa.regs.a = bit (bin (cata.n * 4, 36)); /* set words read */ end; if io_info.mcata_idx <= io_info.mcata_nkeys & io_info.io_type = mca_io_type then call return_plus (2); /* still more catalogs to read */ else call return_plus (3); /* take good return */ /* ********* MME CHANTM ********* (channel time) input registers: X1 = sct (test page index mod 4), X4 = pat address (lal offset) mme chantm ------ return return registers: AR = channel time */ mme_typ (-6): if trace then call tolts_qttyio_$rs (10, "^a MME CHANTM @ ^p", ctime (), mmep); call get_px_sct ("CHANTM", bin (spa.regs.x (1), 17), "1"b); /* get test page index */ spa.regs.a = bit (bin (pages (io_sel).chan_time, 36)); call return_plus (1); /* ********* MME CLEARQ ********* (clear ISC queue) input/return registers: none mme clearq ------ return */ mme_typ (-7): if trace then call tolts_qttyio_$rs (10, "^a MME CLEARQ @ ^p", ctime (), mmep); isc_ccc_rqt = "0"b; if isc_cntdn ^= 1 then isc_cntdn = 0; call return_plus (1); %page; /* ********* MME COINIT ********* (colts slave executive initialize) input/output registers: none mme coinit zero 6,0 number of designators zero wwflag,1 zero lstloc,2 core size available as loaded zero tdflt,5 wrapup address zero mmexec,7 interface module ttl zero systyp,10 os type zero crd30,11 .crd30 bit 17 = 1 if fnp active and 18-29 = # of active fnps ---- return return is mme call + the number of designators + 2 .crfig: 0 = series 60 0r 6000 6 = system sckd. save opt. 24-30 = reserved for gcos 1 = class. module present 7 = reserved for gcos 31 = not in mem avail. space tab 2 = shared memory system 8,9,10,11 = ioms 0-3 configured 32 = RLP300 present 3 = >256k 12,13,14,15 = CPUs 0-3 configured 33 = DN30 4 = IOM system 16-19 = reserved for gcos 34 = DN305 5 = series 60 system 20,21,22,23 = CPU has EIS 35 = DN 355/6600 */ mme_typ (-62): if trace then call tolts_qttyio_$rs (10, "^a MME COINIT @ ^p", ctime (), mmep); exec_wd (mme_call_hf (2).upper) = "0"b; /* zeros says not ww system */ spa.wrapup_add = mme_call_hw (4).upper; /* set wrapup address */ call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */ exec_wd (mme_call_hf (5).upper) = bcd_callname; /* and store in message */ substr (exec_wd (mme_call_hf (5).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */ genp = addrel (execp, mme_call_hf (3).upper); /* get ptr to lstloc */ if fix_wd (1) ^= 0 then /* if lstloc specified... */ mem_now, fix_wd (1) = fix_wd (1) + 49152; /* add 48k to lstloc */ else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 49152; /* otherwise use loaded length */ call cpu_time_and_paging_ (i, cpu_time, j); /* get current cpu time */ tolts_info.init_time = cpu_time; /* save */ exec_wd (mme_call_hf (6).upper) = "000000000002"b3; /* set os to multics */ exec_wd (mme_call_hf (7).upper) = "000001001000"b3; /* set fnp present bit and number of active fnp's to max */ fnp.status_word, colts_pages.status_word = "000000000004"b3; call return_plus (8); /* ********* MME CONTML ********* (controlling terminal) input registers: x1 = old controlling terminal mme contml ------ return tolts aborted ------ return tolts swapped ------ return denied ------ return slaves copying ------ return good return registers: x1 = new logical controlling terminal in lower */ mme_typ (-8): if trace then call tolts_qttyio_$rs (10, "^a MME CONTML @ ^p", ctime (), mmep); spa.regs.x (1) = "000004"b3; /* coded terminal 4 */ call return_plus (5); /* return ic + 5 */ %page; /* ********* MME DATA. ********* (Get itr or mdr from deckfile) input registers: qu = ICC * x1 = ptr to call seq (defined by cata_call structure (see MME CATA.) * x2 = max load address * x3 = test page base * x4 = diskette sector number relative to sector 0 mme data. ------ return if error ------ return if more or extenstion file follows ------ return if all read return registers: AL = words read in this call * Q-reg = error code * status word 1 bit 18 set for extension call */ mme_typ (-51): if trace | tcd then do; call tolts_qttyio_$rs (10, "^a MME DATA. @ ^p to load ^a", ctime (), mmep, cata.key (cata_call.nblk)); genp = addrel (execp, spa.regs.x (1)); /* get ptr to slave call */ end; if substr (spa.regs.q, 7, 1) then /* if new format */ call get_px_tcx ("DATA. ", substr (spa.regs.q, 8, 11)); /* get test page index */ else call get_px_tcx ("DATA. ", substr (spa.regs.q, 10, 9)); /* get test page index */ genp = addrel (execp, spa.regs.x (1)); /* get ptr to slave call */ dcwp = addrel (execp, cata_call.fdcwp); /* get ptr to dcw */ l_ptr = addrel (execp, dcw.address); /* get ptr to buffer */ call tolts_util_$search (tolts_info.df_iocbp, (cata.key (cata_call.nblk)), t_ptr, c_len, error); if error ^= 0 then do; /* if we couldn't find module */ call output_status_code (error, "searching for " || cata.key (cata_call.nblk)); call return_plus (1); /* take error return */ end; if io_info.io_type = mca_io_type then do; if spa.regs.x (4) ^= "777777"b3 then do; /* if data is wanted */ io_info.catx = 0; io_info.mcata_idx = 1; t_ptr = addrel (t_ptr, fixed (spa.regs.x (4)) * 64); /* adjust the ptr to the correct sector */ if bin (dcw.tally) = 0 then tally = 4096; /* ck for a zero tally */ else tally = bin (dcw.tally); if c_len < (fixed (spa.regs.x (4)) * 64) + tally then /* if the data wanted is > then end */ c_len = c_len - fixed (spa.regs.x (4)) * 64; /* adjust the amount to be sent */ else c_len = tally; if c_len < 0 then call return_plus (1); /* should not happen */ mvp = addrel (execp, dcw.address); /* set mvp to where data is to go */ data_move = t_ptr -> data_move; /* move it */ spa.regs.a = bit (bin (c_len, 36)); /* set words read */ end; else spa.regs.a = "0"b; end; else do; call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */ if error ^= 0 then do; call output_status_code (error, gload_data.diagnostic || " loading module " || cata.key (cata_call.nblk)); call return_plus (1); /* take error return */ end; spa.regs.a = bit (bin (gload_data.text_len, 36)); /* set words read */ end; if trace | tcd then call tolts_qttyio_$rs (10, "MME DATA.; loaded ""^a"" @ ^p to ^p for ^d", cata.key (cata_call.nblk), t_ptr, l_ptr, spa.regs.a); call return_plus (3); /* take good return */ %page; /* ********* MME DEALCP ********* (deallocate peripheral) input registers: x1 = sct (test page index mod 4) mme dealcp ------ return return registers: none */ mme_typ (-9): if trace then call tolts_qttyio_$rs (10, "^a MME DEALCP @ ^p", ctime (), mmep); call get_px_sct ("DEALCP", bin (spa.regs.x (1), 17), "0"b); /* get test page index */ call dealcp_sub; if dealc_err ^= 0 then call tolts_abort ("$b3"); else call return_plus (1); /* ********* MME DOFPIO ********* (mme to do reponder io) input registers: x1 = pointer to FPINFO table x3 = test page base a = PCW like direct_channel_pcw q = time out time I/O COMMANDS 71 - Interrupt fnp (uses level 3, 4, 5, 6 & 77) 72 - Bootload fnp (not used) 73 - Interrupt host (uses level 3 & 7) 75 - Test data xfer (fnp - host) 76 - Test data xfer (host - fnp) mme DOFPIO zero good return (mme call + 1) */ mme_typ (-89): if trace | trace_io then call tolts_qttyio_$rs (10, "^a MME DOFPIO ^p, type - ^12.3b", ctime (), mmep, substr (spa.regs.a, 25)); tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1)); do io_sel = 1 to hbound (tolts_info.pages, 1) /* get the correct io_info for this page */ while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num); end; if io_sel > hbound (tolts_info.pages, 1) then call tolts_abort ("$c3"); io_info_ptr = addr (pages (io_sel)); io_info.fpinfo_ptr = tolts_fpinfo_ptr; /* save fpinfo_ptr for this page */ tolts_rspd_wksp = io_info.tolts_rspd_wksp; /* get work space ptr */ tolts_fpinfo.fnpdcw.address = /* set dcw address */ bin (bin (spa.regs.x (3), 18) + bin (substr (spa.regs.a, 1, 18), 18), 18); direct_channel_pcw_ptr = /* set pcw */ addr (tolts_rspd_workspace.mailbox.pcw); substr (unspec (direct_channel_pcw), 19) = substr (spa.regs.a, 19); substr (unspec (tolts_fpinfo.pcw_info), 19) = substr (spa.regs.a, 19); /* save pcw for test page */ io_info.dcw_list (1) = exec_wd (tolts_fpinfo.fnpdcw.address); /* set dcw */ direct_channel_tcw_ptr = addr (tolts_rspd_workspace.tcw); /* get tcw */ unspec (direct_channel_tcw) = unspec (io_info.dcw_list (1)); if direct_channel_pcw.operation = "75"b3 /* if data xfer pcw */ | direct_channel_pcw.operation = "76"b3 then do; /* set up pcw */ substr (spa.regs.a, 1, 18) = unspec (tolts_fpinfo.fnpdcw.address); direct_channel_pcw.tcw_address = wordno (addr (tolts_rspd_workspace.tcw)); end; else direct_channel_pcw.tcw_address = 0; /* else set to 0 */ io_info.pcwa = spa.regs.a; if direct_channel_pcw.operation = "76"b3 then do; /* if sending data - move it */ c_len = direct_channel_tcw.host_word_count; mvp = addrel (execp, bin (substr (spa.regs.a, 1, 18)) + 1); bufp = addr (tolts_rspd_workspace.data_buf); workspace_move = mvp -> workspace_move; end; tolts_rspd_workspace.pcw = direct_channel_pcw; unspec (tolts_rspd_workspace.tcw) = unspec (direct_channel_tcw); tio_off = wordno (direct_channel_pcw_ptr); io_info.lostit_time = bin (tolts_fpinfo.timeout_time); call tolts_init_$gc_tod ((tolts_fpinfo.timeout_time)); tolts_fpinfo.timeout_time = bit (bin (tolts_fpinfo.timeout_time, 36) + io_info.lostit_time, 35); tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt + 1; /* bump io request count */ io_info.io_in_progress = "1"b; io_info.num_connects = io_info.num_connects + 1; call ioi_$connect (io_info.device_index, tio_off, error); if error ^= 0 then do; call output_status_code (error, "io connect error"); call tolts_abort ("$c7"); end; wake_time = 500000; call timer_manager_$sleep (wake_time, "10"b); tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; call return_plus (1); /* ********* MME EXPDEV ********* (return device sct) input registers: x1 = sct (test page index mod 4) mme expdev ------ return return registers: A and Q regs contain 1st and 2nd words of device sct entry */ mme_typ (-12): if trace then call tolts_qttyio_$rs (10, "^a MME EXPDEV @ ^p", ctime (), mmep); call get_px_sct ("EXPDEV", bin (spa.regs.x (1), 17), "1"b); /* get test page index */ spa.regs.a = unspec (io_info.devsct.w1); /* set sct in a */ spa.regs.q = unspec (io_info.devsct.w2); /* and q registers */ call return_plus (1); /* ********* MME FEPTYP ********* (return fnp type) input registers: x2 = logical fep number * 4 mme feptyp oct 0 data returned here ------ return */ mme_typ (-59): if trace then call tolts_qttyio_$rs (10, "^a MME FEPTYP @ ^p", ctime (), mmep); cdtp = cdtptr; j = bin (spa.regs.x (2)); /* get true fnp number */ tolts_info.fnp (j).type = (fnp_entry (j + 1).type); /* find type */ if tolts_info.fnp (j).type = 1 then spa.regs.x (2) = "000002"b3; /* if type 1 (dn355) set code */ else if tolts_info.fnp (j).type = 3 then spa.regs.x (2) = "000001"b3; /* if type 3 (DN6670) set code */ else if tolts_info.fnp (j).type = 0 then spa.regs.x (2) = "777777"b3; /* if type = 0 then illegal type set error return */ if fnp_entry (j + 1).mpxe.current_service_type ^= 1 & fnp_entry (j + 1).state ^= 4 then do; /* if fnp is not up */ spa.regs.x (2) = "777777"b3; /* return a bad code */ call tolts_qttyio_$rs (0, "^as: fnp ^a is ^a", exec, tags (j + 1), fnp_state (fnp_entry (j + 1).mpxe.state)); /* notify the user */ end; call return_plus (1); /* ********* MME FPWRAP ********* (Responder wrapup) input registers: X1 = fpinfo pointer mme fpwrap ------ return */ mme_typ (-93): if trace then call tolts_qttyio_$rs (10, "^a MME FPWRAP @ ^p", ctime (), mmep); tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1)); /* get pointer to test page fpinfo table */ do io_sel = 1 to hbound (pages, 1) /* get the correct io_info for this page */ while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num); end; if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* page not found - */ io_info_ptr = addr (pages (io_sel)); tolts_rspd_wksp = io_info.tolts_rspd_wksp; /* get the io workspace for this page */ tolts_fpinfo.partrs = 0; /* reset tolts assigned flag */ if ^io_info.io_in_progress then tolts_fpinfo.io_rq_cnt = 0; /* reset io rquest count */ unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b; /* reset int count */ tolts_rspd_workspace.mailbox.status_word = "0"b; call dealcp_sub; /* release the fep */ call return_plus (1); /* ********* MME FREEZE ********* (wire main memory (gcos only)) input registers: none mme freeze ------ return return registers: X5 = LAL (returned = 0) */ mme_typ (-53): if trace then call tolts_qttyio_$rs (10, "^a MME FREEZE @ ^p", ctime (), mmep); spa.regs.x (5) = "0"b; /* set x 5 to 0 */ call return_plus (1); %page; /* ********* MME GECALL ********* (load object deck) input registers: none output register: q error code entry options(variable) mme gecall bci 1,name zero add,error return zero transfer add,0 */ mme_typ (18): call bcd_to_ascii_ (mme_call_w (1), ac_name); /* convert callname to ascii */ if trace then call tolts_qttyio_$rs (10, "^a MME GECALL (^a) @ ^p", ctime (), ac_name, mmep); coment = ""; l_ptr = addrel (execp, mme_call_hf (2).upper); call tolts_util_$search (tolts_info.df_iocbp, substr (tolts_info.exec, 1, 1) || "lt." || ac_name, t_ptr, c_len, error); if error ^= 0 then /* if could'nt find polt or molt page, try util */ call tolts_util_$search (tolts_info.df_iocbp, "utl." || ac_name, t_ptr, c_len, error); if error ^= 0 then /* if found test page */ call ioa_$rsnnl ("searching for test page ^a", coment, mesg_len, ac_name); if error = 0 then call gload_ (t_ptr, l_ptr, fixed (spa.regs.x (3), 18), addr (gload_data), error); /* load it */ if error ^= 0 then do; if coment = "" then call ioa_$rsnnl ("^a loading test page ^a", coment, mesg_len, gload_data.diagnostic, ac_name); call output_status_code (error, coment); if mme_call_hw (2).lower = "0"b /* error return = 0 */ then spa.enter.icivlu = spa.wrapup_add; /* set return to molts wrapup */ else do; spa.enter.icivlu.ic = mme_call_hw (2).lower; /* error return */ mme_call_hw (2).lower = "0"b; /* zero error return to prevent loop */ spa.regs.q = "63"b3; /* set q = file not found eror code */ end; end; else spa.enter.icivlu.ic = mme_call_hw (3).upper; /* normal return */ call wake_disp; /* go wake up dispatcher */ /* ********* MME GEENDC ********* (end courtesy call) input/return registers: none mme geendc no return from mme, enters code whereever ccc interrupted */ mme_typ (14): if trace | trace_io then call tolts_qttyio_$rs (10, "^a MME GEENDC @ ^p", ctime (), mmep); if ^in_ccc then do; /* if not in courtesy call complain */ call tolts_qttyio_$rs (0, "^as: MME GEENDC while not in courtesy call", exec); call tolts_abort ("$a6"); end; gndc_flag = "1"b; /* set geendc complete flag */ in_ccc = "0"b; /* reset courtesy call flag */ unspec (spa.regs) = addr (spa.ccc_regs) -> reg_move; string (spa.enter.icivlu) = spa.ccc_icivlu; call wake_disp; /* go wake up dispatcher */ %page; /* ********* MME GEINOS ********* (console write or interslave read) input/return registers: none isc read: mme geinos console write: mme geinos * oct 010000000000 oct 130000000000 * zero quefcd,quedcw zero flcode,ondcw * zero quests,quecc zero ofstat,offccc * ------ return ------ return */ mme_typ (1): if trace then call tolts_qttyio_$rs (10, "^a MME GEINOS @ ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1)); if mme_call_w (1) ^= "130000000000"b3 & mme_call_w (1) ^= "010000000000"b3 then do; /* illegal type */ call tolts_qttyio_$rs (0, "^as: MME GEINOS type ^12.3b not supported", exec, mme_call_w (1)); call tolts_abort ("$a7"); end; dcwp = addrel (execp, mme_call_hf (2).lower); /* get ptr to dcw */ exec_wd (mme_call_hf (3).upper), exec_wd (mme_call_hf (3).upper + 1) = "0"b; /* set status & dcw res to 0 */ if mme_call_hw (1).upper = "010000"b3 then do; /* isc read */ if dcw.type ^= "0"b then do; /* dcw not iotd */ call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc dcw type not iotd. DCW = 12.3b", exec, string (dcw)); call tolts_abort ("$a7"); end; if dcw.tally ^= "0003"b3 then do; /* isc read word cnt must be 3 */ call tolts_qttyio_$rs (0, "^as: MME GEINOS; Read isc word count ^= 3. DCW = 12.3b", exec, string (dcw)); call tolts_abort ("$a7"); end; if tolts_info.exec_dta_cnt ^= 0 then do; /* if data to xfer... */ j = mme_call_hf (3).upper; /* copy status address */ call pop_isc (j, bin (dcw.address, 17)); /* do it */ if mme_call_hf (3).lower ^= 0 then /* if courtesy call requested */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (3).lower || "000000"b3); end; else do; /* no data to xfer */ isc_cntdn = 10000; if mme_call_hf (3).lower ^= 0 then do; /* if courtesy call requested */ isc_ccc_rqt = "1"b; isc_queue.icivlu = mme_call_hw (3).lower || "000000"b3; isc_queue.status_add = mme_call_hf (3).upper; isc_queue.data_add = fixed (dcw.address); end; end; end; else do; /* console write */ if mme_call_hf (3).lower ^= 0 then /* if courtesy call requested */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (3).lower || "000000"b3); call tolts_qttyio_$dcw_list (dcwp, 0); /* output the dcwp */ end; call return_plus (4); /* return ic + 4 */ %page; /* ********* MME GELBAR ********* (load base address register) input registers: AR = upper/ptr to LOC1 structure (defined by gelbar_temp below) * QR = CPU time increment beffor interrupt mme gelbar no return, return to ic value located in gelbar_temp.ic return registers: none */ dcl 1 gelbar_temp based (genp) aligned, /* template for gelbar loc1 and loc1+1 */ (2 bar bit (18), /* desired bar value */ 2 reg_ptr bit (18), /* ptr to register storage */ 2 ic bit (18), /* instruction counter */ 2 ind bit (18)) unaligned; /* indicator register */ mme_typ (31): if trace then call tolts_qttyio_$rs (10, "^a MME GELBAR @ ^p", ctime (), mmep); spa.glbtmr = spa.regs.q; /* store entry timer setting */ genp = addrel (execp, substr (spa.regs.a, 1, 18)); /* get ptr to LOC1 */ spa.enter.icivlu.ic = gelbar_temp.ic; /* set desired ic value */ spa.enter.icivlu.ind = gelbar_temp.ind; /* and indicators */ spa.enter.lbar.bar = gelbar_temp.bar; /* store new bar value to return */ spa.acc_fault = gelbar_temp.bar || "000000"b3; /* also save bar in accum fault status word */ call tolts_init_$gc_tod (gcos_tod); /* get current time of day */ string (spa.glbici) = gcos_tod; /* save current time of day in word 22 */ genp = addrel (execp, gelbar_temp.reg_ptr); unspec (spa.regs) = genp -> reg_move; /* move regs to be returned */ gelbar = "1"b; /* and set gelbar mode indicator */ call wake_disp; /* go wake up dispatcher */ /* ********* MME GEMORE ********* (get more memory) input/return registers: none mme gemore zero 0,no. 1024 word blocks ------ return denial ------ return succesful */ mme_typ (9): if trace then call tolts_qttyio_$rs (10, "^a MME GEMORE @ ^p", ctime (), mmep); call return_plus (3); /* return ic + 3 */ /* ********* MME GEMREL ********* (release memory) input registers: AR = return address in upper, lower not used * QR = words lower mem to release in upper, words upper mem to release in lower mme gemrel ------ return return registers: none */ mme_typ (21): if trace then call tolts_qttyio_$rs (10, "^a MME GEMREL @ ^p", ctime (), mmep); spa.enter.icivlu.ic = substr (spa.regs.a, 1, 18); /* return to address in a upper */ call wake_disp; /* go wake up dispatcher */ %page; /* ********* MME GEPROC ********* (dedicate CPU, unused in Multics. Return error) input/return registers: none mme geproc zero gprprc,0 zero work,0 ------ return error ------ return good */ mme_typ (-13): if trace then call tolts_qttyio_$rs (10, "^a MME GEPROC @ ^p", ctime (), mmep); call return_plus (3); /* return ic + 3, error return for Multics */ /* ********* MME GERELC ********* (wait for I/O interrupt to occur) input/return registers: none mme gerelc ------ return */ mme_typ (15): if trace then call tolts_qttyio_$rs (10, "^a MME GERELC @ ^p", ctime (), mmep); call return_plus (1); /* ********* MME GEROAD ********* (road block, wait) input/return registers: none mme geroad ------ return */ mme_typ (2): if trace then call tolts_qttyio_$rs (10, "^a MME GEROAD @ ^p", ctime (), mmep); rd_blk = "1"b; call return_plus (1); /* ********* MME GEROUT ********* (colts communications) l mme gerout l+1 vfd 18/record pointer,06/op,12/terminal id l+2 status word pointer,courtesy call pointer l+3 return There are six gerout types handled by tolts. 04 write/read 05 remote inquiry 06 terminal type request 07 fnp colts wake-up 17 disconnect 20 line status request */ mme_typ (24): if trace then call tolts_qttyio_$rs (10, "^a MME GEROUT ^p, type - ^12.3b", ctime (), mmep, mme_call_w (1)); gerout_num = bin (substr (mme_call_hw (1).lower, 1, 6)); /* get the gerout number index */ if gicm_count > 0 then call return_plus (0); else go to gerout (gerout_num); /* goto the gerout handler for this gerout */ %page; gerout (4): wicmp = addrel (execp, mme_call_hf (1).upper); /* get write icm pointer */ ricmp = addrel (execp, bin (wicm.rbuf_addr) - 1); /* get read icm pointer */ if gicmp = null then alloc gicm; /* alloc an icm area */ gicmp = addr (gicm); /* get a ptr to it */ icm_tally = bin (wicm.word_total) * 2; /* get icm tally */ k = bin (substr (mme_call_hw (1).lower, 15, 4)); /* get index */ if substr (mme_call_hw (1).lower, 13, 1) = "1"b then do; /* an exec request */ if substr (wicm.host_opcode, 10, 9) = "042"b3 then do; /* if load memory request */ alloc ticm; /* allocate a temp icm */ ticmp = addr (ticm); /* get a ptr */ ticm = wicm; /* move the icm */ fnp_num = bin (substr (mme_call_hw (1).lower, 16, 3)) + 1; /* get the fnp number */ do i = 1 to 2; if substr (ticm.icm_buf (1), 1, 18) = "777777"b3 then do; /* if first get mem icm */ call db_fnp_eval_ (null (), fnp_num, ".criom", null (), exec, fnp_addr, code); /* get address of fnp iom table */ if code ^= 0 then go to db_err; /* if error go to error routine */ icm_tally = 1; /* else set icm tally to correct value */ end; else do; i = 2; /* second get mem icm */ icm_tally = bin (wicm.word_total) * 2; /* compute the icm tally */ fnp_addr = bin (substr (ticm.icm_buf (1), 1, 18)); /* fill in fnp address */ end; call db_fnp_memory_$fetch (null (), fnp_num, fnp_addr, icm_tally, addr (ticm.icm_buf), code); /* get the iom table */ db_err: if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a error reading fnp memory", tolts_info.exec, lginfo); /* can't read fnp memory */ ticm.fnp_opcode = "000051"b3; /* set bad status */ end; else ticm.fnp_opcode = "000041"b3; /* supply op complete code */ end; ticm.rbuf_addr = "0"b; /* zero read buffer pointer */ call tolts_alm_util_$gen_ck_sum (ticmp); /* generate an icm check sum */ ricm = ticm; /* move icm */ free ticm; ticmp = null; if mme_call_hf (2).lower ^= 0 then do; /* a cc is requested */ exec_wd (mme_call_hf (2).upper) = "000000000004"b3; call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (2).lower || "000000"b3); /* enter a ccc request */ end; end; else if substr (wicm.host_opcode, 10, 9) = "001"b3 then do; /* if a start test request */ do i = 1 to 8 while (colts_pages (i).in_use); /* find vacant test page slot */ end; if i = 8 & colts_pages (8).in_use then do; /* if 8 pages running - error */ call tolts_qttyio_$rs (0, "^a: mme gerout 04; no vacant test page slot found", exec); call tolts_abort ("$c1"); end; colts_pages (i).in_use = "1"b; /* else set page in use */ do j = 1 to 8; if substr (fnp (k).cdt_name (j), 1, 5) ^= "empty" then do; colts_pages (i).cdt_name = tolts_info.fnp (k).cdt_name (j); /* save the cdt name in the test page */ tolts_info.fnp (k).cdt_name (j) = "empty"; j = 8; end; end; tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* inc test page count */ dmap = addr (tolts_info.colts_pages (i).dm_arg);/* get dial_manager_arg ptr */ colts_pages (i).dm_arg.version = dial_manager_arg_version_2; /* fill in the required fields */ colts_pages (i).dm_arg.dial_qualifier = substr (colts_pages (i).cdt_name, 1, 22); colts_pages (i).dm_arg.dial_channel = tolts_info.dm_event; colts_pages (i).dm_arg.channel_name = colts_pages (i).cdt_name; colts_pages (i).type_code = substr (wicm.icm_buf (1), 22, 6); nr_cnt = 0; /* reset the no responce count */ call dial_manager_$tandd_attach (dmap, code); /* get the channel for testing */ if code ^= 0 then do; /* if error */ if debugging then call com_err_ (code, "mtdsim_", "Error on tandd_attachment of ^a.", colts_pages (i).cdt_name); colts_pages (i).in_use = "0"b; /* reset test page active */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a tandd_attach of ^a", tolts_info.exec, lginfo, substr (colts_pages (i).cdt_name, 1, 6)); colts_op_flags.colt_flag = "0"b; /* make use flag is reset so we don't go blocked */ alloc ticm; /* allocate a temp icm */ ticmp = addr (ticm); /* get a ptr */ ticm = wicm; /* move the icm */ ticm.fnp_opcode = "000051"b3; /* set error status code */ ticm.rbuf_addr = "0"b; /* zero read buffer pointer */ call tolts_alm_util_$gen_ck_sum (ticmp); /* generate an icm check sum */ ricm = ticm; /* move icm */ free ticm; ticmp = null; if mme_call_hf (2).lower ^= 0 then do; /* a cc is requested */ exec_wd (mme_call_hf (2).upper) = "000000000004"b3; call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (2).lower || "000000"b3); /* enter a ccc request */ end; call return_plus (3); end; tolts_info.wait_list.nchan = tolts_info.wait_list.nchan + 1; /* inc the event wait list */ tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event; /* store the event id */ clt_sw = substr (colts_pages (i).cdt_name, 1, 6) || ".sw"; /* create a switch name */ att_desc = "tty_ " || substr (colts_pages (i).cdt_name, 1, 6); /* and an attach description */ colts_op_flags.dm_attach = "1"b; /* set colts control flags */ colts_op_flags.colt_flag = "1"b; colts_op_flags.sicm = "1"b; l = i; /* save i for later use */ end; else do; /* else a normal exec icm */ call iox_$put_chars (fnp (k).fnp_execp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* transmit the icm */ if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to fnp", tolts_info.exec, lginfo); call tolts_abort ("$c1"); /* then abort colts */ end; gicm_count = gicm_count + 1; /* inc outstanding icms count */ if gicm_count = 17 then do; /* if = 17 - error */ call tolts_qttyio_$rs (0, "^as: excessive outstanding io's", tolts_info.exec); call tolts_abort ("$c1"); /* abort colts */ end; gicm.cltp = fnp (k).fnp_execp; /* save iocb ptr */ gicm.ricmp = ricmp; /* rd icm ptr */ gicm.tally = bin (wicm.word_total) + 1; /* icm tally */ if mme_call_hf (2).lower ^= 0 then do; /* if cc requested */ gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */ gicm.st_addr = mme_call_hf (2).upper; /* save status address */ end; end; end; else do; /* else icm for test chan */ call iox_$put_chars (colts_pages (k).chanp, wicmp, (bin (wicm.word_total) + 1) * 4, code); /* send the icm */ if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error on data xfer to chan ^a", tolts_info.exec, lginfo, substr (colts_pages (k).cdt_name, 1, 6)); colts_pages (k).status_word = "000000000002"b3; /* store bad status */ end; gicm_count = gicm_count + 1; /* inc outstanding icm count */ if gicm_count = 17 then do; /* if 17 - error */ call tolts_qttyio_$rs (0, "as: excessive outstanding io count", tolts_info.exec); call tolts_abort ("$c1"); /* abort tolts */ end; gicm.cltp = colts_pages (k).chanp; /* save iocb ptr */ gicm.ricmp = ricmp; /* read icm ptr */ gicm.tally = bin (wicm.word_total) + 1; /* tally */ if mme_call_hf (2).lower ^= 0 then do; /* if cc requested */ gicm.cc_addr = mme_call_hw (2).lower || "000000"b3; /* save ccc address */ gicm.st_addr = mme_call_hf (2).upper; /* status address */ end; end; call return_plus (3); gerout (5): remote_inquiry_ic = bin (rel (addr (mme_call_w (1)))); /* remember remote inquiry location */ call return_plus (3); /* return to colts */ gerout (06): k = bin (substr (mme_call_hw (1).lower, 15, 4)); if substr (mme_call_hw (1).lower, 13, 1) = "1"b then mme_call_hw (1).upper = tolts_info.fnp (k).exec_type_code || "0000"b3; /* set type code */ else substr (mme_call_hw (1).upper, 1, 6) = colts_pages (k).type_code; call return_plus (3); gerout (7): if remote_inquiry_ic ^= 0 then do; /* if no outstanding remote inquiry - error */ k = bin (substr (mme_call_hw (1).upper, 1, 3)); /* k = fnp number */ if ^tolts_info.fnp (k).exec_active then do; /* if the fnp exec is not active */ dmap = addr (tolts_info.fnp (k).dm_arg); /* get addr of dial_manager arg */ fnp (k).dm_arg.version = dial_manager_arg_version_2; fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22); tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */ tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name */ nr_cnt = 0; /* reset the no responce count */ call dial_manager_$privileged_attach (dmap, code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error attempting a priviledged_attatch of ^a", tolts_info.exec, lginfo, fnp (k).channel_name); call tolts_abort ("$c1"); /* then abort colts */ end; tolts_info.wait_list.nchan = wait_list.nchan + 1; tolts_info.wait_event_id (tolts_info.wait_list.nchan) = tolts_info.dm_event; clt_sw = substr (fnp (k).exec_chan, 1, 6) || ".sw"; att_desc = "tty_ " || substr (fnp (k).exec_chan, 1, 6); colts_op_flags.colt_flag = "1"b; colts_op_flags.dm_attach = "1"b; ; fnp (k).exec_type_code = substr (mme_call_hw (1).lower, 13, 6); /* save exec type code */ end; call return_plus (2); end; else do; call tolts_qttyio_$rs (0, "^as: MME GEROUT 07 - no outstanding GEROUT 05", exec); call tolts_abort ("$c9"); end; gerout (15): if mme_call_hw (1).lower = "170000"b3 then call return_plus (3); k = bin (substr (mme_call_hw (1).lower, 15, 4)); if substr (mme_call_hw (1).lower, 13, 3) = "4"b3 then call rel_exec_chan (k); else call rel_tst_chan (k); if mme_call_hf (2).lower ^= 0 then do; exec_wd (mme_call_hf (2).upper) = "000000000002"b3; call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), mme_call_hw (2).lower || "000000"b3); end; call return_plus (3); gerout (16): k = bin (substr (mme_call_hw (1).lower, 15, 4)); if substr (mme_call_hw (1).lower, 13, 1) = "1"b then exec_wd (mme_call_hf (2).upper) = "000000000004"b3; else exec_wd (mme_call_hf (2).upper) = colts_pages (k).status_word; call return_plus (3); %page; /* ********* MME GESNAP ********* (snap shot dump) input/return registers: none mme gesnap iotd add,wc ------ return */ mme_typ (5): if trace then call tolts_qttyio_$rs (10, "^a MME GESNAP @ ^p", ctime (), mmep); if tolts_info.file_attach then /* if print file attached */ call tolts_file_util_$snap (addrel (mmep, 1)); /* go output snap dump */ call return_plus (2); /* return ic + 2 */ /* ********* MME GETIME ********* (return date/time) input registers: none mme getime ------ return return registers: AR - date, QR - time (right justified--1/64 ms. past midnight */ mme_typ (17): if trace then call tolts_qttyio_$rs (10, "^a MME GETIME @ ^p", ctime (), mmep); call tolts_init_$gc_tod (spa.regs.q); /* get time of day */ spa.regs.a = tolts_info.gc_date; /* and bcd date */ call return_plus (1); /* ********* MME HUNGTM ********* (check for outstanding I/O) input registers: AU = test page index (mod 4) mme hungtm ------ return not in transmission ------ return in transmission return registers: QR = lostit time, X1 = 5 if timeout; = 3 if still time to go */ mme_typ (-16): if trace then call tolts_qttyio_$rs (10, "^a MME HUNGTM @ ^p", ctime (), mmep); call get_px_sct ("HUNGTM", bin (substr (spa.regs.a, 1, 18), 17), "1"b); /* get test page index */ if substr (spa.regs.a, 1, 18) = "0"b then do; call tolts_qttyio_$rs (0, "^a MME HUNGTM illegal test page index @ ^p", ctime (), mmep); call tolts_abort ("$b6"); end; call tolts_init_$gc_tod (gcos_tod); /* get current time of day */ if bin (gcos_tod, 36) >= io_info.con_time + io_info.lostit_time then do; /* if time exceeded */ spa.regs.x (1) = "000005"b3; /* set courtesy call wating */ exec_wd (io_info.status_add) = "510006000000"b3; /* set time out status */ call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), string (io_info.icivlu)); /* enter ccc request */ spa.regs.q = "0"b; /* set 0 lostit time */ end; else do; /* not time out yet */ spa.regs.x (1) = "000003"b3; /* set in xmission */ spa.regs.q = bit ((io_info.con_time + io_info.lostit_time) - bin (gcos_tod, 35, 0), 35); end; call return_plus (2); /* return ic + 2 */ %page; /* ********* MME IOCONS ********* (return number of I/O connects) input registers: x1 = sct (test page index mod 4) mme iocons ------ return return registers: AR = number of connects for this test page */ mme_typ (-17): if trace then call tolts_qttyio_$rs (10, "^a MME IOCONS @ ^p", ctime (), mmep); call get_px_sct ("IOCONS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */ spa.regs.a = bit (bin (pages (io_sel).num_connects, 36)); call return_plus (1); /* ********* MME IPCW. ********* ( send initialize PCW to mpc ) input registers: x1 = ICC mme ipcw. ------ return return registers: none */ mme_typ (-55): if trace then call tolts_qttyio_$rs (10, "^a MME IPCW. @ ^p", ctime (), mmep); if substr (spa.regs.x (1), 7, 1) then /* if new format */ call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 8, 11)); /* get test page index */ else call get_px_tcx ("IPCW. ", substr (spa.regs.x (1), 10, 9)); /* get test page index */ pcwa = "0"b; /* initialize pcw first */ pcwp = addr (pcwa); pcw.code = "111"b; /* Set PCW code */ pcw.mask = "1"b; /* Make it a reset PCW */ pcw.control = "11"b; ioi_wksp = io_info.workspace_ptr; /* get ptr to our workspace */ tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */ idcwp = addr (tolts_workspace.p_idcw); /* set up idcw ptr */ string (idcw) = "0"b; /* intiialize idcw */ idcw.code = "7"b3; /* set in idcw type code */ io_info.to_no_cc = "1"b; /* set flag for int processor */ call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error); if error ^= 0 then do; call output_status_code (error, "io connect error"); call tolts_abort ("$m5"); end; call return_plus (1); %page; /* ********* MME LODIMG ********* (load print train image (GCOS only)) input registers: x1 = sct (test page index mod 4) mme lodimg ------ return good ------ return bad return registers: none */ mme_typ (-18): if trace then call tolts_qttyio_$rs (10, "^a MME LODIMG @ ^p", ctime (), mmep); call return_plus (1); /* return ic + 1 */ /* ********* MME LODVFC ********* (load printer vertical format control (VFC) (GCOS only)) input registers: x1 = sct (test page index mod 4) mme lodvfc ------ return good ------ return error return registers: a-reg = error code on error */ mme_typ (-19): if trace then call tolts_qttyio_$rs (10, "^a MME LODVFC @ ^p", ctime (), mmep); call return_plus (1); /* return ic + 1 */ /* ********* MME LPW. ********* ( return LPW tally residue ) input registers: x1 = ICC mme lpw. ------ return return registers: A-REG = LPW, .crmb1,1 */ mme_typ (-52): if trace then call tolts_qttyio_$rs (10, "^a MME LPW. @ ^p", ctime (), mmep); if substr (spa.regs.x (1), 7, 1) then /* if new format */ call get_px_tcx ("LPW. ", substr (spa.regs.x (1), 8, 11)); /* get test page index */ else call get_px_tcx ("LPW. ", substr (spa.regs.x (1), 10, 9)); /* get test page index */ ioi_wksp = pages (io_sel).workspace_ptr; /* get ptr to proper workspace */ spa.regs.a = tolts_workspace.lpw (1); /* copy lpw tally residue */ call return_plus (1); /* ********* MME MASTER MODE ENTRY ********* */ mme_typ (30): /* not valid on Multics */ call return_plus (1); %page; /* ********* MME MBXCMP ********* (Responder compare mailbox data) inputr registers: X1 = pointer to was data X2 = pointer to s/b data X5 = fpinfo pointer mme mbxcmp error return good return return registers: A = bad data if not compare */ mme_typ (-90): if trace then call tolts_qttyio_$rs (10, "^a MME MBXCMP @ ^p", ctime (), mmep); tolts_fpinfo_ptr = addrel (execp, spa.regs.x (5)); /* get a ptr to the test page fpinfo table */ do io_sel = 1 to hbound (pages, 1) /* get the io_info for this page */ while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num); end; if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */ io_info_ptr = addr (pages (io_sel)); tolts_rspd_wksp = io_info.tolts_rspd_wksp; lvl_idx = (bin (substr (spa.regs.x (1), 13, 3))); /* get the level */ ws_data_idx = (bin (substr (spa.regs.x (1), 16, 3))); /* was data index */ sb_data_idx = (bin (substr (spa.regs.x (2), 16, 3))); /* s/b data index */ if tolts_rspd_workspace.ima_level (lvl_idx).word (sb_data_idx) /* compare the data */ ^= tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx) then do; spa.regs.a = tolts_rspd_workspace.ima_level (lvl_idx).word (ws_data_idx); call return_plus (1); /* take error return */ end; else call return_plus (2); /* take good return */ /* ********* MME MBXDAT ********* (mme to manipulate mailbox data) input registers: x1 = pointer to FPINFO table x2 = subcommand code 1 = MBLC (get mbx location) 2 = INITMB (intialize mailbox data) 3 = RDMBX (read mailbox) 6 = RDINT (read interrupt word) 7 = RDINT0 (rd intrpt wrd & 0) 11 = STMBX (store mailbox word) mme MBXDAT zero error return (mme call + 1) zero timeout return (mme call + 2) zero retry return (mme call + 3) zero good return (mme call + 4) return registers: A & Q = data requested. Data is also entered into FPINFO table. dcl 1 tolts_fpinfo aligned based (tolts_fpinfo_ptr), * 2 pcw_info, * 3 fnp_num fixed bin unaligned, * 3 chan fixed bin (6) unaligned, * 3 cmnd fixed bin (6) unaligned, * 2 fnpdcw, * 3 address fixed bin unaligned, * 3 word_count fixed bin unaligned, * 2 io_rq_cnt fixed bin (35), * 2 mbxloc fixed bin (35), * 2 spec_cnt fixed bin, * 2 term_cnt fixed bin, * 2 partrs fixed bin (35), * 2 timeout_time fixed bin (35), * 2 temp01, * 3 word1, * 4 upper bit (18), * 4 lower bit (18), * 3 word2, * 4 upper bit (18), * 4 lower bit (18), * 2 temp02, * 3 word1, * 4 upper bit (18), * 4 lower bit (18), * 3 word2, * 4 upper bit (18), * 4 lower bit (18), * 2 temp03, * 3 word1, * 4 upper bit (18), * 4 lower bit (18), * 3 word2, * 4 upper bit (18), * 4 lower bit (18), * 2 lvl3_flag bit (36), * 2 lvl7_flag bit (36), * 2 lvl3_cnt fixed bin (35), * 2 lvl7_cnt fixed bin (35), * 2 pprt_avail bit (35); */ mme_typ (-65): if trace then call tolts_qttyio_$rs (10, "^a MME MBXDAT ^p, type - ^6.3b", ctime (), mmep, spa.regs.x (2)); tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1)); /* get a ptr to the test page fpinfo table */ do io_sel = 1 to hbound (pages, 1) /* get the io_info for this page */ while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num); end; if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */ io_info_ptr = addr (pages (io_sel)); io_info.fpinfo_ptr = tolts_fpinfo_ptr; goto sub_cmnd (bin (spa.regs.x (2))); sub_cmnd (1): call tolts_device_info_ (addr (io_info.test_req), io_sel, t_err); if t_err ^= 0 then call tolts_abort ("$c4"); /* create an event call channel for tdio status events */ if ^io_info.ev_ch_ass then do; /* we we havn't done this already */ call tolts_init_$cr_event_chan (io_info.status_event, "1"b, tolts_io_int_, io_info_ptr, 2, error); if error ^= 0 then /* if error creating event call chan */ call tolts_abort ("$a9"); io_info.ev_ch_ass = "1"b; /* set event chan assigned flag */ end; call ioa_$rsnnl ("T&D is attaching for a ^[write^]^[read^] ^a", att_desc, mesg_len, (^rd_flag), (rd_flag), io_info.device_name); call rcp_$attach (io_info.rcp_name, addr (io_info.rcp_area (1)), io_info.status_event, att_desc, io_info.rcp_id, error); if error ^= 0 then do; call output_status_code (error, "rcp attach error"); call dealcp_sub; /* go release status event */ call tolts_abort ("$c5"); end; call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), coment, io_info.device_index, tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err); if io_info.attach_err ^= 0 | io_info.rcp_state ^= 0 then do; if io_info.attach_err ^= 0 then call output_status_code (io_info.attach_err, "workspace assign error"); call dealcp_sub; call tolts_abort ("$c6"); end; io_info.p_att = "1"b; io_info.tolts_rspd_wksp = addr (tolts_rspd_workspace); call ioi_$workspace (io_info.device_index, io_info.tolts_rspd_wksp, tolts_info.wks_sz, error); if error ^= 0 then do; call output_status_code (error, "workspace assign error"); call dealcp_sub; /* go release status event */ call tolts_abort ("$c6"); end; io_info.cur_wks_sz = tolts_info.wks_sz; /* set current value of workspace size */ call ioi_$set_status (io_info.device_index, fixed (rel (addr (tolts_rspd_workspace.mailbox.status_word)), 18), 1, error); tolts_fpinfo.mbxloc = 0; spa.regs.q = "0"b; tolts_fpinfo.partrs = -1; call return_plus (4); sub_cmnd (2): tolts_rspd_wksp = io_info.tolts_rspd_wksp; unspec (tolts_rspd_workspace.num_int) = "0"b; call return_plus (4); sub_cmnd (3): tolts_rspd_wksp = io_info.tolts_rspd_wksp; spa.regs.a = unspec (tolts_rspd_workspace.mailbox.pcw); call return_plus (4); sub_cmnd (6): tolts_rspd_wksp = io_info.tolts_rspd_wksp; unspec (tolts_fpinfo.temp03.word1) = unspec (tolts_rspd_workspace.mailbox.num_int); call return_plus (4); sub_cmnd (7): tolts_rspd_wksp = io_info.tolts_rspd_wksp; unspec (tolts_fpinfo.temp03.word2) = unspec (tolts_rspd_workspace.mailbox.num_int); unspec (tolts_rspd_workspace.mailbox.num_int) = "0"b; call return_plus (4); sub_cmnd (11): tolts_rspd_wksp = io_info.tolts_rspd_wksp; k = bin (substr (tolts_fpinfo.temp03.word1.upper, 13, 3)); unspec (tolts_rspd_workspace.ima_level (k)) = "0"b; do i = 1 to bin (tolts_fpinfo.temp02.word1.upper); ima_level (k).word (i) = spa.regs.a; end; call return_plus (4); %page; /* ********* MME PACMAN ********* (allocate IPC's for mcad test ) input registers: Channel List format: x1 = sct (test page index mod 4) vfd 9/base chnl,9/# of chnls,16/flags x2 = address of channel list . x5 = address of mca config . A = 0 then attach channels oct -1 end of list flag A ^= 0 then return channels Q = ICC mme pacman zero error return x2 = reason code (mme call + 1) zero error return no chnls requested configured (mme call + 2) zero retry return I/O in progress, retry (mme call + 3) zero good return requested chnls assigned (mme call + 4) return registers: X2 = error code on error (see set_sctwrk subroutine for error codes) * output in sctwrk (12 words): see the set_sctwrk subroutine */ dcl 1 chan_list aligned based (clp), (2 base_chan fixed bin (9) uns, 2 num_chans fixed bin (9) uns, 2 flags, 3 reboot bit (1), 3 pad bit (17)) unaligned; dcl clp ptr; dcl p99 pic "99" based; mme_typ (-87): if trace then call tolts_qttyio_$rs (10, "^a MME PACMAN @ ^p", ctime (), mmep); if substr (spa.regs.q, 7, 1) then /* if new format */ call get_px_tcx ("PACMAN", substr (spa.regs.q, 8, 11)); /* get test page index */ else call get_px_tcx ("PACMAN", substr (spa.regs.q, 10, 9)); /* get test page index */ clp = addrel (execp, fixed (spa.regs.x (2))); if spa.regs.a = "0"b then do; if io_info.ipc_attached then do; call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, "0"b, code); call tolts_qttyio_$rs (0, "^a ipc was still attached will detach leaving the device suspended", io_info.ipc_id); end; io_info.ipc_id = substr (io_info.device_name, 4, 1) || convert (p99, (chan_list.base_chan)); call mca_$attach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, io_info.ipc_number, code); if code ^= 0 then do; if code = error_table_$resource_unavailable then do; /* must have been busy */ spa.regs.x (2) = bit (dev_busy); /* set appropriate error code */ call tolts_qttyio_$rs (0, "^a ipc ^a busy", io_info.test_hdr, io_info.ipc_id); call return_plus (1); /* return ic + 7 */ end; else do; call output_status_code (code, "ipc attach error"); spa.regs.x (2) = bit (os_deny); /* set appropriate error code */ call return_plus (1); /* take error return */ end; end; io_info.ipc_attached = "1"b; end; else if io_info.ipc_attached then do; call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, chan_list.flags.reboot, code); if code ^= 0 then call tolts_abort ("$p2"); else io_info.ipc_attached = "0"b; end; call return_plus (4); %page; /* ************************************************************************************************************* * MTAR has to know what operating system it is running on. This code passes the Multics code to cmlt * which passes it to mtar at initialize time. * ************************************************************************************************************** */ /* ********* MME POINIT ********* (slave executive initialize) input/output registers: none mme poinit zero wwflag,o.s. code from .crfig (upper) Multics o.s. code (lower) zero lstloc,0 core size available as loaded zero tewrk,0 from .crctb zero .tdioc,0 from .crioc zero wradd,0 wrapup address zero cvttbl,0 conversion table ptr zero mmexec,0 position of ttl date in message zero mintr,0 min/max memory test ranges (2 words) zero crafc0,0 .cracf bit 3 & mpc entry if single disk & disk acf for pri and alt files (3 words ) ---- return return is mme call + 10 .crfig: 0 = series 60 0r 6000 6 = system sckd. save opt. 24-30 = reserved for gcos 1 = class. module present 7 = reserved for gcos 31 = not in mem avail. space tab 2 = shared memory system 8,9,10,11 = ioms 0-3 configured 32 = RLP300 present 3 = >256k 12,13,14,15 = CPUs 0-3 configured 33 = DN30 4 = IOM system 16-19 = reserved for gcos 34 = DN305 5 = series 60 system 20,21,22,23 = CPU has EIS 35 = DN 355/6600 .crctb -> chars specify the first six tabs beyond position 0 .crioc -> -1 = IOMs */ mme_typ (-20): if trace then call tolts_qttyio_$rs (10, "^a MME POINIT @ ^p", ctime (), mmep); exec_wd (mme_call_hf (1).upper) = "0"b; /* zeros says not ww system */ if mme_call_hf (1).lower ^= 0 then exec_wd (mme_call_hf (1).lower) = "000000000002"b3;/* store Multics code if pointer */ exec_wd (mme_call_hf (3).upper) = "122436506274"b3; /* tabs at 10,20,30,40,50,60 */ iom_cardp = null; term = "0"b; /* reset terminate condition */ do while (^term); /* find all iom cards */ call tolts_util_$find_card ("iom ", iom_cardp); /* find iom card */ if iom_cardp = null then term = "1"b; /* completed search of the deck */ else do; if iom_card.model = "imu " then imu_found = "1"b; else if iom_card.model = "iom" then iom_found = "1"b; end; end; if imu_found then /* imu system */ exec_wd (mme_call_hf (4).upper) = "777777000000"b3; else if iom_found then /* iom system */ exec_wd (mme_call_hf (4).upper) = "777777777777"b3; else exec_wd (mme_call_hf (4).upper) = "0"b3; /* let the usbexec complain */ spa.wrapup_add = mme_call_hw (5).upper; /* set wrapup address */ call tolts_alm_util_$ascii_to_bcd_ (ttl_date, bcd_callname); /* convert ttl date to bcd */ exec_wd (mme_call_hf (7).upper) = bcd_callname; /* and store in message */ substr (exec_wd (mme_call_hf (7).upper - 1), 19, 18) = "622017"b3; /* change version? ?? to version?s ? */ genp = addrel (execp, mme_call_hf (2).upper); /* get ptr to lstloc */ if exec = "molt" then do; if fix_wd (1) ^= 0 then /* if lstloc specified... */ mem_now, fix_wd (1) = fix_wd (1) + 196608; /* add 196k to lstloc */ else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 196608; /* otherwise use loaded length */ end; else do; if fix_wd (1) ^= 0 then /* if lstloc specified... */ mem_now, fix_wd (1) = fix_wd (1) + 32768; /* add 32k to lstloc */ else mem_now, fix_wd (1) = fixed (gload_data.text_len) + 32768; /* otherwise use loaded length */ end; call cpu_time_and_paging_ (i, cpu_time, j); /* get current cpu time */ tolts_info.init_time = cpu_time; /* save */ call return_plus (10); /* return ic + 10 */ %page; /* ********* MME PROCTM ********* (return CPU time used since exec init) input registers: none mme proctm ------ return return registers: a-reg = processor time in 1/64 ms */ mme_typ (-21): if trace then call tolts_qttyio_$rs (10, "^a MME PROCTM @ ^p", ctime (), mmep); call cpu_time_and_paging_ (i, cpu_time, j); /* get current cpu time */ cpu_time = cpu_time - tolts_info.init_time; /* compute delta */ spa.regs.a = bit (bin (divide (cpu_time * 64, 1000, 71, 0), 36)); /* return time */ call return_plus (1); /* ********* MME PRTRAN ********* (load print train image for test) input registers: x1 = sct (test page index mod 4) mme prtran zero loc,0 pointer to buffer for train image ------ return error ------ return good return registers: AR contains error code if error */ mme_typ (-22): if trace then call tolts_qttyio_$rs (10, "^a MME PRTRAN @ ^p", ctime (), mmep); call get_px_sct ("PRTRAN", bin (spa.regs.x (1), 17), "1"b); /* get test page index */ do i = 1 to printer_images_$n_images while (io_info.devsct.ptrain ^= printer_images_$image_numbers (i)); end; if i > printer_images_$n_images then do; call tolts_qttyio_$rs (0, "^as: MME PRTRAN; No such train number - ^d", exec, io_info.devsct.ptrain); call tolts_abort ("$b1"); end; tp = addrel (addr (printer_images_$image_base), printer_images_$image_offsets (i)); train_ptr = addrel (execp, mme_call_hf (1).upper); train_ptr -> prt_image = tp -> prt_image; call return_plus (3); /* return ic + 3 */ %page; /* ********* MME READIO ********* (read options) input registers: x1 = 3/exec #,9/0,6/cid * x4 -> (see opt_temp structure declaration below) mme readio ------ return if tolts aborted ------ return if tolts swapped ------ return good return registers: none */ dcl 1 opt_temp based (genp) aligned, /* template for MME READIO */ (2 bcd_o_dash bit (18), /* = bcd " o-" */ 2 tdpcn_add fixed bin, /* address of .tdpcn */ 2 bufnum fixed bin, /* tadio buffer (array element) number */ 2 nu1 bit (6), 2 exec_num bit (6), 2 nu2 bit (6), 2 opt_ptr fixed bin, /* ptr to options storage area */ 2 nu3 bit (6), 2 phy_term bit (12)) unaligned; /* physical terminal id */ dcl bcd_options bit (6 * 84) based (genp); /* to move options to test page */ mme_typ (-24): if trace then call tolts_qttyio_$rs (10, "^a MME READIO @ ^p", ctime (), mmep); genp = addrel (execp, spa.regs.x (4)); /* get ptr to options template */ i = opt_temp.bufnum; /* get tadio buffer number */ tolts_info.tadio (i).inuse = "0"b; /* reset buffer in use flag */ genp = addrel (execp, opt_temp.opt_ptr); /* get ptr to store options */ bcd_options = tolts_info.tadio (i).option; /* move options to test page */ call return_plus (3); /* return ic + 3 */ %page; /* ********* MME RELEAS ********* ( release device (reboot mpc firmware if running ITRs)) input registers: * POLT MOLT X0 ---- Master console file code X1 SCT (test page index * 4) SCT (test page index * 4) X2 Patptr ---- X4 ---- Patptr X6 ---- possible hang flag X7 0 Molt test type (In upper 6 bits: C = itrs, R = MDRs, T = MTAR, M = memory) AR ---- type code (tdcxxa) QR ---- ICC (XICCXXXX) mme releas ------ return if error ------ return return registers: none */ mme_typ (-56): if trace then call tolts_qttyio_$rs (10, "^a MME RELEAS @ ^p", ctime (), mmep); if spa.regs.x (7) ^= "0"b then /* if not polts */ if substr (spa.regs.x (7), 1, 6) = "23"b3 then do; /* molts, running itrs */ call get_px_sct ("RELEAS", bin (spa.regs.x (1), 17), "1"b); /* get test page index */ if io_info.chan_suspended then do; /* only load firmware if channel suspended */ call tolts_load_firmware_ (io_sel, error); /* go load mpc firmware */ if error ^= 0 then /* if error loading firmware */ call ck_release; /* try again, and then ask user */ end; end; call return_plus (2); /* ********* MME RLSMPC ********* (release mpc) input registers: x1 = mpc controller sct pointer mme rlsmpc ------ return return registers: none */ mme_typ (-26): if trace then call tolts_qttyio_$rs (10, "^a MME RLSMPC @ ^p", ctime (), mmep); call return_plus (1); /* ********* MME RLSPAT ********* (release peripheral allocation table entry) input registers: x4 = pat address (offset relative to LAL) mme rlspat ------ return return registers: none */ mme_typ (-28): if trace then call tolts_qttyio_$rs (10, "^a MME RLSPAT @ ^p", ctime (), mmep); call return_plus (1); %page; /* ********* MME RSPCHK ********* (check for fnp response) input registers: x1 = fpinfo table pointer mme rspchk ---- error return ---- timeout return ---- retry return ---- good return return registers: q = status word if fault occurs */ mme_typ (-91): if trace then call tolts_qttyio_$rs (10, "^a MME RSPCHK @ ^p", ctime (), mmep); tolts_fpinfo_ptr = addrel (execp, spa.regs.x (1)); /* get a ptr to the test page fpinfo table */ do io_sel = 1 to hbound (pages, 1) /* get the io_info for this page */ while (pages (io_sel).fnp_num ^= tolts_fpinfo.pcw_info.fnp_num); end; if io_sel > hbound (pages, 1) then call tolts_abort ("$c3"); /* io_info for this page not found */ io_info_ptr = addr (pages (io_sel)); tolts_rspd_wksp = io_info.tolts_rspd_wksp; call tolts_init_$gc_tod (gcos_tod); if tolts_rspd_workspace.mailbox.status_word ^= "0"b then do; /* error status stored */ if tolts_fpinfo.io_rq_cnt > 0 then /* if io request cnt > 0 */ tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1; if substr (tolts_rspd_workspace.status_word, 4, 1) = "1"b /* if timeout */ | bin (tolts_fpinfo.timeout_time) - bin (gcos_tod) < 1 then call return_plus (2); /* take timeout return */ else do; /* else take normal error return */ spa.regs.q = tolts_rspd_workspace.status_word; /* return the status */ call return_plus (1); /* take error return */ end; end; else do; /* no error */ tolts_fpinfo.spec_cnt = tolts_rspd_workspace.mailbox.num_int.lvl7; /* move spec count */ tolts_fpinfo.term_cnt = tolts_rspd_workspace.mailbox.num_int.lvl3; /* move term count */ tolts_fpinfo.lvl3_cnt = /* decr levl 3 count with saved value */ tolts_fpinfo.term_cnt - bin (unspec (tolts_fpinfo.temp01.word2)); tolts_fpinfo.lvl7_cnt = /* decr levl 7 count with saved value */ tolts_fpinfo.spec_cnt - bin (unspec (tolts_fpinfo.temp01.word1)); if (tolts_fpinfo.lvl3_cnt = 0 & tolts_fpinfo.lvl3_flag) /* if no term int & one expected */ | (tolts_fpinfo.lvl7_cnt = 0 & tolts_fpinfo.lvl7_flag) /* or no spec int & one ecpected */ & (bin (tolts_fpinfo.timeout_time) < 0) then /* & no timeout */ call return_plus (3); /* take retry return */ else do; if tolts_fpinfo.io_rq_cnt > 0 then tolts_fpinfo.io_rq_cnt = tolts_fpinfo.io_rq_cnt - 1; if (tolts_fpinfo.lvl3_cnt = 1 | ^tolts_fpinfo.lvl3_flag) & (tolts_fpinfo.lvl7_cnt = 1 | ^tolts_fpinfo.lvl7_flag) then call return_plus (4); /* take good return */ end; end; %page; /* ********* MME SCTCMP********* (generate SCT entry) input registers: X2 = 128 chan number for new format mme sctcmp zero ficcdd,0 zero sctwrk,0 ------ return good--shared file ------ return good--non-shared file ------ return error return registers: X2 = error code if error (see set_sctwrk subroutine for error codes) * output in sctwrk area: see set_sctwrk subroutine */ mme_typ (-29): if trace then call tolts_qttyio_$rs (10, "^a MME SCTCMP @ ^p", ctime (), mmep); do i = 1 to 8 while (pages (i).in_use); /* find vacant page */ end; if i = 8 & pages (8).in_use then do; /* no vacant page */ call tolts_qttyio_$rs (0, "^a: MME SCTCMP; No vacant test page slot found", exec); call tolts_abort ("$a1"); end; unspec (pages (i)) = "0"b; /* clear test page data */ call set_sctwrk (i); /* go set up the sct work area */ if spa.regs.x (2) ^= "0"b then do; /* if error */ if fixed (spa.regs.x (2)) = m_iv_iom then /* if invalid IOM number... */ spa.regs.x (2) = "0"b; /* correct it */ call return_plus (5); /* take error return */ end; pages (i).in_use = "1"b; /* set page in use flag */ tolts_info.exec_page_count = tolts_info.exec_page_count + 1; /* increment total test page count */ if pages (i).io_type = polt_io_type then /* if user wants to run itrs... */ itr_run = "1"b; /* set flag for wake_disp subroutine */ call return_plus (4); /* take good return */ %page; /* ********* MME SETPRT & MME SETPR2 ********* (reserve printer (attach print file in Multics's case )) input/return registers: none mme setprt ------ return tolts aborted ------ return tolts swapped ------ no prt available ------ return pr2 in use ------ return good */ mme_typ (-30): mme_typ (-31): if trace then call tolts_qttyio_$rs (10, "^a MME SET^[PRT^;PR2^] @ ^p", ctime (), (mme_number = -33), mmep); if ^tolts_info.file_attach then do; /* if print file not already attached... */ call tolts_file_util_$open (error); /* attach and open it */ if error = 0 then /* if no attach error */ call return_plus (5); /* return good */ end; call return_plus (3); /* return ic + 3 */ /* ********* MME SETPUN ********* (set reader/punch to punch mode) input registers: x1 = sct (test page index mod 4) mme setpun ------ return, no operator message ------ return, Output Operator message to put reader/punch in punch mode return registers: X1 = sct address Issued for 214 reader/punch to set in punch mode before mme allocr to set punch indicator in sct */ mme_typ (-32): if trace then call tolts_qttyio_$rs (10, "^a MME SETPUN @ ^p", ctime (), mmep); call get_px_sct ("SETPUN", bin (spa.regs.x (1), 17), "0"b); /* get test page index */ io_info.ccu_pun = "1"b; /* remember we want a punch */ call return_plus (1); /* ********* MME SETTYP & MME DISPRT ********* (reset prt or pr2 request) input/return registers: none mme settyp ------ return tolts aborted ------ return tolts swapped ------ return good */ mme_typ (-11): mme_typ (-33): if trace then call tolts_qttyio_$rs (10, "^a MME ^[SETTYP^;DISPRT^] @ ^p", ctime (), (mme_number = -33), mmep); if tolts_info.file_attach then /* if print file attached... */ call tolts_file_util_$close; /* close it out */ call return_plus (3); /* return ic + 3 */ %page; /* ********* MME TADIOD ********* (T&D terminal I/O) input registers: a-reg = 18/.tdpcn,6/pad,1/nu,1/dont record denial,1/mbz,3/exec,6/lid mme tadio zero nodcws,0 zero iotpd,wc from 1 to 5 of these exist ------ return if tolts aborted ------ return if tolts swapped ------ return if request denied ------ return accepted return registers: none tadio type: bit 23 "p" 1 print line bit 22 "c" 2 controlling terminal * bit 21 "s" 4 slave term. bit 20 "m" 8 master console output * bit 19 "r" 16 output/input bit 18 "e" 32 select console/printer by option all valid combinations: ps - 5 sp - 5 cs - 6 sc - 6 mp - 9 pm - 9 cm - 10 * mc - 10 ms - 12 sm - 12 mps - 13 msp - 13 pms - 13 psm - 13 * smp - 13 spm - 13 cms - 14 csm - 14 mcs - 14 msc - 14 * scm - 14 smc - 14 ep - 33 pe - 33 em - 40 me - 40 */ mme_typ (-34): if trace then call tolts_qttyio_$rs (10, "^a MME TADIOD @ ^p", ctime (), mmep); ndcws = mme_call_hf (1).upper; /* extract number of dcws */ if ndcws < 1 | ndcws > 5 then do; call tolts_qttyio_$rs (0, "^as: MME TADIOD; Number of dcws = ^d", exec, ndcws); call tolts_abort ("$b2"); end; do i = 1 to 8 while (tolts_info.tadio (i).inuse); /* find vacant tadio queue entry */ end; if i = 8 & tolts_info.tadio (8).inuse then do; /* no queue entry */ call tolts_qttyio_$rs (0, "^as: MME TADIOD; No vacant queue entry", exec); call tolts_abort ("$b2"); end; tolts_info.tadio (i).inuse = "1"b; /* fill in the queue entry */ tolts_info.tadio (i).return_word (3) = "000000006361"b3; /* phy term sb 24-35 */ tolts_info.tadio (i).return_word (2) = bit (bin (i, 18)) || "000000"b3; if substr (mme_call_w (2), 20, 1) = "1"b then do; /* if read involved */ tolts_info.tadio (i).optrd = "1"b; tolts_info.tadio (i).return_word (1) = "204652"b3 || substr (spa.regs.a, 1, 18); /* " o-||.tdpcn */ pad_char = substr (spa.regs.a, 19, 6); /* pick up pad character */ do j = 0 to 83; /* pad options buffer */ substr (tolts_info.tadio (i).option, (j * 6) + 1, 6) = pad_char; end; end; else do; tolts_info.tadio (i).optrd = "0"b; tolts_info.tadio (i).return_word (1) = "206252"b3 || substr (spa.regs.a, 1, 18); /* " s-||.tdpcn */ end; call tolts_qttyio_$dcw_ptr (addrel (mmep, 2), ndcws, i); /* go queue up message */ spa.enter.icivlu.ic = rel (addr (mme_call_w (5 + ndcws))); /* return ic +5 + number of dcws */ call wake_disp; /* go wake up dispatcher */ %page; /* ********* MME TDIO ********* (issue I/O to device under test) input registers: none mme tdio eep commands: 3100007x4000 = diagnostic mode control zero myioq,0 2200007x4000 = read controller main memory zero tpbase,0 0600007x4000 = initiate read data transfer zero datara,redfol-wrtpre+1 ( = 0 if molts) where x = 0 if last and 2 if continue idcw zero iotrac,0 ------ return return registers: AR = Time of day of connect, QR = lostit time, X4 = test page index */ mme_typ (-36): ioe_ptr = addrel (execp, mme_call_hf (1).upper); /* get ptr to our io_entry */ if trace then do; call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep); call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)", message, mesg_len, ioe, ioe (5), ioe (9)); call tolts_qttyio_ (message, 10); end; if trace_io then do; /* count number of mme tdio's if -tio option true */ call tolts_qttyio_$rs (10, "^a MME TDIO @ ^p", ctime (), mmep); call ioa_$rsnnl ("^/io_entry:^-^4(^12.3b ^)^/^-^4(^12.3b ^)^/^-^3(^12.3b ^)", message, mesg_len, ioe, ioe (5), ioe (9)); call tolts_qttyio_ (message, 10); tio = tio + 1; call tolts_qttyio_$rs (10, " MME TDIO = ^b @ ^a", tio, ctime ()); /* notify user of tally of tdio's */ end; call get_px_sct ("TDIO ", bin (io_entry.sct_add, 17), "1"b); /* get test page index */ if io_info.io_type = mca_io_type then call mca_io_setup; /* mca is special */ else call io_setup; /* go set up our workspace */ if io_info.suspend_chan then do; /* if channel to be suspended */ call ioi_$suspend_devices (io_info.device_index, error); /* let ioi_$ stop other io */ if error ^= 0 then do; /* error, abort */ call output_status_code (error, "suspend devices error"); call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), string (io_info.icivlu)); /* enter ccc request */ io_info.suspend_chan = "0"b; io_info.io_in_progress = "0"b; /* reset io in progress flag */ if tolts_info.gewake_active then do; /* if gewake alarm set */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */ tolts_info.gewake_active = "0"b; /* reset flag */ end; call tolts_abort ("$b5"); end; io_info.chan_suspended = "1"b; /* remember that channel suspended */ end; if io_info.io_type = mca_io_type then do; if io_entry.prim.dev_cmd = "40"b3 then /* if reset dcw */ call mca_$reset (io_info.mca_ioi_idx, "0"b, error); else if io_entry.prim.dev_cmd = "15"b3 then /* send mca data */ call mca_$tandd_write_data (io_info.mca_ioi_idx, io_info.workspace_ptr, io_block_len, "0"b, error); else if io_entry.prim.dev_cmd = "13"b3 then /* send mca command */ call mca_$tandd_write_text (io_info.mca_ioi_idx, io_info.workspace_ptr, io_block_len, "0"b, error); else if io_entry.prim.dev_cmd = "03"b3 then /* every write must be followed by a read */ call mca_$tandd_read_data (io_info.mca_ioi_idx, io_info.workspace_ptr, io_block_len, "0"b, error); else error = error_table_$bad_command_name; end; else call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error); if error ^= 0 then do; call output_status_code (error, "doing io for a tdio"); call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), string (io_info.icivlu)); /* enter ccc request */ io_info.io_in_progress = "0"b; /* reset io in progress flag */ if tolts_info.gewake_active then do; /* if gewake alarm set */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */ tolts_info.gewake_active = "0"b; /* reset flag */ end; call tolts_abort ("$b5"); end; call tolts_init_$gc_tod (spa.regs.a); /* get current time of day */ io_info.con_time = bin (spa.regs.a, 35); /* save connect time */ spa.regs.q = bit (bin (io_info.lostit_time, 36)); /* set lostit time */ spa.regs.x (4) = bit (bin (io_sel * 4, 18)); /* return test page index, mod 4 */ tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */ call return_plus (5); /* return ic + 5 */ %page; /* ********* MME TERMIN ********* (terminate slave executive) input registers: none mme termin does not return */ mme_typ (-35): if trace then call tolts_qttyio_$rs (10, "^a MME TERMIN @ ^p", ctime (), mmep); term = "1"b; /* set terminate condition */ go to term_lbl; /* and perform nonlocal goto */ /* ********* MME TNDBUG ********* (tolts debugger break point)) input/return registers: none mme tndbug restores mme word with original value and returns to mme location */ mme_typ (-88): if ^debugging then call return_plus (1); call probe (mtdsim_); exec_wd (db_addr) = db_sv_wd; tolts_info.mult_ans = ""; /* clear out response */ call tolts_qttyio_$rs (19, "tolts_debugger: enter break point address"); call message_wait; /* wait for user response */ if mult_ans ^= "" then do; db_addr = cv_oct_check_ ((rtrim (mult_ans)), code); db_sv_wd = exec_wd (db_addr); exec_wd (db_addr) = "777650001000"b3; end; call return_plus (0); /* return ic + 0 */ /* ********* MME TOLDIS ********* (disconnect logical terminal ID (LID)) input/return registers: none mme toldis ------ return tolts aborted ------ return tolts swapped ------ return */ mme_typ (-37): if trace then call tolts_qttyio_$rs (10, "^a MME TOLDIS @ ^p", ctime (), mmep); call return_plus (3); /* return ic + 3 */ /* ********* MME TOLGON ********* (used in gecos to inform tolts is terminating) mme tolgon ----- return */ mme_typ (-38): if trace then call tolts_qttyio_$rs (10, "^a MME TOLGON @ ^p", ctime (), mmep); call return_plus (1); /* ********* MME TOLTIN ********* (slave executive idle dispatcher) input registers: q-reg = time in 1/64 ms for wakeup mme toltin ------ return not in core ------ return in core (does mme gewake if in core) return registers: none */ mme_typ (-39): if trace then call tolts_qttyio_$rs (10, "^a MME TOLTIN @ ^p", ctime (), mmep); wake_time = divide (fixed (spa.regs.q) * 1000, 64, 71, 0); /* convert gcos time to useconds */ call timer_manager_$alarm_wakeup (wake_time, "10"b, tolts_info.gewake_event); /* set the alarm */ tolts_info.gewake_active = "1"b; /* set flag for int processor */ spa.enter.icivlu.ic = rel (addr (mme_call_w (2))); /* increment ic by 2 */ go to blk_lbl; /* return to blocked state */ %page; /* ********* MME TRACIO ********* (trace I/O events (GCOS only, Unused in Multics)) input/output registers: none mme tracio iotd msg,wordcount ------ return */ mme_typ (-40): if trace then call tolts_qttyio_$rs (10, "^a MME TRACIO @ ^p", ctime (), mmep); call return_plus (2); /* return ic + 2 */ /* ********* MME UNFREZ ********* (unwire main memory (gcos only)) input/return registers: none mme unfrez ------ return */ mme_typ (-54): if trace then call tolts_qttyio_$rs (10, "^a MME UNFREZ @ ^p", ctime (), mmep); call return_plus (1); /* ********* MME WRDUMP ********* (wrapup dump) input registers: areg = iotd for dump prefix * qreg = start,size (relative to LAL) * x1 = address bias (-1024 or page base) * x2 = master/slave (=3hm ,=3hs ) mme wrdump ------ return return registers: none */ mme_typ (-42): if trace then call tolts_qttyio_$rs (10, "^a MME WRDUMP @ ^p", ctime (), mmep); if tolts_info.file_attach then do; /* if print file attached... */ call tolts_file_util_$wdump (addr (spa.regs)); /* go output entire dump */ call tolts_file_util_$close; end; else call tolts_qttyio_$rcw (addr (spa.regs.a)); /* otherwise just output dump prefix */ call return_plus (1); /* return ic + 1 */ %page; mme_typ (-60): mme_typ (-58): mme_typ (-57): mme_typ (-49): mme_typ (-48): mme_typ (-47): mme_typ (-46): mme_typ (-45): mme_typ (-44): mme_typ (-43): mme_typ (-41): mme_typ (-27): mme_typ (-23): mme_typ (-10): mme_typ (-25): mme_typ (-15): mme_typ (-14): mme_typ (-3): mme_typ (0): mme_typ (3): mme_typ (4): mme_typ (6): mme_typ (7): mme_typ (8): mme_typ (10): mme_typ (11): mme_typ (12): mme_typ (13): mme_typ (16): mme_typ (19): mme_typ (20): mme_typ (22): mme_typ (23): mme_typ (25): mme_typ (26): mme_typ (27): mme_typ (28): mme_typ (29): undefm: in_ccc = "0"b; call tolts_qttyio_$rs (0, "^as: Improper MME @ ^p; MME type - ^d; Instruction - ^12.3b", exec, mmep, mme_call_hf (0).upper, mme_call_w (0)); call tolts_abort ("$b6"); /* epilogue - entry called by execute_epilogue_ when process is terminated */ epilogue: entry; if tolts_active then do; /* continue only if we were active */ tolts_info.finish_cond = "1"b; /* set finish flag */ call hcs_$get_ips_mask (old_mask); /* get current ips mask */ new_mask = old_mask | sys_info$alrm_mask; /* make sure "alrm"s are enabled */ call hcs_$set_ips_mask (new_mask, new_mask); /* set the mask */ call clean_up; /* go cleanup our enviornment */ call hcs_$set_ips_mask (old_mask, old_mask); /* set original ips mask */ end; return; %page; /* return_plus - int procedure to add specified value to ic, wakeup dispatcher and take non-local goto to block */ return_plus: proc (ic_inc); dcl ic_inc fixed bin; /* value to increment ic by */ spa.enter.icivlu.ic = rel (addr (mme_call_w (ic_inc))); /* increment ic */ /* wake_disp - entry to do non-local goto to dispatcher. If there is any oustanding IO, the wait event channel is woken up and we do non-local goto to the dispatcher block label. If there is no outstanding IO (terminal or test IO), we do non-local goto directly back to the no_blk label, thus saving needless wakeyps and blocks */ wake_disp: entry; if (tolts_info.term_io_req_cnt = 0 & tolts_info.glob_int_cnt = 0 /* if there is nothing to wait for... */ & ^tolts_info.exec_term_io_wait & ^colts_op_flags.colt_flag) then /* go back to slave exec, don't go blocked */ go to no_blk; /* do non-local goto */ call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), null, error); if error ^= 0 then do; /* this is a fatal error, terminate our process */ call com_err_ (error, exec, "***fatal error, terminating process"); /* but tell user first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if ^debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; /* no need to return, as we won't be back */ go to blk_lbl; /* take non-local goto to dispatcher block */ end return_plus; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* fault_dump - internal procedure to force open a file for tolts abort */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ fault_dump: proc; flt_flag = "1"b; if ^tolts_info.file_attach then call tolts_file_util_$open (error); if error ^= 0 then do; call com_err_ (error, exec, "encountered an error while attempting to open a point file for ^a", error); call tolts_abort ("$t1"); end; if debugging then call probe (mtdsim_); if tolts_info.file_attach then do; call display_mc; call tolts_file_util_$wdump (execp); /* go output entire dump */ call tolts_file_util_$close; in_ccc = "0"b; call tolts_abort ("$t2"); end; end fault_dump; /* tolts_abort - internal procedure to set up abort vectors for the slave exec */ tolts_abort: proc (a_code); dcl a_code char (3); dcl tfc bit (18); call tolts_alm_util_$ascii_to_bcd_ (a_code, tfc); /* convert fault code to bcd */ spa.abort.code = tfc; /* and store in spa */ spa.abort.add = scu.ilc; /* equals address of last mme */ if spa.wrapup_add = "0"b /* if we have not been thru mme pointit yet.. */ | flt_flag then do; /* or we have detected a fault */ call clean_up; term = "1"b; /* set terminate condition */ go to term_lbl; /* take non-local goto to get out of dispatcher */ end; spa.enter.icivlu.ic = spa.wrapup_add; /* set wrapup address */ call wake_disp; /* and wake up dispatcher */ end tolts_abort; /* display_mc - int proc to display machine conditions after a fault */ display_mc: proc; dcl cu_$stack_frame_ptr entry (ptr); dcl dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin); dcl find_condition_frame_ entry (ptr) returns (ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl hran_$hranl entry (ptr, ptr, bit (1)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl (faultsp, hreg_ptr, stackp) ptr; dcl code fixed bin (35); call cu_$stack_frame_ptr (stackp); /* get current sstack ptr */ faultsp = find_condition_frame_ (stackp); /* is this the cond frame ? */ if faultsp = null () then do; call ioa_ ("^a: Cannot find condition frame.", "exec_name"); return; end; call find_condition_info_ (faultsp, addr (ci), code); if ci.mc_ptr = null () then do; call ioa_ ("^a: Cannot find condition frame.", "exec_name"); return; end; call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/MACHINE CONDITIONS AT ^p:^/", ci.mc_ptr); call dump_machine_cond_ (addr (ci), faultsp, "err_file", 2); /* print the MC */ HREGS: if mcptr ^= null then hreg_ptr = addrel (mcptr, 96); if hreg_ptr = null then do; /* no history regs to dump */ call ioa_$ioa_switch (tolts_info.pf_iocbp, "History Registers are not available"); return; end; else do; call ioa_$ioa_switch (tolts_info.pf_iocbp, "CPU HISTORY REGISTERS AT TIME OF FAULT"); call hran_$hranl (hreg_ptr, tolts_info.pf_iocbp, "0"b); end; return; end display_mc; %page; /* set_sctwrk - internal procedure to set up the sct work area sctwrk */ set_sctwrk: proc (px); dcl px fixed bin; /* test page index */ /* output in sctwrk (12 words): 18/devsct,6/0,12/xbicc 18/altsct,6/g3typ,12/0 18/cntsct,4/iotyp,4/cnttyp,1/pad,4/xiotyp,4/xcnttyp,1/pad 18/cont. sct,18/mpc index (36/0 for non mpc) 36/word +0 of .crcst entry for mpc 36/word +1 of .crcst entry for mpc 36/word +2 of .crcst entry for mpc 36/word +3 of .crcst entry for mpc 36/word +0 of sct entry 36/word +1 of sct entry 36/word +0 of alt sct 36/word +1 of alt sct */ genp = addrel (execp, mme_call_hf (2).upper); /* get pointer to sctwrk */ spa.regs.x (2), sctwrk = "0"b; /* initialize sctwrk first */ t_err = 0; call tolts_device_info_ (addrel (execp, mme_call_hf (1).upper), px, t_err); /* get type code */ spa.regs.x (2) = bit (bin (t_err, 18)); /* set x2 to type_error if any */ substr (sctwrk (2), 19, 6) = pages (px).devsct.type_code; /* set type code */ if ^pages (px).devsct.com_prph then do; /* if mpc subsystem */ pages (px).sct_info.cntsct = bit (bin (px * 4 + 1024, 18)); /* set cont. sct (device sct + 1024) */ sctwrk (3) = unspec (pages (px).sct_info); /* fill word 3 of sct area */ substr (sctwrk (4), 1, 18) = bit (bin (px * 4 + 1024, 18)); /* set cont. sct */ end; sctwrk (5) = unspec (pages (px).crcst); /* set crcst entry wrd 0 */ sctwrk (6) = unspec (pages (px).crcst); /* set crcst entry wrd 1 */ sctwrk (9) = unspec (pages (px).devsct.w1); /* set dev sct word 1 */ sctwrk (10) = unspec (pages (px).devsct.w2); /* and word 2 */ substr (sctwrk (1), 1, 18) = bit (bin (px * 4, 18)); /* set test page index (mod 4) */ /* The sct pointer and sct data for the alternate device must be passed back to cmlt, provided mtar is running */ if (pages (px).alt_dev_flag) then do; /* alt. device exists return device info */ sctwrk (11) = unspec (pages (px).altsct.w1); sctwrk (12) = unspec (pages (px).altsct.w2); substr (sctwrk (2), 1, 18) = bit (bin (px * 4 + 512, 18)); end; end set_sctwrk; %page; /* mca_io_setup - internal procedure to set up the mca workspace for mca I/O */ mca_io_setup: proc; dcwp = addrel (execp, dcw_ptr); mca_work_space_ptr = io_info.workspace_ptr; /* get a ptr to our workspace */ unspec (mca_work_space) = "0"b; /* clear it */ c_len = 4; /* want to xfer 4 words */ mvp = addrel (execp, dcw_ptr - 1); /* set move ptr to idcw */ bufp = addr (mca_work_space.list_of_dcw); /* set buf ptr to work space dcw list */ workspace_move = mvp -> workspace_move; /* move it */ bufp = addr (io_info.dcw_list); /* move the buf ptrto save the dcw list in io_info */ workspace_move = mvp -> workspace_move; /* move it */ if dcw.tally = "0"b3 then c_len = 4096; /* check for 4096 tally */ else c_len = bin (dcw.tally); /* else use as is */ io_block_len = c_len + 4096 + 2; /* set io block length to reflect the tally */ mvp = addrel (execp, dcw.address); /* set move ptr to data to be sent */ bufp = addr (mca_work_space.data_header_1); /* set buf ptr to data header area */ workspace_move = mvp -> workspace_move; /* move it */ data_size_1 = fixed (data_header_1.dest_len_msb || data_header_1.dest_len_lsb, 16); io_info.icivlu.ic = io_entry.ccc_p; /* set entry to call on io completion */ io_info.icivlu.ind = "0"b; /* initialize indicators */ io_info.status_add = fixed (io_entry.stat_p); /* save status storage ptr */ exec_wd (io_info.status_add) = "0"b; /* initialize test page status */ exec_wd (io_info.status_add + 1) = "0"b; io_info.pcwa = pcwa; /* save pcw */ io_info.tio_off = 0; /* save dcw list offset */ io_info.rew_wait = "0"b; /* not expecting special interrupt */ io_info.io_in_progress = "1"b; /* set flag for interrupt processing */ io_info.num_connects = io_info.num_connects + 1; io_info.int_time = 0; /* clear out interrupt time */ end mca_io_setup; /* io_setup - internal procedure to set up the ioi workspace for test I/O */ io_setup: proc; dcl (continue, first, idcw_io) bit (1); dcl (cbuf_add, lstloc, nxtloc) fixed bin; dcl dcwb fixed bin (18) uns; ioi_wksp = io_info.workspace_ptr; /* get a ptr to our workspace */ continue = "0"b; /* reset continue flag */ unspec (wks_init) = "0"b; /* initialize workspace to zero */ tolts_workspace.l_pad.e = "525252525252"b3; /* set up our lower buffer pad */ tolts_workspace.l_pad.o = "525252525252"b3; tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* set default dcw list offset for ioi */ idcwp = addr (tolts_workspace.p_idcw); /* set up idcw ptr */ idcw.code = "7"b3; /* set in idcw type code */ if io_entry.prim.io_cmd = "40"b3 /* if idcw I/O */ | io_entry.prim.io_cmd = "24"b3 & io_info.io_type = mhp_io_type then do; /* | idcw I/O & hyper */ idcw_io = "1"b; /* set flag for idcw io */ idcw.command = io_entry.prim.dev_cmd; /* set up first idcw from io entry word 4 */ if (idcw.command = "31"b3 & io_info.chan_suspended)/* if diagnostic mode control... */ | io_entry.prim.dev ^= "00"b3 then /* or punch indicator */ idcw.chan_cmd = "00"b3; /* set data xfer chan command */ else if io_entry.prim.io_cmd = "24"b3 /* if cmd = 24 */ & io_info.io_type = mhp_io_type then /* & hyper io */ idcw.chan_cmd = "00"b3; /* set data xfer chan command */ else if io_info.io_type = mtar_io_type then /* if mtar */ idcw.chan_cmd = "00"b3; /* set data xfer chan command */ else idcw.chan_cmd = "40"b3; /* otherwise set special cont. cmd */ idcw.count = io_entry.prim.record_count; /* set record count */ if idcw.count ^= "00"b3 & idcw.count ^= "01"b3 then do; /* if not single idcw */ idcw.control = "10"b; /* set idcw continue bit */ continue = "1"b; /* set continue flag */ end; if idcw.command = "00"b3 then /* if suspend command */ io_info.suspend_chan = "1"b; /* set flag for mme tdio */ if idcw.command = "20"b3 then /* if release command */ io_info.release_chan = "1"b; /* set flag for tolts_io_int_ */ end; /* note that device code is = 0 */ else do; /* not idcw I/O, single or dual I/O */ idcw_io = "0"b; idcw.command = io_entry.second.dev_cmd; /* get idcw from word 7 (same for single or dual I/O */ idcw.chan_cmd = io_entry.second.io_cmd; idcw.count = io_entry.second.record_count; if io_info.io_type = itr_io_type /* insure that release_chan is reset */ then io_info.suspend_chan = "0"b; /* in the event no special was returned */ if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd then do; /* disk/dual I/O */ idcwp = addr (tolts_workspace.seek_idcw); /* set up seek idcw */ idcw.command = io_entry.prim.dev_cmd; /* set device command */ if bin (io_entry.sct_add, 13) >= 512 then idcw.device = io_info.altsct.device_no; else idcw.device = io_info.devsct.device_no; idcw.code = "7"b3; idcw.control = "10"b; /* set continue bit in idcw */ idcw.chan_cmd = io_entry.prim.io_cmd; idcw.count = io_entry.prim.record_count; dcwp = addr (tolts_workspace.seek_dcw); /* set ptr to seek dcw */ string (dcw) = "0"b; /* initialize */ dcw.address = rel (addr (tolts_workspace.seek_add)); /* set dcw address */ dcw.tally = "0001"b3; /* set tally of one */ i = fixed (rel (addrel (execp, first_dcw.address))); /* compute index to seek add */ tolts_workspace.seek_add = exec_wd (i); /* move seek address to workspace */ tio_off = fixed (rel (addr (tolts_workspace.seek_idcw))); /* set dcw list offset to seek idcw */ end; end; /* process dcw list */ idcwp = addr (tolts_workspace.p_idcw); /* set primary idcw ptr */ if ^mpc_io then /* if not controller io */ if bin (io_entry.sct_add, 13) >= 512 then idcw.device = io_info.altsct.device_no; else idcw.device = io_info.devsct.device_no; dcwp = addrel (execp, io_entry.dcw_ptr); /* set dcw ptr to first dcw */ if string (dcw) = "0"b then do; /* if non data command */ tolts_workspace.buf_size, c_len = 1; /* set buffer size to 1 word */ dcwp = addr (tolts_workspace.dcw_list (1)); /* set up iotd that should not be used */ string (dcw) = "0"b; /* initialize dcw */ dcw.address = rel (addr (tolts_workspace.data_buf)); dcw.tally = "0001"b3; /* 1 word iotd */ if continue then /* if idcw continue bit set */ idcw.control = "00"b; /* reset it now */ go to non_data; /* bypass dcw processing */ end; io_info.page_base = bin (dcw.address); /* set first dcw address as data buf base */ first, found = "0"b; /* reset terminate condition */ unspec (io_info.dcw_list) = "0"b; /* clear out saved dcw list */ lstloc, nxtloc, j = 1; /* set initial dcw copy index */ bufp = addr (tolts_workspace.data_buf (1)); /* set intial buffer ptr */ do i = 1 to hbound (tolts_workspace.dcw_list, 1) while (^found); /* go through dcw list */ tolts_workspace.dcw_list (j) = string (dcw); /* copy dcws (and idcws) to work space */ io_info.dcw_list (j) = string (dcw); /* and for interrupt processor */ if dcw.char_pos = "7"b3 then do; /* if idcw */ idcwp = addr (tolts_workspace.dcw_list (j)); /* set idcw ptr */ if idcw.control = "10"b then /* if idcw continue bit set */ continue = "1"b; /* set continue flag */ else continue = "0"b; /* otherwise reset it */ if ^mpc_io then /* if not controller io */ if bin (io_entry.sct_add, 13) >= 512 then idcw.device = io_info.altsct.device_no;/* set device code */ else idcw.device = io_info.devsct.device_no; j = j + 1; /* increment copy dcw index */ end; else if dcw.type = "10"b then /* if tdcw */ dcwp = addrel (execp, bin (dcw.address) - 1); /* set dcwp to list -1 */ else do; /* data dcws */ if ^first then do; /* if the first time through */ first = "1"b; /* set flag, so we don't come back */ dcwb = bin (dcw.address); /* set dcw base address */ end; mvp = addrel (execp, dcw.address); /* get ptr to data to move */ c_len = bin (dcw.tally); /* get length of data */ if string (dcw) = "0"b then do; /* if illegal zero dcw */ c_len = 1; /* set length = 1 */ dcw.address = io_entry.stat_p; /* set address to status word */ call tolts_qttyio_$rs /* tell user */ (0, "Tolts: Last io_entry contains an illegal dcw. Please investigate"); end; if c_len = 0 then c_len = 4096; /* allow for a dcw tally of 4096 */ cbuf_add = bin (dcw.address) - dcwb; /* compute relative address */ if cbuf_add = 0 then /* if this dcw address is the same last */ cbuf_add = lstloc; /* set the same index */ else cbuf_add = nxtloc; /* otherwise use next avail address */ tolts_workspace.buf_size = cbuf_add; bufp = addr (tolts_workspace.data_buf (cbuf_add)); /* set buffer ptr */ workspace_move = mvp -> workspace_move; /* and move it */ mvp = addr (tolts_workspace.dcw_list (j)); /* set ptr to workspace dcw */ mvp -> dcw.address = rel (bufp); /* set relative address */ lstloc = bin (mvp -> dcw.address) - bin (rel (addr (tolts_workspace.data_buf (1)))) + 1; nxtloc = lstloc + c_len; /* set next available location */ dcwb = bin (dcw.address); /* set up to look at nxt dcw */ if idcw_io then do; /* if running mdrs */ bufp = addrel (bufp, c_len); /* set nxt buffer address for idcw io */ c_len = 0; /* reset current length */ end; j = j + 1; /* increment copy dcw index */ if dcw.type = "00"b then /* if iotd */ if ^continue then /* and continue flag not set */ found = "1"b; /* set terminate condition */ end; dcwp = addrel (dcwp, 1); /* increment dcw ptr to next one */ end; tolts_workspace.buf_size = (bin (rel (bufp)) + c_len) - bin (rel (addr (tolts_workspace.data_buf (1)))); non_data: tolts_workspace.h_pad.e = "252525252525"b3; /* set upper buffer pad */ tolts_workspace.h_pad.o = "252525252525"b3; if io_info.devsct.com_prph then do; /* if common prph channel */ pcwa = tolts_workspace.p_idcw; /* pick up first idcw */ tio_off = fixed (rel (addr (tolts_workspace.dcw_list (1)))); /* can't execute idcw on com prph */ end; else pcwa = "000000700000"b3; /* otherwise set phony pcw for ioi */ if substr (mme_call_w (4), 1, 1) = "1"b then do; /* if user wants dcws traced */ io_info.io_trc_flag = "1"b; /* set io trace flag */ call ioa_$rsnnl ("^/ ^/*** i/o trace ***^/", message, mesg_len); if io_entry.prim.dev_cmd ^= io_entry.second.dev_cmd & ^idcw_io then /* if disk io */ call ioa_$rsnnl ("^a^/seek idcw: - ^12.3b, seek dcw: - ^12.3b, seek address: - ^12.3b", message, mesg_len, message, tolts_workspace.seek_idcw, tolts_workspace.seek_dcw, tolts_workspace.seek_add); call ioa_$rsnnl ("^a^/^[pcw^;idcw^]: - ^12.3b^/dcw list:^/", message, mesg_len, message, io_info.devsct.com_prph, tolts_workspace.p_idcw); do i = 1 by 4 while (tolts_workspace.dcw_list (i) ^= "0"b); /* put out only valid dcws */ call ioa_$rsnnl ("^12.3b ", lginfo, mesg_len, tolts_workspace.dcw_list (i)); do j = 1 to 3 while (tolts_workspace.dcw_list (i + j) ^= "0"b); /* 4 wds per line */ call ioa_$rsnnl ("^a ^12.3b ", lginfo, mesg_len, lginfo, tolts_workspace.dcw_list (i + j)); end; call ioa_$rsnnl ("^a^/", lginfo, mesg_len, lginfo); message = rtrim (message) || lginfo; /* add line to message */ end; call tolts_qttyio_ (message, 10); end; else io_info.io_trc_flag = "0"b; /* reset trace flag */ io_info.ext_status_add = io_entry.ext_sts; /* copy extended status store address */ io_info.ignore_term = io_entry.second.ignore_term; /* copy ignore term flag */ io_info.icivlu.ic = io_entry.ccc_p; /* set entry to call on io completion */ io_info.icivlu.ind = "0"b; /* initialize indicators */ io_info.status_add = fixed (io_entry.stat_p); /* save status storage ptr */ exec_wd (io_info.status_add) = "0"b; /* initialize test page status */ exec_wd (io_info.status_add + 1) = "0"b; io_info.pcwa = pcwa; /* save pcw */ io_info.tio_off = tio_off; /* save dcw list offset */ io_info.rew_wait = "0"b; /* not expecting special interrupt */ io_info.io_in_progress = "1"b; /* set flag for interrupt processing */ io_info.num_connects = io_info.num_connects + 1; io_info.int_time = 0; /* clear out interrupt time */ end io_setup; %page; /* get_px_sct - subroutine to get the correct test page index, given entry index */ /* the globol variables io_sel, mpc_io and io_info_ptr are set up by this subroutine */ get_px_sct: proc (mname, px, ck_alloc); dcl mname char (6); dcl px fixed bin; dcl ck_alloc bit (1); if px >= 1024 then do; /* ck for controller sct */ mpc_io = "1"b; /* set flag if controller sct */ io_sel = px - 1024; /* get device sct */ end; else if px >= 512 then do; /* check for alt. device sct */ mpc_io = "0"b; io_sel = px - 512; /* get primary device sct */ end; else do; /* not controller sct, it is device sct */ mpc_io = "0"b; /* reset controller io flag */ io_sel = px; /* test page index is correct as is */ end; io_sel = divide (io_sel, 4, 17, 0); /* Multics scts are mod 4 */ if io_sel < 1 | io_sel > 8 | ^pages (io_sel).in_use | (ck_alloc & ^pages (io_sel).allocated) then do; /* if error in sct */ call tolts_qttyio_$rs (0, "^as: MME ^a; Invalid SCT - ^6.3b", exec, mname, bit (bin (px, 18))); call tolts_abort ("$a2"); end; io_info_ptr = addr (pages (io_sel)); /* get ptr to this test page */ end get_px_sct; /* get_px_tcx - subroutine to get the correct page index, given the true channel index (ICC) */ /* the global variables io_sel and io_info_ptr are set up by this subroutine */ get_px_tcx: proc (mname, tci); dcl mname char (6); dcl tci bit (11); do io_sel = 1 to (hbound (pages, 1)) while (tci ^= pages (io_sel).devsct.icc); /* find correct page */ end; if io_sel > (hbound (pages, 1)) then do; /* no matching page */ call tolts_qttyio_$rs (0, "^as: MME ^a; no matching page found for true chan. index - ^3.3b", exec, mname, tci); call tolts_abort ("$m1"); end; else io_info_ptr = addr (pages (io_sel)); /* get ptr to this test page */ end get_px_tcx; %page; /* output_status_code - internal procedure to queue up a status message */ output_status_code: proc (ecode, mess); dcl ecode fixed bin (35); dcl mess char (*); call convert_status_code_ (ecode, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a^/^a", tolts_info.exec, lginfo, mess); end output_status_code; dealcp_sub: proc; dealc_err = 0; if io_info.p_att | io_info.alloc_wait then do; /* if perp. device attached to this page */ call ck_release; /* go check mpc stae */ if io_info.io_type = mca_io_type then do; if io_info.ipc_attached then do; call tolts_qttyio_$rs (0, "^a IPC ^a not reloaded.^/^a^/", io_info.test_hdr, io_info.ipc_number, "Do you wish to quit leaving IPC unloaded?"); ask_again: call tolts_qttyio_$rs (19, "Please answer yes or no. - "); call message_wait; /* wait for users answer */ if tolts_info.mult_ans = "yes" | tolts_info.mult_ans = "y" then do; io_info.suspend_chan = "1"b; opr_query_info.q_sw = "0"b; call ioa_$rsnnl ("^/^a Unrecoverable error running ipc ^a firmware.^/^-^a", message, i, io_info.test_hdr, io_info.ipc_number, "IPC will not be reloaded"); call opr_query_ (addr (opr_query_info), substr (message, 1, i)); /* tell opr bad news */ end; else if mult_ans = "no" | mult_ans = "n" then do; io_info.io_in_progress = "1"b; /* set flag for interrupt processing */ io_info.num_connects = io_info.num_connects + 1; call mca_$load_ipc (io_info.mca_ioi_idx, io_info.ipc_number, "0"b, code); end; else goto ask_again; call mca_$detach_ipc ((io_info.ipc_id), io_info.mca_ioi_idx, ^io_info.suspend_chan, code); io_info.ipc_attached = "0"b; end; if io_info.mca_attach_state ^= MCA_NOT_CONFIGURED then do; io_info.io_in_progress = "1"b; /* set flag for interrupt processing */ io_info.num_connects = io_info.num_connects + 1; call mca_$reset (io_info.mca_ioi_idx, "0"b, code); io_info.io_in_progress = "1"b; /* set flag for interrupt processing */ io_info.num_connects = io_info.num_connects + 1; call mca_$detach_mca (io_info.mca_ioi_idx, code); end; end; else call rcp_$detach (io_info.rcp_id, "0"b, 0, "T&D is detaching " || io_info.device_name, error); if error ^= 0 then do; /* error detaching device */ dealc_err = 1; call output_status_code (error, "unassign error"); end; end; /* This code will detach the alternate device for mtar (or anyother program). The alternate device attached flag (io_info.p2_att) is checked to see if an alternate device is attached. If so it is detached. */ if io_info.p2_att then do; /* detach alternate device if attached */ call rcp_$detach (io_info.alt_rcp_id, "0"b, 0, "t&d is detaching " || io_info.alt_device_name, error); if error ^= 0 then do; /* handle detach error */ dealc_err = 1; call output_status_code (error, "unassign error"); end; end; if io_info.ev_ch_ass then do; /* if status event channel assigned to this page */ call ipc_$delete_ev_chn (io_info.status_event, error); if error ^= 0 then do; /* error deleting event channel */ dealc_err = 1; call output_status_code (error, " deleting test io event channel "); end; end; unspec (io_info) = "0"b; /* clear the test page data */ tolts_info.exec_page_count = tolts_info.exec_page_count - 1; /* decrement total test page count */ end dealcp_sub; /* rel_exec_chan - internal procedure to release the colts exec channel */ rel_exec_chan: proc (k); dcl k fixed bin (6); dmap = addr (tolts_info.fnp (k).dm_arg); /* get addr of dial_manager arg */ fnp (k).dm_arg.version = dial_manager_arg_version_2; fnp (k).dm_arg.dial_qualifier = substr (fnp (k).exec_chan, 1, 22); tolts_info.fnp (k).dm_arg.dial_channel = tolts_info.dm_event; /* set dial_channel to event channel */ tolts_info.fnp (k).dm_arg.channel_name = fnp (k).exec_chan; /* get channel name */ call dial_manager_$release_channel (dmap, code); if code ^= 0 then do; if debugging then call com_err_ (code, "mtdsim_", "Error releasing ^a.", dmap -> dial_manager_arg.channel_name); call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error doing exec channel release", tolts_info.exec, lginfo); call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if ^debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; /* no need to return, as we won't be back */ cltp = fnp (k).fnp_execp; call close_sw (cltp); tolts_info.fnp (k).exec_active = "0"b; return; end rel_exec_chan; /* rel_tst_chan - internal procedure to release the colts test channel */ rel_tst_chan: proc (k); dcl k fixed bin (6); dmap = addr (tolts_info.colts_pages (k).dm_arg); tolts_info.colts_pages (k).dm_arg.version = dial_manager_arg_version_2; tolts_info.colts_pages (k).dm_arg.dial_qualifier = substr (colts_pages (k).cdt_name, 1, 22); tolts_info.colts_pages (k).dm_arg.dial_channel = tolts_info.dm_event; tolts_info.colts_pages (k).dm_arg.channel_name = colts_pages (k).cdt_name; call tolts_qttyio_$rs (0, "Do you want to return the channel ^a to service?", tolts_info.colts_pages (k).cdt_name); reask: call tolts_qttyio_$rs (19, "Please answer yes or no - "); call message_wait; if tolts_info.mult_ans = "yes" | mult_ans = "y" then call dial_manager_$release_channel (dmap, code); else if tolts_info.mult_ans = "no" | mult_ans = "n" then call dial_manager_$release_channel_no_listen (dmap, code); else goto reask; if code ^= 0 then do; if debugging then call com_err_ (code, "mdtsim_", "Error releasing channel ^a.", dmap -> dial_manager_arg.channel_name); call convert_status_code_ (code, shortinfo, lginfo); call tolts_qttyio_$rs (0, "^as: ^a/ error doing channel detach", tolts_info.exec, lginfo); call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; /* no need to return, as we won't be back */ cltp = colts_pages (k).chanp; call close_sw (cltp); colts_pages (k).in_use = "0"b; tolts_info.exec_page_count = tolts_info.exec_page_count - 1; return; end rel_tst_chan; /* close_sw - internal procedure to close and detatch colts io switches */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_sw: proc (cltp); dcl cltp ptr; call iox_$close (cltp, code); /* close a switch */ if code ^= 0 then do; /* if erroe */ call convert_status_code_ (code, shortinfo, lginfo); /* convert the status code */ call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$close", tolts_info.exec, lginfo); /* and notify the user */ call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if ^debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; call iox_$detach_iocb (cltp, code); /* detach the io switch */ if code ^= 0 then do; /* if error */ call convert_status_code_ (code, shortinfo, lginfo); /* convert the error code */ call tolts_qttyio_$rs (0, "^as: ^a/ doing iox_$detach", tolts_info.exec, lginfo); /* notify the user */ call com_err_ (error, exec, "*** fatal error, terminating process"); /* tell users first */ fatal_desc.version = 0; fatal_desc.fatal_code = error; if ^debugging then call terminate_process_ ("fatal_error", addr (fatal_desc)); else signal tolts_error_; end; return; end close_sw; /* ctime - internal function to return pl1 time string */ ctime: proc returns (char (16)); dcl tim char (12); dcl ptime char (16); dcl plen fixed bin; tim = time; /* get current time */ call ioa_$rsnnl ("^2a:^2a:^2a.^6a:", ptime, plen, substr (tim, 1, 2), substr (tim, 3, 2), substr (tim, 5, 2), substr (tim, 7, 6)); return (ptime); /* return time string */ end ctime; %page; /* clean_up - entry to clean_up - our enviornment before returning to tolts command level */ clean_up: entry; if exec = "colt" then do; do k = 1 to hbound (pages, 1); if colts_pages (k).in_use then call rel_tst_chan (k); end; do k = 0 to hbound (fnp, 1); if fnp (k).exec_active then call rel_exec_chan (k); end; end; do io_sel = 1 to hbound (pages, 1); /* deallocate all perp. devices */ io_info_ptr = addr (pages (io_sel)); if io_info.in_use then call dealcp_sub; end; if gicmp ^= null then free gicm; if ticmp ^= null then free ticm; term = "1"b; /* set terminate condtion */ if tolts_info.file_attach then do; /* if print file attached... */ call tolts_file_util_$wdump (addr (spa.regs)); call tolts_file_util_$close; /* go close it out */ end; if tolts_info.term_io_req_cnt ^= 0 & ^tolts_info.finish_cond /* if we are still doing io */ & ^q_flag then go to blk_lbl; call tolts_init_$clean_up; /* go delete our event channels and our slave segment */ tolts_active = "0"b; /* reset active state for epilogue handler */ return; /* decode_den - int procedure to decode density info returned from rcp and put into sct entry */ decode_den: proc; tape_info_ptr = addr (io_info.rcp_area); /* set tape info ptr */ if substr (tape_info.density, 1, 6) = "00"b3 then do; /* rcp returned bad density information */ ask: call tolts_qttyio_$rs (0, " ^a RCP returned incorrect device info ^/^a^/", io_info.test_hdr, "Please input density capabilities of device to be tested"); call tolts_qttyio_$rs (19, "Please input densities in the form: 200,556,800,1600,6250 ^-"); call message_wait; if tolts_info.mult_ans = "200,556,800" then io_info.devsct.w2.den_cap = "0001"b; else if tolts_info.mult_ans = "200,556,800,1600" then io_info.devsct.w2.den_cap = "0100"b; else if tolts_info.mult_ans = "556,800,1600" then io_info.devsct.w2.den_cap = "0101"b; else if tolts_info.mult_ans = "556,800" then io_info.devsct.w2.den_cap = "1001"b; else if tolts_info.mult_ans = "800,1600" then io_info.devsct.w2.den_cap = "1000"b; else if tolts_info.mult_ans = "1600" then io_info.devsct.w2.den_cap = "1100"b; else if tolts_info.mult_ans = "1600,6250" then io_info.devsct.w2.den_cap = "1011"b; else if tolts_info.mult_ans = "6250" then io_info.devsct.w2.den_cap = "1010"b; else do; call tolts_qttyio_$rs (0, "Incorrect reply. ^/ ^a ^/", /* If no match we fall thru */ "Do you want to run with default density"); call tolts_qttyio_$rs (19, "Please answer yes or no"); call message_wait; if tolts_info.mult_ans = "no" | mult_ans = "n" then goto ask; /* ask for density again */ else if io_info.crcst.mtp610 then do; io_info.devsct.w2.den_cap = "1100"b; /* if mtp610 set density to 1600 only */ call tolts_qttyio_$rs (0, "Test will be run at 1600bpi ^/"); end; else do; io_info.devsct.w2.den_cap = "1000"b; /* else run at 500/800bpi */ call tolts_qttyio_$rs (0, "Test will be run at 500/1600bpi ^/"); end; end; end; else if substr (tape_info.density, 1, 6) = "70"b3 then/* 200,556 and 800 bpi */ io_info.devsct.w2.den_cap = "0001"b; else if substr (tape_info.density, 1, 6) = "74"b3 then/* 200,556,800 and 1600 bpi */ io_info.devsct.w2.den_cap = "0100"b; else if substr (tape_info.density, 1, 6) = "30"b3 then/* 556 and 800 bpi */ io_info.devsct.w2.den_cap = "1001"b; else if substr (tape_info.density, 1, 6) = "14"b3 then/* 800 and 1600 bpi */ io_info.devsct.w2.den_cap = "1000"b; else if substr (tape_info.density, 1, 6) = "04"b3 then/* 1600 bpi only */ io_info.devsct.w2.den_cap = "1100"b; else if substr (tape_info.density, 1, 6) = "06"b3 then/* 1600 and 6250 bpi */ io_info.devsct.w2.den_cap = "1011"b; else if substr (tape_info.density, 1, 6) = "02"b3 then/* 6250 bpi only */ io_info.devsct.w2.den_cap = "1010"b; else if substr (tape_info.density, 1, 6) = "34"b3 then/* 556, 800, and 1600bpi */ io_info.devsct.w2.den_cap = "0101"b; end decode_den; /* pop_isc - subroutine to pop the inter slave read queue and return data to slave exec */ pop_isc: proc (s_add, d_add); dcl (s_add, d_add) fixed bin; exec_wd (s_add) = "400000000000"b3; /* set status to complete */ exec_wd (d_add) = tolts_info.exec_dta (1).word (1); /* move isc data from queue */ exec_wd (d_add + 1) = tolts_info.exec_dta (1).word (2); exec_wd (d_add + 2) = tolts_info.exec_dta (1).word (3); tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt - 1;/* decrement count */ do i = 1 to tolts_info.exec_dta_cnt; tolts_info.exec_dta (i) = tolts_info.exec_dta (i + 1); /* move queue down */ end; end pop_isc; %page; /* ck_release - subroutine to check to see if mpc firmware has been destoryed and reload it */ ck_release: proc; if io_info.io_in_progress then do; /* if some io outstanding */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */ call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */ tolts_info.gewake_active = "1"b; /* set flag */ do while (tolts_info.gewake_active); /* wait for timer to go off or interrupt */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */ end; if io_info.chan_suspended then /* if ioi_$suspend has been called */ if io_info.io_type = itr_io_type | io_info.io_type = firm_ld_io_type then do; /* and itrs have been run or attempted to load fw */ retry_ld: call tolts_load_firmware_ (io_sel, error); /* go reload firmware */ if error ^= 0 then do; /* some problem, ask user what to do */ if tolts_info.finish_cond then /* if we don't have a terminal... */ go to tell_opr; /* just tell opr bad news */ call tolts_qttyio_$rs (0, "^a Error loading mpc firmware.^/^a^/", io_info.test_hdr, "Do you wish to retry or quit leaving mpc suspended?"); retype: call tolts_qttyio_$rs (19, "Please answer retry or quit. - "); call message_wait; /* wait for users answer */ if tolts_info.mult_ans = "retry" then go to retry_ld; /* go retry load again */ else if tolts_info.mult_ans = "quit" then do; tell_opr: opr_query_info.q_sw = "0"b; call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr, "Unrecoverable error loading mpc firmware.", "I/O will remain suspended"); call opr_query_ (addr (opr_query_info), substr (message, 1, i)); /* tell opr bad news */ end; else go to retype; /* user gave wrong answer */ end; end; else if io_info.io_type ^= mca_io_type then do; /* must be suspended from mdr io */ ioi_wksp = io_info.workspace_ptr; /* get a ptr to our workspace */ unspec (wks_init) = "0"b; /* initialize workspace to zero */ idcwp = addr (tolts_workspace.p_idcw); /* set up idcw ptr */ idcw.code = "7"b3; /* set in idcw type code */ idcw.command = "20"b3; /* set release command */ idcw.chan_cmd = "40"b3; /* special cont. command */ pcwa = "000000700000"b3; /* set up phony pcw */ tio_off = fixed (rel (addr (tolts_workspace.p_idcw))); io_info.release_chan = "1"b; /* set flag for interrupt processor */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */ call timer_manager_$alarm_wakeup (10, "11"b, tolts_info.gewake_event); /* Set 10 second timer */ tolts_info.gewake_active = "1"b; /* set flag */ if pages (io_sel).p_att then do; call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error); if error ^= 0 then call output_status_code (error, "cleanup io connect error"); tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1; /* increment global IO count */ end; do while (tolts_info.gewake_active); /* wait for timer to go off or interrupt */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */ end; if io_info.io_in_progress then do; /* if we still got timeout... */ call ioa_$rsnnl ("^/^a ^a^/^-^a", message, i, io_info.test_hdr, "Unable to release mpc,", "manually reset and branch to reinitialize mpc"); opr_query_info.q_sw = "0"b; call opr_query_ (addr (opr_query_info), substr (message, 1, i)); call ioi_$release_devices (io_info.device_index, error); /* do it now */ end; end; end; end ck_release; /* message_wait - subroutine to wait for terminal message to complete */ message_wait: proc; do while (tolts_info.term_io_req_cnt > 0); /* wait for all terminal io to complete */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); end; end message_wait; %page; /* set_gelbar - int procedure to set up information to enter gelbar mode */ set_gelbar: proc; dcl fwd bit (36); dcl 1 acc_over based (addr (fwd)) aligned, /* overlay of acc fault status */ (2 bar bit (18), /* BAR value from last mme gelbar */ 2 nu1 bit (1), 2 fault bit (1), /* "1"b = fault occurred */ 2 nu2 bit (1), 2 overflow bit (1), /* "1"b = fixed point overflow */ 2 ex_over bit (1), /* "1"b = exponent overflow */ 2 ex_under bit (1), /* "1"b = exponent underflow */ 2 ipr bit (1), /* "1"b = eis data ipr fault */ 2 nu3 bit (4), 2 dcf bit (1), /* "1"b = divide check fault */ 2 f_type fixed bin (5)) unaligned; /* fault type, (refer to gcos manual DD19) */ fwd = "0"b; /* reset all bits */ acc_over.fault = "1"b; /* valid gelbar fault,set the fault bit */ acc_over.bar = substr (spa.acc_fault, 1, 18); /* pick up the current bar setting */ spa.acc_fault = fwd; /* store accumlated ault status */ spa.enter.lbar.bar = "000630"b3; /* reset bar to 0 lal */ spa.enter.icivlu.ic = rel (addr (spa.glbflt)); /* set ic to return to gelbar fault vector */ call tolts_init_$gc_tod (gcos_tod); /* get current time of day */ spa.glbtmr = bit (fixed (gcos_tod, 35, 0) - fixed (string (spa.glbici), 35, 0), 36); /* delta time */ spa.glbici.ic = bit (bin (scu.ilc, 17) + 1, 18); /* store current ic + 1 */ spa.glbici.ind = string (scu.ir); /* and indicators */ gelbar, in_ccc = "0"b; /* reset gelbar mode, and in ccc */ glb_brk = "1"b; /* and set gelbar break ind */ call wake_disp; /* go wake up dispatcher */ end set_gelbar; %page; %include author_dcl; %page; %include cdt; %page; %include condition_info; %page; %include config_iom_card; %page; %include event_wait_info; %page; %include gload_data; %page; %include mc; %page; %include mca_data; %page; %include mca_data_area; %page; %include opr_query_info; %page; %include rcp_disk_info; %page; %include rcp_resource_types; %page; %include rcp_tape_info; %page; %include tolts_err_codes; %page; %include tolts_fpinfo; %page; %include tolts_info; %page; %include tolts_rspd_workspace; %page; %include tolts_workspace; end mtdsim_;  opr_query_.pl1 12/09/86 1539.4rew 12/09/86 1521.7 57978 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Initial coding by J. A. Bush 10/78. Modified 09/80 to clarify the operator reply expected. - R. Fakoury Modified 12/80 to use set_lock_ primitives - P. B. Kelley Modified 03/83 by Rick Fakoury to restructure the operator message format. Modified 11/83 to correct a bug. Modified 1985-03-08, BIM: phcs_ --> tandd_ */ /****^ HISTORY COMMENTS: 1) change(86-08-21,Fakoury), approve(86-08-21,MCR7514), audit(86-11-24,Martinson), install(86-12-04,MR12.0-1235): to correct the alignment of the operator messages. END HISTORY COMMENTS */ /* opr_query_ - subroutine to send message to the system operator and wait for his response */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ opr_query_: proc (oqip); dcl oqip ptr; /* ptr to opr_query_ info structure */ dcl tandd_$ring_0_message entry (char (*)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl get_process_id_ entry returns (bit (36) aligned); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count entry returns (fixed bin); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl (com_err_, ioa_$rsnnl) entry options (variable); dcl (error_table_$invalid_lock_reset, error_table_$locked_by_this_process) ext static fixed bin (35); dcl 1 oq_info like opr_query_info based (oqip) aligned; dcl 1 event_info aligned, 2 cid fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 origin, 3 dev_signal bit (18) unaligned, 3 ring bit (18) unaligned, 2 cx fixed bin; dcl argp ptr; dcl code fixed bin (35); dcl mess char (80); dcl len fixed bin; dcl (addr, null) builtin; dcl cleanup condition; dcl sc_dir char (168) static options (constant) init (">system_control_1"); on cleanup go to unlock; /* unconditionaly unlock lock on cleanup condition */ if oq_info.q_sw then do; /* if user wants answer from operator */ if oqdp = null then do; /* if first reference in our process */ call hcs_$initiate (sc_dir, "opr_query_data", "", 0, 1, oqdp, code); /* initiate opr_query_data segment */ if oqdp = null then do; /* if we can't initiate, tell user */ call com_err_ (code, "opr_query_", "attempting to initiate ^a>opr_query_data", sc_dir); oq_info.err_code = code; /* return error code to user */ return; end; end; call set_lock_$lock (opr_query_data.lock_id, 60, code); /* set lock */ if code = error_table_$invalid_lock_reset then call com_err_ (code, "opr_query_", "^/(referencing ^a>opr_query_data)", sc_dir); else if code = error_table_$locked_by_this_process then call com_err_ (code, "opr_query_", "^/The lock will remain set by this process."); else if code ^= 0 then do; call com_err_ (code, "opr_query_", "^/The lock cannot be set by this process."); oq_info.err_code = code; /* indicate error to caller */ return; end; opr_query_data.process_id = get_process_id_ (); /* fill in user's process id */ call ipc_$create_ev_chn (opr_query_data.event_chan, code); /* create an event chan, for oprs response */ if code ^= 0 then do; /* some error */ call com_err_ (code, "opr_query_", "attempting to create event wait channel"); oq_info.err_code = code; /* copy error code for caller */ go to unlock; /* and go unlock lock */ end; opr_query_data.nchan = 1; /* set number of ipc channels to 1 */ opr_query_data.answer = ""; /* set up the rest of the opr_query data structure */ opr_query_data.prim = oq_info.prim; opr_query_data.alt = oq_info.alt; opr_query_data.q_sw = oq_info.q_sw; opr_query_data.r_comment = oq_info.r_comment; end; call cu_$arg_list_ptr (argp); /* get ptr to our argument list */ if cu_$arg_count () > 1 then do; /* if message is to output to opr */ call ioa_$general_rs (argp, 2, 3, mess, len, "0"b, "0"b); /* format message */ if len > 80 then len = 80; /* max length is 80 chars */ call tandd_$ring_0_message (substr (mess, 1, len));/* and output to operator */ end; if oq_info.q_sw then do; /* if waiting for operator response */ call ioa_$rsnnl (" ^[ ^a^;^s ^/ ^] ^[ ^/^3-respond: x oqr ^a^;^s^]^[ ^/^3-^5xor: x oqr ^a^;^s ^] ", mess, len, (oq_info.r_comment ^= ""), oq_info.r_comment, (oq_info.prim ^= ""), oq_info.prim, (oq_info.alt ^= ""), oq_info.alt); if len > 80 then len = 80; call tandd_$ring_0_message (substr (mess, 1, len));/* output expected response */ call ipc_$block (addr (opr_query_data.wait_list), addr (event_info), code); /* wait */ if code ^= 0 then do; /* if some error */ call com_err_ (code, "opr_query_", "while blocked"); oq_info.err_code = code; /* copy error code for caller */ end; else oq_info.answer = opr_query_data.answer; /* copy operators answer */ call ipc_$delete_ev_chn (opr_query_data.event_chan, code); unlock: call set_lock_$unlock (opr_query_data.lock_id, code); /* unlock our lock */ if code ^= 0 then call com_err_ (code, "opr_query_", "Attempting to unlock the opr_query_data lock."); end; oq_info.err_code = 0; /* reset error code, and return */ %include opr_query_data; %include opr_query_info; end opr_query_;  opr_query_response.pl1 12/05/86 0937.4r 12/05/86 0902.6 34173 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ opr_query_response: proc; /* opr_query_response - operator command interface to respond to an opr_query_ request */ /* initial coding by J. A. Bush 10/78. Modified 03/83 by Rick Fakoury to allow the operator to send a message in responce to a question. Modified 08/83 by Rick Fakoury to correct an oversight. */ dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl arg char (al) based (ap); dcl (al, arg_cnt, i) fixed bin; dcl ap ptr; dcl msg char (80) varying init (""); dcl code fixed bin (35); dcl error_table_$wrong_no_of_args fixed bin (35) ext; dcl null builtin; dcl pname char (18) static options (constant) init ("opr_query_response"); dcl sc_dir char (168) static options (constant) init (">system_control_1"); msg = ""; call cu_$arg_count (arg_cnt, code); do i = 1 to arg_cnt; call cu_$arg_ptr (i, ap, al, code); /* get the operators response */ if code ^= 0 then do; /* some error, tell opr about it */ call com_err_ (error_table_$wrong_no_of_args, pname, /* so tell him */ "Usage: ^a answer", pname); return; end; msg = msg || " " || arg; end; if oqdp = null then do; /* if first reference in our process */ call hcs_$initiate (sc_dir, "opr_query_data", "", 0, 1, oqdp, code); /* initiate opr_query_data segment */ if oqdp = null then do; /* if we can't initiate, tell user */ call com_err_ (code, pname, "attempting to initiate ^a>opr_query_data", sc_dir); return; end; end; if opr_query_data.lock_id = "0"b then do; /* no response pending */ call com_err_ (0, pname, "No operator response pending"); return; end; if arg = opr_query_data.prim | arg = opr_query_data.alt then do; /* if valid response */ opr_query_data.answer = arg; /* save answer and wakeup requesting process */ call hcs_$wakeup (opr_query_data.process_id, opr_query_data.event_chan, 0, code); if code ^= 0 then do; /* error on wakeup */ call com_err_ (code, pname, "attempting to issue wakeup to process id ^12.3b", opr_query_data.lock_id); return; end; end; else if opr_query_data.q_sw then do; opr_query_data.answer = msg; /* save answer and wakeup requesting process */ call hcs_$wakeup (opr_query_data.process_id, opr_query_data.event_chan, 0, code); if code ^= 0 then do; /* error on wakeup */ call com_err_ (code, pname, "attempting to issue wakeup to process id ^12.3b", opr_query_data.lock_id); return; end; end; else do; /* if invalid response */ call com_err_ (0, pname, " ^[ ^a ^/ ^] ^[ respond: x oqr ^a^]^[ ^/^-^-^-or: x oqr ^a ^] ", (opr_query_data.r_comment ^= ""), opr_query_data.r_comment, (opr_query_data.prim ^= ""), opr_query_data.prim, (opr_query_data.alt ^= ""), opr_query_data.alt); return; /* tell opr what is expected and return */ end; %include opr_query_data; end opr_query_response;  tolts_.pl1 12/09/86 1539.4rew 12/09/86 1521.8 61083 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Rewritten 6/78 by J. A. Bush to conform to Multics programming standards Modified 79/02/08 by J. A. Bush to call the Multics T & D Slave Interface Module (mtdsim_) for Molts and Polts Modified 80/02/06 by J. A. Bush to handle the sus_ condition Modified 80/12/08 by R. E. Fakoury to handle a colts request. Modified 03/83 by Rick Fakoury to change the msg1 to msg and to call tolts_util_$opr_msg. Also added a check for user access to system data_bases and gates. Modified 10/83 to use access_mode_values.incl as recommended by the auditor. Modified 01/84 by R Fakoury to support new tolts debugger call. Modified 01/85 by R Fakoury to change the check for tandd.acs. */ /****^ HISTORY COMMENTS: 1) change(85-10-21,Fakoury), approve(86-08-21,MCR7514), audit(86-12-01,Martinson), install(86-12-09,MR12.0-1235): to check for user access to mca gate & system mca data segs. END HISTORY COMMENTS */ /* tolts_ - this is the TOLTS executive that controls execution of POLTS, MOLTS, COLTS, and ISOLTS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_: proc; /* AUTOMATIC */ dcl c_args (32) char (28) varying; dcl c_len fixed bin; dcl cardp ptr init (null); dcl code fixed bin (35); dcl com_string char (132) aligned; dcl cmd_cnt fixed bin; dcl entry_var entry variable; dcl tandd_ok bit (1); dcl term bit (1); dcl ttl_date char (6); dcl user_access fixed bin (5); /* BUILTINS */ dcl null builtin; /* CONDITIONS */ dcl linkage_error condition; /* CONSTANTS */ dcl current_ring fixed bin int static options (constant) init (-1); dcl no_error_expected fixed bin (35) int static options (constant) init (0); dcl pname char (6) static options (constant) init ("tolts_"); dcl ring_1 fixed bin int static options (constant) init (1); dcl sl_dir char (4) int static options (constant) init (">sl1"); dcl sc_admin_dir char (14) int static options (constant) init (">sc1>admin_acs"); dcl sc_dir char (4) int static options (constant) init (">sc1"); /* ENTRIES */ dcl com_err_ entry () options (variable); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl ioa_ entry options (variable); dcl isolts_ entry; dcl mca_$attach_mca entry; dcl mtdsim_ entry options (variable); dcl no_save_on_disconnect entry; dcl save_on_disconnect entry; dcl tandd_$ring_0_message entry; dcl tolts_util_$get_ttl_date entry (entry, char (6)); dcl tolts_util_$on_off entry (char (6), char (3), char (6)); dcl tolts_util_$opr_msg entry; dcl tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin); /* EXTERNAL */ dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; %page; call no_save_on_disconnect; /* do not want process saved on terminal disconnect */ call tolts_util_$get_ttl_date (tolts_, ttl_date); call tolts_util_$on_off ("tolts", "on", ttl_date); /* signon */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Verify user access to system data and system gates. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call check_access (sc_dir, "opr_query_data", RW_ACCESS_BIN, no_error_expected, current_ring); call check_access (sc_admin_dir, "tandd.acs", RW_ACCESS_BIN, no_error_expected, current_ring); call check_access (sc_dir, "cdt", R_ACCESS_BIN, no_error_expected, current_ring); call check_access (sl_dir, "mca_data_seg", RW_ACCESS_BIN, error_table_$noentry, ring_1); on linkage_error begin; call com_err_ (error_table_$moderr, pname, "^[mca_^;tandd_^]", tandd_ok); goto t_off; /* exit */ end; tandd_ok = "0"b; entry_var = tandd_$ring_0_message; tandd_ok = "1"b; entry_var = mca_$attach_mca; revert linkage_error; %page; /* Now loop until user quits */ term = "0"b; /* reset terminate condition */ do while (^term); call ioa_ (" ^/***enter ""polts"", ""molts"", ""colts"", ""isolts"", ""quit"", or ""msg"""); call tolts_util_$query ("??? ", com_string, c_len, c_args, cmd_cnt); /* Now see what user wants to do */ if c_args (1) = "quit" | c_args (1) = "q" then /* user wants to quit */ term = "1"b; else if c_args (1) = "polts" then /* user wants to run polts */ call mtdsim_ ("polt"); else if c_args (1) = "molts" then /* user wants to run molts */ call mtdsim_ ("molt"); else if c_args (1) = "colts" then /* user wants to run colts */ call mtdsim_ ("colt"); else if c_args (1) = "isolts" then /* user wants to run isolts */ call isolts_; else if c_args (1) = "msg" then /* user wants to send message to operator */ call tolts_util_$opr_msg; else call ioa_ ("^/invalid response - ^a", com_string); end; /* User is all done, output Tolts wrap up message */ t_off: call tolts_util_$on_off ("tolts", "off", ttl_date); /* signoff */ call save_on_disconnect; /* restore users save on disconnect state */ return; %page; /* check_access - int proc that will check the user's access to system gates & data bases */ check_access: proc (dir, entry, lowest_access, error_expected, ring); dcl error_expected fixed bin (35); dcl dir char (*); dcl entry char (*); dcl lowest_access fixed bin (5); dcl ring fixed bin; call hcs_$get_user_effmode (dir, entry, "", ring, user_access, code); if code ^= 0 then do; if code = error_expected then return; call com_err_ (code, pname, "attemping to get user access to ^a>^a.", dir, entry); go to t_off; /* exit */ end; if user_access >= lowest_access then return; call com_err_ (error_table_$moderr, pname, "^a>^a", dir, entry); goto t_off; /* exit */ end check_access; %page; %include access_mode_values; end tolts_; /* thats it */  tolts_alm_util_.alm 12/05/86 0937.4r w 12/05/86 0900.5 52605 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " Modified by R. Fakoury 8102 to cumpute an icm checksum for colts. " " The entry point, ascii_to_bcd_, takes a character string " as input and produces a bit string of length divide (length (output),6,24) " as output. If the output string has more bcd char positions " than there are input chars to convert, then the output is blank filled. " " PL/1 Usage: " " dcl tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*)); " call tolts_alm_util_$ascii_to_bcd_ (input_chars, output_bits); " " The entry point, ascii_to_bci_ is the same as ascii_to_bcd_ except " that the output string is zero filled. " PL/1 Usage: " " dcl tolts_alm_util_$ascii_to_bci_ entry (char (*), bit (*)); " call tolts_alm_util_$ascii_to_bci_ (input_chars, output_bits); " " " The entry point enter_slave_ is used to do a transfer into a gcos type object. " The single entry argument is a pointer to the desired entry address into the gcos object. " By convention this entry point is a 3 word program located in the slave prefix area, " at offset 32 (octal). This 3 word program contains: " " lreg load safe stored registers " lbar ,du load desired base address setting " ret return to desired ic and i value " " The enter_slave_ entry merely does an indirect TRA instruction into this entry program. " The RET instruction will put the processor in slave mode and returns to the saved IC value " that is relative to the loaded BAR. " " " The entry point gen_ck_sum computes an icm cksum for colts icm's " pl/1 usage: " dcl tolts_alm_util_$gen_ck_sum entry (ptr); " call tolts_alm_util_$gen_ck_sum entry (icm ptr); """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" name tolts_alm_util_ entry ascii_to_bcd_ entry ascii_to_bci_ entry enter_slave_ entry enter_ccc_req_ entry gen_ck_sum temp temp gen_ck_sum: "generate icm cksum epp1 ap|2,* get ptr to icm ldx6 pr1|0,* get the number of words ldx5 1,du set word index ldx4 1,du lda pr1|0,*5 load first word ana -1,dl exclude cksum bits sta pr1|0,*4 store in cksum word ck_sum2: adlx5 1,du inc index sblx6 1,du decrement wrod count tze ck_sum3 tally exhausted lda pr1|0,*5 load next word ersa pr1|0,*4 include in checksum tra ck_sum2 loop ck_sum3: lda pr1|0,*4 als 18 reduce to 18 bits era pr1|0,*4 store in checksum ana -1,du sta pr1|0,*4 short_return ascii_to_bcd_: " ascii to bcd entry ldx5 1,du set bcd indicator tra *+2 ascii_to_bci_: " ascii to bci entry ldx5 2,du set bci indicator epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load arg list code value canx2 =o0000004,du check for no parent pointer (code 4) tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer, set x3 to skip it ldq ap|8,x3* load target string descriptor anq mask drop all but string size bits div 6,dl get length of target in BCD characters lda ap|6,x3* load source string descriptor ana mask drop all but string size bits cmpx5 2,du test for bci conversion tze cv_bci tra if bci convert even "EIS address must be even mvt (pr,rl),(pr,rl),fill(040) now do the ascii to bcd desc9a 1|0,al desc6a 3|0,ql arg atb_tab short_return even "EIS address must be even cv_bci: mvt (pr,rl),(pr,rl),fill(060) now do the ascii to bci desc9a 1|0,al desc6a 3|0,ql arg atb_tab short_return inhibit on enter_ccc_req_: push " " pl1 definition of courtesy call queue: " " dcl 1 ccc_queue, " 2 ccc_requests fixed bin, /* number of courtesy call requests outstanding */ " 2 icivlu (16) bit (36), /* outstanding ic values (ind value is always 0) */ " eppbp ap|2,* get ptr to ccc queue eppbp bp|0,* lda bp|0 get ccc request count, current adla 1,dl increment by 1 sta bp|0 store updated count ldq ap|4,* get ic value to store stq bp|0,al store in correct queue entry anq 777777,du save only ic value return enter_slave_: push sprisp sb|stack_header.bar_mode_sp save sp so signaller can reset " it in case gcos uses adr6 eppbp ap|2,* get the entry ptr eppbp bp|0,* .. stz sp|stack_frame.entry_ptr make stack traces look nice stz sp|stack_frame.entry_ptr+1 tra bp|0 transfer directly into to the entry program inhibit off mask: oct 000077777777 even atb_tab: " ascii chars 000 - 037 (8) - invalid bcd chars set to bcd "?" (ignore char) oct 017017017017,017017017017,017017017017,017017017017 oct 017017017017,017017017017,017017017017,017017017017 " ascii chars 040 - 057 (8) = " !"#$%&'()*+,-./" oct 020077076013,053074032057,035055054060,073052033061 " ascii chars 060 - 077 (8) = "0123456789:semicolon<=>?" oct 000001002003,004005006007,010011015056,036075016017 " ascii chars 100 - 117 (8) = "@ABCDEFGHIJKLMNO" oct 014021022023,024025026027,030031041042,043044045046 " ascii chars 120 - 137 (8) = "PQRSTUVWXYZ[\]^_" oct 047050051062,063064065066,067070071012,037034040072 " ascii chars 140 - 157 (8) = "`abcdefghijklmno" oct 017021022023,024025026027,030031041042,043044045046 " ascii chars 160 - 177 (8) = "pqrstuvwxyz{|}~PAD" oct 047050051062,063064065066,067070071012,040034017017 include stack_header include stack_frame end  tolts_alrm_util_.pl1 12/09/86 1539.4r w 12/09/86 1522.7 23058 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ tolts_alrm_util_: proc; /* tolts_alrm_util_ - a group of entries that are called by asyncronous timers */ /* coded by J. A. Bush 2/3/79 */ dcl tolts_qttyio_ entry (char (*), fixed bin); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl terminate_process_ entry (char (*), ptr); dcl com_err_ entry options (variable); dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl error fixed bin (35); dcl null builtin; quit: entry; /* this entry is called by the tolts_quith event call channel when we are in a blocked state. It is used to syncronys the quit signal caused by a terminal break or interrupt key being depressed by the user */ if tolts_info.exec_term_io_wait | tolts_info.term_io_in_prog then tolts_info.optflag = tolts_info.optflag + 1; /* increment options request flag */ else do; /* no terminal io in prog, queue up exec read */ tolts_info.optflag = 0; /* reset options request flag */ call tolts_qttyio_ ("???", 9); /* issue exec read */ end; return; gewake: entry; /* this entry is called by the gewake event channel when the asyncronous gewake alarm timer goes off It is used to wakeup the dispatcher after a specified time period has elapsed, if an io interrupt has not ocurred in the meantime. If an io interrupt has occurred, the alrarm timer will be reset in the interrupt processor */ tolts_info.gewake_active = "0"b; /* reset alarm flag */ call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), null, error); if error ^= 0 then do; /* if error on wakeup, terminate process */ call com_err_ (error, "tolts_alrm_util_", "fatal error, terminating process"); fatal_desc.version = 0; fatal_desc.fatal_code = error; /* copy error code */ call terminate_process_ ("fatal_error", addr (fatal_desc)); end; return; /* thats it */ %include tolts_info; end tolts_alrm_util_;  tolts_device_info_.pl1 12/09/86 1539.4rew 12/09/86 1520.9 359523 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* original coding by J. A. Bush 79/02/13. Modified by Michael R. Jordan 79/10/09 for new MPC card format. Modified by G. Haney & R. Fakoury 80/13/24 to set up secondary sct, rcp for alternate device. Modified by R. Fakoury 08/80 include 501 config card and to examine the entire chan config card Modified by R. Fakoury 09/80 to remove rcp_ area initialization. Modified by R.Fakoury 11/80 to allow mtar to run on 400 type devices Modified by R.Fakoury 12/80 to fix bug in chnl card interrupter. Modified by R.Fakoury 04/80 & 05/80 to fix a bug in the mpc card interrupter. Modified by M.R. Jordan 7/81 for changes in PRPH OPC card format. Modified by R. Fakoury 04/82 to add pr54 support and fix ccu bug. Modified by C. Horning 08/82 to support new tape config card. Modified by R. Fakoury 09/82 to allow booting the eurc from a non-lo order chan. Modified by R. Fakoury 11/82 to correct eurc problems and allow cp120 & 121 devices, allow mtg, mtc & mdc test request & 128 chan support. Modified by R. Fakoury 05/83 to allow mdr testing from non logical 0 chans. Modified by R. Fakoury 06/09/83 to corect a mpc attachment problem and answer TRs' 13296, 14742, 15343. Modified by R. Fakoury 06/15/83 to correct a problem caused by the changes made for the new tape prph card. Modified by R. Fakoury 08/19/83 to support the new opc config card and correct 128chan support bug. Modified by R. Fakoury 11/83 to support hyperchannel. Modified by R Fakoury 11/83 to make more corrections to support the tape config card. Modified by R Fakoury 12/83 to put back a conditional check for a com prph prior to checking for an mpc card. Also added changes to remove the restriction on running itrs on non-logical zero channels. Modified by R. Fakoury 01/84 to close a hole in an mpc601 and mth610 possible configuration. Modified by R Fakoury 04/84 to support the DAU. Modified by R Fakoury 10/84 to correct an extranous check to compare an mpc card to a mpc device string. Modified by R. Fakoury 10/84 to utilize the system prph card incls. Modified by R Fakoury 2/85 to fix a hyperchannel bug. Modified by R Fakoury 4/26 to fix a dau bug. */ /****^ HISTORY COMMENTS: 1) change(86-06-04,Hartogs), approve(86-06-04,MCR7383), audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098): Changed to use version constant in rcp_device_info.incl.pl1. 2) change(86-08-21,Fakoury), approve(86-08-21,MCR7514), audit(86-12-01,Martinson), install(86-12-04,MR12.0-1235): to correct an error in attaching the mpc for disk and tape mdrs. to correct an extranous check to compare to a mpc device string. to utilize the system prph card incls. to support Dipper FIPS tape & disk to implement test nio request. to implement responder test request. END HISTORY COMMENTS */ /* tolts_device_info_ - procedure to find a prph by IOM, channel and device and return info. /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_device_info_: proc (icdtp, px, type_error); /* Entry parameters */ dcl icdtp ptr; /* ptr to iom, chan, & device info (see icdt structure below) */ dcl px fixed bin; /* test page index */ dcl type_error fixed bin; /* error code (returned) */ /* Automatic */ dcl (IOM, CHAN, device2, device, di, MODEL, NDRIVES, i, k) fixed bin; dcl model_index fixed bin; dcl code fixed bin (35); dcl rs_mode fixed bin (5); dcl (spec_chan, term, term1, trm, urcitr) bit (1) init ("0"b); dcl rcpsp ptr; dcl (dname, altname) char (8); dcl mdr_cat char (5); dcl xregp ptr; dcl cont_cardp ptr; /* Structures and based variables */ dcl xreg3 bit (36) based (xregp); dcl 1 cont_card aligned based (cont_cardp) like mpc_card; dcl 1 icdt based (icdtp) aligned, /* structure defining input parameters */ (2 ficcdd bit (18), /* iom, chan and device */ 2 tt bit (6), /* test type: 0 = polt, C = ITRs, R = MDRs, T = MTAR */ 2 u_opt bit (6), /* if = bcd "U", then set disk/tape to "T&D_Volume" */ 2 pad1 bit (6)) unaligned; /* Static, builtins, and external entries */ dcl ioa_$rsnnl entry options (variable); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); dcl tolts_util_$dev0_valid entry (ptr, fixed bin) returns (bit (1)); dcl tolts_util_$find_card entry (char (4), ptr); dcl one_sec fixed bin (35) int static options (constant) init (1000000); /* in micro sec */ dcl one_min fixed bin (35) int static options (constant) init (60000000); /* in micro sec */ dcl five_min fixed bin (35) int static options (constant) init (300000000); /* in micro sec */ dcl execute bit (5) int static options (constant) init ("00100"b); dcl tags (1:8) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl (addr, addrel, bin, bit, fixed, hbound, mod, null, substr, unspec) builtin; %page; if icdt.tt ^= "0"b & icdt.tt ^= "22"b3 & icdt.tt ^= "23"b3 & icdt.tt ^= "24"b3 & icdt.tt ^= "25"b3 & icdt.tt ^= "30"b3 & icdt.tt ^= "41"b3 & icdt.tt ^= "45"b3 & icdt.tt ^= "51"b3 & icdt.tt ^= "63"b3 & icdt.tt ^= "71"b3 then goto t_err23; /* if invalid test type - set error */ io_info_ptr = addr (pages (px)); /* get ptr to our page entry */ unspec (io_info.devsct) = "0"b; /* initilize device sct */ io_info.cat_name, io_info.device_name = ""; type_error = 0; /* reset return error code */ if icdt.tt = "71"b3 then do; prph_cardp = null; term = "0"b; do while (^term); call tolts_util_$find_card ("prph", prph_cardp); if prph_cardp = null then goto t_err0; else if prph_card.name = "dia" || tags (io_info.fnp_num + 1) then do; term = "1"b; dname = prph_card.name; IOM = prph_card.iom; CHAN = prph_card.chan; goto c_info; end; end; end; else if substr (icdt.ficcdd, 4, 1) then do; /* if new format */ io_info.nff = "1"b; /* set new format flag */ xregp = addrel (execp, 33); /* get ptr to chan number */ CHAN = fixed (substr (xreg3, 28, 9)); /* save channel number */ io_info.devsct.icc = "0"b || substr (icdt.ficcdd, 5, 2) /* save icc in devsct */ || substr (xreg3, 29, 8); IOM = fixed (substr (icdt.ficcdd, 5, 2)); /* set iom number */ end; else do; /* else old format */ io_info.nff = "0"b; /* not new format */ substr (io_info.devsct.icc, 1, 9) = substr (icdt.ficcdd, 4, 9); /* save iom and channel */ CHAN = fixed (substr (icdt.ficcdd, 7, 6)); /* and channel number */ IOM = fixed (substr (icdt.ficcdd, 4, 3)); /* set iom number */ end; device = fixed (substr (icdt.ficcdd, 13, 6)); /* and device number */ io_info.devsct.device_no = substr (icdt.ficcdd, 13, 6); /* set device number in device sct */ /* first validate IOM number */ chnl_cardp, iom_cardp, mpc_cardp = null; term = "0"b; /* reset terminate condition */ do while (^term); /* find all iom cards */ call tolts_util_$find_card ("iom ", iom_cardp); /* find iom card */ if iom_cardp = null then /* didn't find iom card, get out of loop */ goto t_err0; /* error, invalid IOM number */ else if tag - 1 = IOM then do; /* found right card */ if iom_card.state ^= "on " then goto t_err1; if iom_card.model = "imu " then io_info.sct_info.ioc_type = "0001"b; term = "1"b; end; end; if CHAN = 3 then do; if iom_card.model ^= "imu" then goto t_err23; else dname = "mca" || tags (iom_card.tag); goto c_info; end; %page; /* now validate channel with iom */ prph_cardp = null; /* reset prph_cardp to start at beginning of deck */ term = "0"b; /* reset terminate condition */ do while (^term); /* go thru prph cards to find chan, and iom */ call tolts_util_$find_card ("prph", prph_cardp); /* find next config card */ if prph_cardp = null then term = "1"b; /* if last card in deck passed */ else do; if prph_card.iom - 1 = IOM then /* found iom number */ if prph_card.chan = CHAN then /* and channel */ term = "1"b; /* set terminate condition */ else if substr (prph_card.name, 1, 3) = "dsk" then do; /* if disk */ prph_dsk_cardp = prph_cardp; if CHAN >= prph_dsk_card.chan & CHAN < prph_dsk_card.chan + prph_dsk_card.nchan then term = "1"b; /* special case for disks */ end; else if substr (prph_card.name, 1, 3) = "tap" then do; /* if tape */ prph_tap_cardp = prph_cardp; if CHAN >= prph_tap_card.chan & CHAN < prph_tap_card.chan + prph_tap_card.nchan then term = "1"b; /* special case for tapes */ end; end; end; term = "0"b; /* reset terminate condition */ if prph_cardp = null then do; do while (^term); /* look at chanl cards */ call tolts_util_$find_card ("chnl", chnl_cardp); if chnl_cardp = null then /* if last card in deck passed */ goto t_err1; /* channel not assignable */ else do i = 1 to 3 while (chnl_card.group (i).iom ^= -1 & ^term); if IOM = chnl_card.group (i).iom - 1 then do; if CHAN >= chnl_card.group (i).chan /* found chan in range */ & CHAN <= (chnl_card.group (i).chan + chnl_card.group (i).nchan - 1) then do; term = "1"b; prph_cardp = chnl_cardp; altname, dname = chnl_card.name; end; end; end; end; if prph_cardp ^= null & icdt.tt = "51"b3 & ^io_info.p2_att then /* if first attach request & mdr */ if substr (dname, 1, 3) = "tap" | /* if tape or disk */ substr (dname, 1, 3) = "dsk" then do; term = "0"b; /* reset terminate condition */ mpc_cardp = null; /* set config ptr to start at top */ do while (^term); call tolts_util_$find_card ("mpc ", mpc_cardp); /* find mpc card */ if mpc_cardp = null () then /* shouldn't happen */ goto t_err1; /* channel unassignable */ do i = 1 to 4 while (mpc_card.port (i).iom ^= -1 & ^term); /* ck each field */ if mpc_card.port (i).iom - 1 = IOM then/* if match on iom */ if CHAN >= mpc_card.port (i).chan & CHAN <= mpc_card.port (i).chan + (mpc_card.port (i).nchan - 1) /* match */ then term = "1"b; /* set terminate condition */ device = 0; /* want to atatch the mpc first */ end; end; end; term = "0"b; prph_cardp = null; do while (^term); /* now find prph card that goes with chnl */ call tolts_util_$find_card ("prph", prph_cardp); if prph_cardp = null then goto t_err1; else if prph_card.name = dname then term = "1"b;/* found it */ end; if prph_cardp = null then /* if this is true, error */ goto t_err1; end; else do; dname, altname = prph_card.name; if icdt.tt = "51"b3 & ^io_info.p2_att then /* if first attach request & mdr */ if substr (dname, 1, 3) = "tap" | /* if tape or disk */ substr (dname, 1, 3) = "dsk" then device = 0; end; MODEL, NDRIVES = 0; /* set device range to 0 initialy */ term = "0"b; if substr (dname, 1, 3) = "dsk" then do; call ioa_$rsnnl ("^a_^[0^]^d", dname, i, dname, (device < 10), device); /* set in ascii device */ prph_dsk_cardp = prph_cardp; if icdt.tt = "23"b3 /* if running itrs */ | icdt.tt = "51"b3 then do; do i = 1 to 5 while (prph_dsk_card (i).model ^= -1); if prph_dsk_card.group (i).model > MODEL then/* if this model higher than prev */ MODEL = prph_dsk_card.group (i).model; /* use this one */ end; end; else do; do i = 1 to 5 while ((prph_dsk_card.group (i).model ^= -1) & ^term); /* go through each possible pair */ if prph_dsk_card.group (i).model ^= 0 then do; /* if not fence */ if device >= NDRIVES & device <= NDRIVES + prph_dsk_card.group (i).ndrives then do; MODEL = prph_dsk_card.group (i).model; /* found model */ if tolts_util_$dev0_valid (addr (config_data_$disk_drive_model_names), MODEL) then io_info.sct_info.cnt_type = "0011"b; if io_info.sct_info.cnt_type ^= "0011"b & device = 0 then goto t_err2; term = "1"b; di = i; end; else NDRIVES = NDRIVES + prph_dsk_card.group (i).ndrives; end; else NDRIVES = NDRIVES + prph_dsk_card.group (i).ndrives; end; if ^term then goto t_err2; /* invalid device */ end; end; else if substr (dname, 1, 3) = "tap" then do; prph_tap_cardp = prph_cardp; call ioa_$rsnnl ("^a_^[0^]^d", dname, i, dname, (device < 10), device); /* set in ascii device */ if (device = 0) & (icdt.tt = "23"b3 | icdt.tt = "51"b3) then do; do i = 1 to 5 while (prph_tap_card.group (i).model ^= -1); if prph_tap_card.group (i).model > MODEL then MODEL = prph_tap_card.group (i).model; end; end; else do; do i = 1 to 5 while ((prph_tap_card.group (i).model ^= -1) & ^term); if prph_tap_card.group (i).model ^= 0 then do; if (device >= NDRIVES) & (device <= NDRIVES + prph_tap_card.group (i).ndrives) then do; MODEL = prph_tap_card.group (i).model; if tolts_util_$dev0_valid (addr (config_data_$tape_drive_model_names), MODEL) then io_info.sct_info.cnt_type = "0011"b; if io_info.sct_info.cnt_type ^= "0011"b & device = 0 then goto t_err2; term = "1"b; end; else NDRIVES = NDRIVES + prph_tap_card.group (i).ndrives; end; else NDRIVES = NDRIVES + prph_tap_card.group (i).ndrives; end; if ^term then goto t_err2; end; end; %page; /* at this point we have ptr to correct prph card */ c_info: mdr_cat = "card "; /* set default mdr catalog suffix */ io_info.lostit_time = /* default lostit time is 1 sec (+ 1min from exec) */ divide ((one_min + one_sec) * 64, 1000, 35); device_info_ptr = addr (io_info.rcp_area (1)); /* set general RCP info first */ device_info.version_num = DEVICE_INFO_VERSION_1; /* structure version DEVICE_INFO_VERSION_1 */ device_info.version_num = 1; /* structure version 1 */ device_info.usage_time = 0; /* T&D will use resource for an indefinite time */ device_info.wait_time = 0; /* T&D will not wait for the resource */ device_info.system_flag = "0"b; /* T&D is not a system process */ if substr (dname, 1, 3) = "ccu" then call set_ccu; /* if combined card unit */ else if substr (dname, 1, 3) = "dsk" then call set_disk; /* if disk subsystem */ else if substr (dname, 1, 3) = "dia" then call set_dia; /* if dia */ else if substr (dname, 1, 3) = "hch" then call set_hch; /* if hyperchannel */ else if substr (dname, 1, 3) = "mca" then call set_mca; /* if mca */ else if substr (dname, 1, 3) = "opc" then call set_opc; /* if system console */ else if substr (dname, 1, 3) = "prt" then call set_prt; /* if printer */ else if substr (dname, 1, 3) = "pun" then call set_pun; /* if card punch */ else if substr (dname, 1, 3) = "rdr" then call set_rdr; /* if card reader */ else if substr (dname, 1, 3) = "tap" then call set_tape; /* if tape subsystem */ else goto t_err1; /* invalid prph */ io_info.device_name = dname; /* copy device name */ io_info.devsct.com_prph = ck_com_prph (); if ^spec_chan & ^io_info.devsct.com_prph then call ck_mpc; /* go check mpc card */ device_info.device_name = io_info.device_name; /* set device for rcp */ if icdt.tt = "0"b then io_info.io_type = polt_io_type; /* set io type (0 = POLT) */ else if icdt.tt = "22"b3 then io_info.io_type = mtc_io_type; /* MTC io */ else if icdt.tt = "23"b3 then io_info.io_type = itr_io_type; /* ITR io */ else if icdt.tt = "24"b3 then io_info.io_type = mtg_io_type; /* MTG io */ else if icdt.tt = "25"b3 then io_info.io_type = mdc_io_type; /* MDC io */ else if icdt.tt = "30"b3 then io_info.io_type = mhp_io_type; /* MHP io */ else if icdt.tt = "41"b3 then io_info.io_type = mdc_io_type; /* MFC io like MDC io */ else if icdt.tt = "45"b3 then io_info.io_type = mca_io_type; /* NIO io */ else if icdt.tt = "51"b3 then io_info.io_type = mdr_io_type; /* MDR io */ else if icdt.tt = "63"b3 then io_info.io_type = mtar_io_type; /* MTAR io */ else if icdt.tt = "71"b3 then io_info.io_type = rspd_io_type; /* RSPD io */ io_info.test_hdr = ""; /* build ascii test header */ call ioa_$rsnnl ("**^d(^[p^;itr^;mdr^;mtr^;itr^;mtc^;mtg^;mdc^;mhp^;nio^;rsp^]^d^[0^]^d^[^2s^;^[0^]^d^]):", io_info.test_hdr, i, px - 1, io_info.io_type + 1, IOM, (CHAN < 10), CHAN, (io_info.io_type = 1), (device < 10), device); return; t_err0: type_error = m_iv_iom; /* set error, invalid IOM number */ return; t_err1: type_error = ch_not_ass; /* set error, unrecognized prph */ return; t_err2: type_error = iv_dev; /* set error, invalid device */ return; t_err9: type_error = not_psia; /* set error, not a psia channel */ return; t_err10: type_error = not_log_0; /* set error, not logical channel 0 of mpc */ return; t_err21: type_error = dev_busy; /* set error, device attached by system */ return; t_err23: type_error = inv_tt; /* set error, invalid test type */ return; %page; /* ck_com_prph - function to check if common prph and if molts in control, return "0"b, return "1"b if ok and set io_info.com_prph flag */ ck_com_prph: proc returns (bit (1)); if spec_chan then return ("0"b); /* special channel don't bother */ term = "0"b; cont_cardp = null; do while (^term); if io_info.sct_info.cnt_type = "0011"b then call tolts_util_$find_card ("ipc", cont_cardp); else call tolts_util_$find_card ("mpc ", cont_cardp); if cont_cardp = null () then return ("1"b); /* If no mpc | ipc cards found */ if io_info.sct_info.cnt_type = "0011"b then do; ipc_cardp = cont_cardp; if ipc_card.iom - 1 = IOM then /* if match on iom */ if CHAN >= ipc_card.chan & CHAN <= ipc_card.chan + (ipc_card.nchan - 1) then do; /* match */ term = "1"b; /* set terminate condition */ return ("0"b); /* must be an mpc device */ end; end; else do i = 1 to 4 while (cont_card.port (i).iom ^= -1 & ^term); /* ck each field */ mpc_cardp = cont_cardp; if cont_card.port (i).iom - 1 = IOM then /* if match on iom */ if CHAN >= cont_card.port (i).chan & CHAN <= cont_card.port (i).chan + (cont_card.port (i).nchan - 1) then do; /* match */ term = "1"b; /* set terminate condition */ return ("0"b); /* must be an mpc device */ end; end; end; end ck_com_prph; /* ck_mpc - internal procedure to check mpc cards */ ck_mpc: proc; if cont_card.model >= 8000 & cont_card.model < 8005 then do; /* must be a EURC */ io_info.crcst.volatile = "0"b; /* make it a eurc mpc */ io_info.crcst.mpc = "1"b; /* set mpc flag */ io_info.sct_info.cnt_type = "0010"b; urcitr = "0"b; /* reset urcitr flag as firmware is not needed */ end; else do; io_info.crcst.mpc = "1"b; /* set mpc flag */ io_info.crcst.volatile = "1"b; /* make it a old style mpc */ if cont_card.model = 800 then io_info.sct_info.cnt_type = "0001"b; end; if icdt.tt = "23"b3 & io_info.crcst.volatile /* if running itrs */ & CHAN ^= cont_card.port (1).chan /* and not on log chan 0 */ & ((substr (cont_card.name, 1, 3) = "msp" & cont_card.model < 600) | (substr (cont_card.name, 1, 3) = "msp" & cont_card.model = 800) | (substr (cont_card.name, 1, 3) = "mtp" & cont_card.model < 610)) then goto t_err10; /* error, not on log chan 0 */ if icdt.tt = "23"b3 then call set_itr_cat; /* go decode mpc card to determine itr catalog name */ if urcitr then do; /* if running itrs on urc, find all firmware */ io_info.mpc_dev_cnt = mpc_card.port (1).nchan; /* save number of log channels */ prph_cardp = null; /* start at beginning of deck */ do i = 1 to io_info.mpc_dev_cnt; /* get each device */ trm = "0"b; /* reset terminate condition */ do while (^trm); /* loop until we find right kind of card */ call tolts_util_$find_card ("prph", prph_cardp); /* find prph config card */ if prph_cardp = null then trm = "1"b; /* this should not happen */ else if prph_card.iom - 1 = IOM /* if on right iom */ & prph_card.chan >= mpc_card.port (1).chan & prph_card.chan <= mpc_card.port (1).chan + (mpc_card.port (1).nchan - 1) then do; /* if in range */ trm = "1"b; /* set terminate condition */ CHAN = prph_card.chan - mpc_card.port (1).chan + 1; /* get right log chan */ if substr (prph_card.name, 1, 3) = "rdr" /* if reader */ | substr (prph_card.name, 1, 3) = "pun" /* if punch */ | substr (prph_card.name, 1, 3) = "ccu" then /* if combined reader and punch */ call set_mask ("ucrp"); else if substr (prph_card.name, 1, 3) = "prt" then /* if printer */ call set_mask ("u400"); end; end; end; do k = 1 to 4 while (io_info.dev_firm (k).mask ^= "0"b); /* get true device count */ end; io_info.mpc_dev_cnt = k - 1; /* set adjusted device count */ end; end ck_mpc; /* ck_urcd - fuction to check device code on urcmpc device */ ck_urcd: proc returns (bit (1)); if icdt.tt = "0"b | icdt.tt = "51"b3 then /* if polts or mdrs */ if device ^= 1 then /* device code must be device 1 */ return ("0"b); /* return false */ if icdt.tt = "51"b3 then /* if mdrs to be run */ io_info.cat_name = "mdr." || mdr_cat; /* set mdr catalog name */ else if icdt.tt = "23"b3 then do; /* if itrs on urmpc */ if device ^= 0 then /* and device not 0 */ return ("0"b); urcitr = "1"b; /* set flag to set up firmware */ end; return ("1"b); end ck_urcd; /* The following function returns the 'console model index' given the console model number. If the model number is not known, -1 is returned. */ CONSOLE_MODEL_TO_INDEX_FCN: procedure (model_number) returns (fixed bin); dcl (i, model_number) fixed bin; do i = 1 to hbound (CONSOLE_MODEL_NUMBER, 1); if model_number = CONSOLE_MODEL_NUMBER (i) then return (CONSOLE_MODEL_INDEX (i)); end; return (-1); end CONSOLE_MODEL_TO_INDEX_FCN; %page; /* set_ccu - internal procdure to set type codes for combined card (CCU) equitment */ set_ccu: proc; %include config_prph_ccu_card; prph_ccu_cardp = prph_cardp; if model = 401 then do; /* if correct model */ io_info.devsct.type_code = "22"b3; /* set correct type code */ if ^ck_urcd () then /* ck device number */ goto t_err2; /* error, invalid device */ if ^io_info.ccu_pun then do; /* if mme setpun has not been called... */ io_info.rcp_name = DEVICE_TYPE (READER_DTYPEX); /* set default rcp type to reader */ substr (dname, 1, 3) = "rdr"; end; else do; io_info.rcp_name = DEVICE_TYPE (PUNCH_DTYPEX); /* otherwise set for punch */ substr (dname, 1, 3) = "pun"; end; end; else goto t_err1; /* not supported */ end set_ccu; %page; /* set_disk - internal procedure to set type codes for disk subsystems */ set_disk: proc; /* *************************************************** * if mtar 500/501, check for alternate device * *************************************************** */ if icdt.tt = "63"b3 & (MODEL = 500 | MODEL = 501) then do; io_info.alt_dev_flag = "1"b; if mod (device, 2) = 1 /* odd device */ & device + 1 > prph_dsk_card.group (di).ndrives + NDRIVES then goto t_err2; else if device - 1 < NDRIVES then goto t_err2; end; if MODEL = 181 then io_info.devsct.type_code = "60"b3; else if MODEL = 190 then io_info.devsct.type_code = "61"b3; else if MODEL = 191 | MODEL = 400 then io_info.devsct.type_code = "62"b3; else if MODEL = 451 then io_info.devsct.type_code = "65"b3; else if MODEL = 500 then io_info.devsct.type_code = "66"b3; else if MODEL = 501 then io_info.devsct.type_code = "67"b3; else if MODEL = 509 then io_info.devsct.type_code = "70"b3; else if MODEL = 3380 then io_info.devsct.type_code = "53"b3; else if MODEL = 3381 then io_info.devsct.type_code = "55"b3; else goto t_err1; /* set error */ if MODEL >= 500 & MODEL < 510 then io_info.crcst.ms500 = "1"b; /* set ms500 indicator */ if icdt.tt = "51"b3 then /* if running mdrs */ io_info.cat_name = "mdr.disk"; /* set mdr catalog name */ if icdt.tt = "23"b3 /* if running ITRs */ | (icdt.tt = "51"b3 & ^io_info.p2_att) then /* if running MDRs & the first attachment */ io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX); /* set "special" designator */ else do; /* other wise set up specific info */ disk_info_ptr = device_info_ptr; io_info.rcp_name = DEVICE_TYPE (DISK_DRIVE_DTYPEX); disk_info.write_flag = "1"b; if icdt.u_opt = "64"b3 then /* if unload option in force... */ disk_info.volume_name = "T&D_Volume"; /* set special volume name */ else disk_info.volume_name = "scratch"; /* otherwise have operator load and authenicate mount */ disk_info.device_name = dname; disk_info.model = MODEL; /* ************************************************* * set up alternate sct/rcp if mtar 500/501 * ************************************************* */ if io_info.alt_dev_flag then do; io_info.altsct = io_info.devsct; /* copy sct */ if mod (device, 2) ^= 0 then io_info.altsct.device_no = bit (bin (bin (io_info.devsct.device_no, 6) + 1, 6), 6); /* odd device */ else io_info.altsct.device_no = bit (bin (bin (io_info.devsct.device_no, 6) - 1, 6), 6); io_info.alt_rcp_area = io_info.rcp_area; /* build alternate device name */ device2 = fixed (io_info.altsct.device_no); disk_info_ptr = addr (io_info.alt_rcp_area); if icdt.u_opt = "64"b3 then disk_info.volume_name = "T&D_Volume"; else disk_info.volume_name = "scratch"; call ioa_$rsnnl ("^a_^[0^]^d", altname, i, altname, (device2 < 10), device2); disk_info.device_name = altname; /* store alternate device name in rcp */ io_info.alt_device_name = altname; disk_info.model = MODEL; disk_info_ptr = addr (io_info.rcp_area); /* restore pointer */ end; /* check users access to the rcp_sys_ gate. If he has access, make him a system process */ call hcs_$initiate (">system_library_1", "rcp_sys_", "", 0, 0, rcpsp, code); if rcpsp ^= null then do; call hcs_$fs_get_mode (rcpsp, rs_mode, code); if code = 0 then if bit (rs_mode) & execute then disk_info.system_flag = "1"b; /* make him a system process */ disk_info_ptr = addr (io_info.alt_rcp_area); /* set pointer to alternate rcp area */ disk_info.system_flag = "1"b; /* set alternate system flag in case needed */ disk_info_ptr = addr (io_info.rcp_area); /* restore pointer */ end; end; end set_disk; %page; /* set_dia - internal procedure to set device info for a Colts RSPD request */ set_dia: proc; spec_chan = "1"b; io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX); /* set "special" designator */ device_info.device_name = dname; device_info.model = 0; end set_dia; /* set_hch - internal procedure to set type code for hyperchannels */ set_hch: proc; if substr (dname, 1, 3) = "hch" then do; spec_chan = "1"b; /* special channel */ io_info.devsct.type_code = "07"b3; io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX); /* set "special" designator */ end; else goto t_err2; end set_hch; %page; /* set_itr_cat - int procedure to set up itr catalog name from mpc card info */ set_itr_cat: proc; if substr (mpc_card.name, 1, 3) = "urp" then /* urmpc is easy */ io_info.cat_name = "itr.urcmpc"; else if substr (mpc_card.name, 1, 3) = "mtp" then do; /* mag tapes */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* /* Since we are here because we are running itrs and the correct mpc is located, the correct /* devsct.type_code will also be set. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if mpc_card.model >= 500 & mpc_card.model < 601 /* mtc500 type */ then io_info.cat_name = "itr.mtc500"; else if mpc_card.model = 601 | mpc_card.model = 602 then do; /* mtp601 */ io_info.cat_name = "itr.mtp601"; if io_info.devsct.type_code = "13"b3 then io_info.devsct.type_code = "15"b3; else io_info.devsct.type_code = "16"b3; io_info.crcst.mtp610 = "0"b; /* if mpc601 there should not be any mth610 devices. */ end; else if mpc_card.model = 610 | mpc_card.model = 611 then do; /* mtp610 */ io_info.cat_name = "itr.mtp610"; if io_info.devsct.type_code = "13"b3 then io_info.devsct.type_code = "15"b3; else io_info.devsct.type_code = "16"b3; end; else goto t_err1; /* should go to something for invalid mpc card */ end; else if substr (mpc_card.name, 1, 3) = "msp" then do; /* disks */ if mpc_card.model = 181 then /* dsc181 */ io_info.cat_name = "itr.dsc181"; else if mpc_card.model = 190 then /* dsc190 */ io_info.cat_name = "itr.dsc190"; else if mpc_card.model = 191 | mpc_card.model = 400 | mpc_card.model = 451 | (mpc_card.model >= 600 & mpc_card.model <= 603) then io_info.cat_name = "itr.dsc191"; /* dsc191 */ else if mpc_card.model >= 604 & mpc_card.model <= 612 then do; /* dsc500 */ io_info.cat_name = "itr.dsc500"; io_info.crcst.ms500 = "1"b; end; else if mpc_card.model = 800 then do; /* msp800 */ io_info.cat_name = "itr.msp800"; end; else goto t_err1; end; else goto t_err1; end set_itr_cat; /* set_mask - internal procedure to set device mask for urcmpc devices */ set_mask: proc (en); dcl en char (4); /* device firmware edit name */ term = "0"b; /* reset terminate condition */ do k = 1 to 4 while (^term); /* go through all masks */ if unspec (io_info.dev_firm (k).edit_name) = "0"b | io_info.dev_firm (k).edit_name = en then do; /* if found match */ term = "1"b; io_info.dev_firm (k).edit_name = en; /* set edit name, in case it wasn't set */ substr (io_info.dev_firm (k).mask, CHAN + 1, 1) = "1"b; /* set port mask */ end; end; end set_mask; %page; /* set_mca - internal procedure to setup io_info for mca */ set_mca: proc; if substr (dname, 1, 3) = "mca" then do; io_info.lostit_time = /* lostit time for the mca is 5min + 1 sec */ divide ((five_min + one_sec) * 64, 1000, 35); spec_chan = "1"b; /* special channel */ io_info.cat_name = "nio.IMU"; end; else goto t_err2; end set_mca; %page; /* set_opc - internal procedure to set up type codes for operators consoles */ set_opc: proc; %include config_prph_opc_card; prph_opc_cardp = prph_cardp; if icdt.tt ^= "0"b then /* if molts in control */ goto t_err9; if state = "on " | state = "alt " then goto t_err21; model_index = CONSOLE_MODEL_TO_INDEX_FCN (prph_opc_card.model); if model_index < 0 then goto t_err1; io_info.devsct.type_code = CONSOLE_GCOS_TYPE (model_index); if CONSOLE_IS_BCD (model_index) then if device ^= 0 then /* device 0 is only legal device code */ goto t_err2; else ; else if device ^= 1 then /* device 1 is only legal device code */ goto t_err2; spec_chan = "1"b; /* special channel */ io_info.rcp_name = DEVICE_TYPE (CONSOLE_DTYPEX); /* set rcp designator */ end set_opc; %page; /* set_prt - internal procedure to set type codes for printers */ set_prt: proc; %include config_prph_prt_card; prph_prt_cardp = prph_cardp; if model = 301 then do; /* if prt301 */ if icdt.tt ^= "0"b then /* if Molts in control... */ goto t_err9; /* can't run Itrs or mdrs on com prph */ if device ^= 0 then /* common perp urc equip is device 0 */ goto t_err2; /* error, invalid device */ io_info.devsct.type_code = "25"b3; end; else if model = 1000 | model = 1200 | model = 1600 then /* if pru1200/1600 */ io_info.devsct.type_code = "24"b3; else if model = 500 | model = 501 | model = 901 | model = 1201 then do; /* check for pr54 id */ io_info.devsct.type_code = "24"b3; io_info.devsct.cr501_pr54 = "1"b; /* set pr54 flag */ io_info.crcst.volatile = "0"b; /* make it a eurc mpc */ io_info.crcst.mpc = "1"b; /* set mpc flag */ io_info.sct_info.cnt_type = "0010"b; spec_chan = "1"b; /* and it is a special channel */ end; else goto t_err1; /* not supported */ mdr_cat = "print"; /* set mdr catalog suffix */ if model >= 900 then /* if urcmpc device */ if ^ck_urcd () then /* ck device number */ goto t_err2; /* error, invalid device */ io_info.devsct.ptrain = train; /* set print train number */ if line_length = 160 then /* if line length is 160 ... */ io_info.devsct.ll160 = "1"b; /* set it */ printer_info_ptr = device_info_ptr; /* set up rcp info */ printer_info.line_length = line_length; printer_info.print_train = train; /* set print train number */ io_info.rcp_name = DEVICE_TYPE (PRINTER_DTYPEX); end set_prt; %page; /* set_pun - internal procedure to set type codes for card punches */ set_pun: proc; %include config_prph_pun_card; prph_pun_cardp = prph_cardp; if model = 201 then do; if icdt.tt ^= "0"b then /* if Molts in control... */ goto t_err9; /* can't run itrs or mdrs on com prph */ if device ^= 0 then /* common perp urc equip is device 0 */ goto t_err2; /* error, invalid device */ io_info.devsct.type_code = "23"b3; /* set type code */ end; else if model > 201 & ^ck_urcd () then /* ck device number */ goto t_err2; /* error, invalid device */ else if model = 300 | model = 120 | model = 121 then io_info.devsct.type_code = "32"b3; else if model = 301 then io_info.devsct.type_code = "33"b3; else if model = 401 then do; /* if ccu goto ccu proc */ call set_ccu; goto end_sp; end; else goto t_err1; /* not supported */ io_info.rcp_name = DEVICE_TYPE (PUNCH_DTYPEX); /* set rcp designator */ end_sp: end set_pun; %page; /* set_rdr - internal procedure to set type codes for card readers */ set_rdr: proc; %include config_prph_rdr_card; prph_rdr_cardp = prph_cardp; if model = 201 then do; /* if type 201 reader */ if icdt.tt ^= "0"b then /* if Molts in control... */ goto t_err9; /* can't run itrs or mdrs on com prph */ if device ^= 0 then /* common perp urc equip is device 0 */ goto t_err2; /* error, invalid device */ io_info.devsct.type_code = "21"b3; /* set type code */ if model = 500 | model = 501 then io_info.devsct.cr501_pr54 = "1"b; /* set cr500 flag */ end; if model > 201 /* if urcmpc device */ & ^ck_urcd () then goto t_err2; /* ck device number- error invalid device */ else do; if model = 301 | model = 500 | model = 501 then /* if type 301 or 500/501 */ io_info.devsct.type_code = "34"b3; if model = 401 then /* if ccu goto ccu proc */ call set_ccu; else goto t_err1; /* not supported */ end; io_info.rcp_name = DEVICE_TYPE (READER_DTYPEX); /* set rcp designator */ end set_rdr; %page; /* set_tape - internal procdure to set type codes for tapes */ set_tape: proc; if MODEL = 500 then io_info.devsct.type_code = "14"b3; else if MODEL = 507 then io_info.devsct.type_code = "13"b3; else if MODEL = 600 then io_info.devsct.type_code = "16"b3; else if MODEL = 610 then io_info.devsct.type_code = "16"b3; else if MODEL = 630 then io_info.devsct.type_code = "16"b3; else if io_info.sct_info.cnt_type = "0011"b then /* if fips controler */ io_info.devsct.type_code = "16"b3; /* set type = 16 */ else goto t_err1; if MODEL = 610 | MODEL = 630 then io_info.crcst.mtp610 = "1"b; io_info.devsct.den_cap = "0100"b; /* set for nrzi, and 1600 for now */ if icdt.tt = "51"b3 then /* if running mdrs */ io_info.cat_name = "mdr.tape"; /* set mdr catalog name */ if icdt.tt = "23"b3 /* if running ITRs */ | (icdt.tt = "51"b3 & ^io_info.p2_att) then /* if running MDRs & the first attachment */ io_info.rcp_name = DEVICE_TYPE (SPECIAL_DTYPEX); /* set "special" designator */ else do; /* other wise set up specific info */ tape_info_ptr = device_info_ptr; /* set structure ptr */ tape_info.version_num = tape_info_version_2; /* set version 2 for tapes */ io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX); tape_info.write_flag = "1"b; if icdt.u_opt = "64"b3 then /* if unload option in force... */ tape_info.volume_name = "T&D_Volume"; /* set special volume name */ else tape_info.volume_name = "scratch"; /* no, let opr load and authenticate mount */ tape_info.device_name = dname; tape_info.model = MODEL; if MODEL = 507 then tape_info.tracks = 7; else tape_info.tracks = 9; io_info.lostit_time = 64000 * 180; /* 3 min lostit time on tapes */ end; end set_tape; %page; %include console_device_specs; %page; %include config_data_dcls; %page; %include config_chnl_card; %page; %include config_iom_card; %page; %include config_ipc_card; %page; %include config_mpc_card; %page; %include config_prph_card; %page; %include config_prph_dsk_card; %page; %include config_prph_tap_card; %page; %include rcp_device_info; %page; %include rcp_disk_info; %page; %include rcp_printer_info; %page; %include rcp_resource_types; %page; %include rcp_tape_info; %page; %include tolts_err_codes; %page; %include tolts_info; end tolts_device_info_;  tolts_file_util_.pl1 10/28/88 1413.0r w 10/28/88 1302.2 82962 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* orginal coding by J. A. Bush 79/03/22 */ /****^ HISTORY COMMENTS: 1) change(85-03-16,Fakoury), approve(86-08-22,MCR7514), audit(86-11-24,Martinson), install(86-12-04,MR12.0-1235): change dump offset and correct a problem when wdump is called to force a dump. END HISTORY COMMENTS */ /* tolts_file_util_ - subroutines to manage print file output for polts and molts */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_file_util_: proc; /* Constants */ dcl ds_format_1 bit (11) int static options (constant) init ("01000100000"b); /* display address offset only & data in long format */ dcl ds_format_2 bit (11) int static options (constant) init ("11000100000"b); /* display address & offset & data in long format */ /* External entries */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl dprint_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl user_info_ entry (char (*), char (*), char (*)); dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)); dcl (tolts_qttyio_$rs, ioa_$ioa_switch) entry options (variable); dcl clock_ entry returns (fixed bin (71)); dcl tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin); /* Automatic */ dcl (i, first, c_len) fixed bin; /* do loop cnters */ dcl (uname, uproj, uacct) char (32); dcl out_str char (136) varying; dcl time_str char (24); dcl code fixed bin (35); dcl (dptr, genp) ptr; dcl format bit (11); /* Entry parameters */ dcl rcode fixed bin (35); /* standard system error rcode */ dcl a_dcwp ptr; dcl regp ptr; /* Builtins */ dcl (addr, fixed, floor, length, null, ptr, substr, rtrim) builtin; /* Structures */ dcl 1 regs based (regp) aligned, /* registers from sregs instruction */ (2 x (0:7) bit (18), /* index regs */ 2 a bit (36), /* a register */ 2 qu fixed bin (18) unsigned, 2 ql fixed bin (18) unsigned) unaligned; /* q reg */ dcl 1 rcw based (genp), /* structure for gcos sysout records with rcws */ (2 dlen fixed bin, /* number of words */ 2 pad fixed bin) unaligned, /* reset of rcw not used */ 2 data bit (rcw.dlen * 36), /* bcd data as bit string */ 2 nxt_rcw bit (0); /* used for getting next rcw */ %page; /* open - entry to attach and open print file */ open: entry (rcode); rcode = 0; /* initialize return code */ tolts_info.pf_name = unique_chars_ (""b) || "." || tolts_info.exec || ".dump"; /* form unique name */ call iox_$attach_name ("err_file", tolts_info.pf_iocbp, /* attach file */ "vfile_ " || rtrim (tolts_info.hdir) || ">" || tolts_info.pf_name, null, code); if code ^= 0 then do; /* if some problem with attach */ rcode = code; /* return error code */ return; /* get out now */ end; tolts_info.file_attach = "1"b; /* indicate our seg is attached */ call iox_$open (tolts_info.pf_iocbp, 2, "0"b, code); /* open for stream output */ if code ^= 0 then do; rcode = code; /* return error code */ call clean_up; /* go detach file */ return; end; tolts_info.file_open = "1"b; call date_time_ ((clock_ ()), time_str); /* get current time of day */ call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/^2-^as print file ^a>^a opened at ^a^/", tolts_info.exec, tolts_info.hdir, tolts_info.pf_name, time_str); return; %page; /* close - entry to close and detach print file and queue up dprint */ close: entry; call date_time_ ((clock_ ()), time_str); /* get current time of day */ call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/^2-^as print file ^a>^a closed at ^a", tolts_info.exec, tolts_info.hdir, tolts_info.pf_name, time_str); call clean_up; /* close and detach file */ call user_info_ (uname, uproj, uacct); /* get users name and project */ out_str = rtrim (uname) || "." || rtrim (uproj); /* form desc line */ if length (out_str) < 10 then i = floor ((14 - length (out_str)) / 2); /* form center index */ else i = 1; /* if name to long, start at collum 1 */ dpap = addr (dprint_arg_buf); /* set dprint arg ptr */ dprint_arg.version = 1; /* set appropriate args */ dprint_arg.copies = 1; dprint_arg.delete = 1; dprint_arg.queue = 3; /* probably should be queue 1 */ dprint_arg.pt_pch = 1; dprint_arg.notify = 1; /* might want to make this 0 */ dprint_arg.output_module = 1; substr (dprint_arg.dest, i) = out_str; /* set in person/project info */ if tolts_info.exec = "polt" then /* if polts dump */ dprint_arg.heading = " for POLTS DUMP"; else if tolts_info.exec = "molt" then /* if molts dump */ dprint_arg.heading = " for MOLTS DUMP"; else if tolts_info.exec = "colt" then /* if colts dump */ dprint_arg.heading = " for COLTS DUMP"; call dprint_ (tolts_info.hdir, tolts_info.pf_name, dpap, code); /* queue it up */ call tolts_qttyio_$rs (0, "^as dump file ^a>^a has been queued for printing", tolts_info.exec, tolts_info.hdir, tolts_info.pf_name); return; %page; /* snap - entry to output snap shot dumps */ snap: entry (a_dcwp); dcwp = a_dcwp; /* copy dcw ptr */ c_len = fixed (dcw.tally); /* set dump length */ first = fixed (dcw.address); /* set first address */ dptr = ptr (tolts_info.execp, first); /* and start dump ptr */ format = ds_format_1; /* display address offset & data in long format */ call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/"); /* output blank line */ call dump_segment_ (tolts_info.pf_iocbp, dptr, 0, first, c_len, format); /* dump it */ return; /* thats it */ %page; /* wdump - entry to output wrap up dumps and dumps with formatted register panal */ wdump: entry (regp); call date_time_ ((clock_ ()), time_str); /* get current date/time */ if regp ^= execp then do; call ioa_$ioa_switch (tolts_info.pf_iocbp, /* put out dump header line */ "^/^2-^as ^[master mode^;slave^] dump taken ^a^/", tolts_info.exec, (regs.x (2) = "442020"b3), time_str); dcwp = addr (regs.a); /* get dcw ptr */ c_len = fixed (dcw.tally); /* get dcw length */ i = 0; /* reset word counter */ genp = ptr (dcwp, dcw.address); /* get ptr to first rcw */ do while (i < c_len); /* do until we are done */ i = i + rcw.dlen + 1; /* add current rcw length + rcw */ call tolts_util_$bci_to_ascii (rcw.data, out_str, rcw.dlen * 6); /* convert to ascii */ call ioa_$ioa_switch (tolts_info.pf_iocbp, "^a", out_str); genp = addr (rcw.nxt_rcw); /* get next rcw address */ end; end; else call ioa_$ioa_switch (tolts_info.pf_iocbp, /* put out dump header line */ "^/^2-^as master mode dump taken ^a^/", tolts_info.exec, time_str); call ioa_$ioa_switch (tolts_info.pf_iocbp, "^/"); /* put out new line */ if regp = execp | regs.x (2) = "442020"b3 then do; /* if master mode dump */ format = ds_format_2; /* display address & offset & data long format */ first = -72; c_len = 77777; /* dump the entire seg */ dptr = execp; /* set ptr to beginning of seg */ end; else do; format = ds_format_2; /* display address & offset & data long format */ first = -72; c_len = regs.ql; dptr = ptr (execp, regs.qu); end; call dump_segment_ (tolts_info.pf_iocbp, dptr, 0, first, c_len, format); /* dump it */ return; /* thats it */ %page; /* clean_up - internal procedure to close and detach print file */ clean_up: proc; if tolts_info.file_open then do; /* if file open */ call iox_$close (tolts_info.pf_iocbp, code); tolts_info.file_open = "0"b; end; if tolts_info.file_attach then do; /* if file attached */ call iox_$detach_iocb (tolts_info.pf_iocbp, code); tolts_info.file_attach = "0"b; tolts_info.pf_iocbp = null; end; end clean_up; %page; %include dprint_arg; %page; %include mca_data_area; %page; %include tolts_info; end tolts_file_util_;  tolts_init_.pl1 07/20/88 1306.3r w 07/19/88 1536.9 160470 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified by R.Fakoury 01/81 & 09/81 for colts implementation. Modified by R. Fakoury 09/81 to increase wks_sz for mtar. */ /****^ HISTORY COMMENTS: 1) change(86-08-21,Fakoury), approve(86-08-21,MCR7514), audit(86-11-11,Martinson), install(86-12-04,MR12.0-1235): 2/85 to MCA cleanup, 1/86 for colts RSPD to get a correct workspace size. END HISTORY COMMENTS */ /* The function of the external procedure "tolts_init_" is to perform certain initialization actions for the test system. There are three functions to be performed for this initialization: 1. Creating a temporary "slave" segment. 2. Initializing static variables. 3. Creating event channels to handle service requests. Creating a temporary "slave" segment: A temporary segment of the name of "_slave", is created, where is the input parameter by the same name and can be "polt", "molt" or "colt". This temporary segment will be used to load the core image of the target slave mode exec. Initializing static variables: "tolts_init_" will initialize static variables in the static structure "tolts_info". Creating event channels to handle service requests: The following event channels are created by "tolts_init_": 1. tolts_info.tty_ccc_event: (call channel) This event channel is used by the routine "term_io_sim_comp_" whenever the simulated tty io termination timer calls "term_io_sim_comp_" to indicate that the tty io should be complete (see "term_io_sim_comp_" for information on this). When "term_io_sim_comp_" is called, it will issue a wakeup to the "tolts_info.tty_ccc_event" event channel. The purpose of this is to convert the process asychronous timer signal used to indicate that the tty io has been completed to a process "sychronous" IPC call channel. In that way, the tty io termination service will only occur when the process goes blocked for some reason rather than at any time that might not be desirable such as at a time when a data base is being altered by the interrupted procedure where "tty_ccc" must also alter that data data base. "tty_ccc" is the procedure called by signalling "tolts_info.tty_ccc_event". 2. tolts_info.tty_issue_event: (call channel) This event channel is used to actually issue the tty io. Whenever tty io is buffered for output, this channel is signalled and whenever it is called, the tty io will be issued. By having this channel masked wherever a tty io is already in progress, and unmasking it when the current io is complete, tty io will be issued in succesion as they are requested rather than overlapped. 3. tolts_info.request_event: (call channel) This event channel is used to signal the procedure "test_request" for every operator solicited input (after a "???" typeout due to a quit condition and the original input data after "test" that starts the test process). 4. tolts_info.wait_list.wait_event_id: (wait channel) This event wait channel is used to allow breaking the test systems only "block" whenever processing is to be done other than "call event" type processing. Such "non-call" processing is either dispatching to a test page via the "main_dispatcher" or test system termination (either normal or forced). /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_init_: proc (exec, a_error); /* input parameters */ dcl exec char (4); /* can be "polt", "molt" or "colt" */ dcl (a_error, a_err) fixed bin (35); /* return error codes */ dcl event_ch fixed bin (71); /* event channel id to create */ dcl call bit (1); /* = "1"b if call channel is to be created */ dcl call_entry entry; /* entry to call for call channels */ dcl odp ptr; /* ptr to region for data to be pssed */ dcl prior fixed bin; /* relative priority of call channel */ dcl g_time bit (36); /* return parameter for gc_tod entry */ dcl slave_exec char (10); /* external entries */ dcl add_epilogue_handler_ entry (entry, fixed bin (35)); dcl com_err_ entry options (variable); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_process_id_ entry returns (bit (36)); dcl get_default_wdir_ entry returns (char (168) aligned); dcl hcs_$assign_channel entry (fixed bin (71), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$set_call_prior entry (fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl mca_$detach_mca entry (fixed bin, fixed bin (35)); dcl mtdsim_$mme_fault entry; dcl mtdsim_$epilogue entry; dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl sct_manager_$get entry (fixed bin, ptr, fixed bin (35)); dcl sct_manager_$set entry (fixed bin, ptr, fixed bin (35)); dcl tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*)); dcl tolts_alrm_util_$gewake entry; dcl tolts_alrm_util_$quit entry; dcl tolts_file_util_$wdump entry (ptr); dcl tolts_ttyio_display_ entry (ptr); dcl tolts_ttyio_display_$nxt_line entry (ptr); dcl tolts_ttyio_end_ entry; /* automatic */ dcl code fixed bin (35); dcl data char (36) varying; dcl date_str char (8); dcl delta fixed bin (71); dcl error fixed bin (35); dcl gc_date bit (36); dcl i fixed bin; /* constants */ dcl small_workspace fixed bin int static options (constant) init (4096); dcl large_workspace fixed bin int static options (constant) init (9000); dcl gewake_prior fixed bin int static options (constant) init (11); dcl old_mme1 ptr int static init (null); dcl pname char (11) int static options (constant) init ("tolts_init_"); dcl quith_prior fixed bin int static options (constant) init (8); dcl sec_per_day fixed bin (37) int static options (constant) init (86400000000); dcl tty_ccc_prior fixed bin int static options (constant) init (9); dcl tty_issue_prior fixed bin int static options (constant) init (10); dcl sc_dir char (168) static options (constant) init (">system_control_1"); dcl (addr, clock, date, null, unspec) builtin; %page; a_error = 0; /* preset return code good */ tolts_infop = null; /* preset our info ptr to null */ call get_temp_segment_ ("tolts_info", tolts_infop, error); /* get a ptr to our info segment */ if error ^= 0 then do; /* problem creating info seg */ call com_err_ (error, pname, "getting temporary segment for tolts_info"); a_error = error; return; end; unspec (tolts_info) = "0"b; /* clear entire structure first */ tolts_info.execp = null; /* preset exec ptr to null */ tolts_info.exec = exec; /* store exec name */ tolts_info.df_iocbp = null; /* preset deckfile iocb ptr to null */ tolts_info.pf_iocbp = null; /* preset print file iocb ptr to null */ tolts_info.hdir = get_default_wdir_ (); /* get users home dir pathname */ tolts_info.pf_name = ""; /* initialize print file name to blanks */ /* get a temporary segment for _slave */ slave_exec = exec || "_slave"; call get_temp_segment_ (slave_exec, execp, error); if error ^= 0 then do; /* can't get temporary segment */ call com_err_ (error, pname, "getting temporary segment for ^a_slave", exec); a_error = error; /* copy error code */ return; end; unspec (slave_exec) = "0"b; /* clear entire slave exec temp seg */ /* initialize the rest of tolts_info */ fnp (*).cdt_name = "empty"; tolts_info.process = get_process_id_ (); /* get our process id */ tolts_info.wait_list.nchan = 1; tolts_info.mess_buf.first, tolts_info.mess_buf.nxt = addr (tolts_info.mess_buf.term_queue); /* set tty io ptrs */ if exec = "polt" /* if running polts */ | exec = "colt" then tolts_info.wks_sz = small_workspace; /* or colts set workspace for 4K */ else tolts_info.wks_sz = large_workspace; /* if molts set it for 9k */ /* set up mme1 condition static handler */ call sct_manager_$get (mme1_sct_index, old_mme1, error); /* save old mme sct index */ if error = 0 then call sct_manager_$set (mme1_sct_index, addr (mtdsim_$mme_fault), error); /* and set up static mme handler */ if error ^= 0 then do; call com_err_ (error, pname, "setting up static mme1 handler"); call clean_up; a_error = error; return; end; /* set up epilogue handler for process hangups */ call add_epilogue_handler_ (mtdsim_$epilogue, error); /* add epilogue entry */ if error ^= 0 then do; call com_err_ (error, pname, "setting up epilgue handler"); call clean_up; a_error = error; return; end; /* i~\nitialize date time constants in tolts_info */ call init_time (error); if error ^= 0 then do; call com_err_ (error, pname, "error from convert_date_to_binary_"); call clean_up; a_error = error; return; end; %page; /* create an event call channel for tty io termination requests */ data = "original message data"; call cr_event_chan (tolts_info.tty_ccc_event, "1"b, tolts_ttyio_end_, addr (data), tty_ccc_prior, error); if error ^= 0 then do; /* trouble creating event call channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; /* create an event call channel for tty io initiation requests */ call cr_event_chan (tolts_info.tty_issue_event, "1"b, tolts_ttyio_display_, addr (data), tty_issue_prior, error); if error ^= 0 then do; /* trouble creating event call channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; /* create an event call channel for tty io display requests */ call cr_event_chan (tolts_info.tty_display_event, "1"b, tolts_ttyio_display_$nxt_line, addr (data), tty_issue_prior, error); if error ^= 0 then do; /* trouble creating event call channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; /* create an event call channel for user requests (quit condition) */ call cr_event_chan (tolts_info.quith_event, "1"b, tolts_alrm_util_$quit, addr (data), quith_prior, error); if error ^= 0 then do; /* trouble creating event call channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; %page; /* create an event call channel for gewake events */ call cr_event_chan (tolts_info.gewake_event, "1"b, tolts_alrm_util_$gewake, addr (data), gewake_prior, error); if error ^= 0 then do; /* trouble creating event call channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; /* create a "fast" event wait channel for waking up the dispatcher */ call hcs_$assign_channel (tolts_info.wait_list.wait_event_id (1), error); if error ^= 0 then do; /* trouble creating event wait channel... */ a_error = error; /* copy error code */ call clean_up; /* go delete event channels already created */ return; /* and return */ end; /* create an event-wait channel for dial_manger */ if exec = "colt" then do; call ipc_$create_ev_chn (tolts_info.dm_event, code); if code ^= 0 then do; a_error = code; call com_err_ (code, pname, "creating an event channel"); call clean_up; end; call hcs_$initiate (sc_dir, "cdt", "", 0, 1, cdtp, code); /* initiate cdt seg */ if cdtp = null then do; /* if we can't initiate tell user */ call com_err_ (code, " Tolts", "attempting to initiate ^a>cdt", sc_dir); end; cdtptr = cdtp; end; return; %page; /* cr_event_chan - external entry to create ipc wait or call channels */ cr_event_chan: entry (event_ch, call, call_entry, odp, prior, a_err); a_err = 0; /* preset good return code */ call ipc_$create_ev_chn (event_ch, code); /* create requested event channel */ if code ^= 0 then do; /* error creating event channel */ a_err = code; /* copy return code */ call com_err_ (code, pname, "creating event channel"); return; end; if call then do; /* if user wants an event call channel */ call ipc_$decl_ev_call_chn (event_ch, call_entry, odp, prior, code); /* change wait into call chan */ if code ^= 0 then do; /* error */ a_err = code; /* copy return error code */ call com_err_ (code, pname, "changing wait channel into call channel"); return; end; call ipc_$set_call_prior (code); /* set call channel with priority over wait channel */ if code ^= 0 then do; /* error */ a_err = code; /* copy error code */ call com_err_ (code, pname, "setting call channels with priority over wait channels"); return; end; end; return; /* return with no error */ %page; /* clean_up - external entry to delete event channels and _slave segment */ clean_up: entry; /* delete event channels if they exist */ if tolts_info.dm_event ^= 0 then call ipc_$delete_ev_chn (tolts_info.dm_event, code); /* if dial_manager event channel $delete it */ if tolts_infop ^= null then do; /* if our info seg exists */ if tolts_info.wait_list.wait_event_id (1) ^= 0 then/* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.wait_list.wait_event_id (1), code); if tolts_info.tty_issue_event ^= 0 then /* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.tty_issue_event, code); if tolts_info.quith_event ^= 0 then /* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.quith_event, code); if tolts_info.gewake_event ^= 0 then /* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.gewake_event, code); if tolts_info.tty_ccc_event ^= 0 then /* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.tty_ccc_event, code); if tolts_info.tty_display_event ^= 0 then /* if event channel exists */ call ipc_$delete_ev_chn (tolts_info.tty_display_event, code); do i = lbound (tolts_info.pages, 1) to hbound (tolts_info.pages, 1); if pages (i).in_use then do; if pages (i).mca_ioi_idx ^= 0 then do; call mca_$detach_mca (pages (i).mca_ioi_idx, 0); pages (i).mca_ioi_idx = 0; end; end; end; if tolts_info.execp ^= null then /* if temporary segment exists */ call release_temp_segment_ (tolts_info.exec || "_slave", execp, code); /* release temp seg */ if tolts_info.df_iocbp ^= null then do; /* detach deck file if attached */ call iox_$close (tolts_info.df_iocbp, code); call iox_$detach_iocb (tolts_info.df_iocbp, code); tolts_info.df_iocbp = null; end; call release_temp_segment_ ("tolts_info", tolts_infop, code); /* release our info seg */ end; if old_mme1 ^= null then /* if static handler is set... */ call sct_manager_$set (mme1_sct_index, old_mme1, error); /* reset it */ return; %page; /* gc_tod - entry to compute gcos time of day (in 1/64th milliseconds since midnight */ gc_tod: entry (g_time); get_delta: delta = clock () - tolts_info.micro_time; /* get delta usecs since midnight */ if delta > sec_per_day then do; /* check for day rollover (86400000000 usec/day) */ call init_time (error); /* go reinitialize clock time and date */ go to get_delta; end; g_time = bit (multiply (delta, .064, 36, 0), 36); return; /* init_time - subroutine to compute the clock time at midnight and the current date and save in tolts_info */ init_time: proc (code); dcl code fixed bin (35); call date_time_ (clock (), date_str); /* get current date in form for convert_date_to_binary_ */ call convert_date_to_binary_ (date_str || " 0000.001", tolts_info.micro_time, code); call tolts_alm_util_$ascii_to_bcd_ (date (), gc_date); tolts_info.gc_date = gc_date; end init_time; %page; %include tolts_info; %include static_handlers; %include cdt; %include author_dcl; end tolts_init_;  tolts_io_int_.pl1 12/09/86 1539.4rew 12/09/86 1520.9 222093 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Original coding by J. K. Rhodes 4Q/77 Modified by J. A. Bush 78/9/25 to conform to Multics programming standards Modified by J. A. Bush 79/02/28 to handle ITR and MDR I/O interrupts Modified by G. Haney & R. Fakoury 80/03/24 to treat mtar i/o as polts i/o with no special modes, and to handle the second device alocation. Modified by R. Fakoury 80/06/03 to reverse the data and status store sequence for polts disk io security (iontp string used with finial iotd to status words) Modified 07/30/80 by R. Fakoury to handle a dcw tally of zero and a dcw residue correctly. Modified 9/30/82 by R. Fakoury to change an illegal zero dcw to a valid do nothing dcw. Modified 12/83 by R. Fakoury to support hypercannel interrupts. */ /****^ HISTORY COMMENTS: 1) change(85-02-01,Fakoury), approve(86-08-21,MCR7514), audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235): to implement the test nio request to implement extended status store, to fix a bug handling itr special interrupts for a suspend channel, to add changes for responder interrupts. END HISTORY COMMENTS */ /* tolts_io_int_ - I/O interrupt processor for POLTS and MOLTS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_io_int_: proc (event_ptr); /* External entries */ dcl com_err_ entry () options (variable); dcl com_err_$convert_status_code_ entry (fixed bin (35), char (*), char (*)); dcl free_area area based (get_system_free_area_ ()); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36) aligned, fixed bin (35)); dcl ioi_$get_detailed_status entry (fixed bin (12), bit (1) aligned, bit (*), fixed bin (35)); dcl ioi_$release_devices entry (fixed bin (12), fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl mca_$process_io_event entry (fixed bin, ptr, ptr, fixed bin (35)); dcl rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin (12), fixed bin (19) aligned, fixed bin (71) aligned, fixed bin, fixed bin (35)); dcl terminate_process_ entry (char (*), ptr); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl tolts_alm_util_$enter_ccc_req_ entry (ptr, bit (36)); dcl tolts_init_$gc_tod entry (bit (36)); dcl tolts_qttyio_$rs entry options (variable); /* Structures */ dcl detailed_status bit (288) based; dcl 1 event_info based (event_ptr), 2 causing_event fixed bin (71), 2 message, /* event message */ (3 pad1 bit (15), 3 lv fixed bin (3) unsigned, /* interrupt level */ 3 pad2 bit (18), 3 istat bit (36)) unaligned, /* first word of iom status (or special status) */ 2 sender bit (36), 2 origin bit (36), /* upper 18 bits = signal, lower 18 bits = ring */ 2 in_data_pointer ptr; dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl workspace_move char (c_len * 4) based (mvp); /* move data as char string for effiency */ /* Builtins, Constants, and Static */ dcl (addr, addrel, bin, bit, fixed, hbound, ptr, rel, string, substr, unspec) builtin; dcl (bufp, event_ptr, mvp, wakeup_ptr) ptr; dcl code fixed bin (35); dcl (c_len, i) fixed bin, error fixed bin (35), stata fixed bin (18); dcl (found, continue, read) bit (1); dcl g_time bit (36); dcl longinfo char (100), shortinfo char (8); %page; io_info_ptr = in_data_pointer; /* get io_info_ptr from event info */ if ^io_info.io_in_progress then do; /* no interrupt expected, lets see if */ if ^io_info.allocated & io_info.alloc_wait then do;/* allocation waiting, check RCP */ if io_info.io_type = mca_io_type then do; allocate mca_area in (free_area) set (mca_area_ptr); call mca_$process_io_event (io_info.mca_ioi_idx, addr (event_info), addr (mca_area), io_info.attach_err); io_info.mca_attach_state = mca_area.mca_attach_state; if io_info.mca_attach_state = MCA_ATTACHING then call signal; end; else if io_info.p_att & ^io_info.p2_att & (io_info.io_type = mdr_io_type | io_info.io_type = mtar_io_type) then /* if second attach */ call rcp_$check_attach (io_info.alt_rcp_id, addr (io_info.alt_rcp_area (1)), longinfo, io_info.alt_device_index, tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err); else call rcp_$check_attach (io_info.rcp_id, addr (io_info.rcp_area (1)), longinfo, io_info.device_index, tolts_info.max_wks_sz, tolts_info.max_to, io_info.rcp_state, io_info.attach_err); if (io_info.io_type ^= mca_io_type & io_info.rcp_state = 0) /* or attach done */ | (io_info.io_type = mca_io_type & io_info.mca_attach_state = MCA_ATTACHED) | io_info.attach_err ^= 0 then do; /* if attach err */ io_info.alloc_wait = "0"b; /* turn off allocation wait flag */ if tolts_info.glob_int_cnt ^= 0 then tolts_info.glob_int_cnt = tolts_info.glob_int_cnt - 1; /* decrement global IO count */ call queue_and_signal; /* go queue up ccc request and issue wakeup */ end; if io_info.io_type = mca_io_type then free mca_area_ptr -> mca_area in (free_area); end; return; /* and return */ end; if tolts_info.glob_int_cnt ^= 0 then tolts_info.glob_int_cnt = tolts_info.glob_int_cnt - 1; /* decrement global IO count */ if io_info.io_type = mca_io_type then /* if mca test */ mca_work_space_ptr = io_info.workspace_ptr; if io_info.io_type = rspd_io_type /* if rspd test */ then tolts_rspd_wksp = io_info.tolts_rspd_wksp; else ioi_wksp = io_info.workspace_ptr; go to ilv (event_info.message.lv); /* process correct interrupt level */ ilv (1): /* Level 1, IOM fault */ ilv (0): ilv (2): ilv (4): ilv (6): /* Levels 0, 2, 4 & 6, Illegal */ call tolts_qttyio_$rs (0, "^as: ^[IOM fault^s^;Illegal Interrupt level - ^d^], IOM status = ^12.3b ^12.3b", tolts_info.exec, (tolts_workspace.status.level = 1), tolts_workspace.status.level, substr (tolts_workspace.iom_status, 1, 36), substr (tolts_workspace.iom_status, 37, 36)); ilv (5): /* Level 5, marker interrupt (not expected) */ if io_info.io_type ^= firm_ld_io_type then do; /* if not loading firmware... */ call move_status; /* go move status to test page */ status.channel_stat, status.central_stat = "7"b3; /* phony up iom status */ status.initiate = "1"b; /* set initiate */ status.soft = "01"b; /* set "timeout" */ call queue_and_signal; /* go enter courtesy call request */ end; else call signal; /* if loading firmware, just wakeup dispatcher */ return; ilv (3): /* Level 3, terminate interrupt */ if io_info.io_type = mca_io_type then call mca_term; else if io_info.io_type = rspd_io_type then call rspd_term; else do; statp = addr (tolts_workspace.iom_status); /* set ptr to examine status */ if io_info.io_type = polt_io_type /* if polt io type terminate interrupt */ | io_info.io_type = mtar_io_type /* or mtar, treat like Polts */ | io_info.io_type = mtc_io_type /* or mtc, treat like Polts */ | io_info.io_type = mtg_io_type /* or mtg, treat like Polts */ | io_info.io_type = mdc_io_type then /* or mtg, treat like Polts */ call polt_term; else if io_info.io_type = itr_io_type /* if itr io type terminate interrupt */ | io_info.io_type = mhp_io_type then /* or mhp io_type then treat like itr */ call itr_term; else if io_info.io_type = mdr_io_type then /* if mdr terminate interrupt */ call mdr_term; else if io_info.io_type = firm_ld_io_type then call signal; /* if terminate interrupt while loading firmware */ end; return; ilv (7): /* Level 7, special interrupt, get special status */ if io_info.io_type = rspd_io_type then call rspd_spec; else do; io_info.sp_status = event_info.message.istat; /* extract special status from event message */ io_info.sp_flag = "1"b; /* set availablity flag */ if io_info.io_type = polt_io_type /* if polts special interrupt */ | io_info.io_type = mtc_io_type | io_info.io_type = mtg_io_type | io_info.io_type = mdc_io_type then call polt_spec; else if io_info.io_type = itr_io_type /* if itr special interrupt */ | io_info.io_type = mhp_io_type then call itr_spec; else if io_info.io_type = mdr_io_type then call mdr_spec; /* if mdr special interrupt */ else if io_info.io_type = firm_ld_io_type then call signal; /* if special interrupt while loading firmware */ end; return; %page; /* check_copy - internal procedure to copy data back to test page if reading */ check_copy: proc; if status.r then do; /* if reading copy data, otherwise don't */ read = "1"b; /* set read flag */ idcwp = addr (tolts_workspace.p_idcw); /* get ptr to primary idcw */ if idcw.control = "10"b then /* if continue but set */ continue = "1"b; /* set flag */ else continue = "0"b; /* otherwise stop at first iotd */ found = "0"b; /* reset terminate condition */ do i = 1 to hbound (io_info.dcw_list, 1) while (^found); /* go through dcw list */ dcwp = addr (io_info.dcw_list (i)); /* set test page dcw ptr */ if dcw.char_pos = "7"b3 then do; /* if idcw */ if dcwp -> idcw.control = "10"b then /* if idcw continue bit set */ continue = "1"b; /* set continue flag */ else continue = "0"b; /* otherwise reset it */ if substr (dcwp -> idcw.command, 3, 1) = "0"b then /* if read operation */ read = "1"b; /* set read flag */ else read = "0"b; /* otherwise reset it */ end; else if read & dcw.type ^= "11"b then do; /* if read and not iontp */ if dcw.type = "00"b then /* if iotd */ if ^continue then /* and continue flag not set */ found = "1"b; /* set terminate condition */ tdcwp = addr (tolts_workspace.dcw_list (i)); /* set workspace dcw ptr */ mvp = addrel (execp, dcw.address); /* get ptr to data to move */ c_len = bin (dcw.tally); /* get length of data */ if c_len = 0 then c_len = 4096; /* if tally is zero force tally equal to 4096 */ if string (dcw) = "0"b then do; /* if zero dcw then fake out dcw */ c_len = 1; /* set tally = 1 */ mvp = addrel (execp, io_info.status_add); /* set mvp to status_word */ end; if found & status.tally ^= "0000"b3 then /* if last dcw and tally residue */ c_len = c_len - bin (status.tally); /* subtract tally residue */ if c_len > 0 then do; /* if <0 then error and skip */ bufp = ptr (ioi_wksp, tdcwp -> dcw.address); /* get ptr to workspace buffer address */ workspace_move = bufp -> workspace_move; /* and move it */ end; end; end; end; end check_copy; %page; /* itr_spec - interrupt processor for Molt/ITR special interrupts */ itr_spec: proc; statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ string (special_status) = io_info.sp_status; if io_info.io_type = mhp_io_type then /* if hyper leave staus */ substr (unspec (special_status), 1, 1) = "0"b; /* just zero the first bit */ else substr (unspec (special_status), 1, 9) = "0"b; /* else zero first 9 bits */ if io_info.release_chan then /* if special from a release cmd */ call release_dev; /* go call ioi_$release_devices */ else if ^io_info.suspend_chan then call queue_and_signal; /* go enter courtesy call request */ end itr_spec; /* itr_term - interrupt processor for Molt/ITR terminate interrupts */ itr_term: proc; if tolts_workspace.status.timeout then do; /* if ioi timeout */ if ^io_info.to_no_cc then do; /* if not executing IPCW */ statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ substr (unspec (status), 1, 18) = "510006"b3; /* set time out status */ call queue_and_signal; /* go queue up cc request */ end; else io_info.to_no_cc = "0"b; /* reset flag if set */ end; else if status.power then do; /* if power off status */ if io_info.suspend_chan then /* if this is from suspend channel */ io_info.suspend_chan = "0"b; /* this is the only int we will get */ call move_status; /* move status to test page */ call queue_and_signal; /* go queue up cc request */ end; else if ^io_info.ignore_term then do; /* if we are not ignoring terminates */ call check_copy; /* go copy data if reading */ call move_status; /* move the status to test page */ call queue_and_signal; /* queue up cc request */ end; end itr_term; %page; /* mca_term - interrupt processor for Molt/MCA terminate interrupts */ mca_term: proc; allocate mca_area in (free_area) set (mca_area_ptr); call mca_$process_io_event (io_info.mca_ioi_idx, addr (event_info), addr (mca_area), error); if error ^= 0 then do; if ^substr (unspec (error), 1, 1) then do; call com_err_ (error, "tolts_io_int_", "fatal error, terminating process"); fatal_desc.version = 0; fatal_desc.fatal_code = error; /* copy error code */ call terminate_process_ ("fatal_error", addr (fatal_desc)); end; end; if mca_work_space.list_of_dcw.idcw1.command = "03"b3 then do; data_header_ptr = addr (mca_work_space.data_header_1); io_param_blk_ptr = addr (mca_work_space.data_header_1.io_param_blk); data_size_1 = fixed (io_parameter_block.source_len_msb || io_parameter_block.source_len_lsb, 16); dcwp = addr (io_info.dcw_list (2)); bufp = addr (mca_work_space.data_header_1); end; else do; io_param_blk_ptr = addr (mca_work_space.data_header_1.io_param_blk); data_size_1 = fixed (io_parameter_block.dest_len_msb || io_parameter_block.dest_len_lsb, 16); dcwp = addr (io_info.dcw_list (4)); bufp = addr (mca_work_space.data_header_2); end; data_header_ptr = addr (mca_work_space.data_header_2); io_param_blk_ptr = addr (mca_work_space.data_header_2.io_param_blk); data_size_2 = fixed (io_parameter_block.source_len_msb || io_parameter_block.source_len_lsb, 16); if string (dcw) = "0"b then do; c_len = 1; mvp = addrel (execp, io_info.status_add); end; else do; mvp = addrel (execp, dcw.address); if dcw.tally = "0"b then c_len = 4096; else c_len = bin (dcw.tally); end; workspace_move = bufp -> workspace_move; statp = addrel (execp, io_info.status_add); unspec (status) = mca_area.mca_status; free mca_area_ptr -> mca_area in (free_area); call queue_and_signal; end mca_term; %page; /* mdr_spec - interrupt processor for Molt/MDR special interrupts */ mdr_spec: proc; statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ string (special_status) = io_info.sp_status; if io_info.io_type ^= mhp_io_type then substr (unspec (special_status), 1, 9) = "0"b; if io_info.suspend_chan then /* if this is a special from suspend cmd */ io_info.suspend_chan = "0"b; /* reset flag */ if io_info.release_chan then /* if special from a release cmd */ call release_dev; /* go call ioi_$release_devices */ end mdr_spec; /* mdr_term - interrupt processor for Molt/MDR terminate interrupts */ mdr_term: proc; if tolts_workspace.timeout | status.power | status.major | status.sub | status.channel_stat | status.central_stat then do; /* debug trap */ c_len = 0; end; if tolts_workspace.status.timeout then do; /* if ioi timeout */ statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ substr (unspec (status), 1, 18) = "510006"b3; /* set time out status */ call queue_and_signal; /* go queue up cc request */ end; else if status.power then do; /* if power off status */ call move_status; /* move status to test page */ call queue_and_signal; /* go queue up cc request */ end; else do; /* good terminate */ call check_copy; /* go copy data if reading */ call move_status; /* move iom status to test page */ call queue_and_signal; /* go enter courtesy call request */ if io_info.release_chan then /* if special from a release cmd */ call release_dev; /* go call ioi_$release_devices */ end; end mdr_term; %page; /* move_status - internal procedure to move term status to test page and correct dcw residue address */ move_status: proc; if io_info.ext_status_add ^= 0 then call ioi_$get_detailed_status (io_info.device_index, "1"b, addrel (execp, io_info.ext_status_add) -> detailed_status, code); statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ string (status) = tolts_workspace.iom_status; /* move the status to the test page */ if substr (tolts_workspace.iom_status, 37, 36) = "777777777777"b3 then /* if garbage */ substr (string (status), 37, 36) = "0"b; /* set to zero */ else do; /* otherwise move it */ i = bin (rel (addr (tolts_workspace.dcw_list (1)))); /* get offset of dcw list */ if tolts_workspace.offset >= i then do; /* if we have processed dcws */ i = tolts_workspace.offset - i + 1; /* get array index of last dcw */ dcwp = addr (io_info.dcw_list (i)); /* get ptr to unaltered dcw */ stata = bin (dcw.address) + bin (dcw.tally); /* add address and tally */ stata = stata - bin (status.tally); /* and subtract tally residue */ status.address = bit (stata); /* correct test page dcw residue add */ end; end; end move_status; %page; /* polt_spec - interrupt processor for Polt special interrupts */ polt_spec: proc; if io_info.rew_wait then do; /* special expected? ignore if not */ io_info.rew_wait = "0"b; /* yes, reset flag */ /* reconnect original dcw list, this will occur if device was busy before */ call ioi_$connect_pcw (io_info.device_index, io_info.tio_off, io_info.pcwa, error); if error ^= 0 then do; /* error on connect */ call com_err_$convert_status_code_ (error, shortinfo, longinfo); call tolts_qttyio_$rs (0, "^as: Error on connect after special interrupt:^/^a", tolts_info.exec, longinfo); tolts_info.special_fault = "1"b; /* set special int fault flag */ call signal; /* wakeup dispatcher, but do not queue up cc */ end; end; end polt_spec; /* polt_term - interrupt processor for Polt terminate interrupts */ polt_term: proc; if status.major | status.channel_stat | status.central_stat then do; /* debug trap */ c_len = 0; end; if tolts_workspace.status.timeout then do; /* if ioi timeout */ statp = addrel (execp, io_info.status_add); /* get ptr to test page status storage */ unspec (status) = "0"b; /* clear status first */ substr (unspec (status), 1, 18) = "510006"b3; /* set time out status */ call queue_and_signal; /* go queue up cc request */ end; else if status.major = "0001"b & io_info.rcp_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then /* else if tape device and */ io_info.rew_wait = "1"b; /* device busy, wait for rewind complete */ else do; /* normal terminate */ call check_copy; /* go copy data if reading */ call move_status; /* move iom status to test page */ call queue_and_signal; /* go enter courtesy call request */ end; end polt_term; %page; /* queue_and_signal - subroutine to enter cc request for io completion (or alloc wait completion) and wakeup the dispatcher */ queue_and_signal: proc; call tolts_alm_util_$enter_ccc_req_ (addr (tolts_info.ccc_queue), string (io_info.icivlu)); /* enter ccc request */ signal: entry; /* wakeup the dispatcher */ io_info.io_in_progress = "0"b; /* reset io in progress flag */ wakeup_ptr = in_data_pointer; call tolts_init_$gc_tod (g_time); /* get current time */ io_info.int_time = bin (g_time, 35); /* set current interrupt time */ io_info.chan_time = io_info.chan_time + (io_info.int_time - io_info.con_time); /* delta chan time */ if tolts_info.gewake_active then do; /* if gewake alarm set */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* reset it */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* make sure no alarms queue up */ tolts_info.gewake_active = "0"b; /* reset flag */ end; call hcs_$wakeup (tolts_info.process, tolts_info.wait_list.wait_event_id (1), wakeup_ptr, error); if error ^= 0 then do; /* error on wakeup, terminate proc */ call com_err_ (error, "tolts_io_int_", "fatal error, terminating process"); fatal_desc.version = 0; fatal_desc.fatal_code = error; /* copy error code */ call terminate_process_ ("fatal_error", addr (fatal_desc)); end; end queue_and_signal; /* release_dev - internal procedure to call ioi_$release_devices and reset release_chan flag */ release_dev: proc; io_info.release_chan = "0"b; /* reset flag */ call ioi_$release_devices (io_info.device_index, error); /* let ioi have a turn */ if error ^= 0 then do; /* error, abort */ call com_err_$convert_status_code_ (error, shortinfo, longinfo); call tolts_qttyio_$rs (0, "^as: Error from ioi_$release_devices:^/^a", tolts_info.exec, longinfo); tolts_info.special_fault = "1"b; /* set special int fault flag */ call signal; /* wakeup dispatcher, but do not queue up cc */ end; end release_dev; /* rspd_spec - interrupt processor for Colt/RSPD special interrupts */ rspd_spec: proc; tolts_rspd_workspace.mailbox.lvl7 = tolts_rspd_workspace.mailbox.lvl7 + 1; /* bump spec int count */ direct_channel_pcw_ptr = addr (io_info.pcwa); tolts_rspd_workspace.mailbox.status_word = event_info.message.istat; if direct_channel_pcw.operation = "75"b3 then do; /* if read pcw move data */ c_len = tolts_rspd_workspace.tcw.host_word_count; bufp = addr (tolts_rspd_workspace.data_buf); mvp = addrel (execp, direct_channel_pcw.tcw_address + 1); workspace_move = bufp -> workspace_move; end; call signal; end rspd_spec; /* rspd_term - interrupt processor for Colt/RSPD terminate interrupts */ rspd_term: proc; tolts_rspd_workspace.mailbox.lvl3 = tolts_rspd_workspace.mailbox.lvl3 + 1; /* inc term int count */ direct_channel_pcw_ptr = addr (io_info.pcwa); tolts_rspd_workspace.mailbox.status_word = event_info.message.istat; if direct_channel_pcw.operation = "75"b3 then do; /* if read pcw read data */ c_len = tolts_rspd_workspace.tcw.host_word_count; bufp = addr (tolts_rspd_workspace.data_buf); mvp = addrel (execp, direct_channel_pcw.tcw_address + 1); workspace_move = bufp -> workspace_move; end; call signal; end rspd_term; %page; %include iom_stat; %page; %include mca_area; %page; %include mca_data; %page; %include mca_data_area; %page; %include rcp_resource_types; %page; %include tolts_info; %page; %include tolts_rspd_workspace; %page; %include tolts_workspace; end tolts_io_int_;  tolts_load_firmware_.pl1 12/09/86 1539.4rew 12/09/86 1520.9 177462 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Initial coding 79/03/05 By J. A. Bush Modified 10/84 to add delay for a dc_reset of the DAU. */ /****^ HISTORY COMMENTS: 1) change(85-08-01,Fakoury), approve(86-08-22,MCR7514), audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235): to correct a stringrange error. END HISTORY COMMENTS */ /* tolts_load_firmware_ - subroutine to load mpc firmware for all mpc types, after ITRs have been run on that mpc, and is called from MME RELEAS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_load_firmware_: proc (px, a_error); /* Entry parameters */ dcl px fixed bin; /* test page index */ dcl a_error fixed bin (35); /* return error code */ /* External entries */ dcl ioi_$connect_pcw entry (fixed bin (12), fixed bin (18), bit (36), fixed bin (35)); dcl ioi_$release_devices entry (fixed bin (12), fixed bin (35)); dcl ioi_$workspace entry (fixed bin (12), ptr, fixed bin, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl (ioa_$rsnnl, tolts_qttyio_$rs, opr_query_) entry options (variable); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl tolts_util_$search entry (ptr, char (32), ptr, fixed bin, fixed bin (35)); dcl gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl tolts_qttyio_ entry (char (*), fixed bin); dcl com_err_$convert_status_code_ entry (fixed bin (35), char (*), char (*)); /* Automatic */ dcl (catx, cxs, i, j, l, c_len, css, csl, rws, rwl) fixed bin; dcl tio_off fixed bin (18); dcl error fixed bin (35); dcl (err, term) bit (1); dcl (t_ptr, l_ptr, idbp, top) ptr; dcl shortinfo char (8); dcl ov_name char (17); dcl longinfo char (100); /* structures and based variables */ dcl 1 event_out static, 2 causing_event fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 origin, 3 signal bit (18) unaligned, 3 ring bit (18) unaligned, 2 in_data_pointer ptr; dcl 1 cata based (io_info.catp) aligned, /* template for deckfile catalog */ 2 n fixed bin, /* number of entries */ 2 key (1 refer (cata.n)) char (24); /* array of key names */ dcl 1 id_blk based (idbp) aligned, /* template for an mpc deck id block */ (2 id_name bit (36), /* BCD id name */ 2 rev_level bit (36), /* BCD revision */ 2 dk_purpose bit (36), /* BCD deck purpose */ 2 pad1 bit (36), 2 rw_start fixed bin (18) unsigned, /* offset of read/write overlay */ 2 pad2 bit (18), 2 hx_cs_st fixed bin (18) unsigned, /* rel. start of control store in hex words */ 2 hx_rw_st fixed bin (18) unsigned, /* rel. start of read/write overlay in hex words */ 2 pad3 (3) bit (36), 2 mpcbot bit (36)) unaligned; /* = "MPCBOT" in BCD */ dcl buffer (fixed (gload_data.text_len)) bit (36) based (top); /* for moving data to ioi buffer */ dcl f_wd (10240) bit (36) based (l_ptr); /* for moving data from temp buffer */ /* constants */ dcl (addr, addrel, bin, bit, fixed, index, rel, string, substr) builtin; dcl error_table_$action_not_performed fixed bin (35) ext; dcl ipcw bit (36) int static options (constant) init ("000000770000"b3); dcl pcwa bit (36) int static options (constant) init ("000000700000"b3); %page; a_error = 0; /* preset return code to 0 */ io_info_ptr = addr (pages (px)); /* get ptr to this test page */ io_info.io_type = 4; /* set type for interrupt processor */ ioi_wksp = io_info.workspace_ptr; /* get ptr to our workspace */ tio_off = fixed (rel (addr (tolts_workspace.p_idcw)));/* get buffer offset for ioi */ l_ptr = addr (tolts_info.firm_buf); /* place to temp load firmware */ top = addr (tolts_workspace.data_buf); /* set ptr to move firmware */ do catx = 1 to cata.n while (index (cata.key (catx), ".") < 6); /* find first fw module */ end; call fw_load; /* go load deck in temp buffer */ if error ^= 0 then do; /* if some problem, return */ err_1: a_error = error; return; end; call dc_reset; /* go send initialize pcw to mpc */ if error ^= 0 then go to err_1; call copy_cs (0, err); /* copy control store overlay */ if err then do; /* if any error ocurred */ err_2: a_error = error_table_$action_not_performed; /* set an apropriate error code */ return; end; call run_dcw; /* execute dcw list */ if error ^= 0 then go to err_1; call copy_rw (err); /* copy read/write overlay */ if err then go to err_2; call run_dcw; /* execute dcw list */ if error ^= 0 then go to err_1; /* get out on error */ call fw_load_mess; /* let user and operator know what has been loaded */ if io_info.mpc_dev_cnt ^= 0 then do; /* if urcmpc, load device overlays */ cxs = catx + 1; /* save catalog index + 1 */ do l = 1 to io_info.mpc_dev_cnt; /* load each overlay type */ term = "0"b; /* reset terminate condition */ do catx = cxs to cata.n while (^term); /* find each key */ if substr (cata.key (catx), 15, 4) = io_info.dev_firm (l).edit_name then do; /* found it */ term = "1"b; /* set terminate condition */ call fw_load; /* go copy firmware overlay into temp storage */ if error ^= 0 then go to err_1; call copy_cs (1, err); /* copy control store (offset by 1 word */ if err then go to err_2; idcw.command = "36"b3; /* set overlay command */ idcw.device = "01"b3; /* device code of 1 for device overlays */ idcw.chan_cmd = "40"b3; /* special controller command */ buffer (1) = io_info.dev_firm (l).mask; /* set in port mask */ call run_dcw; /* execute overlay */ if error ^= 0 then go to err_1; call fw_load_mess; /* let user and operator know what has been loaded */ end; end; end; end; call ioi_$release_devices (io_info.device_index, error); /* can let ioi do other io now */ if error ^= 0 then do; /* can't win */ call output_status_code (error, "calling ioi_$release_devices"); go to err_1; end; io_info.chan_suspended = "0"b; /* channel is no longer suspended */ return; %page; /* fw_load - internal procedure to find requested deck in deckfile and load core image */ fw_load: proc; /* find firmware deck in the deckfile */ call tolts_util_$search (tolts_info.df_iocbp, (cata.key (catx)), t_ptr, c_len, error); if error ^= 0 then do; /* if we couldn't find module */ call output_status_code (error, "searching for " || cata.key (catx)); return; end; /* now load core image into temp buffer */ call gload_ (t_ptr, l_ptr, 0, addr (gload_data), error); /* load it */ if error ^= 0 then do; call output_status_code (error, gload_data.diagnostic || " loading module " || cata.key (catx)); return; /* and return */ end; idbp = addrel (l_ptr, fixed (gload_data.text_len) - 10); /* get ptr to id blk */ css = 1; /* control store starts at 1 */ rws = id_blk.rw_start; /* set start of read/write memory */ if rws = 0 then do; /* if read/write overlay non-existant... */ csl = fixed (gload_data.text_len) - 10; /* set cs length to loaded blk minus id blk */ rwl = 0; /* no read/write overlay */ end; else do; csl = rws; rwl = fixed (gload_data.text_len) - rws - 10; /* set lengths */ rws = rws + 1; end; end fw_load; /* output_status_code - internal procedure to queue up a status message */ output_status_code: proc (ecode, mess); dcl ecode fixed bin (35); dcl mess char (*); call com_err_$convert_status_code_ (ecode, shortinfo, longinfo); call tolts_qttyio_$rs (0, "^as: ^a^/^a", tolts_info.exec, longinfo, mess); end output_status_code; %page; /* Procedure to dc reset of an mpc by isuing a reset pcw */ dc_reset: proc; idcwp = addr (tolts_workspace.p_idcw); /* Set up IDCW, although it wont be executed */ string (idcw) = "0"b; idcw.code = "7"b3; idcw.chan_cmd = "02"b3; call ioi_$connect_pcw (io_info.device_index, tio_off, ipcw, error); /* Do connect */ if error ^= 0 then do; call output_status_code (error, "issuing initialize pcw"); return; end; tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */ io_info.io_in_progress = "1"b; /* set flag */ do while (io_info.io_in_progress); /* make sure we only take interrupt wakeup */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); if error ^= 0 then do; call output_status_code (error, "waiting for ioi timeout from initialize pcw"); return; end; end; if tolts_workspace.status.level ^= 3 | ^tolts_workspace.status.timeout then do; call tolts_qttyio_$rs (0, "^a No ioi timeout after issuing initialize pcw", io_info.test_hdr); error = error_table_$action_not_performed; /* set phony error */ return; end; /* Since time out was only simulated by ioi, a real delay must be done to allow the mpc to reset */ call timer_manager_$reset_alarm_wakeup (tolts_info.gewake_event); /* Be sure no alarm already set */ call ipc_$drain_chn (tolts_info.gewake_event, error); /* In case event occured */ if error ^= 0 then do; call output_status_code (error, "calling ipc_$drain_chn durring dc_reset"); return; end; if io_info.cat_name = "itr.msp800" then call timer_manager_$alarm_wakeup (20, "11"b, tolts_info.gewake_event); /* Set 1 second timer */ else call timer_manager_$alarm_wakeup (1, "11"b, tolts_info.gewake_event); /* Set 1 second timer */ tolts_info.gewake_active = "1"b; /* set flag */ do while (tolts_info.gewake_active); /* make sure we only take alarm wakeup */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */ if error ^= 0 then do; call output_status_code (error, "waiting for dc_reset"); return; end; end; end dc_reset; %page; /* run_dcw - subroutine to do the actual I/O */ run_dcw: proc; call ioi_$connect_pcw (io_info.device_index, tio_off, pcwa, error); /* Do connect */ if error ^= 0 then do; call output_status_code (error, "attempting connect"); return; end; tolts_info.glob_int_cnt = tolts_info.glob_int_cnt + 1;/* increment global IO count */ io_info.io_in_progress = "1"b; /* set flag */ do while (io_info.io_in_progress); /* make sure we only take interrupt wakeup */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); if error ^= 0 then do; call output_status_code (error, "waiting for terminate interrupt"); return; end; end; if tolts_workspace.status.level ^= 3 then do; /* looking for terminate */ call tolts_qttyio_$rs (0, "^a Unexpected level ^d interrupt while waiting for terminate", io_info.test_hdr, tolts_workspace.status.level); error = error_table_$action_not_performed; /* set phony error code */ return; end; if tolts_workspace.status.timeout then do; /* not good */ call tolts_qttyio_$rs (0, "^a ioi timeout while waiting for terminate", io_info.test_hdr); error = error_table_$action_not_performed; /* set phony error code */ return; end; statp = addr (tolts_workspace.status.iom_status); /* set status ptr */ if status.power then do; /* power off status */ call tolts_qttyio_$rs (0, "^a Unexpected power off status, check MPC", io_info.test_hdr); error = error_table_$action_not_performed; return; end; if status.major | status.sub | status.channel_stat | status.central_stat then do; /* If any other error */ call tolts_qttyio_$rs (0, "^a Unexpected IOM status: ^12.3b ^12.3b", io_info.test_hdr, substr (tolts_workspace.iom_status, 1, 36), substr (tolts_workspace.iom_status, 37, 36)); error = error_table_$action_not_performed; /* set phoney error code */ return; end; end run_dcw; %page; /* copy_cs - subroutine to copy control store overlay from temp buf to ioi workspace */ copy_cs: proc (buf_off, err_bit); dcl err_bit bit (1); dcl buf_off fixed bin; err_bit = "0"b; /* reset error flag */ ov_name = "control store"; /* set overlay name */ call make_dcw ("10"b3, (csl - css + 1) + buf_off, err_bit); /* set up dcw list */ if ^err_bit then /* if no error... */ call copy (css, csl, buf_off, err_bit); /* go copy the data */ end copy_cs; /* copy_rw - subroutine to copy read/write memory overlay from temp buf to ioi workspace */ copy_rw: proc (err_bit); dcl err_bit bit (1); err_bit = "0"b; /* reset error flag */ ov_name = "read/write memory"; call make_dcw ("11"b3, rwl, err_bit); /* set up dcw list */ if ^err_bit then /* if no error... */ call copy (rws, rws + rwl - 1, 0, err_bit); /* go copy the data */ end copy_rw; /* fw_load_mess - subroutine to put out message telling the operator and user that firmware has been loaded */ fw_load_mess: proc; call ioa_$rsnnl ("^/^a ^as has loaded ^a firmware ^a rev. ^a", longinfo, c_len, io_info.test_hdr, tolts_info.exec, substr (cata.key (catx), 8, 6), substr (cata.key (catx), 15, 4), substr (cata.key (catx), 20, 2)); opr_query_info.q_sw = "0"b; /* we don't want operator response */ call opr_query_ (addr (opr_query_info), substr (longinfo, 1, c_len)); /* tell operator */ if ^tolts_info.finish_cond then do; /* only output message if we still have terminal */ call tolts_qttyio_ (substr (longinfo, 1, c_len), 0); /* and ourselves what we are loading */ do while (tolts_info.term_io_req_cnt ^= 0); /* wait for message to be output */ call ipc_$block (addr (tolts_info.wait_list), addr (event_out), error); /* Wait for a second */ if error ^= 0 then do; call output_status_code (error, "waiting for firmware load message"); return; end; end; end; end fw_load_mess; %page; /* make_dcw - subroutine to set up dcw list */ make_dcw: proc (op_code, dlen, err_bit); dcl op_code bit (6); dcl (dlen, dleft, ovh) fixed bin; dcl err_bit bit (1); ovh = bin (rel (addr (tolts_workspace.data_buf))) + 2;/* compute overhead length of ioi buf */ idcwp = addr (tolts_workspace.p_idcw); /* get ptr to primary idcw loc */ string (idcw) = "0"b; /* initialize */ idcw.command = op_code; /* copy command */ idcw.code = "7"b3; /* this must be set for an idcw */ dcwp = addr (tolts_workspace.dcw_list (1)); /* set up 1st dcw */ string (dcw) = "0"b; /* initialize 1st dcw */ dcw.address = rel (addr (tolts_workspace.data_buf)); /* set dcw address */ dleft = dlen; /* start with entire length */ do while (dleft > 4096); /* set up as many dcws as neccessary */ dcw.type = "01"b; /* set type to iotp */ dcw.tally = "0000"b3; /* 0 = tally of 4096 */ if io_info.cur_wks_sz < dlen + ovh then /* if our workspace is to small */ if tolts_info.max_wks_sz < dlen + ovh then do; /* and we can't get enough */ err_bit = "1"b; /* set error indicator */ call tolts_qttyio_$rs (0, "^a max workspace size of ^d is less than ^a overlay length of ^d", io_info.test_hdr, tolts_info.max_wks_sz, ov_name, dlen); return; /* return and report error */ end; else do; if io_info.cur_wks_sz + 4096 > tolts_info.max_wks_sz then /* if current + 4k is > max */ io_info.cur_wks_sz = tolts_info.max_wks_sz; /* set current size to max */ else io_info.cur_wks_sz = io_info.cur_wks_sz + 4096; /* increse by 4k */ call ioi_$workspace (io_info.device_index, ioi_wksp, io_info.cur_wks_sz, error); if error ^= 0 then do; /* ioi_ didn't like it */ call output_status_code (error, "setting max workspace size"); err_bit = "1"b; /* set error indicator */ return; end; end; tdcwp = dcwp; /* save current dcw ptr */ dcwp = addrel (dcwp, 1); /* go to next dcw */ string (dcw) = "0"b; /* initialize dcw */ dcw.address = bit (bin (bin (tdcwp -> dcw.address) + 4096, 18)); dleft = dleft - 4096; /* decrement data left */ end; dcw.type = "00"b; /* last dcw is iotd */ dcw.tally = bit (bin (dleft, 12)); /* set tally */ tolts_workspace.buf_size = dlen; /* set buffer size */ end make_dcw; %page; /* This procedure actually copies the firmware data */ copy: proc (start, stop, b_off, err_bit); dcl (start, stop, b_off) fixed bin; /* The range of words to be copied */ dcl err_bit bit (1); /* An error code */ dcl ck_sum fixed bin (35) init (0); /* To do check sum calculations */ dcl ck_bit bit (36) based (addr (ck_sum)); /* Another way of looking at ck_sum */ j = 1 + b_off; /* start at one plus offset */ do i = start to stop; /* Copy it all */ buffer (j) = f_wd (i); /* This moves a word */ if i < stop then do; /* If not last word, do checksum calc */ call ch_add (ck_sum, bin (substr (f_wd (i), 2, 8) || substr (f_wd (i), 11, 8))); call ch_add (ck_sum, bin (substr (f_wd (i), 20, 8) || substr (f_wd (i), 29, 8))); end; j = j + 1; end; ck_sum = -ck_sum; /* Get complement of check sum */ if "0"b || substr (ck_bit, 21, 8) || "0"b || substr (ck_bit, 29, 8) ^= substr (f_wd (stop), 1, 18) then do; call tolts_qttyio_$rs (0, "^a check sum error detected in ^a overlay of ^a firmware - ^a", io_info.test_hdr, ov_name, substr (cata.key (catx), 8, 6), substr (cata.key (catx), 15, 4)); err_bit = "1"b; end; return; end copy; /* This subroutine does 16 bit addition with end around carry to validate check sums */ ch_add: proc (sum, add_val); dcl sum fixed bin (35); /* The accumulated sum */ dcl add_val fixed bin (16); /* New value to add */ sum = sum + add_val; /* Do the add */ carry: if sum > 1111111111111111b then do; /* If overflow into 17th bit */ sum = sum - 10000000000000000b; /* Subtract it out */ sum = sum + 1; /* Do end-around carry */ go to carry; /* Check again */ end; return; end ch_add; %page; %include gload_data; %page; %include iom_stat; %page; %include mca_data_area; %page; %include opr_query_info; %page; %include tolts_info; %page; %include tolts_workspace; end tolts_load_firmware_;  tolts_pcd_.pl1 07/20/88 1306.3r w 07/19/88 1536.9 283743 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* tolts_pcd_ subroutine to output the configuration deck for polts and molts Coded 79/03/12 by J. A. Bush Modified 79/10/09 by Michael R. Jordan for new MPC card. Modified 08/80 by R. Fakoury to correctly interrupt chnl cards and to identify bootload chan in the config printout. Modified 11/80 by R.Fakoury to handle new config deck channel card utilization Modified 1/81 by R Fakoury to output fnp config info for colts. Modified 4/81 by R Fakoury to print the cpu and mem config. Modified 8/81 by M.R. Jordan for new PRPH OPC card format. Modified October 1982 by C. Hornig for new PRPH TAP format. Modified 03/17/83 by Rick Fakoury to print hyperchannel config. Modified 08/12/83 by Rick Fakoury for the new cpu & console config cards. Modified 08/16/83 by Rick Fakoury to allow user to specify device type on config requests. and to add support for the iom and hyperchannel config card. Modified 10/84 by R Fakoury to use system config card incls. */ /****^ HISTORY COMMENTS: 1) change(84-10-01,Fakoury), approve(86-08-21,MCR7514), audit(86-11-25,Martinson), install(86-12-04,MR12.0-1235): to use system config card incls, for Dipper to print the MCA config, for colts rspd request to print the DIA config. END HISTORY COMMENTS */ /* tolts_pcd_ subroutine to output the configuration deck for polts and molts */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_pcd_: proc (exec, eq_type); /* tolts_pcd_ subroutine to output the configuration deck for polts & molts */ /* Builtins */ dcl (addr, addrel, hbound, null, rtrim, substr) builtin; /* Conditions */ dcl cleanup condition; dcl linkage_error condition; /* Constants */ dcl ADAPTER_FAILURE bit (2) unal init ("01"b) int static options (constant); dcl con_types (0:4) char (3) int static options (constant) init (" ", "IBM", "EMC", "SCC", "LCC"); dcl fnp_state (0:4) char (7) int static options (constant) init ("free ", "unknown", "down ", "booting", "up "); dcl MAINT_ABNORMAL_TERM bit (2) unal init ("11"b) int static options (constant); dcl MAINT_NORMAL_TERM bit (2) unal init ("10"b) int static options (constant); dcl max_imu_channels fixed bin init (15) int static options (constant); dcl tags (1:26) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"); dcl types (1:3) char (6) int static options (constant) init ("dn355 ", "l6 ", "dn6670"); /* External Static */ dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$timeout fixed bin (35) ext static; /* External Entries */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl com_err_ entry () options (variable); dcl find_config_card_$prph_for_channel entry (fixed bin (3), fixed bin (6), ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35)); dcl mca_$config entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35)); dcl mca_$detach_mca entry (fixed bin, fixed bin (35)); dcl mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35)); dcl mtdsim_$clean_up entry; dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl tolts_qttyio_$rs entry options (variable); dcl tolts_qttyio_ entry (char (*), fixed bin); dcl tolts_util_$dev0_valid entry (ptr, fixed bin) returns (bit (1)); dcl tolts_util_$find_card entry (char (4), ptr); /* Internal Static */ dcl code fixed bin (35) init (0); dcl CHAN_NUM fixed bin (6); dcl c_sw bit (1) init ("0"b); dcl data_ptr ptr int static; dcl d_sw bit (1) init ("0"b); dcl data_present bit (1) init ("0"b); dcl entry_var entry variable; dcl exec char (6); dcl eq_type char (*); dcl fips bit (1) init ("0"b); dcl i fixed bin init (0); dcl iom_num fixed bin (3); dcl ipc_type char (9); dcl j fixed bin init (0); dcl k fixed bin init (0); dcl mca_data char (4000) init (""); dcl mca_ev_chn fixed bin (71) int static init (0); dcl mca_ioi_idx fixed bin int static init (0); dcl mca_name char (4) init (""); dcl model_index fixed bin; dcl NAME char (4) aligned; dcl nchn fixed bin; dcl ndevices fixed bin; dcl od char (136); dcl ol fixed bin; dcl out_data char (10000); dcl prph_name char (4) aligned; dcl p99 pic "99" based; dcl ret_len fixed bin (21); dcl retry_sw bit (1); dcl str_info bit (1) init ("0"b); dcl ss_info bit (1) init ("0"b); dcl session_over bit (1) init ("0"b); dcl static_config_ptr ptr int static init (null ()); dcl status_a bit (72) init ("0"b); dcl sub_ptr ptr int static; dcl subsys bit (1) init ("0"b); dcl term bit (1) init ("0"b); dcl total_chars_read fixed bin (21); dcl trm bit (1) init ("0"b); /* Structures */ dcl 1 mca_sub based (sub_ptr) unal, 2 data_p bit (1) unal, 2 mbz bit (3) unal, 2 term_state bit (2) unal; %page; if eq_type ^= "" then do; /* if equip type = some type user wants partial config */ if length (eq_type) = 4 then str_info = "1"b; /* user wants info on a device */ else if length (eq_type) = 3 then ss_info = "1"b; /* user wants all info on a device */ else do; /* must be invalid arg */ if exec = "isolts" then /* if isolts use ioa */ call ioa_ ("tolts_pcd_: Invalid length ARG received"); else call tolts_qttyio_$rs (0, "tolts_pcd_: Invalid lenght ARG received"); return; end; call ioa_$rsnnl ("^/ ^/^a configuration:^/ ^/", out_data, ol, substr (eq_type, 1, 3)); if substr (eq_type, 1, 3) = "cpu" | /* if cpu or mem */ substr (eq_type, 1, 3) = "mem" then do; if substr (eq_type, 1, 3) = "cpu" then call cpu_fig; else if substr (eq_type, 1, 3) = "mem" then call mem_fig; call ioa_ ("^a", out_data); return; end; else if substr (eq_type, 1, 3) = "fnp" then call fnp_fig; else if substr (eq_type, 1, 3) = "dia" then call dia_fig; else if substr (eq_type, 1, 3) = "iom" | substr (eq_type, 1, 3) = "imu" then call iom_fig; else if substr (eq_type, 1, 3) = "mca" then do; if str_info then call mca_fig ("mca" || substr (eq_type, 4)); else call mca_fig (""); end; else if substr (eq_type, 1, 3) = "ccu" | substr (eq_type, 1, 3) = "hch" | substr (eq_type, 1, 3) = "opc" | substr (eq_type, 1, 3) = "prt" | substr (eq_type, 1, 3) = "pun" | substr (eq_type, 1, 3) = "rdr" then call sing_fig; else if substr (eq_type, 1, 3) = "dsk" then call disk_fig; else if substr (eq_type, 1, 3) = "tap" then call tape_fig; else do; /* can't find a match */ if exec = "isolts" then call ioa_ ("tolts_pcd_: Unreconizable ARG received."); else call tolts_qttyio_$rs (0, "tolts_pcd_: Unreconizable ARG received."); return; end; out_data = rtrim (out_data) || rtrim (mca_data); call tolts_qttyio_ (out_data, 10); return; end; else str_info, ss_info = "0"b; /* user wants config */ call ioa_$rsnnl ("^/ ^/^a configuration:^/ ^/", out_data, ol, exec); if exec = "colt " then do; call dia_fig; /* output dia configuration first */ call fnp_fig; /* now output fnp configuration */ end; if exec = "isolts" then do; call cpu_fig; call mem_fig; call ioa_ ("^a", out_data); return; end; if exec = "polt " | exec = "molt " then do; call iom_fig; /* output iom configuration second */ call disk_fig; /* output disk configuration second */ call tape_fig; /* followed by tape configuration */ call sing_fig; /* and all other peripherals */ call mca_fig (""); end; out_data = rtrim (out_data) || rtrim (mca_data); call tolts_qttyio_ (out_data, 10); /* output config */ return; /* thats it folks */ %page; /* dia_fig - internal procedure to format dia configuration for the DN8 FEP */ dia_fig: proc; declare dia_number fixed bin; prph_cardp = null; /* start at the beginning of the config deck */ term = "0"b; /* reset terminate condition */ do while (^term); /* check all cards */ call tolts_util_$find_card ("prph", prph_cardp); /* get pointer to fnp config card */ if prph_cardp = null then term = "1"b; /* no card found */ else if (str_info & prph_card.name = eq_type) | (substr (prph_card.name, 1, 3) = "dia" & ^str_info) then do; dia_number = rank (substr (prph_card.name, 4, 1)) - rank ("a") + 1; /* dia a is 1 */ call ioa_$rsnnl ("dia ^a (^d) on iom ^a ^d", od, ol, tags (dia_number), dia_number - 1, tags (iom), chan); call ioa_$rsnnl ("^a^/", od, ol, od); /* add new line to output */ out_data = rtrim (out_data) || od; /* add to to output */ if str_info then term = "1"b; end; end; end dia_fig; %page; /* fnp_fig - internal procedure to format fnp configuration */ fnp_fig: proc; declare fnp_number fixed bin; %include config_prph_fnp_card; prph_fnp_cardp = null; /* start at the beginning of the config deck */ term = "0"b; /* reset terminate condition */ call hcs_$initiate (">sc1", "cdt", "", 0, 0, cdtp, code); do while (^term); /* check all cards */ call tolts_util_$find_card ("prph", prph_fnp_cardp); /* get pointer to fnp config card */ if prph_fnp_cardp = null then term = "1"b; /* no card found */ else if (str_info & name = eq_type) | (substr (name, 1, 3) = "fnp" & ^str_info) then do; fnp_number = rank (substr (name, 4, 1)) - rank ("a") + 1; /* fnp a is 1 */ fnpep = addr (cdt.fnp_entry (fnp_number)); call ioa_$rsnnl ("fnp ^a (^d) on iom ^a ^d is a ^6a with ^d k of memory and ^d hslas is ^a", od, ol, tags (fnp_number), fnp_number - 1, tags (iom), chan, types (fnpe.type), fnpe.memory, fnpe.nhslas, fnp_state (fnpe.mpxe.state)); call ioa_$rsnnl ("^a^/", od, ol, od); /* add new line to output */ out_data = rtrim (out_data) || od; /* add to to output */ if str_info then term = "1"b; end; end; end fnp_fig; %page; /* cpu_fig - internal procedure to format cpu configuration */ cpu_fig: proc; %include config_cpu_card; term = "0"b; cpu_cardp = null; /* set config ptr to null */ do while (^term); /* loop through all cpu cards first */ call tolts_util_$find_card ("cpu ", cpu_cardp); if cpu_cardp = null then term = "1"b; /* the last card */ else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type) | (word = "cpu" & ^str_info) then do; call ioa_$rsnnl ("cpu ^a a^[ ^dK cache ^; ^s^]^a/^d cpu on scu port ^d is ^[on-line & unavailable for test ^;^[off-line & available for test ^;^[currently under test ^]^]^] ", od, ol, tags (tag), (cache_size > 0), (cache_size), type, model, port, (state = "on "), (state = "off "), (state = "test ")); call ioa_$rsnnl ("^a^/", od, ol, od); /* add a new line to output */ out_data = rtrim (out_data) || od; if str_info then term = "1"b; end; end; end cpu_fig; %page; /* mem_fig - internal procedure to format mem configuration */ mem_fig: proc; %include config_mem_card; term = "0"b; mem_cardp = null; /* set config ptr to null */ do while (^term); /* loop through all cpu cards first */ call tolts_util_$find_card ("mem ", mem_cardp); if mem_cardp = null then term = "1"b; /* the last card */ else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type) | (word = "mem" & ^str_info) then do; call ioa_$rsnnl ("scu ^a has ^4dk words of memory & is ^[the bootload scu & is unavailable ^;^[on-line & available ^;^[off-line & unavailable ^]^]for test", od, ol, tags (tag), size, (state = "on " & k = 0), (state = "on " & k > 0), (state = "off ")); k = k + 1; call ioa_$rsnnl ("^a^/", od, ol, od); /* add a new line to output */ out_data = rtrim (out_data) || od; if str_info then term = "1"b; end; end; end mem_fig; %page; /* iom_fig - internal procedure to formatiom configuration */ iom_fig: proc; %include config_iom_card; term = "0"b; iom_cardp = null; /* set config ptr to null */ do while (^term); /* loop through all iom cards first */ call tolts_util_$find_card ("iom ", iom_cardp); if iom_cardp = null then term = "1"b; /* the last card */ else if (str_info & (string (rtrim (word)) || tags (tag)) = eq_type) | (word = "iom" & ^str_info) then do; call ioa_$rsnnl ("iom ^a a ^a iom on scu port ^d is ^[on-line ^;^[off-line ^;^[currently under test ^]^]^] ", od, ol, tags (tag), model, port, (state = "on "), (state = "off "), (state = "test ")); call ioa_$rsnnl ("^a^/", od, ol, od); /* add a new line to output */ out_data = rtrim (out_data) || od; if str_info then term = "1"b; end; end; end iom_fig; %page; /* disk_fig - internal procedure to format disk configuration */ disk_fig: proc; %include config_prph_dsk_card; term = "0"b; prph_dsk_cardp = null; /* start at beginning of config deck */ do while (^term); /* get all disk subsystems */ call tolts_util_$find_card ("prph", prph_dsk_cardp); /* get next config card */ if prph_dsk_cardp = null then term = "1"b; /* if last card, thats it */ else if (str_info & name = eq_type) | (substr (name, 1, 3) = "dsk" & ^str_info) then do; ndevices = 0; fips, subsys = "0"b; do i = 1 to hbound (prph_dsk_card.group, 1) while (prph_dsk_card.group (i).model ^= -1); /* loop thru all dev pairs */ if prph_dsk_card.group (i).model ^= 0 then do; /* if not 0 devices */ fips = tolts_util_$dev0_valid (addr (config_data_$disk_drive_model_names), prph_dsk_card.group (i).model); if ^fips & ^subsys then ndevices = ndevices + 1; call ioa_$rsnnl ("^[^a^;^s ^] ^3d ^2d units;^-starting with device no. ^d^/", od, ol, ^subsys, name, prph_dsk_card.group (i).model, prph_dsk_card.group (i).ndrives, ndevices); out_data = rtrim (out_data) || od; /* at line to output */ subsys = "1"b; /* indicate we have output subsystem */ end; ndevices = ndevices + prph_dsk_card.group (i).ndrives; /* add incremental device numbers */ end; NAME = name; call find_mpc (iom, chan, nchan, fips); /* get mpc card for this prph */ call find_chnl (fips); /* go output associated chnl cards if present */ if str_info then term = "1"b; end; end; end disk_fig; %page; /* tape_fig - internal procedure to format tape configuration */ tape_fig: proc; %include config_prph_tap_card; term = "0"b; prph_tap_cardp = null; /* start at beginning of tolts_util_$find_card deck */ do while (^term); /* get all tape subsystems */ call tolts_util_$find_card ("prph", prph_tap_cardp); /* get next config card */ if prph_tap_cardp = null then term = "1"b; /* if last card, thats it */ else if (str_info & name = eq_type) | (substr (name, 1, 3) = "tap" & ^str_info) then do; ndevices = 0; subsys = "0"b; /* start by outputting subsystem */ do i = 1 to hbound (prph_tap_card.group, 1) while (prph_tap_card.group (i).model ^= -1); /* loop thru all dev pairs */ if prph_tap_card.group (i).model ^= 0 then do; /* if not 0 devices */ fips = tolts_util_$dev0_valid (addr (config_data_$tape_drive_model_names), prph_tap_card.group (i).model); if ^fips & ^subsys then ndevices = ndevices + 1; call ioa_$rsnnl ("^[^a^;^s ^] ^3d ^2d units;^-starting with device no. ^d^/", od, ol, ^subsys, name, prph_tap_card.group (i).model, prph_tap_card.group (i).ndrives, ndevices); out_data = rtrim (out_data) || od; /* at line to output */ subsys = "1"b; /* indicate we have output subsystem */ end; ndevices = ndevices + prph_tap_card.group (i).ndrives; /* add incremental device numbers */ end; NAME = name; call find_mpc (iom, chan, nchan, fips); /* get mpc card for this prph */ call find_chnl (fips); /* go output associated chnl cards if present */ if str_info then term = "1"b; end; end; end tape_fig; %page; /* sing_fig - internal procedure to format all single line peripherals (rdr,pun,opc,prt) */ sing_fig: proc; %include config_prph_opc_card; %include config_prph_prt_card; dcl (term, term1, trm) bit (1) init ("0"b); nchn = 1; prph_cardp = null; /* start at beginning of config deck */ do while (^term); /* get all other peripherals */ fips, trm = "0"b; if ss_info then term1 = "0"b; call tolts_util_$find_card ("prph", prph_cardp); /* get next config card */ if prph_cardp = null then term = "1"b; /* if last card, thats it */ else if str_info & eq_type = (substr (prph_card.name, 1, 4)) then term1 = "1"b; else if ss_info & eq_type = (substr (prph_card.name, 1, 3)) then term1 = "1"b; else if exec = "polt" & (^str_info & ^ss_info) then do; if substr (prph_card.name, 1, 3) = "prt" /* if printer */ | substr (prph_card.name, 1, 3) = "pun" /* or punch */ | substr (prph_card.name, 1, 3) = "rdr" /* or reader */ | substr (prph_card.name, 1, 3) = "opc" /* or console */ | substr (prph_card.name, 1, 3) = "ccu" /* or combined card unit */ then trm = "1"b; /* display it */ end; else if exec = "molt" & (^str_info & ^ss_info) then do; if substr (prph_card.name, 1, 3) = "prt" /* if printer */ | substr (prph_card.name, 1, 3) = "pun" /* or punch */ | substr (prph_card.name, 1, 3) = "rdr" /* or reader */ | substr (prph_card.name, 1, 3) = "hch" /* or hyperchannel */ | substr (prph_card.name, 1, 3) = "ccu" /* or combined card unit */ then trm = "1"b; /* display it */ end; if ^term & trm & ^str_info | ^term & ^trm & (str_info | ss_info) & term1 then do; prph_opc_cardp, prph_prt_cardp = prph_cardp; model_index = 0; d_sw = "1"b; /* device 1 in most cases */ if substr (prph_card.name, 1, 3) = "opc " then do; /* if console */ model_index = CONSOLE_MODEL_TO_INDEX_FCN (prph_opc_card.model); if model_index > 0 then d_sw = ^CONSOLE_IS_BCD (model_index); end; if substr (prph_card.name, 1, 3) = "hch" then d_sw = "0"b; call ioa_$rsnnl ("^4a ^d^[0^]^d^[01^;00^] model ^d ^[^a ^[is available for test ^;is the^[ alternate^]^[^s^] system console ^]^s ^;^4s^a^] ^[with ^d columns and a ^d print belt ^]", od, ol, prph_card.name, prph_card.iom - 1, (prph_card.chan < 10), prph_card.chan, d_sw, prph_card.model, (model_index > 0), con_types (model_index), (prph_opc_card.state = "io") | (prph_opc_card.state = "inop"), (prph_opc_card.state = "alt "), (prph_opc_card.state = "on"), (substr (prph_card.name, 1, 3)), (substr (prph_card.name, 1, 3) = "prt"), line_length, train); call ioa_$rsnnl ("^a^/", od, ol, od); /* add new line */ out_data = rtrim (out_data) || od; /* add to line */ if substr (prph_card.name, 1, 3) ^= "opc" | substr (prph_card.name, 1, 3) ^= "hch" then do; /* might be mpc device */ NAME = prph_card.name; call find_mpc (prph_card.iom, prph_card.chan, nchn, fips); /* get mpc card for this perph */ call find_chnl (fips); /* find chnl cards if present */ end; else call set_cline (prph_card.iom - 1, prph_card.chan, 0, "", -1); /* tell them no mpc card found */ if str_info then term = "1"b; end; end; end sing_fig; %page; /* find_mpc - internal procedure to find mpc card given iom and channel, and return mpc number */ find_mpc: proc (iom, a_chan, a_nchan, fips); %include config_ipc_card; %include config_mpc_card; dcl fips bit (1); dcl (chan, a_chan) fixed bin (8); dcl iom fixed bin (3); dcl (i, j, a_nchan, nchan) fixed bin; dcl cont_cardp ptr; dcl 1 cont_card aligned based (cont_cardp) like mpc_card; chan = a_chan; /* copy parameters */ nchan = a_nchan; cont_cardp = null (); /* start at beginning of deck */ trm = "0"b; /* reset terminate condition */ do while (^trm); /* find mpc card */ if ^fips then call tolts_util_$find_card ("mpc ", cont_cardp); else call tolts_util_$find_card ("ipc", cont_cardp); /* look for an fips card */ if cont_cardp = null () then trm = "1"b; else if fips then do; ipc_cardp = cont_cardp; j = 1; if ipc_card.iom = iom then /* if match on iom number */ if (chan >= ipc_card.chan & chan <= ipc_card.chan + (ipc_card.nchan - 1)) then do; if chan ^= ipc_card.chan then j = 2; call set_cline (iom - 1, (chan), ipc_card.nchan, ipc_card.type, j); /* output chan line */ if nchan <= ipc_card.nchan then /* if this is all chanels */ trm = "1"b; /* and chan number, this is it */ else do; /* more channels on diffent mpc cards */ chan = chan + ipc_card.nchan; /* add in channels processed */ nchan = nchan - ipc_card.nchan; /* and subtract number of chans */ end; end; end; else do i = 1 to hbound (cont_card.port, 1) while (cont_card.port (i).iom ^= -1 & ^trm); j = i; if cont_card.port (i).iom = iom then /* if match on iom number */ if (chan >= cont_card.port (i).chan & chan <= cont_card.port (i).chan + (cont_card.port (i).nchan - 1)) then do; if chan ^= cont_card.port (i).chan then j = 2; call set_cline (iom - 1, (chan), cont_card.port (i).nchan, cont_card.name, j); /* output chan line */ if nchan <= cont_card.port (i).nchan then /* if this is all chanels */ trm = "1"b; /* and chan number, this is it */ else do; /* more channels on diffent mpc cards */ chan = chan + cont_card.port (i).nchan;/* add in channels processed */ nchan = nchan - cont_card.port (i).nchan; /* and subtract number of chans */ end; end; end; end; if cont_cardp = null () then /* if we didn't find an mpc */ call set_cline (iom - 1, chan, 0, "", -1); /* tell them no mpc card found */ end find_mpc; %page; /* find_chnl - internal procdure to find chnl card associated with prph card and output info */ find_chnl: proc (fips); %include config_chnl_card; dcl fips bit (1); chnl_cardp = null; /* start at beginning */ trm = "0"b; /* and find possible chnl card */ do while (^trm); call tolts_util_$find_card ("chnl", chnl_cardp); if chnl_cardp = null then trm = "1"b; /* if last card, no chnl card */ else if name = NAME then do; /* if for right subsystem */ trm = "1"b; /* set terminate condition */ do i = 1 to 3 while (chnl_card.group (i).iom ^= -1); /* loop through all fields of chnl card */ call find_mpc (chnl_card.group (i).iom, chnl_card.group (i).chan, chnl_card.group (i).nchan, fips); /* find mpc card */ end; end; end; end find_chnl; %page; /* mca_fig - int proc to attach a MCA, reads its config table and add the info to the out_data buffer. */ mca_fig: proc (MCA_NAME); %include config_iom_card; dcl MCA_NAME char (4); mca_config_file_ptr = null; iom_cardp = null; /* set config ptr to null */ on linkage_error begin; call com_err_ (error_table_$moderr, "mca_fig", "mca_"); goto mca_fig_end; /* exit */ end; on cleanup begin; if mca_config_file_ptr ^= null then call release_temp_segment_ ("tolts_pcd_", mca_config_file_ptr, code); call mtdsim_$clean_up (); /* call our normal handler */ goto mca_fig_end; end; entry_var = mca_$attach_mca; revert linkage_error; call get_temp_segment_ ("tolts_pcd_", mca_config_file_ptr, code); data_ptr, static_config_ptr = mca_config_file_ptr; next: if MCA_NAME = "" then do; /* loop through all iom cards first */ call tolts_util_$find_card ("iom ", iom_cardp); if iom_cardp = null then return; /* the last card */ if iom_card.model = "imu" then mca_name = "mca" || tags (iom_card.tag); else goto next; end; else mca_name = MCA_NAME; retry_sw = "1"b; retry_attach: call ioa_ ("attaching ^a for configuration read", mca_name); /* let the user know */ call mca_$attach_mca (mca_name, mca_ev_chn, mca_ioi_idx, code); if code ^= 0 then do; if code = error_table_$timeout then do; if retry_sw then do; retry_sw = "0"b; call com_err_ (code, "tolts_pcd_", "Attaching ^a, will retry..", mca_name); goto retry_attach; end; end; if addr (code) -> status.t & addr (code) -> status.major = "0"b then call com_err_ (0, "mca_$attach_mca", "status ^w", code); else call com_err_ (code, "tolts_pcd_", "Attempting to attach ^a", mca_name); return; end; call ioa_ ("^a attached for configuration read", mca_name); call rd_config; DONE: if mca_ioi_idx ^= -1 then call mca_$detach_mca (mca_ioi_idx, code); if code ^= 0 then do; call com_err_ (code, "tolts_pcd_", "Attempting to detach ^a", mca_name); end; if mca_config_file_ptr ^= null () then call release_temp_segment_ ("tolts_pcd_", mca_config_file_ptr, code); if MCA_NAME = "" & iom_cardp ^= null then goto next; revert cleanup; /* re-enable previous cleanup handler */ mca_fig_end: end mca_fig; %page; /* rd_config - int proc that actually reads the MCA config & formats the data */ rd_config: proc; total_chars_read = 0; call mca_$config ((mca_ioi_idx), mca_config_file_ptr, (4 * size (mca_config_file)), ret_len, status_a, code); if code ^= 0 then do; call com_err_ (code, "mca_$config", "status_a ^w", status_a); end; else do; call read_more (mca_config_file_ptr); /* go read the rest of the data */ if code ^= 0 then return; iom_num = index ("abcd", substr (mca_name, 4, 1)); do i = 0 to max_imu_channels; CHAN_NUM = channel_data (i).prim_ch_num; call find_config_card_$prph_for_channel (iom_num, CHAN_NUM, prph_cardp); if prph_cardp = null () then prph_name = ""; else prph_name = prph_card.name; ipc_type = TYPE (channel_data (i).lvl_1_id_type); if channel_data (i).fw_id = "00001000"b then ipc_type = rtrim (ipc_type) || "_tape"; if channel_data (i).fw_id = "00001001"b then ipc_type = rtrim (ipc_type) || "_disk"; if channel_data (i).lvl_1_state ^= 1 then do; call ioa_$rsnnl ("^2xIPC_^2a ^9a ch ^2d for ^2d ^4a state = ^d dt ^d ^[fw_rev ^a^]^/", od, ol, convert (p99, i), ipc_type, channel_data (i).prim_ch_num, channel_data (i).num_of_log_ch, prph_name, channel_data (i).lvl_1_state, channel_data (i).disk_tab, (channel_data (i).fw_id ^= "0000"b), channel_data (i).fw_rev); mca_data = rtrim (mca_data) || od; /* at line to output */ end; end; end; end rd_config; %page; /* read_more - int proc to contine to read the mca config data until it is all read */ read_more: proc (start_ptr); dcl start_ptr ptr; dcl read_ptr ptr; read_ptr = start_ptr; one_more_time: total_chars_read = ret_len + total_chars_read; if ^check_status_ok () then return; if data_present then read_ptr = add_char_offset_ (read_ptr, ret_len); if ^session_over then do; call mca_$read_data (mca_ioi_idx, read_ptr, (16 * 1024), ret_len, status_a, code); if code ^= 0 then do; call com_err_ (code, "mca_$read_data", "status_a ^w", status_a); return; end; goto one_more_time; end; end read_more; %page; /* check_status_ok - int proc to examine the MCA status & return the state */ check_status_ok: proc () returns (bit (1)); dcl state bit (1) init ("1"b); /* assume the return status is ok */ data_present = "0"b; session_over = "0"b; statp = addr (status_a); if ^status.t then do; call ioa_ ("Returned status was no good. (^w)", unspec (status)); state = "0"b; goto return_state; end; if status.power then do; state = "0"b; goto return_state; end; if (status.channel_stat | status.central_stat) ^= "0"b then do; state = "0"b; goto return_state; end; sub_ptr = addr (status.sub); data_present = mca_sub.data_p; if status.major ^= ""b then do; state = "0"b; end; if mca_sub.mbz ^= ""b then do; state = "0"b; end; if mca_sub.term_state = MAINT_ABNORMAL_TERM then do; session_over = "1"b; state = "0"b; end; if mca_sub.term_state = MAINT_NORMAL_TERM then session_over = "1"b; return_state: return (state); end check_status_ok; %page; /* The following function returns the 'console model index' given the console model number. If the model number is not known, -1 is returned. */ CONSOLE_MODEL_TO_INDEX_FCN: procedure (model_number) returns (fixed bin); dcl model_number fixed bin; dcl i fixed bin; do i = 1 to hbound (CONSOLE_MODEL_NUMBER, 1); if model_number = CONSOLE_MODEL_NUMBER (i) then return (CONSOLE_MODEL_INDEX (i)); end; return (-1); end CONSOLE_MODEL_TO_INDEX_FCN; %page; /* set_cline - internal procedure to add channel line to output */ set_cline: proc (iom, chan, lchan, mpcnm, fldno); dcl iom fixed bin (3); dcl chan fixed bin (8); dcl (lchan, fldno) fixed bin; dcl mpcnm char (4) aligned; call ioa_$rsnnl (" ^d^[0^]^dxx^-^[ special purpose chan ^3s^;^[primary^]^[secondary^] channel of ^d logical channel^[s^] on mpc card ^a ^]^/", od, ol, (iom), (chan < 10), (chan), (mpcnm = ""), (fldno = 1), (fldno > 1), (lchan), (lchan > 1), mpcnm); out_data = rtrim (out_data) || od; /* add to end of line */ end set_cline; %page; %include author_dcl; %page; %include cdt; %page; %include config_data_dcls; %page; %include config_prph_card; %page; %include console_device_specs; %page; %include mca_area; %page; %include mca_config_file; %page; %include mca_constants; %page; %include iom_stat; end tolts_pcd_;  tolts_qttyio_.pl1 12/09/86 1539.4r w 12/09/86 1522.8 92169 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ tolts_qttyio_: proc (message, a_page); /* tolts_qttyio_ - procedure and related entries to queue up terminal io for tolts, 1 line at a time */ /* the page numbers have the following meaning: page = 0 = output to users terminal page = 1 - 8 = output from 1 of the test pages, routed to users terminal or print file (see dcw_lp struct) page = 9 = output message on users terminal and then read input from user page = 10 = output to user terminal or print file, if print file attached (tolts_info.file_attach = "1"b) */ /* External Entries */ dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl com_err_ entry options (variable); dcl terminate_process_ entry (char (*), ptr); dcl cu_$arg_list_ptr entry (ptr); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); dcl tolts_util_$bci_to_ascii entry (bit (*), char (*) varying, fixed bin); /* Entry Parameters */ dcl message char (*); dcl (a_page, np) fixed bin; dcl a_dcwp ptr; /* Automatic */ dcl (genp, argp, dcwptr) ptr; dcl mep ptr; dcl (page, lp, lb, c_len, i) fixed bin; dcl (found, pline) bit (1); dcl NLFF char (2); dcl rs_data char (136); /* structures and based variables */ dcl bcd_str bit (c_len * 6) based (genp); dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl 1 mes_buf based (mep) aligned, /* template for a message queue entry */ 2 page fixed bin, /* test page number issuing io */ 2 nlines fixed bin, /* number of array elements in message */ 2 cline fixed bin, /* line number currently being displayed */ 2 lines (nlines) char (136), /* array of message lines */ 2 nxt_mes char (1); /* method to get to next message */ dcl 1 rcw based (genp), /* structure for gcos sysout records with rcws */ (2 dlen fixed bin, /* number of words */ 2 pad fixed bin) unaligned, /* reset of rcw not used */ 2 data bit (rcw.dlen * 36), /* bcd data as bit string */ 2 nxt_rcw bit (0); /* used for getting next rcw */ dcl 1 dcw_lp based (dcwptr) aligned, /* template for tadio dcw ptr */ (2 add fixed bin (18) unsigned, /* address of tadio dcw */ 2 type, /* dcw type */ 3 e bit (1), /* select terminal/print file by option */ 3 r bit (1), /* write then read */ 3 m bit (1), /* master console output */ 3 s bit (1), /* slaved terminal output */ 3 c bit (1), /* controlling terminal output */ 3 p bit (1), /* output to print file */ 2 wc fixed bin (12) unsigned) unaligned; /* total message word count */ /* Builtins */ dcl (addr, addrel, length, rel, rtrim, search, substr, unspec, verify) builtin; page = a_page; /* copy test page number */ if page = 9 then tolts_info.term_io_in_prog = "1"b; call que_setup; /* go set up queue entry */ if tolts_info.file_attach then /* if print file attached.... */ if page > 0 & page ^= 9 & page ^= 19 then /* and if exec I/O... */ pline = "1"b; /* set print flag */ c_len = length (rtrim (message)); /* get rtrim(message) length */ call parse_mess (addr (message), c_len); /* go parse up message into individual lines */ call wakeup; /* go wakeup display event */ return; /* thats all folks */ /* dcw_ptr - entry to queue up message given a list of dcw ptrs (for MME TADIOD) */ dcw_ptr: entry (a_dcwp, np, a_page); page = a_page; dcwptr = a_dcwp; do i = 1 to np; /* process all dcw ptrs */ call que_setup; /* go set up our message queue entry */ dcwp = ptr (dcwptr, dcw_lp.add); /* get ptr to next dcw */ if tolts_info.file_attach then /* if print file attached... */ if dcw_lp.type.e | dcw_lp.type.p then /* and line to be printed */ pline = "1"b; /* set flag */ call pdcw_list; /* go process dcw list */ call wakeup; /* go wakeup display event */ dcwptr = addrel (dcwptr, 1); /* increment to next ptr */ end; return; /* thats all folks */ /* dcw_list - entry to queue up a message given a dcw list */ dcw_list: entry (a_dcwp, a_page); page = a_page; /* copy test page number */ call que_setup; /* go get the next avail buffer and initialize */ dcwp = a_dcwp; /* copy dcw ptr */ call pdcw_list; /* go process the dcw list */ call wakeup; /* issue wakeup to tolts_ttyio_display_ */ return; /* thats all folks */ /* rs - entry to pass in short messages with ioa_ control args */ rs: entry (a_page); page = a_page; /* set test page */ call que_setup; /* go get next queue loc */ if tolts_info.file_attach then /* if print file attached.... */ if page > 0 & page ^= 9 & page ^= 19 then pline = "1"b; /* set print flag */ call cu_$arg_list_ptr (argp); /* get ptr to our argument list */ call ioa_$general_rs (argp, 2, 3, rs_data, c_len, "0"b, "0"b); /* format message */ call parse_mess (addr (rs_data), c_len); /* go parse message and store in queue */ call wakeup; /* wakeup display */ return; /* rcw - entry to output a message coded for gcos sysout */ rcw: entry (a_dcwp); page = 0; /* set test page to exec */ call que_setup; /* go get next queue loc */ dcwp = a_dcwp; /* copy dcw ptr */ c_len = fixed (dcw.tally); /* get dcw length */ i = 0; /* reset word counter */ genp = ptr (dcwp, dcw.address); /* get ptr to first rcw */ do while (i < c_len); /* do until we are done */ i = i + rcw.dlen + 1; /* add current rcw length + rcw */ call tolts_util_$bci_to_ascii (rcw.data, tolts_info.cv_buf, rcw.dlen * 6); /* convert to ascii */ call parse_mess (addrel (addr (tolts_info.cv_buf), 1), length (tolts_info.cv_buf)); /* go parse message */ genp = addr (rcw.nxt_rcw); /* get next rcw address */ end; call wakeup; /* wakeup display event */ return; /* thats it folks */ /* pdcw_list - subroutine to process a dcw list containing messages */ pdcw_list: proc; found = "0"b; /* initiaize terminate condition */ do while (^found); /* process all dcws */ genp = ptr (dcwp, fixed (dcw.address, 17)); /* get ptr to string */ c_len = fixed (dcw.tally) * 6; /* number of bcd chars */ call tolts_util_$bci_to_ascii (bcd_str, tolts_info.cv_buf, c_len); call parse_mess (addrel (addr (tolts_info.cv_buf), 1), length (tolts_info.cv_buf)); /* go parse message */ if dcw.type = "00"b then found = "1"b; /* if last dcw */ else dcwp = addrel (dcwp, 1); /* otherwise get next dcw */ end; end pdcw_list; /* parse_mess - subroutine to parse terminal messages and store in queue entry message array */ parse_mess: proc (mesp, slen); dcl mesp ptr; /* ptr to message to be parsed */ dcl slen fixed bin; /* length of message to be parsed */ dcl rmess char (slen) based (mesp); /* template for message to be parsed */ if slen = 0 then /* special case null lines */ lp = 0; else lp = 1; /* set initial scan position */ do while (lp <= slen); /* process entire line */ mes_buf.nlines = mes_buf.nlines + 1; /* update number of lines */ mes_buf.lines (nlines) = ""; /* initialize buffer to blanks */ if slen ^= 0 then do; /* if somebody sent over a null string, special case */ lb = verify (substr (rmess, lp, (slen - lp) + 1), NLFF); /* strip off NLs and Form feeds */ if lb = 0 then do; /* if couldn't find... */ lp = lp + (slen - lp) + 1; /* update lp to escape from loop */ mes_buf.nlines = mes_buf.nlines - 1; /* get rid of blank line */ end; else do; lp = lp + (lb - 1); /* correct starting position */ lb = search (substr (rmess, lp), NLFF); /* search for next NL or form feed */ if lb = 0 then /* if no more */ lb = (slen - lp) + 1; /* set to end of line */ else lb = lb - 1; mes_buf.lines (nlines) = substr (rmess, lp, lb); /* save substr as line */ lp = lp + lb; /* update position */ end; end; else lp = 1; /* set condition to get out of loop */ end; end parse_mess; /* que_setup - subroutine to initialize a new queue entry */ que_setup: proc; unspec (NLFF) = "012014"b3; /* set new line and form feed constants */ mep = tolts_info.mess_buf.nxt; /* set message ptr to next avail loc */ mes_buf.page = page; /* set page number in entry */ mes_buf.nlines, mes_buf.cline = 0; /* initialize number of lines and current line */ pline = "0"b; /* reset print line flag */ end que_setup; /* wakeup - subroutine to set the nxt queue entry address and wakeup tolts_dtty_io_ */ wakeup: proc; if pline then /* if message to be printed... */ mes_buf.page = mes_buf.page + 20; /* set print indicator */ tolts_info.mess_buf.nxt = addr (mes_buf.nxt_mes); /* set next queue address */ if rel (tolts_info.mess_buf.nxt) > rel (addr (tolts_info.mess_buf.q_end)) then /* if wrap */ tolts_info.mess_buf.nxt = tolts_info.mess_buf.first; /* set to start of queue */ tolts_info.term_io_req_cnt = tolts_info.term_io_req_cnt + 1; /* increment number of requests */ /* send tolts_dttyio_ a wakeup and send him the message ptr */ call hcs_$wakeup (tolts_info.process, tolts_info.tty_issue_event, mep, fatal_desc.fatal_code); if fatal_desc.fatal_code ^= 0 then do; call com_err_ (fatal_desc.fatal_code, "tolts_qttyio_", "fatal error, terminating process"); fatal_desc.version = 0; call terminate_process_ ("fatal_error", addr (fatal_desc)); end; end wakeup; %include tolts_info; %include iom_dcw; end tolts_qttyio_;  tolts_ttyio_display_.pl1 12/09/86 1539.4r w 12/09/86 1522.8 55791 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ tolts_ttyio_display_: proc (event_ptr); /* This procedure displays each line of a queued terminal io message and is driven by IPC call channels. The first call is initiated by the tolts_qttyio_ subroutine waking up the tty_issue_event channel. Further calls on this event channel are inhibited until the entire message has been displayed. After the first line of a message is displayed, all subsequent lines are output by waking up the tty_display_event channel. The tty_display event channel will call the entry tolts_ttyio_display_$nxt_line until all lines of the message are output. After the last line of a message is displayed, the event channel tty_ccc_event is woken up. This calls the routine tolts_ttyio_end_ for message completion. Message routing is determined by the value of the message entry page number (mes_buf.page). If the page number has a value from 0 to 9, then the message is routed to the user_output io switch. If the page number has a value greater than or equal to 20, then the message is routed to the io switch defined by tolts_info.pf_iocbp. The page number is then corrected to its true value (0 to 9) before the tolts_ttyio_end_ entry is signalled. */ /* External Entries */ dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl (com_err_, ioa_$ioa_switch_nnl) entry options (variable); dcl terminate_process_ entry (char (*), ptr); dcl ipc_$cutoff entry (fixed bin (71), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); /* Entry Parameters */ dcl event_ptr ptr; /* Automatic */ dcl (mep, iocbp) ptr; dcl page fixed bin; dcl error fixed bin (35); dcl npnl bit (1); /* structures and based variables */ dcl 1 event_info based (event_ptr), 2 causing_event fixed bin (71), 2 cmp ptr, 2 sender bit (36), 2 origin, 3 signal bit (18) unaligned, 3 ring bit (18) unaligned, 2 in_data_pointer ptr; dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl 1 mes_buf based (mep) aligned, /* template for a message queue entry */ 2 page fixed bin, /* test page number issuing io */ 2 nlines fixed bin, /* number of array elements in message */ 2 cline fixed bin, /* line number currently being displayed */ 2 lines (nlines) char (136), /* array of message lines */ 2 nxt_mes char (1); /* method to get to next message */ /* Builtins */ dcl (addr, null) builtin; /* Static */ dcl (iox_$user_output, iox_$user_io) ptr ext; call ipc_$cutoff (tolts_info.tty_issue_event, error); /* inhibit further calls from tolts_qttyio_ */ if error ^= 0 then do; disaster: call com_err_ (error, "tolts_ttyio_display_", "fatal error, terminating process"); fatal_desc.fatal_code = error; fatal_desc.version = 0; call terminate_process_ ("fatal_error", addr (fatal_desc)); end; /* entry to display more than one line (after first line) */ nxt_line: entry (event_ptr); mep = event_info.cmp; /* copy message ptr */ tolts_info.term_io_in_prog = "1"b; /* set io in progress flag */ if tolts_info.optflag ^= 0 then do; /* has a quit been signalled? */ call wakeup (tolts_info.tty_ccc_event, "1"b);/* yes signal tolts_ttyio_end_ */ return; end; mes_buf.cline = mes_buf.cline + 1; /* increment current line number */ /* determine if going to printer or terminel */ page = mes_buf.page; /* copy page number */ if page >= 20 then do; /* if printer flag set */ if tolts_info.pf_iocbp ^= null then /* if print file iocb ptr good */ iocbp = tolts_info.pf_iocbp; /* output to print file switch */ else iocbp = iox_$user_output; /* go to terminal */ page = page - 20; /* get right page number */ end; else iocbp = iox_$user_output; /* otherwise go to terminal */ /* determine if line should end with newline character */ npnl = "0"b; /* default is to output new line */ if page = 9 | page = 19 then /* if exec read, no newline */ if mes_buf.cline = mes_buf.nlines then /* and this is the last line of message */ npnl = "1"b; else ; else if page > 0 & page ^= 10 then /* if not exec write */ if tolts_info.tadio (page).optrd then /* and test page requesting options */ if mes_buf.cline = mes_buf.nlines then /* and this is the last line of message */ npnl = "1"b; /* don't put out newline */ call ioa_$ioa_switch_nnl (iocbp, "^a^[ ^;^/^]", mes_buf.lines (mes_buf.cline), npnl); /* display line */ if mes_buf.cline = mes_buf.nlines | tolts_info.optflag ^= 0 then /* last line or quit? */ call wakeup (tolts_info.tty_ccc_event, "1"b);/* wake up tolts_ttyio_end_ */ else call wakeup (tolts_info.tty_display_event, "0"b); /* otherwise, wakeup ourself */ call iox_$control (iox_$user_io, "start", null, error); /* allow cleanup of any blocks */ return; /* wakeup - subroutine to wakeup requested event channel */ wakeup: proc (e_chan, last_line); dcl e_chan fixed bin (71); dcl last_line bit (1); if last_line then /* if last line of message.... */ if mes_buf.page >= 20 then /* and if printer output */ mes_buf.page = mes_buf.page - 20; /* correct page number for tolts_ttyio_end_ */ call hcs_$wakeup (tolts_info.process, e_chan, mep, error); /* wakeup desired channel */ if error ^= 0 then /* if some problem... */ go to disaster; /* terminate process */ end wakeup; %include tolts_info; end tolts_ttyio_display_;  tolts_ttyio_end_.pl1 12/09/86 1539.4rew 12/09/86 1521.0 131580 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified on 5/80 by R. Fakoury to check for mtar request. Modified 12/80 by R. Fakoury to implement colts. Modified 81/05 by R. Fakoury to correctly handle a Multics command request. Modified 04/81 by R. Fakoury to allow clstal requests. Modified 03/83 by Rick Fakoury to implement 'test msg' for operator/user communication. Modified 08/16/83 by Rick Fakoury to allow partial config messages. Modified 11/83 by Rick Fakoury to allow hyperchannel test request. Modified 01/84 to allow input prior to first request. */ /****^ HISTORY COMMENTS: 1) change(85-12-21,Fakoury), approve(86-08-21,MCR7514), audit(86-11-11,Martinson), install(86-12-04,MR12.0-1235): for a test nio request, to allow the Colts responder (rsp) request, set limit of Molts request line to 11 chars, allow single character reply to a tolts query. END HISTORY COMMENTS */ /* This procedure is called (via the event call channel id tty_ccc_event) from tolts_ttyio_display_. It functions to do any cleanup upon the completion of a terminal io message. If the io request was for test page number 9, this is a read request folloiwing the message completion. If this is the case, or if a quit was signaled during transmission of the last message, a call is made to tolts_util_$query to get input from the user. The input requests are processed accordingly. */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_ttyio_end_: proc (event_ptr); /* External Entries */ dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), ptr, fixed bin (35)); /* arg 3 is suppose to be fixed bin (71) */ dcl (com_err_, ioa_) entry options (variable); dcl terminate_process_ entry (char (*), ptr); dcl ipc_$reconnect entry (fixed bin (71), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl tolts_util_$opr_msg entry; dcl tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) varying, fixed bin); dcl tolts_alm_util_$ascii_to_bci_ entry (char (*), bit (*)); dcl tolts_pcd_ entry (char (6), char (*)); dcl tolts_qttyio_ entry (char (*), fixed bin); /* Entry Parameters */ dcl event_ptr ptr; /* Automatic */ dcl com_string char (132) aligned; dcl args (32) char (28) varying; dcl ascii_in char (18); dcl bcd_out bit (144); dcl bcd_opt bit (6 * 84); dcl (page, cmd_cnt, c_len, i, j, term_io_req_cnt_hld) fixed bin; dcl mep ptr; dcl error fixed bin (35); dcl q_str char (5); dcl NL char (1) int static options (constant) init (" "); /* structures and based variables */ dcl bcd_request (4) bit (36) based (addr (bcd_out)); dcl opt_str char (c_len) based (addr (com_string)); dcl fnp_num (0:7) char (1) static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl chn_num (0:14) char (2) static options (constant) init ("77", "77", "77", "77", "77", "77", "h0", "h1", "h2", "l0", "l1", "l2", "l3", "l4", "l5"); dcl cdt_fnp char (1); dcl (cdt_chn, cdt_subchan) char (2); dcl 1 event_info based (event_ptr), 2 causing_event fixed bin (71), 2 cmp ptr, 2 sender bit (36), 2 origin, 3 signal bit (18) unaligned, 3 ring bit (18) unaligned, 2 in_data_pointer ptr; dcl 1 fatal_desc aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl 1 mes_buf based (mep) aligned, /* template for a message queue entry */ 2 page fixed bin, /* test page number issuing io */ 2 nlines fixed bin, /* number of array elements in message */ 2 cline fixed bin, /* line number currently being displayed */ 2 lines (nlines) char (136), /* array of message lines */ 2 nxt_mes char (1); /* method to get to next message */ /* Builtins */ dcl (addr, bin, length, ltrim, null, search, substr) builtin; dcl iox_$user_io ptr ext; %page; if ^tolts_info.term_io_in_prog then return; /* not mine forget it */ mep = event_info.cmp; /* get currnet message ptr */ page = mes_buf.page; /* extract test page number */ if tolts_info.optflag ^= 0 then q_str = NL || "??? "; /* if quit signaled output "??? " */ else q_str = ""; if page = 9 | page = 19 | tolts_info.optflag ^= 0 then do; /* exec read or quit signaled */ tolts_info.optflag = 0; /* reset option request flag */ requery: call tolts_util_$query (q_str, com_string, c_len, args, cmd_cnt); /* get user input */ if page = 19 then do; /* is it local Multics question? */ tolts_info.mult_ans = substr (com_string, 1, 28); /* yes copy answer */ go to ck_first; end; if c_len <= 2 then do; /* if user just typed nl */ ck_first: if ^tolts_info.first_request_done & page ^= 19 then do; /* and initial read not complete */ q_str = NL || "??? "; /* set up questions for requery */ go to requery; /* go ask again */ end; call reconnect; /* enable term io again */ call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wake up dispatcher */ return; end; else if args (1) = "reprint" then do; /* user wants to see last message */ if page = 9 then /* it has already been printed */ call ioa_ ("^as: Last message was complete and is not available for reprinting", tolts_info.exec); else do; mes_buf.cline = 0; /* make tolts_ttyio_display_ start at beginning of message */ call wakeup (tolts_info.tty_display_event, mep); /* signal restart of message */ if tolts_info.first_request_done then /* if first request complete */ call tolts_qttyio_ ("??? ", 9); /* queue up another read, but don't reconnect issue channel */ return; end; end; else if args (1) = "msg" then /* user wants to communicate with the operator */ call tolts_util_$opr_msg; else if args (1) = "E" | args (1) = "e" | substr (args (1), 1, 2) = ".." then do; /* user wants to execute Multics command */ com_string = ltrim (substr (com_string, 2)); if substr (args (1), 1, 2) = ".." then com_string = substr (com_string, 2); term_io_req_cnt_hld = tolts_info.term_io_req_cnt; tolts_info.term_io_req_cnt = 0; call cu_$cp (addr (com_string), length (com_string), error); /* execute Multics command */ tolts_info.term_io_req_cnt = term_io_req_cnt_hld; end; /* check for improper input */ else if args (1) ^= "test" then /* input must be "test piccdd" etc */ call ioa_ ("^as: (^a) invalid input;^/use ""test xx--""", tolts_info.exec, com_string); else if args (2) = "msg" then /* user wants to communicate with the operator */ call tolts_util_$opr_msg; else if args (2) = "pcd" then do; /* user wants to get config */ if cmd_cnt = 3 then call tolts_pcd_ (((exec) || " "), (args (3))); else call tolts_pcd_ (((exec) || " "), ("")); call reconnect; /* reconnect ipc channel and give pcd a chance to come out */ call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wakeup the dispatcher */ return; end; else if tolts_info.exec = "polt" then /* if running polts */ if search (args (2), "pwl") ^= 1 | length (args (2)) > 11 | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2 then /* improper input? */ call ioa_ ("^as: (^a) invalid input, use:^/^a, ^[^a,^;^s^] ^a, ^a, or ^a", tolts_info.exec, com_string, """test piccddooooo""", (tolts_info.first_request_done), """test pxiccddoooo""", """test w""", """test lstal""", """test pcd"""); else call test_request; /* enter test_request */ else if tolts_info.exec = "molt" then /* if running molts */ if search (args (2), "lmnw") ^= 1 /* if one of these errors */ | length (args (2)) > 11 | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2 then call ioa_ ("^as: (^a) invalid input, use:^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, ^a,^/^a, ^a, or ^a", tolts_info.exec, com_string, """test mdciccooooo""", """test mdriccddooooo""", """test mhpiccooooo""", """test mmticcddoooo""", """test mpciccooooo""", """test mpticcddooooo""", """test mtgiccddoooo""", """test mxdciccoooo""", """test mxdriccddoooo""", """test mxhpiccoooo""", """test mxmticcddoooo""", """test mxpciccoooo""", """test mxpticcddoooo""", """test mxtgiccddoooo""", """test nioi""", """test w""", """test lstal""", """test pcd"""); else if length (args (2)) > 2 then do; if (substr (args (2), 1, 3) = "mpc" | substr (args (2), 1, 3) = "mdr") & tolts_info.first_request_done then /* if user attempting to enter more than one page */ call ioa_ ("^as: (^a) only one mpc (itr) or mdr test request may be active at one time", tolts_info.exec, com_string); else call test_request; /* enter test request */ end; else call test_request; /* enter test request */ else if tolts_info.exec = "colt" then do; /* if running colts */ if search (args (2), "cwl") ^= 1 | length (args (2)) > 11 | substr (args (2), 1, 1) ^= "w" & length (args (2)) < 2 then do; call ioa_ ("^as: (^a) invalid input, use: ^/^a, ^a, ^[^a, ^a,^;^2s^] ^a, ^a, or ^a", tolts_info.exec, com_string, """test Cnccssooooo""", """test Cfrspd""", (tolts_info.first_request_done), """test Cxccssoooo""", """test Cxfrspd""", """test w""", """test lstal""", """test pcd"""); go to ck_first; end; if search (args (2), "wl") ^= 1 & search (args (2), "loew") ^= 2 then do; if search (args (2), "rsp") ^= 0 then do; do j = lbound (tolts_info.pages, 1) to hbound (tolts_info.pages, 1); if ^pages (j).in_use then do; io_info_ptr = addr (pages (j)); io_info.test_req.tt = "71"b3; io_info.fnp_num = (bin (substr (args (2), 2, 1))); j = 8; end; end; end; else do; cdt_fnp = fnp_num (bin (substr (args (2), 2, 1))); cdt_chn = chn_num (bin (substr (args (2), 3, 2))); cdt_subchan = substr (args (2), 5, 2); fnp (bin (substr (args (2), 2, 1))).exec_chan = cdt_fnp || "." || "c000"; do j = 1 to 8; if substr (fnp (bin (substr (args (2), 2, 1))).cdt_name (j), 1, 5) = "empty" then do; fnp (bin (substr (args (2), 2, 1))).cdt_name (j) = cdt_fnp || "." || cdt_chn || cdt_subchan; j = 8; end; end; end; end; call test_request; if substr (args (2), 2, 3) = "rsp" then io_info.test_req.fnccss = substr (bcd_out, 7, 18); end; go to ck_first; /* go reconnect */ end; if page = 0 | page = 10 | tolts_info.exec_term_io_wait then /* if exec io or waiting to abort */ go to ck_first; /* go check if first request complete */ if tolts_info.tadio (page).optrd then do; /* test page looking for options */ tolts_info.tadio (page).optrd = "0"b; /* reset options flag */ call tolts_util_$query ("", com_string, c_len, args, cmd_cnt); /* get user input */ if c_len > 0 then do; /* if something entered.. */ call tolts_alm_util_$ascii_to_bci_ (opt_str, bcd_opt); /* convert to bcd */ substr (tolts_info.tadio (page).option, 1, c_len * 6) = substr (bcd_opt, 1, c_len * 6); /* move to buffer */ end; end; else tolts_info.tadio (page).inuse = "0"b; /* release this tadio queue entry */ i, tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt + 1; /* increment count */ tolts_info.exec_dta (i).word (1) = tolts_info.tadio (page).return_word (1); tolts_info.exec_dta (i).word (2) = tolts_info.tadio (page).return_word (2); tolts_info.exec_dta (i).word (3) = tolts_info.tadio (page).return_word (3); call reconnect; /* reconnect ipc channel */ call wakeup (tolts_info.wait_list.wait_event_id (1), null); /* wake up dispatcher */ return; /* thats all folks */ %page; /* reconnect - internal procedure to reconnect ipc channel */ reconnect: proc; /* re enable io issuing */ tolts_info.term_io_in_prog = "0"b; tolts_info.term_io_req_cnt = tolts_info.term_io_req_cnt - 1; call ipc_$reconnect (tolts_info.tty_issue_event, error); if error ^= 0 then do; /* term process if error */ call com_err_ (error, "tolts_ttyio_end_", "fatal error, terminating process"); fatal_desc.version = 0; fatal_desc.fatal_code = error; call terminate_process_ ("fatal_error", addr (fatal_desc)); end; call iox_$control (iox_$user_io, "start", null, error); /* allow cleanup of any blocks */ end reconnect; /* wakeup - internal procedure to issue wakeup to ipc wait channel */ wakeup: proc (e_chan, wakeup_ptr); dcl e_chan fixed bin (71); dcl wakeup_ptr ptr; /* issue wakeup to dispatcher */ call hcs_$wakeup (tolts_info.process, e_chan, wakeup_ptr, error); if error ^= 0 then do; /* term process if error */ call com_err_ (error, "tolts_ttyio_end_", "fatal error, terminating process"); fatal_desc.version = 0; fatal_desc.fatal_code = error; call terminate_process_ ("fatal_error", addr (fatal_desc)); end; end wakeup; /* test_request - internal procedure to convert test request data and queue it up */ test_request: proc; ascii_in = args (2); /* copy data to convert */ substr (ascii_in, 12, 7) = "10000t/"; /* use coded logical terminal 1 and "t/" tty code */ call tolts_alm_util_$ascii_to_bci_ (ascii_in, bcd_out); /* convert to bcd */ i, tolts_info.exec_dta_cnt = tolts_info.exec_dta_cnt + 1; /* increment count */ tolts_info.exec_dta (i).word (*) = bcd_request (*); /* move the data to the queue */ tolts_info.first_request_done = "1"b; /* set flag for dispatcher */ end test_request; %page; %include tolts_info; end tolts_ttyio_end_;  tolts_util_.pl1 12/09/86 1539.4rew 12/09/86 1521.6 161703 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Initially coded 6/78 by J. A. Bush Modified by Rich Coppola 9/29/81 to return value of iocbp if non-null so caller can clean up. Modified by R. Fakoury 3/16/83 to add the get_ttl_date entry. Modified by R. Fakoury 6/10/83 to add opr_msg facility. Modified by R. Fakoury 8/02/83 to fix a typo in opr_msg. Modified by R. Fakoury 10/84 to replace the internal proc, find_card with an external entry of find_card, and to remove the obsolete entry config. */ /****^ HISTORY COMMENTS: 1) change(84-11-01,Fakoury), approve(86-08-21,MCR7514), audit(86-11-17,Martinson), install(86-12-04,MR12.0-1235): to add the dev0_valid entry. to change call hcs_$status_long to hcs_$status_minf. END HISTORY COMMENTS */ /* tolts_util_ - a group of utility subroutines for TOLTS, MOLTS, POLTS, and ISOLTS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ tolts_util_: proc; /* External entries */ dcl decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3)); dcl (get_wdir_, get_default_wdir_) entry returns (char (168)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl (ioa_, ioa_$nnl, ioa_$rsnnl, com_err_) entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); dcl object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl opr_query_ entry options (variable); /* External static */ dcl iox_$user_input ptr ext; /* Entry parameters */ dcl seg_name entry; dcl com_string char (132) aligned; dcl mess char (*); dcl c_args (32) char (28) varying; dcl rcode fixed bin (35); dcl cmd_cnt fixed bin; dcl c_len fixed bin; dcl (a_iocbp, c_ptr) ptr; dcl config_name char (4); dcl in bit (*); dcl out char (*) varying; dcl bci_len fixed bin; dcl c_name char (32); dcl exec char (6); dcl state char (3); dcl ttl_date char (6); /* Automatic */ dcl 1 o_info like object_info; dcl (month, dom, year, dow) fixed bin; dcl tod fixed bin (71); dcl zone char (3); dcl ttl char (6); dcl bc fixed bin (24); dcl type fixed bin (2); dcl (i, j, lp, escape_cnt) fixed bin; dcl rec_len fixed bin (21); dcl seek_key char (256) varying; dcl ename char (32); dcl tim char (12); dcl cc char (1); dcl (temp_ptr, info_ptr, seg_ptr, iocbp) ptr; dcl cur_char bit (6); dcl bit_cnt fixed bin (24); dcl code fixed bin (35); /* error code */ dcl info (20) bit (36); dcl gki (20) bit (36); /* Builtins */ dcl (addr, addrel, before, date, divide, fixed, hbound, length, ltrim, null, rtrim, codeptr, ptr, reverse, search, substr, time, unspec, verify) builtin; /* Based */ dcl 1 rsi like rs_info aligned; dcl 1 cata_info based (c_ptr) aligned, /* info structure for cata_sel entry */ 2 n_keys fixed bin, /* number of multiple keys */ 2 cata_keys (1 refer (cata_info.n_keys)) char (24); /* multiple key array */ /* Constants */ dcl opn_ksi fixed bin int static options (constant) init (8); dcl bcd_to_ascii char (64) int static options (constant) init ("0123456789[#@:>? abcdefghi&.](<\^jklmnopqr-$*);'+/stuvwxyz_,%=""!"); dcl lib_dir char (168) int static options (constant) init (">system_library_tandd"); dcl WS char (2) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl NP char (1) int static options (constant) init (" "); %page; /* query - entry to query and get response from user */ query: entry (mess, com_string, c_len, c_args, cmd_cnt); cmd_cnt = 0; /* initilize parameters */ c_args = ""; m_retry: if length (rtrim (mess)) ^= 0 then /* only print message if there */ call ioa_$nnl (mess); /* print out prompt for user */ com_string = ""; /* clear out last command */ call iox_$get_line (iox_$user_input, addr (com_string), length (com_string), rec_len, code); if code ^= 0 then do; /* error reading from terminal */ call com_err_ (code, "tolts_util_$query", "reading input from user_input, re-enter"); go to m_retry; end; substr (com_string, rec_len) = ""; /* strip out new_line */ c_len = rec_len; /* set command line length */ if rec_len = 1 then return; /* return if no message */ /* separate arguments into arg array */ lp = 1; /* start at beginning of line */ do i = 1 to hbound (c_args, 1) while (lp < rec_len); j = length (ltrim (substr (com_string, lp, rec_len), WS)); /* strip off leading white space */ lp = (rec_len - j) + lp; /* lp = starting position of next string */ j = search (substr (com_string, lp), WS); /* find end of string */ c_args (i) = substr (com_string, lp, j - 1); lp = lp + (j - 1); /* update line position */ end; cmd_cnt = i - 1; /* set arg count for user */ return; %page; /* on_off - entry to display greeting or signoff message from executives */ on_off: entry (exec, state, ttl_date); tim = time; /* output message */ call ioa_ ("^/***^a executive version ^a ^a ^a at ^a", exec, ttl_date, state, date, substr (tim, 1, 2) || "." || substr (tim, 3, 3)); return; %page; /* bci_to_ascii - entry to convert bcd with imbedded escape and ignore characters to ascii */ bci_to_ascii: entry (in, out, bci_len); out = ""; /* pad output string with blanks */ escape_cnt = 0; /* initialize escape_cnt */ do i = 1 to bci_len; /* go through entire input string */ cur_char = substr (in, 6 * (i - 1) + 1, 6); /* pick up current bcd char */ if escape_cnt = 2 then /* if 2 times through here... */ go to use_char; /* convert the character */ else if cur_char = "77"b3 then /* escape character */ escape_cnt = escape_cnt + 1; /* increment escape count */ else if escape_cnt = 1 then do; /* if only 1 escape... */ lp = fixed (cur_char, 6); /* get slew count */ if lp = 0 then lp = 1; if lp >= 16 then /* if slew to top of page */ out = out || NP; /* set new page charater in out string */ else do j = 1 to lp; /* put in correct number off new lines */ out = out || NL; end; escape_cnt = 0; /* clear out escape cnt */ end; else if cur_char = "17"b3 then /* ignore character */ escape_cnt = 0; else do; /* valid bcd character */ use_char: cc = substr (bcd_to_ascii, fixed (cur_char, 6) + 1, 1); /* extract current char from table */ if cc = ")" | cc = "," then do; /* check for white space before close paren or comma */ j = verify (reverse (out), WS); /* find leading blank or tab */ if j ^= 1 then /* if we found some */ out = substr (out, 1, length (out) - j + 1); /* wipe it out */ end; out = out || cc; /* add in current character */ escape_cnt = 0; end; end; return; %page; /* search - entry to find and return a pointer to a test page */ search: entry (a_iocbp, c_name, c_ptr, c_len, rcode); temp_ptr, c_ptr = null; /* preset return parameters */ rcode, c_len = 0; iocbp = a_iocbp; /* copy dkfile iocb ptr */ ename = c_name; /* copy search name */ /* attempt to initiate the segment first in working dir, home dir and then in sys lib */ call hcs_$initiate_count ((get_wdir_ ()), ename, "", bit_cnt, 0, temp_ptr, code); if temp_ptr = null then /* no find, check home dir */ call hcs_$initiate_count ((get_default_wdir_ ()), ename, "", bit_cnt, 0, temp_ptr, code); if temp_ptr = null then /* no find, check sys dir */ call hcs_$initiate_count (lib_dir, ename, "", bit_cnt, 0, temp_ptr, code); if temp_ptr ^= null then do; /* found it, return to user */ c_ptr = temp_ptr; /* copy seg ptr */ c_len = divide (bit_cnt, 36, 17, 0); return; end; /* couldn't find entry as a ssf, now lets check to see if we have a deckfile */ if iocbp = null then do; /* deckfile not attached */ call find_deckfile ((get_wdir_ ())); /* try to find deckfile in working dir */ if code ^= 0 then /* no deck file there, try sys dir */ call find_deckfile (lib_dir); if code ^= 0 then do; /* still couln't find it, return */ rcode = code; /* give user the error */ return; end; end; call find_record; /* go find desired record */ if code = 0 then do; /* found it ok */ a_iocbp = iocbp; /* return good iocb ptr to user */ c_ptr = rsi.record_ptr; /* return ptr to deckfile record */ c_len = divide (rsi.record_length, 4, 17, 0); /* and record word length */ end; else rcode = code; /* else return error */ return; %page; /* cata_sel - entry to find all catalog search keys, given search key head */ cata_sel: entry (a_iocbp, c_name, c_ptr, rcode); rcode = 0; iocbp = a_iocbp; /* copy dkfile iocb ptr */ ename = c_name; /* copy search name */ info_ptr = addr (info); /* set info ptrs */ unspec (info) = "0"b; /* clear structure first */ if iocbp = null then do; /* deckfile not attached */ call find_deckfile ((get_wdir_ ())); /* try to find deckfile in working dir */ if code ^= 0 then /* no deck file there, try sys dir */ call find_deckfile (lib_dir); if code ^= 0 then do; /* still couln't find it, return */ rcode = code; /* give user the error */ if iocbp ^= null then a_iocbp = iocbp; /* let caller clean up */ return; end; end; a_iocbp = iocbp; /* copy iocb ptr back */ common_sl_info.version = sl_info_version_0; common_sl_info.list_type = 1; /* set to reuse subset */ common_sl_info.output_descriptors = "1"b; /* want descriptors */ common_sl_info.array_limit = 1; /* 1 element array */ common_sl_info.desc_arrayp = null; /* let vfile_ allocate area for storage */ hi_sl_info.first_head (1).length, hi_sl_info.last_head (1).length = length (rtrim (ename)); hi_sl_info.first_head (1).kptr, hi_sl_info.last_head (1).kptr = addr (ename); call iox_$control (iocbp, "select", addr (info), code); /* get select info */ if code ^= 0 then do; /* problem with select */ rcode = code; return; end; call iox_$position (iocbp, -1, 0, code); /* position to beginning of file */ if code ^= 0 then do; /* problem with select */ rcode = code; return; end; cata_info.n_keys = common_sl_info.count; /* copy number of descriptors */ gk_info_ptr = addr (gki); /* set info ptr */ unspec (gki) = "0"b; /* clear structure first */ gk_info.input_desc = "1"b; /* using input descriptors */ gk_info.reset_pos = "1"b; /* don't change position */ do i = 1 to common_sl_info.count; /* find each key */ gk_info.descrip = desc_array (i); /* insert each descriptor */ call iox_$control (iocbp, "get_key", addr (gki), code); if code ^= 0 then do; /* error */ rcode = code; return; end; cata_info.cata_keys (i) = gk_info.key; /* copy key */ end; common_sl_info.list_type = 0; /* set to reuse subset */ common_sl_info.subset_no = 0; common_sl_info.array_limit = 0; /* 0 element array */ common_sl_info.desc_arrayp = null; /* let vfile_ allocate area for storage */ call iox_$control (iocbp, "select", addr (info), code); /* reset current subset */ return; /* thats it folks */ %page; /* find_deckfile - int procedure to search for tandd_deck_file and return desired record info if found */ find_deckfile: proc (dir); dcl deckfile_dir char (168); dcl dir char (168); dcl type fixed bin (2) init (0); call hcs_$status_minf (dir, "tandd_deck_file", 1, type, 0, code); if type = 2 then do; /* found deck file 0 = link, 1 = seg, 2 = dir */ /* attach and open deck file for keyed seq input */ call iox_$attach_name ("dk_file_sw", iocbp, "vfile_ " || rtrim (dir) || ">tandd_deck_file", null, code); if code ^= 0 then return; call iox_$open (iocbp, opn_ksi, "0"b, code); /* attach ok, open it */ if code ^= 0 then return; unspec (rsi) = "0"b; /* clear structure */ rsi.version = rs_info_version_2; /* set proper version for vfile_ */ call iox_$control (iocbp, "record_status", addr (rsi), code); /* get record info */ if code ^= 0 then return; call hcs_$fs_get_path_name (rsi.record_ptr, deckfile_dir, 0, "", code); /* code always = 0 */ if before (deckfile_dir, ">tandd_deck_file") ^= lib_dir then call ioa_ ("Using ^a", deckfile_dir); end; end find_deckfile; /* find_record - int precdure to find desired record in deckfile */ find_record: proc; seek_key = ename; /* copy search key */ call iox_$seek_key (iocbp, seek_key, rec_len, code); /* find record */ if code = 0 then do; /* record exists, get record info */ unspec (rsi) = "0"b; /* clear structure */ rsi.version = rs_info_version_2; /* set proper version for vfile_ */ call iox_$control (iocbp, "record_status", addr (rsi), code); /* get record info */ end; end find_record; %page; /* find_card - external procedure to search config deck for desired config card */ find_card: entry (config_name, cardp); %include config_deck; dcl config_deck_end fixed bin based (addr (config_card.word)); if cardp = null then /* if pointer is null, set it */ cardp = addr (config_deck$); else cardp = addrel (cardp, 16); /* else go to next card */ do while (config_deck_end ^= -1); /* go through entire deck if necessary */ if config_card.word = config_name then /* found the right card */ return; else cardp = addrel (cardp, 16); /* get next card */ end; cardp = null; /* did'nt find it */ return; %page; /* get_ttl_date - entry to find date a obj seg was compiled */ get_ttl_date: entry (seg_name, ttl_date); seg_ptr = ptr (codeptr (seg_name), 0); o_info.version_number = 2; call hcs_$status_mins (seg_ptr, type, bc, code); call object_info_$display (seg_ptr, bc, addr (o_info), code); call decode_clock_value_ (o_info.compile_time, month, dom, year, tod, dow, zone); year = year - 1900; call ioa_$rsnnl ("^d^[0^]^d^[0^]^d", ttl, i, year, (month < 10), month, (dom < 10), dom); ttl_date = ttl; return; %page; /* opr_msg - internal procedure to send messages to the operator */ opr_msg: entry; dcl tolts_util_$query entry (char (*), char (132) aligned, fixed bin, (32) char (28) var, fixed bin); dcl d fixed bin (71) init (1); dcl c_string char (132) aligned; dcl (clen, c_cnt) fixed bin; dcl cargs (32) char (28) varying; call ioa_ ("^/enter 1 line message of up to 80 characters"); call tolts_util_$query ("??? ", c_string, clen, cargs, c_cnt); if substr (c_string, clen - 1, 1) = "?" then do; opr_query_info.q_sw = "1"b; opr_query_info.prim = ""; opr_query_info.alt = ""; opr_query_info.r_comment = "Please reply: x oqr followed by message of up to 80 characters"; if clen > 80 then clen = 80; /* truncate message length if necessary */ call opr_query_ (addr (opr_query_info), substr (c_string, 1, clen)); call ioa_ ("^a", opr_query_info.answer); end; else do; opr_query_info.q_sw = "0"b; /* no operator response needed */ call opr_query_ (addr (opr_query_info), substr (c_string, 1, clen)); end; return; %page; /* The following function returns the value of the first disk driver in a string . */ dev0_valid: entry (cdp, Model) returns (bit (1)); dcl (Model, nnames) fixed bin; dcl cdp ptr; dcl 1 cd_model_info based (cdp) aligned, 2 count fixed bin, 2 names (nnames) aligned, 3 model fixed bin, 3 name char (8), 3 dev_0_valid bit (1); nnames = cd_model_info.count; do i = 1 to cd_model_info.count while (cd_model_info.names (i).model ^= Model); end; if cd_model_info.names (i).dev_0_valid then return ("1"b); else return ("0"b); %page; %include ak_info; %page; %include object_info; %page; %include opr_query_info; %page; %include rs_info; %page; %include select_info; %page; %include status_structures; end tolts_util_; 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