cv_error_.pl1 11/11/89 1139.1rew 11/11/89 0838.7 23535 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Function to return an error code from an error name. This entry can be called by programs written in languages which can not directly reference names of the form "reference$entry". */ /* Originally written 22 March 1982 by Chris Jones */ /* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */ cv_error_: proc; signal bad_call_; /* not a valid entry */ return; name: entry (error_name, converted_code, code); dcl code fixed bin (35) parameter; /* the result of this operation */ dcl converted_code fixed bin (35) parameter; /* the answer to the question */ dcl error_name char (*) parameter; /* the error name (e.g. "error_table_$bad_arg" */ dcl et_ptr ptr; /* pointer to the error code */ dcl based_code fixed bin (35) based (et_ptr); dcl 1 cc aligned based, /* this structure is laid over converted_code */ 2 segno bit (18) unal, 2 pad bit (18) unal; dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl cv_ptr_$terminate entry (ptr); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl error_table_$ fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl any_other condition; dcl bad_call_ condition; dcl cleanup condition; dcl (addr, after, baseno, before, null) builtin; call hcs_$make_ptr (null (), before (error_name, "$"), after (error_name, "$"), et_ptr, code); if code ^= 0 then return; et_ptr = null (); on cleanup call CLEAN_UP; et_ptr = cv_ptr_ (error_name, code); if code ^= 0 then do; ERROR_RETURN: call CLEAN_UP; return; end; on any_other begin; code = error_table_$bad_arg; goto ERROR_RETURN; end; converted_code = based_code; if baseno (et_ptr) ^= baseno (addr (error_table_$)) then addr (converted_code) -> cc.segno = baseno (et_ptr); /* put in segment number for non error_table_ codes */ call CLEAN_UP; code = 0; return; CLEAN_UP: proc; if et_ptr ^= null () then call cv_ptr_$terminate (et_ptr); et_ptr = null (); end CLEAN_UP; end cv_error_;  default_error_handler_.pl1 11/11/89 1139.1rew 11/11/89 0830.0 281286 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-05,Lippard), approve(87-06-22,MCR7718), audit(87-07-01,Fawcett), install(87-07-15,MR12.1-1041): Modified to verify that entries returned by call to hcs_$make_ptr are actually in the segment message_table_. 2) change(88-05-19,Hergert), approve(88-05-19,MCR7903), audit(88-05-19,Dupuis), install(88-08-01,MR12.2-1073): John Hergert (FMC) Added code to handle mrds_se_error_ condition for MRDS. 3) change(89-05-26,Farley), approve(89-06-22,MCR8114), audit(89-06-22,Fawcett), install(89-06-26,MR12.3-1064): Added initialization of the currently uninitailized no_restart flag to allow restarts as the default. END HISTORY COMMENTS */ /*format: style2 */ /* default_error_handler_.pl1 */ dummy: procedure; /* This is the default error handling routine used by Multics. There are several entries as follows: default_error_handler_ no condition wall handles program_interrupt ignore_pi no condition wall ignores program_interrupt wall yes condition wall handles program_interrupt wall_ignore_pi yes condition wall ignores program_interrupt interpret_condition_ returns to caller without calling cu_$cl condition_interpreter_ change_error_mode_ reprint_error_message_ reinterpret_condition_ add_finish_handler /* initially coded by M. Weaver 12 February 1970 */ /* modified by M. Weaver 27 September 1971 */ /* recoded by M. Weaver 12 October 1973 to handle software conditions better */ /* modified by M. Weaver 6/13/74 for finish and storage conditions and to use iox_ */ /* modified 11/76 by M. Weaver to move illegal_procedure handling to better place */ /* Last modified (Date and Reason): Aug 12, 1977 by Steve Webber to add wall entries and merge with standard_default_handler_. Aug 17, 1977 by Steve Webber to use new message_table_ format Nov 18, 1977 by Melanie Weaver to fix bugs in reprint_error and quit handling Dec 19, 1977 by Melanie Weaver to fix bug in illegal_procedure handling Nov. 22, 1978 by Melanie Weaver to print long messages in their entirety March 1979 by T. Casey to add call to sus_signal_handler_. July 1979 by Steve Webber to pass "finish" through the wall entries. April 1981 by Benson I. Margulies for null_pointer_ instead of simfault. remove special cases for conditions already caught by static handlers, use find_condition_info_, respect the quiet_restart bit, and houseclean some. July 1981 by BIM for the new program interrupt (kludge) special case. December 1981 by E. N. Kittlitz for quit_info. June 1983 by M. Weaver for fortran_pause. September 1983 by M. Weaver to put newline before fortran_pause message. 1984-10-18 BIM to special case signal_io_ in the normal case ( terminate the process if user_i/o) and in the blowup_handler_ (pass it through if on error_output). */ /* Parameters */ /* Used only by the interpreting entrypoints, not the actual handlers */ dcl a_mcptr ptr; dcl a_conname char (*); dcl a_wcptr ptr; dcl a_infoptr ptr; dcl a_flag bit (1) aligned; /* Automatic */ dcl eof bit (1) aligned; dcl establish_wall bit (1) aligned; dcl found bit (1) aligned; dcl 1 dd aligned like decode_definition_str; dcl iocb_ptr ptr; dcl cond_id char (46) var; /* for condition name */ dcl ring_mes char (10); /* ring n or lower ring */ dcl retsw bit (1) aligned; dcl realsw bit (1) aligned init ("1"b); /* indicates whether this is a "rerun" */ dcl defaultsw bit (1) aligned; /* indicates to use conname as such in message */ dcl no_restart bit (1) aligned; dcl ignore_pi_sw bit (1) aligned; dcl pass_finish_sw bit (1) aligned; dcl optr ptr; dcl longsw_ptr ptr; dcl lsp ptr; /* ptr to stack frame at time of condition */ dcl new_con char (32) varying; dcl temp_longsw fixed bin init (-1); dcl (flong, i) fixed bin; dcl long fixed bin; dcl code fixed bin (35); dcl resetwrite bit (1) aligned; dcl 1 cl_arg aligned, 2 reset_sw bit (1) unaligned, 2 pad bit (35) unaligned; /* External */ dcl message_table_$privileged_info ext; dcl message_table_$soft_default_info ext; dcl message_table_$hard_default_info ext; dcl message_table_$formats (26) char (104) var ext; %include iox_entries; /* Static */ dcl real_longsw fixed bin int static init (1); dcl rptsw fixed bin (17) int static init (0); /* indicates level of recursion in blowup handler */ /* Based */ dcl based_var char (256) var based; dcl longsw fixed bin based (longsw_ptr); dcl ostring char (1000) aligned based (optr); /* based string for output */ dcl any_other condition; /* Big String Department */ dcl (pname1, pname2, pname3, tname1, tname2) char (500) aligned; dcl linfo char (500) var; dcl my_string char (1000); /* actual space normally used for output */ /* Entries */ declare condition_ entry (char (*), entry); declare reversion_ entry (char (*)); dcl cu_$cl entry (1 aligned, 2 bit (1) unaligned, 2 bit (35) unaligned); dcl decode_definition_ entry (ptr, ptr, bit (1) aligned); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl ( ioa_$ioa_switch, ioa_$rs, ioa_$rsnnl ) entry options (variable); dcl signal_ ext entry options (variable); dcl linkage_error_ entry (ptr, fixed bin, ptr, ptr, char (500) aligned, char (500) aligned, ptr, fixed bin); dcl get_ppr_ entry (fixed bin, ptr, ptr, char (500) aligned, char (500) aligned, char (500) aligned); dcl get_tpr_ entry (ptr, ptr, ptr, char (500) aligned, char (500) aligned); dcl special_messages_ entry (ptr, ptr, char (500) var, bit (1), bit (1) aligned); dcl interpret_info_struc_ ext entry (char (32), ptr, char (500) var, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin); dcl interpret_info_struc_$no_message entry (char (32), ptr); dcl find_condition_frame_ entry (ptr) returns (ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl (addr, baseno, baseptr, bin, byte, codeptr, length, null, ptr, size, string, unspec) builtin; wall_ignore_pi: entry; pass_finish_sw = "1"b; ignore_pi_sw = "1"b; establish_wall = "1"b; go to COMMON; standard_default_handler_: wall: entry; pass_finish_sw = "0"b; ignore_pi_sw = "0"b; establish_wall = "1"b; goto COMMON; ignore_pi: entry; pass_finish_sw = "1"b; ignore_pi_sw = "1"b; establish_wall = "0"b; go to COMMON; default_error_handler_: entry; pass_finish_sw = "0"b; establish_wall = "0"b; ignore_pi_sw = "0"b; COMMON: mtep = null (); iocb_ptr = iox_$error_output; lsp = null (); realsw = "1"b; /* we are an error handler, not an interpreter */ retsw = "0"b; /* this entry usually does not just return */ no_restart = "0"b; /* allow restarts by default */ call condition_ ("any_other", blowup_handler_); call get_condition_info; /* pickup condition info */ /* Now check for common conditions */ /* finish passes walls */ if (cond_info.condition_name = "finish") then do; if pass_finish_sw /* can only be on if realsw is on */ then call continue_to_signal_ (0); go to exit; end; /* we may need to do more for pi someday, so it is in its own statement */ /* ignore_pi_sw only on if realsw on */ if ignore_pi_sw & (cond_info.condition_name = "program_interrupt") then do; call continue_to_signal_ (0); go to exit; end; /**** The following special case improves the system's behavior when then signal_io_ I/O module is in use on a critical switch */ if realsw & (cond_info.condition_name = "signal_io_") then do; if cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_io | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_output | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$user_input | cond_info.info_ptr -> signal_io_info.iocb_ptr = iox_$error_output then call terminate_process; /* no one is dealing with critical I/O */ end; if realsw & cond_info.condition_name = "quit" then do; call reversion_ ("any_other"); /* check for condition_info which directs reset operations. This is currently only present if a call to signal_ was made. sus_signal_handler_ does this very thing. */ if cond_info.info_ptr ^= null then if cond_info.info_ptr -> quit_info.version = 1 & cond_info.info_ptr -> quit_info.length = size (quit_info) then resetwrite = cond_info.info_ptr -> quit_info.switches.reset_write; else resetwrite = "1"b; /* do the reset if not told otherwise */ if resetwrite then call iox_$control (iox_$user_io, "resetwrite", null, (0)); call iox_$control (iox_$user_io, "printer_on", null, (0)); call ioa_$ioa_switch (iox_$user_io, "QUIT"); if establish_wall then on any_other call wall_ignore_pi; cl_arg.reset_sw = "0"b; cl_arg.pad = "0"b; call cu_$cl (cl_arg); go to exit; end; /*** format: off */ if (cond_info.condition_name = "command_error" | cond_info.condition_name = "command_question") /* preserve special case for private versions */ then go to exit; /*** format: ^off */ /* reprinters and interpreters enter here */ begin: optr = addr (my_string); begin_com: cl_arg.reset_sw = "1"b; /* set resetread switch for all other conditions */ cl_arg.pad = "0"b; /* initialize variables to be args */ if cond_info.mc_ptr ^= null () then scup = addr (cond_info.mc_ptr -> mc.scu); else scup = null (); /* the following must be initialized here as longsw can be referenced if cond_info.mc_ptr is null */ if temp_longsw ^= -1 then longsw_ptr = addr (temp_longsw); /* have temporary message mode */ else longsw_ptr = addr (real_longsw); defaultsw = "0"b; /* Now get a pointer to the appropriate message_table entry */ found = "0"b; call hcs_$make_ptr (codeptr (wall), "message_table_", (cond_info.condition_name), mtep, code); if mtep ^= null () then do; call decode_definition_ (baseptr (baseno (mtep)), addr (dd), eof); do while (^eof & ^found); if dd.section = "segn" then if dd.symbol = "message_table_" then found = "1"b; call decode_definition_ (dd.next_def, addr (dd), eof); end; found = "0"b; do while (^eof & ^found); if dd.section ^= "text" then eof = "1"b; else if dd.entrypoint = 0 then if dd.symbol = cond_info.condition_name then found = "1"b; else call decode_definition_ (dd.next_def, addr (dd), eof); end; end; if ^found then do; if cond_info.mc_ptr = null then mtep = addr (message_table_$soft_default_info); else mtep = addr (message_table_$hard_default_info); defaultsw = "1"b; end; /* if the condition is mrds_se_error and we made it into default_error_handler_ then we can assume the user did not handle the condition. We set the value in mrds_se_error_info.header.info_string equal to the string "default_error_handler_" to tell the signaller to handle the error. */ if cond_info.condition_name = "mrds_se_error_" then do; cond_info.info_ptr -> mrds_se_error_info.header.info_string = "default_error_handler_"; goto exit; end; if cond_info.condition_name = "error" then if cond_info.info_ptr = null () then do; /* signalled by another handler */ linfo = "system handler for error returns to command level "; long = length (linfo); if cond_info.crawlout then do; /* must still tell user about crawlout */ ostring = "Error while processing in lower ring:" || byte (10) /* NL */ || linfo; long = long + 38; end; else ostring = linfo; go to out; end; if mte.endpage then if ^cond_info.crawlout then if cond_info.info_ptr ^= null () then if realsw then do; /* indicate end of page in file */ call interpret_info_struc_$no_message ((cond_info.condition_name), cond_info.info_ptr); go to exit; end; if cond_info.condition_name = "underflow" then if ^cond_info.crawlout /* be sure test performed for all modes */ then retsw = "1"b; /* default is to return, but can't on cond_info.crawlout */ if longsw = 0 then if cond_info.condition_name ^= "fortran_pause" then do; /* just print condition name */ if cond_info.crawlout then if cond_info.mc_ptr ^= null then call ioa_$rs ("^/Error: ^a while in ring ^d", ostring, long, cond_info.condition_name, bin (scup -> scu.ppr.prr, 3)); else call ioa_$rs ("^/Error: ^a while in lower ring", ostring, long, cond_info.condition_name); else call ioa_$rs ("^/Error: ^a", ostring, long, cond_info.condition_name); /* just print name */ go to out; end; else ; /* handle fortran_pause later */ else do; /* (longsw > 0) print part common to all messages */ if cond_info.crawlout then /* try to print ring no. */ if cond_info.mc_ptr ^= null then call ioa_$rsnnl ("ring ^d", ring_mes, long, bin (scup -> scu.ppr.prr, 3)); else ring_mes = "lower ring"; end; if mte.undefined then do; /* we have a division of illegal_procedure which the fim didn't isolate for us */ if scup -> scux.fd.isp then mtep = addr (message_table_$privileged_info); /* this is a special case */ else do; /* some other random type */ mtep = addr (message_table_$hard_default_info); defaultsw = "1"b; /* so cond_info.condition_name will get printed */ end; end; if defaultsw then new_con = cond_info.condition_name; else new_con = ""; /* rest of stuff contains enough information */ if cond_info.info_ptr ^= null then do; if realsw & cond_info.info_ptr -> condition_info_header.action_flags.quiet_restart then go to exit; call interpret_info_struc_ ((cond_info.condition_name), cond_info.info_ptr, linfo, retsw, no_restart, realsw, longsw); /* Program interrupt has a special case here, because it is not strictly "quiet restart". See the source of program_interrupt.pl1 for an explanation of the protocol, and interpret_info_struc_ for the real work of this side of the protocol. */ if cond_info.condition_name = "program_interrupt" then go to exit; if mte.active_func then do; ostring = linfo; long = length (linfo); go to out; /* don't print pathname */ end; end; /* the following two conditions get special treatment */ if mte.linkerr then if ^cond_info.crawlout then do; /* ordinary linkage _error */ call linkage_error_ (cond_info.mc_ptr, longsw, lsp, addr (cond_info), pname1, pname2, optr, long) ; /* linkage_error_ calls get_ppr_ itself */ go to out; end; if mte.sub_err then new_con = cond_info.info_ptr -> sub_error_info.name; /* use more descriptive name */ if longsw = 0 & (cond_info.condition_name = "fortran_pause") then do; call ioa_$rs ("^/^a", ostring, long, linfo); go to out; end; /* get the name of the procedure that took the fault */ call get_ppr_ (longsw, lsp, addr (cond_info), pname1, pname2, pname3); /* find out what was being referenced */ call get_tpr_ (lsp, addr (cond_info), mtep, tname1, tname2); cond_id = ""; /* set default value */ if longsw = 2 then cond_id = ptr (mtep, mte.cond_id_relp) -> based_var; if mte.no_special = "0"b then call special_messages_ (cond_info.mc_ptr, mtep, linfo, cond_info.crawlout, no_restart); /* format messages */ /* obtain format string and assemble message */ if cond_info.condition_name = "fortran_pause" then do; /* this doesn't fit the message_table_ scheme */ call ioa_$rs ("^/^a at ^a^a^[^/^;^]^a", ostring, long, linfo, pname1, pname2, longsw = 2, cond_id); go to out; /* should not have a crawlout with this condition */ end; if cond_info.crawlout then do; call ioa_$rs (message_table_$formats (mte.format_x + 1), ostring, long, ring_mes, new_con, ptr (mtep, mte.string_relp (1)) -> based_var, pname3, ptr (mtep, mte.string_relp (2)) -> based_var, tname1, linfo, ptr (mtep, mte.string_relp (3)) -> based_var, ptr (mtep, mte.string_relp (4)) -> based_var, pname1, pname2, tname2, cond_id); end; else do; /* Not cond_info.crawlout */ call ioa_$rs (message_table_$formats (mte.format_x), ostring, long, new_con, ptr (mtep, mte.string_relp (1)) -> based_var, pname1, pname2, ptr (mtep, mte.string_relp (2)) -> based_var, tname1, linfo, ptr (mtep, mte.string_relp (3)) -> based_var, ptr (mtep, mte.string_relp (4)) -> based_var, cond_id); end; /* warn user if any IPS interrupts have been recently disabled */ /* out: if cond_info.mc_ptr ^= null then if substr(cond_info.mc_ptr -> mc.ips_temp,36,1) = "1"b then do; call hcs_$get_ips_mask (ips_mask); ips_string = ""; do i = 1 to sys_info$ips_mask_data.count; if (cond_info.mc_ptr -> mc.ips_temp & sys_info$ips_mask_data.masks(i).mask) > (ips_mask & sys_info$ips_mask_data.masks(i).mask) then do; if ips_string = "" then ips_string = substr(masks(i).name, 1, index(masks(i).name, "")-1); else ips_string = ips_string || ", " || substr(masks(i).name, 1, index(masks(i).name, "") -1 ); end; end; if ips_string ^= "" then call ioa_$rs("^a^a disabled", ostring, long, ostring, ips_string); end; */ /* print it out at last! */ out: if (iocb_ptr ^= null) then if (long > 0) & (optr ^= null) then do; call iox_$put_chars (iocb_ptr, optr, (long), code); call iox_$control (iocb_ptr, "start", null (), (0)); /* just in case a timer that did not expect to print took a fault */ end; else ; else mlong = long; /* called from return string entry */ last: /* clean up and leave */ if retsw then go to exit; else do; call reversion_ ("any_other"); /* but don't want blowup handler to get invoked */ rptsw = 0; /* can't enter blowup handler again */ if mtep ^= null then if mte.sig_error /* CHECK THIS SOMETIME */ then call signal_ ("error"); /* these are really pl1 conditions */ else go to go_to_cl; /* pl1 clumsiness */ else go_to_cl: do; if establish_wall then on any_other call wall_ignore_pi; call cu_$cl (cl_arg); if establish_wall then revert any_other; end; if no_restart then do; /* don't allow restart */ call ioa_$ioa_switch (iox_$error_output, "computation cannot be restarted"); go to go_to_cl; end; end; exit: /* we are here if we want to return and not abort */ rptsw = 0; /* can't enter blowup handler again */ return; interpret_condition_: entry (a_mcptr, a_conname, a_wcptr, a_infoptr, a_flag);/* this entry point prints out a message and returns */ /* it can be used by procedures who want to call the default handler */ /* ASSERT: there is a fault frame on the stack, these arguments are not just constructed */ call get_condition_info; realsw = "0"b; /* do not suppress quiet conditions */ retsw = "1"b; /* definitely return */ go to begin; /* */ blowup_handler_: procedure (mc_ptr, condition_name, wc_ptr, info_ptr, continue_flag); declare ( continue_flag bit (1) aligned, (mc_ptr, wc_ptr, info_ptr) pointer, condition_name character (*) ) parameter; dcl mess0 char (40) aligned; dcl short_mess char (8) aligned; /* for convert_status_code_ */ dcl long_mess char (100) aligned; dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); /* this is the default handler for default_error_handler_ */ /*** format: off */ if condition_name = "quit" | condition_name = "alrm" | condition_name = "cput" | condition_name = "program_interrupt" | condition_name = "storage" | condition_name = "finish" | condition_name = "signal_io_" /* might be needed to do the work */ then do; call continue_to_signal_ ((0)); /* works fine */ return; end; /*** format: ^off */ rptsw = rptsw + 1; /* increase recursion indicator */ if rptsw = 3 then do; /* can't even write on user_i/o; terminate proc */ call terminate_process; go to last; /* if not... */ end; if ^cond_info.crawlout then mess0 = byte (10) /* NL */ || "Error:"; else mess0 = byte (10) /* NL */ || "Error while processing in lower ring: "; /* the next section is for dire emergencies, when we don't trust anything */ if rptsw = 2 then do; /* don't take chances with rqo--use user_i/o */ call ioa_$ioa_switch (iox_$user_io, "^/^a^a (Unable to obtain proper message.)", mess0, condition_name); go to last; /* rptsw will be reset there */ end; /* at this point, try at least to get decent names to print */ if mc_ptr ^= null then do; /* have machine conditions */ if (wc_ptr ^= null ()) /* crawlout */ then pname1 = pname3; /* print name from mc */ if pname1 = "" then call format_name (ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc), pname1); if tname1 = "" then call format_name (ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca), tname1); if mc_ptr -> mc.errcode = 0 then long_mess = ""; else do; call convert_status_code_ ((mc_ptr -> mc.errcode), short_mess, long_mess); if short_mess = "xxxxxxxx" then long_mess = ""; /* don't print code not found */ end; /* print basic message for original fault */ call ioa_$rs ("^/^a ^a condition by ^a^/referencing ^a^/^a", ostring, long, mess0, cond_info.condition_name, pname1, tname1, long_mess); end; else do; /* no mc -> no pathnames */ if linfo ^= "" then go to print; /* have as much as we can get */ if info_ptr ^= null then do; /* see what we can find in info structure */ call interpret_info_struc_ ((condition_name), info_ptr, linfo, retsw, no_restart, realsw, longsw); end; print: call ioa_$rs ("^/^a ^a condition^/^a", ostring, long, mess0, condition_name, linfo); end; go to out; /* print it out */ format_name: proc (p, name); dcl p ptr; dcl code fixed bin (35); dcl find_pathname_ entry (ptr, ptr, fixed bin (35)); dcl name char (500) aligned; dcl 1 name_info aligned like find_pathname_info automatic; call find_pathname_ (p, addr (name_info), code); if name_info.component_ename ^= "" then /* use name from bindmap */ call ioa_$rsnnl ("^a^a (^a^a^a^a^a)^a", name, long, name_info.component_ename, name_info.adjusted_offset, name_info.dirname, name_info.gt_char, name_info.real_ename, name_info.real_offset, name_info.pdir_string, name_info.offset_msg); else call ioa_$rsnnl ("^a^a^a^a^a^a", name, long, name_info.dirname, name_info.gt_char, name_info.real_ename, name_info.real_offset, name_info.pdir_string, name_info.offset_msg); return; end format_name; end blowup_handler_; change_error_message_mode_: entry (longsw_val); /* this entry allows the user to specify the length of the message that he wants */ /* the possibilities are: 0 for brief, 1 for normal, and 2 for long */ /* (long means that both sets of machine conditions will be printed on crawl_outs */ dcl longsw_val fixed bin; if longsw_val < 0 | longsw_val > 2 then real_longsw = 1; /* set to default */ else real_longsw = longsw_val; return; reprint_error_message_: entry (areap, mptr, mlong, mode, depth, ecode); /* this entry is called from a command and looks back in the stack for the arguments of a previous invocation of default_error_handler_. These are used to call default_error_handler_ recursively nad print out the message again. this feature would normally be used when the first message was of the short form and a longer message is desired. */ dcl (depth, ecode) fixed bin; /* depth specifies how many stack frames to go back */ i = 0; do lsp = find_condition_frame_ (null) repeat find_condition_frame_ (lsp); /* do not use language for test */ if lsp = null then go to return_no_such_level; i = i + 1; /* count number of levels we have found */ /* we do not want a while loop, we want an until loop. so we hand to the test-and-go-to, to avoid an extra pass through the repeat code */ if i = depth then go to found_level; end; found_level: /* get arguments from earlier frame so we can call ourself */ call get_condition_info_code (code); if code ^= 0 then do; call ioa_$ioa_switch (iox_$error_output, "condition information not available for level ^d", depth); ecode = -1; return; end; call reinterpret_condition_ (areap, mptr, mlong, mode, cond_info.mc_ptr, (cond_info.condition_name), cond_info.wc_ptr, cond_info.info_ptr, lsp); return_no_such_level: ecode = i; /* tell them how far we went */ return; reinterpret_condition_: entry (areap, mptr, mlong, mode, c_mcptr, c_conname, c_wcptr, c_infoptr, r_sp); /* this entry is identical to condition_interpreter_ except that the real switch is turned off, and a stack ptr can be supplied */ declare r_sp ptr; realsw = "0"b; retsw = "1"b; lsp = r_sp; go to ci_start; condition_interpreter_: entry (areap, mptr, mlong, mode, c_mcptr, c_conname, c_wcptr, c_infoptr); /* this entry is just like interpret_condition_ except that the string can be returned */ /* an area is provided for that purpose */ dcl (areap, mptr) ptr; dcl (mlong, mode) fixed bin; dcl (c_mcptr, c_wcptr, c_infoptr) ptr; dcl c_conname char (*); dcl based_area area based (areap); dcl re_map_mode (1:3) fixed bin init (1, 0, 2); /* These next two bits are really very important. realsw causes this entrypoint to actually perform condition semantics, like setting the bit in the active_function_error structure to indicate that the message has been printed. It will also return null messages for conditions with quiet_restart. How it's caller is supposed to know whether restarting is appropriate is beyond me. retsw, on the other hand, prevents this entry from getting to command level. This entrypoint is not very useful, therefore, but its all we document. --bim What we really want is an entrypoint with a return string AND realsw off and retsw on, which we lack. That might be more useful that this, but changing this to do that would be incompatable. */ realsw = "1"b; retsw = "1"b; lsp = null (); ci_start: call condition_ ("any_other", blowup_handler_); iocb_ptr = null (); /* until proven otherwise */ optr = addr (my_string); /* if there is something on the stack it supercedes args */ /* so we call find_condition_info_ */ call get_condition_info_code (code); if code ^= 0 then do; /* strictly caller should not call unless there is an error on the stack, but we try anyway */ cond_info.version = condition_info_version_1; cond_info.mc_ptr = c_mcptr; cond_info.wc_ptr = c_wcptr; cond_info.info_ptr = c_infoptr; string (cond_info.flags) = ""b; if cond_info.wc_ptr ^= null () then cond_info.crawlout = "1"b; /* good guess */ cond_info.pad2 = ""b; cond_info.user_loc_ptr = null (); cond_info.pad3 (*) = ""b; end; if areap = null then iocb_ptr = iox_$error_output; /* print error message rather than returning it */ else do; /* return message in area provided */ iocb_ptr = null; /* won't be using switch */ allocate ostring in (based_area) set (optr); mptr = optr; /* let caller know where message is */ mlong = 0; /* initialize in case there is no message to be returned */ end; if mode < 1 | mode > 3 then temp_longsw = real_longsw; /* if not specified, set to current mode */ else temp_longsw = re_map_mode (mode); /* be sure mode has correct value for us */ retsw = "1"b; /* definitely return */ flong = 8; /* indicates which arg is infoptr */ go to begin_com; /* */ add_finish_handler: entry (fhandler, xcode); /* this entry adds the specified entry to a list to be called for the finish condition */ dcl xcode fixed bin (35); dcl fhandler entry (); dcl add_epilogue_handler_ entry (entry) returns (fixed bin (35)); xcode = add_epilogue_handler_ (fhandler); return; get_condition_info: procedure; declare code fixed bin (35); declare code_flag bit (1); code_flag = "0"b; goto common; get_condition_info_code: entry (a_code); declare a_code fixed bin (35); code_flag = "1"b; a_code = 0; common: unspec (cond_info) = ""b; cond_info.version = condition_info_version_1; cond_info.mc_ptr = null (); cond_info.wc_ptr = null (); cond_info.info_ptr = null (); cond_info.user_loc_ptr = null (); pname1, pname2, pname3, tname1, tname2, linfo = ""; if lsp = null () then lsp = find_condition_frame_ (null ()); /* find the offending frame */ call find_condition_info_ (lsp, addr (cond_info), code); if code ^= 0 then do; if code_flag then do; a_code = code; return; end; else go to exit; /* nothing on stack, we cannot do anything */ end; condition_info_header_ptr = cond_info.info_ptr; /* find the bits */ end get_condition_info; terminate_process: procedure; declare terminate_process_ entry (char (*), ptr); declare error_table_$unable_to_do_io fixed bin (35) ext static; declare 1 terminate_info aligned, 2 version init (0), 2 status_code fixed bin (35); terminate_info.status_code = error_table_$unable_to_do_io; call terminate_process_ ("fatal_error", addr (terminate_info)); /* should not return */ end terminate_process; %include condition_info; dcl 1 cond_info aligned like condition_info; %include condition_info_header; %page; %include decode_definition_str; %page; %include quit_info; %page; %include mrds_se_error_info; %page; %include signal_io_info; %include sub_error_info; %page; %include stack_header; %include stack_frame; %page; %include mc; %page; %include message_table_entry; %page; %include find_pathname_info; end dummy;  find_pathname_.pl1 11/11/89 1139.1rew 11/11/89 0839.0 43326 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ find_pathname_: proc (locp, strucp, code); /* This procedure returns pathname information about a given pointer. */ /* coded by M. Weaver July 1973 */ /* last modified by M. Weaver 27 November 1973 */ /* Modified to use include file and clean up April 81 Benson i Margulies */ declare (locp, segp, strucp) ptr; declare (code, ecode) fixed bin (35); declare error_table_$oldobj ext fixed bin (35); declare (lng, highct, hcsct, cur_lab) fixed bin; declare map bit (1) aligned; declare temp char (6) aligned; declare aligned_component_ename character (32) aligned; declare (bin, baseno, byte, rel, null, ptr) builtin; declare convert_binary_integer_$octal_string entry (fixed bin (35)) returns (char (13) var); declare ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); declare find_condition_info_ entry (ptr, ptr, fixed bin (35)); declare continue_to_signal_ entry (fixed bin (35)); declare hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); declare hcs_$high_low_seg_count entry (fixed bin, fixed bin); declare interpret_bind_map_ entry (ptr, char (32) aligned, fixed bin (18), fixed bin (35)); declare get_pdir_ entry () returns (char (168)); declare any_other condition; %include find_pathname_info; /* initialize structure so it will always be printable */ find_pathname_info_ptr = strucp; component_ename = ""; adjusted_offset = ""; dirname = ""; gt_char = ""; real_ename = ""; pdir_string = ""; offset_msg = ""; bin_adjusted_off = 0; bin_real_off = bin (rel (locp), 18); real_offset = "|" || convert_binary_integer_$octal_string (bin (bin_real_off, 35)); /* see if segment is in ring 0; if so, we can't get name from KST */ segp = ptr (locp, 0); call hcs_$high_low_seg_count (highct, hcsct); /* find out which segs are in r0 */ if bin (baseno (segp), 18) <= hcsct then do; cur_lab = 1; /* indicates return loc to handler */ on any_other call catch; call ring0_get_$name (dirname, real_ename, segp, code); revert any_other; if code ^= 0 then go to ret_segno; /* return something for name */ if (dirname ^= "") & (dirname ^= ">") then gt_char = ">"; return; end; /* pick up pathname */ call hcs_$fs_get_path_name (segp, dirname, lng, real_ename, code); if code ^= 0 then do; /* return something for name */ finish (1): ret_segno: real_ename = convert_binary_integer_$octal_string (bin (bin (baseno (segp), 18), 35)); return; end; /* get component name from bindmap it it exists; be prepared for access fault */ map = "0"b; /* indicates have not looked at bind map */ cur_lab = 2; /* indicates return loc for handler */ on any_other call catch; call interpret_bind_map_ (locp, aligned_component_ename, bin_adjusted_off, ecode); if ecode = 0 then component_ename = aligned_component_ename; map = "1"b; /* id not fault */ revert any_other; /* fill in rest of items */ finish (2): if dirname = get_pdir_ () then do; /* don't print messy string */ pdir_string = " (in process dir)"; dirname = ""; end; if (dirname ^= "") & (dirname ^= ">") then gt_char = ">"; if (ecode = error_table_$oldobj) | ^map then offset_msg = byte (10 /* NL */) || "(offset is relative to base of segment)"; if (ecode = 0) & map then do; /* get compiler error when put all on 1 line */ temp = convert_binary_integer_$octal_string (bin (bin_adjusted_off, 35)); adjusted_offset = "|" || temp; end; return; catch: procedure; %include condition_info; declare 1 CI aligned like condition_info; CI.version = condition_info_version_1; on any_other go to finish (cur_lab); call find_condition_info_ (null (), addr (CI), (0)); revert any_other; if /* tree */ CI.condition_name ^= "quit" then if CI.condition_name ^= "alrm" then if CI.condition_name ^= "cput" then if CI.condition_name ^= "storage" then if CI.condition_name ^= "finish" then if CI.condition_name ^= "program_interrupt" then go to finish (cur_lab); /* probably access fault */ call continue_to_signal_ (0); return; end catch; end find_pathname_;  get_ppr_.pl1 11/11/89 1139.1r w 11/11/89 0839.0 137061 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style1 */ get_ppr_: proc (length_sw, asp, sptr, pname1, pname2, pname3); /* This procedure returns the name(s) and location(s) of the procedure(s) active when a condition occurred. If the condition occurred in a support 3 procedure, the name of the most recent non-support procedure will also be returned. */ /* last modified by M. Weaver 23 October 1973 */ /* Modified by B. Margulies for include files and cleanup */ /* Further modified to check the ring brackets of the ppr segment before calling object_info on it */ /* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */ declare (pname1, pname2, pname3, ptemp) char (500) aligned; declare (link_segname, op_seg_name) char (32) aligned; /* enttypoint is either the file system entryname or the entrypoint name. The first comes from get_entry_name_, the second from interpret_link_. Note that interpret_link_ truncates to 32 */ declare (entryname, entrypoint) char (256) aligned; declare lang char (8) aligned; declare spno bit (18) aligned; declare find_op bit (1) aligned; declare length_sw fixed bin; declare lng fixed bin; declare segno fixed bin (18); declare code fixed bin (35); declare (asp, nsp, use_ptr, last_ptr, sptr) ptr; declare (addr, after, baseno, baseptr, before, byte, bin, null, ptr, rel, rtrim, substr) builtin; declare ioa_$rsnnl entry options (variable); declare stack_frame_exit_ entry (ptr, ptr, ptr, bit (1) unaligned, ptr, char (32) aligned, ptr); declare get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)); declare is_cls_ entry (ptr) returns (bit (1) aligned); %include condition_info; declare 1 cond_info aligned like condition_info based (sptr); declare 1 situation aligned, ( 2 bad_frame, 2 exists_ppr, 2 ppr_is_owner, 2 ppr_is_ops, 2 caller_is_owner, 2 entry_ptr_invalid, 2 ret_ptr_is_ops ) bit (1) unal, 2 pad bit (29) unal; %include interpret_link_info; %include mc; %include stack_frame; pname1, pname2, pname3, ptemp = ""; sp = asp; if cond_info.loc_ptr = null then return; if cond_info.user_loc_ptr ^= cond_info.loc_ptr then do; /* get info from first non-support frame */ spno = baseno (sp); /* get segno of sp */ nsp = sp; do while (baseno (nsp -> stack_frame.prev_sp) = spno); nsp = nsp -> stack_frame.prev_sp; if ^nsp -> stack_frame_flags.support then do; /* found non-support frame */ entryname, link_segname, entrypoint, op_seg_name = ""; find_op = "0"b; /* no operator involved */ use_ptr = cond_info.user_loc_ptr; call get_entry_name_ (nsp -> stack_frame.entry_ptr, entryname, segno, lang, code); call check_call_link_ (nsp); /* see how frame's proc was called */ call put_together_ (pname1); /* format full name and offset */ if length_sw = 2 then go to find_real; /* print support proc as well */ else go to test_crawlout; end; end; end; find_real: /* obtain loc where condition occurred */ entryname, link_segname, entrypoint = ""; use_ptr = cond_info.loc_ptr; call stack_frame_exit_ (sp, cond_info.mc_ptr, cond_info.wc_ptr, cond_info.crawlout, last_ptr, op_seg_name, addr (situation)); if (ppr_is_owner | caller_is_owner | ^exists_ppr) then do; /* use owner of stack frame */ if ^entry_ptr_invalid then call get_entry_name_ (sp -> stack_frame.entry_ptr, entryname, segno, lang, code); call check_call_link_ (sp); /* find out how owner was called */ end; else do; /* know ppr is not owner */ if is_cls_ (use_ptr) then do; /* print frame owner anyway--don't want cls */ use_ptr = last_ptr; call get_entry_name_ (sp -> stack_frame.entry_ptr, entryname, segno, lang, code); end; /* what frame owner last called seems to mislead as much as it helps */ /* else call check_call_link_(sp -> stack_frame.next_sp); */ end; if ppr_is_ops then find_op = "1"b; /* print operator name as well */ else find_op = "0"b; call put_together_ (ptemp); /* format name with offset */ if (length_sw = 1) | (pname1 = " ") then pname1 = ptemp; else call ioa_$rsnnl ("^/ (actually by support procedure ^a)", pname2, lng, ptemp); test_crawlout: if cond_info.crawlout then do; /* if possible, get name of real faulting proc */ if cond_info.mc_ptr ^= null then do; /* have some info from lower ring */ entryname, link_segname, entrypoint, op_seg_name = ""; find_op = "0"b; scup = addr (cond_info.mc_ptr -> mc.scu (0)); use_ptr = ptr (baseptr (bin (bin (scup -> scu.ppr.psr, 15), 18)), scup -> scu.ilc); call put_together_ (pname3); end; end; return; check_call_link_: proc (asp); /* This internal procedure tries to find out how the owner of the specified stack frame was called by looking at the last reference from the preceding stack frame */ declare (asp, csp, callp, entry_ptr, link_ptr) ptr; declare frame_flag bit (1) aligned; declare op_seg char (32) aligned; declare get_link_ptr_ entry (ptr, ptr, ptr); declare interpret_link_ entry (ptr, ptr, fixed bin (35)); declare interpret_op_ptr_ entry (ptr, ptr, ptr, char (32) aligned, bit (1) aligned); declare 1 auto_interpret_link_info aligned like interpret_link_info; csp = asp -> stack_frame.prev_sp; /* get ptr to previous frame */ if csp = null then return; /* no previous frame */ /* get last location in owner of previous frame */ call interpret_op_ptr_ (null, csp, callp, op_seg, frame_flag); if callp = null then callp = ptr (csp -> stack_frame.return_ptr, rel (csp -> stack_frame.return_ptr)); /* return_ptr may have indicators in modifier */ call get_link_ptr_ (callp, link_ptr, entry_ptr); if link_ptr ^= null then do; /* link name probably more accurate */ auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), link_ptr, code); if code = 0 then do; /* use link name */ link_segname = auto_interpret_link_info.segment_name; auto_interpret_link_info.entry_point_name = substr (auto_interpret_link_info.entry_point_name, 2); end; return; end; if entry_ptr ^= null then /* see if we have reference to an entry */ call get_entry_name_ (entry_ptr, auto_interpret_link_info.entry_point_name, segno, lang, code); return; end; put_together_: procedure (pname); /* This internal procedure finds the rest of the pathname, figures out which of of the entry name pieces are appropriate, tries to avoid duplications and extra dollar signs, and formats the complete name */ /* If the segname is foo, and the entrypoint is foo$SOMETHING, then improve the message removing the second foo. foo. Admittedly, ALM or hand construction could make an object segment with both foo and foo$foo for entrypoints, but there is no reason users should see foo$foo$foo just in case that happens. This is a temporary measure until pl1 does multiple segnames right, and we can display the segment-entrypoint instead of the entryname-pl1_entry_name_from_symbol_table. */ declare pname char (500) aligned; declare r_entrypoint char (256) var; declare r_entryname char (32); /* fs entryname or segname */ declare op_name char (32) aligned; declare op_msg char (57) aligned; declare line_msg char (13); /* from get_line_no_ */ declare formatx fixed bin; declare (add_offset, use_offset) char (7); declare ioa_$rsnnl entry options (variable); declare find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned); declare find_pathname_ entry (ptr, ptr, fixed bin (35)); declare 1 name_info aligned like find_pathname_info; call find_pathname_ (use_ptr, addr (name_info), code); /* get pathname and offset pieces */ if name_info.adjusted_offset ^= "" /* if bound segment */ then do; add_offset = name_info.real_offset; /* for msg in () */ use_offset = name_info.adjusted_offset; /* in component */ end; else do; use_offset = name_info.real_offset; add_offset = ""; end; op_msg = ""; /* assume no operator involved */ if op_seg_name ^= "" /* operator */ then if find_op /* global from main block -- operator is interesting */ then do; /* condition happened in operator */ call find_operator_name_ (op_seg_name, use_ptr, op_name); if op_name ^= "" /* was an operator we could find */ then if substr (op_name, 1, 4) ^= "call" then op_msg = byte (10 /* NL */) || /* NL */ "(while in operator " || rtrim (op_name) || ")"; end; call get_line_no_ (); /* try to find source line */ /* figure out which names and format to use */ formatx = 0; /* assume no dirname but full seg$entry|offset */ if entryname ^= "" /* main block found full description, probably from stack_frame.entry_ptr */ then r_entrypoint = entryname; /* we like that */ else if entrypoint ^= "" /* link target entryname in file system */ then r_entrypoint = entrypoint; /* that will do */ else do; /* no obvious entrypoint description */ r_entrypoint = ""; formatx = 1; /* so skip to format 1, use refname */ end; /* Now, what goes in for a segname?? */ /* put the result in entryname as the putative fs entryname */ if link_segname ^= "" /* If a link was involved, use that */ then r_entryname = link_segname; /* resort to find_pathname_ */ else if name_info.component_ename ^= "" /* bound seg, show both component name and entryname */ then r_entryname = name_info.component_ename; else do; r_entryname = ""; /*** skip to one-entryname formats */ formatx = formatx + 2; /* 0, 1 go to 2, 3 */ end; if formatx = 3 /* we know all we are gonna know */ then go to format (3); if formatx ^= 0 then if (r_entryname = r_entrypoint) then formatx = formatx + 1; if formatx < 2 /* r_entryname is in use */ then if name_info.real_ename = r_entryname /* but its the same as the find_pathname_ entryname, so punt it */ then formatx = formatx + 2; if formatx = 2 then if (name_info.real_ename = r_entrypoint) /* redundant */ | (r_entrypoint = "") /* unknown */ then formatx = 3; go to format (formatx); format (0): /* r_entryname$r_entrypoint_name|offset (line #) dirname>bound_seg_entryname|offset in pdir in operator operator name */ if r_entryname = before (r_entrypoint, "$") then r_entrypoint = after (r_entrypoint, "$"); if length_sw ^= 2 /* Dont want super-verbose */ then add_offset = ""; call ioa_$rsnnl ("^a$^a^a ^a^/(^a^a^a^a^a)^a^a", pname, lng, r_entryname, r_entrypoint, use_offset, line_msg, name_info.dirname, name_info.gt_char, name_info.real_ename, add_offset, name_info.pdir_string, op_msg, offset_msg); return; format (1): /* entryname|adj_offset (dname>real_entryname|real_off) */ if length_sw ^= 2 then add_offset = ""; call ioa_$rsnnl ("^a^a ^a^/(^a^a^a^a^a) ^a^a", pname, lng, r_entryname, use_offset, line_msg, name_info.dirname, name_info.gt_char, name_info.real_ename, add_offset, name_info.pdir_string, op_msg, offset_msg); return; format (2): /* dname>real_entryname$entrypoint_name|adj_offset */ if name_info.real_ename = before (r_entrypoint, "$") then r_entrypoint = after (r_entrypoint, "$"); call ioa_$rsnnl ("^a^a^a$^a^a^a ^a^a^a", pname, lng, name_info.dirname, name_info.gt_char, name_info.real_ename, r_entrypoint, use_offset, name_info.pdir_string, line_msg, op_msg, offset_msg); return; format (3): /* dname>real_entryname|offset */ call ioa_$rsnnl ("^a^a^a^a^a ^a^a^a", pname, lng, name_info.dirname, name_info.gt_char, name_info.real_ename, use_offset, name_info.pdir_string, line_msg, op_msg, offset_msg); return; get_line_no_: procedure; /* This procedure finds the source line number corresponding to a given location */ dcl (segp, symbp) ptr; dcl (start, num, line_no, offset) fixed bin (18); dcl bitcnt fixed bin (24); declare mode fixed bin (5); dcl code fixed bin (35); dcl std bit (1) aligned; dcl (addr, addrel, baseptr, bin, bit, ptr, rel) builtin; dcl component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl ( stu_$get_line_no, stu_$get_runtime_line_no ) entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18), fixed bin (18)); dcl ioa_$rsnnl entry options (variable); declare hcs_$status_mins entry (pointer, fixed bin (2), fixed bin (24), fixed bin (35)); declare hcs_$fs_get_mode entry (pointer, fixed bin (5), fixed bin (35)); %include access_mode_values; /* Include file symbol_header follows */ %include symbol_header; %include component_info; dcl 1 oi aligned like object_info; %include object_info; line_msg = ""; segp = baseptr (baseno (use_ptr)); /* get ptr to beginning of seg */ offset = bin (rel (use_ptr), 18); /* extract offset of location */ /* First see if we have access to touch the segment AT ALL */ call hcs_$fs_get_mode (segp, mode, code); if code ^= 0 /* Should not happen, but .. */ | ((bit (mode, 5) & bit (R_ACCESS_BIN, 5)) = "00000"b) /* no R */ then return; /* first see if seg is bound; if so use only component info */ call component_info_$offset (segp, offset, addr (ci), code); if code = 0 then do; /* use info for component */ symbp = ci.symb_start; std = ci.standard; go to call_stu; end; /* segment is not bound; see if seg itself has statement map */ call hcs_$status_mins (segp, (0), bitcnt, code); if code ^= 0 then return; oi.version_number = object_info_version_2; call object_info_$brief (segp, bitcnt, addr (oi), code); if code ^= 0 then return; /* no symbol section so no map */ symbp = oi.symbp; std = oi.format.standard; call_stu: start = -1; if std then call stu_$get_runtime_line_no (symbp, offset, start, num, line_no); else if symbp -> symbol_header.root then call stu_$get_line_no (addrel (symbp, symbp -> symbol_header.root), offset, start, num, line_no); if start > -1 then call ioa_$rsnnl ("(line ^d)", line_msg, num, line_no); return; end get_line_no_; end put_together_; %include find_pathname_info; end get_ppr_;  get_tpr_.pl1 11/11/89 1139.1rew 11/11/89 0839.0 74943 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* Modified April 1981 by B. Margulies for quiet_restart, null_pointer, include file for find_pathname_info */ /* Further modified in August to fix the segfault-garbage bug */ /* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */ /* format: style4,insnl,delnl */ get_tpr_: proc (asp, sptr, a_mtep, tname1, tname2); dcl a_mtep ptr; dcl (tname1, tname2) char (500) aligned; dcl ptemp character (500) aligned; dcl ename char (256) aligned; dcl op_seg_name char (32) aligned; dcl lang char (8) aligned; dcl (asp, tpr, sptr, sp, last_ptr, linkp, entryp) ptr; dcl lng fixed bin; dcl segno fixed bin (18); dcl code fixed bin (35); /* Entries */ dcl find_pathname_ entry (ptr, ptr, fixed bin (35)); dcl ( ioa_$rsnnl ) entry options (variable); dcl stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr); dcl get_link_ptr_ entry (ptr, ptr, ptr); dcl get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)); dcl interpret_link_ entry (ptr, ptr, fixed bin (35)); dcl (addr, baseno, baseptr, bin, hbound, lbound, null, ptr, substr) builtin; %include condition_info; declare 1 cond_info aligned like condition_info based (sptr); %include find_pathname_info; declare 1 name_info aligned like find_pathname_info; %include interpret_link_info; dcl 1 auto_interpret_link_info aligned like interpret_link_info; dcl 1 situation aligned, /* structure from stack_frame_exit_ */ ( 2 bad_frame, 2 exists_ppr, 2 ppr_is_owner, 2 ppr_is_ops, 2 caller_is_owner, 2 entry_ptr_invalid, 2 ret_ptr_is_ops ) bit (1) unal, 2 pad bit (29) unal; tname1, tname2, ptemp = ""; sp = asp; mtep = a_mtep; /* get referenced proc name if relevant and if it exists */ if mte.with_tpr then if cond_info.mc_ptr ^= null then do; scup = addr (cond_info.mc_ptr -> mc.scu (0)); tpr = ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca); if cond_info.crawlout then do; /* can't do anything fancy */ call find_pathname_ (tpr, addr (name_info), code); ename = ""; /* not used here */ call format_name (tname1); end; else call try (cond_info.mc_ptr, tname1); /* see if we can get a better name from a link */ end; if cond_info.crawlout then do; /* get last proc referenced in current ring */ if cond_info.wc_ptr ^= null then call try (cond_info.wc_ptr, ptemp); else do; /* see if proc was called through link */ call stack_frame_exit_ (sp, null, null, cond_info.crawlout, last_ptr, op_seg_name, addr (situation)); if last_ptr = null then return; /* don't know where frame was left */ ename = ""; call get_link_ptr_ (last_ptr, linkp, entryp); if linkp ^= null then do; /* found a link */ auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), linkp, code); /* get name of link target */ if code = 0 then call ioa_$rsnnl ("^a^a^a^a^a", ename, lng, auto_interpret_link_info.segment_name, auto_interpret_link_info.entry_point_name, auto_interpret_link_info.expression, auto_interpret_link_info.modifier, auto_interpret_link_info.trap); end; else if entryp ^= null /* text-text transfer; highly unlikely */ then call get_entry_name_ (entryp, ename, segno, lang, code); ptemp = ename; end; if ptemp ^= "" then tname2 = " referencing " || ptemp; end; return; format_name: proc (tname); dcl tname char (500) aligned; if name_info.component_ename ^= "" then do; /* use name from bindmap */ call ioa_$rsnnl ("^a^a^a (^a^a^a^a^a)^a", tname, lng, name_info.component_ename, ename, name_info.adjusted_offset, name_info.dirname, name_info.gt_char, name_info.real_ename, name_info.real_offset, name_info.pdir_string, name_info.offset_msg); end; else do; call ioa_$rsnnl ("^a^a^a^a^a^a^a", tname, lng, name_info.dirname, name_info.gt_char, name_info.real_ename, ename, name_info.real_offset, name_info.pdir_string, name_info.offset_msg); end; return; end; try: proc (mp, tname); dcl no_name bit (1) aligned; dcl mp ptr; dcl error_table_$invalidsegno ext fixed bin (35); dcl i fixed bin; dcl op_code bit (10) aligned; dcl tname char (500) aligned; dcl tr_insts (35) bit (10) aligned init ("1110010110"b, "1100011000"b, "1100011010"b, "1100001000"b, "1100000100"b, "1100000010"b, "1100011110"b, "1100001010"b, "1100000110"b, "1110010000"b, "1100000000"b, "0101110000"b, "0101110010"b, "0101110100"b, "0101110110"b, "1101110000"b, "1101110010"b, "1101110100"b, "1101110110"b, "1110011010"b, "1110000000"b, "1110000010"b, "1110000100"b, "1110000110"b, "1110001000"b, "1110001010"b, "1110001100"b, "1110001110"b, "1100001110"b, "1100001100"b, "1100000011"b, "1100001001"b, "1100001011"b, "1100001101"b, "1100000001"b) internal static options (constant); dcl is_cls_ entry (ptr) returns (bit (1) aligned); %include db_inst; /* */ ename = ""; no_name = "0"b; scup = addr (mp -> mc.scu (0)); tpr = ptr (baseptr (bin (bin (scup -> scu.tpr.tsr, 15), 18)), scup -> scu.ca); if mte.segferr & (mp -> mc.errcode = error_table_$invalidsegno) then do; /* symbolic name no longer available */ print_ptr: call ioa_$rsnnl ("^p", tname, lng, tpr); no_name = "1"b; end; else do; /* get basic name info */ call find_pathname_ (tpr, addr (name_info), code); if code ^= 0 then go to print_ptr; end; /* see if an inter-segment transfer was involved to see if it's worth looking for a link */ if scup -> scu.ppr.psr = scup -> scu.tpr.tsr then go to simple; /* same segment */ op_code = addr (scup -> scux.instr (bin (substr (scup -> scu.ilc, 18, 1), 1))) -> instr.opcode; do i = lbound (tr_insts, 1) to hbound (tr_insts, 1); /* see if a transfer instruction was being executed */ if op_code = tr_insts (i) then if ^is_cls_ (cond_info.loc_ptr) then do;/* cond_info.loc_ptr might be near link ref */ call get_link_ptr_ (cond_info.loc_ptr, linkp, entryp); if entryp = null then go to simple; /* no snapped link */ call get_entry_name_ (entryp, ename, segno, lang, code); /* this name should be good enough */ if code ^= 0 then go to simple; /* don't bother looking for unsnapped link */ if segno ^= bin (baseno (tpr), 18) then ename = ""; /* not same seg */ else if no_name then go to add; /* can't do normal formatting */ else do; /* print name if not redundant */ if name_info.component_ename ^= "" & ename = name_info.component_ename then ename = ""; else if name_info.real_ename ^= "" & ename = name_info.real_ename then ename = ""; else ename = "$" || ename; end; end; end; simple: if no_name then return; /* have nothing to add */ call format_name (tname); return; add: /* could not find real symbolic name but found a name heuristically */ if linkp ^= null then do; /* if possible, replace ename with names from link */ auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), linkp, code); if code ^= 0 then call ioa_$rsnnl ("^a^a", ename, lng, auto_interpret_link_info.segment_name, auto_interpret_link_info.entry_point_name); end; call ioa_$rsnnl ("^a^/(probably referencing ^a)", tname, lng, tname, ename); return; end; %include mc; %include message_table_entry; end get_tpr_;  interpret_info_struc_.pl1 11/11/89 1139.1rew 11/11/89 0839.0 80244 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ interpret_info_struc_: procedure (conname, infoptr, linfo, retsw, no_restart, realsw, lngsw); /* This procedure is used by default_error_handler_ to interpret the info structures passed with software signalled conditions */ /* Last modified by M. Weaver 2 December 1973 */ /* Changed 25 January 1979 B. Margulies to set print_sw on af errors */ /* Modified: 8 August 1980 by G. Palter to special case the code error_table_$active_function for the active_function_error condition */ /* Modified: 10 September 1980 by G. Palter to rtrim command name in error_table_$active_function message */ /* Modified April 1981 by B. Margulies for quiet_restart and new includes */ /* Modified for program_interrupt BIM July 1981 */ /* Modified for quit_info E. N. Kittlitz December 1981 */ /* Modified to notice pl1-signal-statement info structures on non-pl1 */ /* conditions 4/82 BIM */ /* Modified for malformed_list_template_entry_ November 29, 1984 by M. Weaver */ dcl conname char (32); /* condition name */ dcl linfo char (500) var; /* resulting info string */ dcl temp char (100) aligned; dcl shortinfo char (8) aligned; dcl temp2 char (150) var; dcl name char (afe_info.name_lth) based (afe_info.name_ptr); /* for active_function_error caller */ dcl errmsg char (afe_info.errmess_lth) based (afe_info.errmess_ptr); /* for new afe message */ dcl pl1_signalled_this bit (1); dcl tempchar char (1) aligned; dcl (infoptr, lp) ptr; dcl (lng, lngsw) fixed bin; dcl toncode fixed bin (35); dcl lv (4) fixed bin (35) based (lp); dcl (retsw, realsw, no_restart) bit (1) aligned; dcl error_table_$active_function fixed binary (35) external; dcl (addr, rtrim, substr) builtin; dcl ( ioa_$rs, ioa_$ioa_stream ) ext entry options (variable); dcl convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl interpret_oncode_ entry (fixed bin (35), char (150) var); %include condition_info_header; dcl 1 cond_header aligned like condition_info_header based (infoptr); dcl 1 unwind_err aligned based (infoptr), 2 header aligned like condition_info_header, 2 target_label label; %include com_af_error_info; dcl 1 afe_info like com_af_error_info based (infoptr); %include io_error_info; dcl 1 io_err_info aligned like io_error_info based (infoptr); %include sub_error_info; dcl 1 sub_error_struc aligned like sub_error_info based (infoptr); %include pl1_info; dcl 1 pl1_info_struc aligned like pl1_info based (infoptr); %include program_interrupt_info; dcl 1 pi_info aligned like program_interrupt_info based (infoptr); %include quit_info; dcl 1 quit_info_struc aligned like quit_info based (infoptr); %include malformed_list_template; dcl 1 template_info_struc aligned like template_info based (infoptr); pl1_signalled_this = pl1_info_struc.id = "pliocond"; if cond_header.quiet_restart then do; retsw = "1"b; /* restart the condition */ return; /* and that is all we do */ end; if ^retsw then retsw = cond_header.action_flags.default_restart; no_restart = cond_header.action_flags.cant_restart; if ^pl1_signalled_this then do; if conname = "sub_error_" then sub_error_struc.retval = 0; if conname = program_interrupt_condition_name then do; retsw = "1"b; pi_info.default_handler_restarted_this_signal = "1"b; return; /* protocol is satisfied */ end; if conname = "active_function_error" then do; if realsw then call ioa_$ioa_stream ("error_output", errmsg); afe_info.print_sw = "0"b; /* error message causing error must be printed first, but only once */ if afe_info.status_code = error_table_$active_function then linfo = "Error: Attempt to invoke command " || rtrim (name) || " as an active function." || byte (10) /* NL */; else linfo = "Error: Bad call to active function " || rtrim (name) || byte (10) /* NL */; /* now fill in info string itself */ end; else if conname = "io_error" then do; call convert_status_code_ (io_err_info.status.code, shortinfo, temp); if shortinfo = (8)"x" then call ioa_$rs (" Cannot do I/O on switch ^a.^/Hardware status = ^w ^w", linfo, lng, io_err_info.switch_name, io_err_info.status.code, io_err_info.status.IOS_status_bits); else call ioa_$rs (" Cannot do I/O on stream ^a.^/^a", linfo, lng, io_err_info.switch_name, temp); end; else if conname = "unwinder_error" then do; if lngsw = 1 then linfo = unwind_err.info_string; else do; lp = addr (unwind_err.target_label); /* want to print label in octal */ call ioa_$rs ("^a^/Label is: ^w ^w ^w ^w", linfo, lng, unwind_err.info_string, lp -> lv (1), lp -> lv (2), lp -> lv (3), lp -> lv (4)); end; end; else if conname = "quit" then do; /* everything is done by default_error_handler_ */ end; else if conname = "malformed_list_template_entry_" then call ioa_$rs ("A compiler has generated incorrect list template initialization^/for an array or external variable.^/The template is at ^p. The malformed entry is at ^p.", linfo, lng, template_info_struc.template_p, template_info_struc.template_error_p); else do; /* get what we can from structure header */ if cond_header.status_code = 0 then linfo = cond_header.info_string; else do; call convert_status_code_ (cond_header.status_code, shortinfo, temp); call ioa_$rs ("^a ^a", linfo, lng, temp, cond_header.info_string); end; end; end; else do; /* have a pl1 condition */ if pl1_info_struc.content_flags.onfile_sw then call ioa_$rs ("occurred while doing I/O on file ^a", linfo, lng, pl1_info_struc.onfile); if pl1_info_struc.content_flags.onkey_sw then /* have a key to print */ if conname = "endfile" | conname = "transmit" | conname = "record" | conname = "key" then call ioa_$rs ("^aonkey = ^a", linfo, lng, linfo, pl1_info_struc.onkey_onfield); if conname = "conversion" then if pl1_info_struc.content_flags.onsource_sw then do; if pl1_info_struc.content_flags.onchar_sw then do; /* print both onsource and onchar */ tempchar = substr (pl1_info_struc.onsource, pl1_info_struc.oncharindex, 1); /* must copy to get correct descriptor */ call ioa_$rs ("^aonsource = ""^a"", onchar = ""^1a""", linfo, lng, linfo, pl1_info_struc.onsource, tempchar); end; else call ioa_$rs ("^aonsource = ""^a""", linfo, lng, linfo, pl1_info_struc.onsource); end; if conname = "name" then if pl1_info_struc.content_flags.onfield_sw then call ioa_$rs ("^aonfield = ^a", linfo, lng, linfo, pl1_info_struc.onkey_onfield); if pl1_info_struc.content_flags.oncode_sw then do; toncode = pl1_info_struc.oncode; if toncode ^= 0 & toncode ^= 700 then do; /* determine source */ if conname = "error" | conname = "conversion" | conname = "size" | conname = "record" | conname = "key" | conname = "undefinedfile" then do; /* want to print oncode */ call interpret_oncode_ (toncode, temp2); linfo = linfo || temp2; end; end; end; if linfo ^= "" then if substr (linfo, 1, 1) ^= byte (10) /* NL */ then linfo = byte (10) /* NL */ || linfo; /* don't add double newline */ end; return; /* */ no_message: entry (conname, infoptr); /* this entry makes use of info struc but does not format message */ dcl based_ptrs (100) ptr based; dcl based_bins (100) fixed bin (15) aligned based; dcl based_file file variable based; if conname = "endpage" then if pl1_info_struc.id = "pliocond" then if pl1_info_struc.content_flags.file_ptr_sw then do; if pl1_info_struc.content_flags.v1_sw then pl1_info_struc.file_ptr -> based_ptrs (2) -> based_bins (13) = 1; else put page file (pl1_info_struc.file_ptr -> based_file); end; return; end interpret_info_struc_;  interpret_oncode_.pl1 11/11/89 1139.1rew 11/11/89 0839.0 24876 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ interpret_oncode_: proc(on_code, string); /* This procedure returns the message corresponding to a given pl1 oncode value */ /* it references a list made up from P. Belmont's 3 lists */ /* coded by M.B. Weaver 73/5/3 */ /* modified 77/03/08 by M. Weaver to increase size of oncode_messages_ */ declare (lng, i, j, k) fixed bin; declare on_code fixed bin(35); declare (index, substr) builtin; declare nl char(1) int static init(" "); declare nlnl char(2) aligned int static init(" "); declare string char(150) var; declare oncode_messages_$ char(65536) ext aligned; declare oncode_message_string char (om_length) based (addr (oncode_messages_$)); declare om_length fixed bin static init (65536); declare first bit (1) aligned static init ("1"b); declare ioa_$rs entry options(variable); declare convert_binary_integer_$decimal_string entry(fixed bin(35)) returns(char(12) var); /* * * * * * * * * * * * * * * * * * * * * */ /* a typical message in oncode_messages_ follows: 205 [CTN]Character other than sign or digit follows "e" of exponent field. Messages are located by the oncode value and delimited by a double new-line. The name in [] indicates the module signalling the error. */ if first then do; /* find real length of oncode_messages_$ */ om_length = index (oncode_messages_$, nl || "[END]"); first = "0"b; end; /* find beginning of message */ i = index(oncode_message_string, nl || convert_binary_integer_$decimal_string(on_code)); if i = 0 then go to error_return; /* find length of message */ j = index(substr(oncode_message_string, i, 300), nlnl); if j = 0 then go to error_return; /* find beginning of relevant part of message */ k = index(substr(oncode_message_string, i, j), "]"); if k = 0 then k = 1; /* print whole message anyway */ /* fill in string argument */ string = substr(oncode_message_string, i+k, j - k - 1); return; error_return: /* let users know so it will be reported */ call ioa_$rs("There is no message for oncode = ^d. Contact pl1 maintainence.", string, lng, on_code); return; end;  linkage_error_.pl1 11/11/89 1139.1rew 11/11/89 0839.1 93942 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-12,Zwick), install(86-11-20,MR12.0-1222): special cased error code invalid_ptr_target to get a usefull message. END HISTORY COMMENTS */ linkage_error_: proc (mcptr, lngsw, lsp, sptr, pname1, pname2, optr, lng); /* last modified by M. Weaver 21 August 1970 */ /* last modified by M. Weaver 17 October 1973 */ /* modified 10/76 by M. Weaver to improve messages for types 1 and 5 */ /* modified 11/77 by M. Weaver to improve messages for ext variables and ec = bigger_ext_variable in particular */ /* modified 21 Feb 80 JRDavis MCR 4347 remove red-shift */ /* Modified 831006 BIM to change call from hcs_$set_ext_variable to just set_ext_variable_ */ /* parameters */ dcl mcptr ptr parameter; /* ptr to machine conditions */ dcl lngsw fixed bin parameter; dcl lsp ptr parameter; /* ptr to condition frame */ dcl sptr ptr parameter; /* ptr to condition info structure */ dcl (pname1, pname2) char (500) aligned parameter; dcl optr ptr parameter; /* ptr to output string */ dcl lng fixed bin (17) parameter; /* automatic */ dcl (buf1, buf4) char (100) aligned automatic; dcl (buf2, buf3) char (200) varying automatic; dcl code fixed bin (35) automatic; dcl def_section_ptr ptr automatic; /* ptr to defs */ dcl dirname char (168) automatic; dcl ec fixed bin (35) automatic; /* errcode from linker */ dcl exp char (12) var automatic; /* value of expression */ dcl entname char (32) automatic; dcl ext_var_name char (65) automatic; dcl ext_ptr ptr automatic; /* ptr to symbol */ dcl found_sw bit (1) aligned automatic; dcl header_ptr ptr automatic; /* ptr to linkage block header */ dcl (i, tlng) fixed bin (17) automatic; dcl linfo char (100) aligned automatic; /* for convert_status_code_ */ dcl link_ptr ptr automatic; /* pointer to link */ dcl (n2, o2) varying char (32) aligned automatic; /* printable names */ dcl nchars fixed bin (17) automatic; /* number of chars in name */ dcl nl char (1) aligned automatic; dcl node_ptr ptr automatic; dcl p ptr automatic; dcl pname3 char (500) aligned automatic; dcl segptr ptr automatic; /* ptr to seg name */ dcl sinfo char (8) aligned automatic; dcl type fixed bin (17) automatic; /* type of link */ dcl texp char (12) aligned automatic; /* constants */ dcl New_line char (1) static options (constant) init (" "); /* external variables */ dcl (error_table_$bad_link_type, error_table_$no_ext_sym, error_table_$bad_entry_point_name, error_table_$bigger_ext_variable, error_table_$bad_self_ref, error_table_$invalid_ptr_target) ext fixed bin (35) aligned; /* external entries */ dcl get_ppr_ entry (fixed bin, ptr, ptr, char (500) aligned, char (500) aligned, char (500) aligned); dcl (ioa_$rs, ioa_$rsnnl) ext entry options (variable); dcl set_ext_variable_ entry (char (*), ptr, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned); /* builtins */ dcl (addr, addrel, baseptr, bin, fixed, index, length, null, ptr, substr) builtin; /* based */ dcl ostring char (1000) aligned based (optr); dcl 1 word based (p), /* access structure for pickup */ 2 (one, two) fixed bin (35); dcl 1 init_info aligned based, 2 length fixed bin, 2 type fixed bin; /* * * * * * * * * * * * * * * * * * * */ linfo, nl, buf1, buf4 = " "; /* initialize */ n2, o2, buf2, buf3 = ""; code = 0; scup = addr (mcptr -> mc.scu (0)); /* get ptr to scu; use real conditions */ ec = mcptr -> mc.errcode; /* extract linker code */ /* obtain ptr to link */ link_ptr = ptr (baseptr (fixed (scup -> scu.tsr, 15)), scup -> scu.ca); if ec = error_table_$bad_entry_point_name then do; ugh: call ioa_$rsnnl ("^/Link is ^w ^w at ^p.", buf1, tlng, link_ptr -> word.one, link_ptr -> word.two, link_ptr); go to exit; end; if link_ptr -> object_link.tag ^= FAULT_TAG_2 then go to ugh; /* get pointers to the information concerning the link. ie. expression word, type_pair and link type */ header_ptr = addrel (link_ptr, link_ptr -> object_link.header_relp); def_section_ptr = header_ptr -> linkage_header.def_ptr; exp_ptr = addrel (def_section_ptr, link_ptr -> object_link.expression_relp); type_ptr = addrel (def_section_ptr, exp_ptr -> exp_word.type_relp); type = type_ptr -> type_pair.type; if ec = error_table_$bad_link_type then do; call ioa_$rsnnl ("^/Illegal type number in type pair block. Type = ^o.", buf1, tlng, type); go to last_exit; end; /* check the trap information it is either a pointer to a trap or it specifies the class information */ if type_ptr -> type_pair.trap_relp ^= 0 then if type = LINK_CREATE_IF_NOT_FOUND then call ioa_$rsnnl ("^/(with a create-if-not-found link)", buf1, tlng); if exp_ptr -> exp_word.expression ^= 0 then do; call ioa_$rsnnl ("^o", texp, tlng, exp_ptr -> exp_word.expression); exp = substr (texp, 1, lng); end; else exp = ""; /* get the symbolic name of the link */ if (type = LINK_SELF_BASE) | (type = LINK_SELF_OFFSETNAME) then do; if ec ^= error_table_$bad_self_ref then n2 = SYMBOLIC_SECTION_NAMES (type_ptr -> type_pair.segname_relp); else n2 = "*"; if (type = LINK_SELF_OFFSETNAME) then goto noent; else goto noext; end; if (type = LINK_OBSOLETE_2) then do; /* ITB link? */ if ec = error_table_$no_ext_sym then do; call ioa_$rsnnl ("base ^o", n2, lng, type_ptr -> type_pair.segname_relp); go to noent; end; go to exit; end; /* get the link name information eg. either x$y or y or y|x */ segptr = addrel (def_section_ptr, type_ptr -> type_pair.segname_relp); nchars = bin (segptr -> acc_string.count, 9); n2 = substr (segptr -> acc_string.string, 1, nchars); if (type = LINK_REFNAME_BASE) then do; /* |exp,m ? */ noext: if exp = "" then o2 = "0"; else o2 = exp; end; else do; noent: ext_ptr = addrel (def_section_ptr, type_ptr -> type_pair.offsetname_relp); nchars = fixed (ext_ptr -> acc_string.count, 9); if nchars = 0 then do; if (type = LINK_CREATE_IF_NOT_FOUND) then o2 = ""; else o2 = "0"; end; else o2 = substr (ext_ptr -> acc_string.string, 1, nchars); if exp ^= "" then o2 = o2 || "+" || exp; end; call ioa_$rsnnl ("^/referencing ^a|^a", buf2, tlng, n2, o2); /* get information concerning the initialization information of *system *heap or create if not found links */ if (type = LINK_SELF_OFFSETNAME) | (type = LINK_CREATE_IF_NOT_FOUND) then do; ext_var_name = " "; if (type = LINK_SELF_OFFSETNAME) then do; if (type_ptr -> type_pair.segname_relp = CLASS_SYSTEM) | (type_ptr -> type_pair.segname_relp = CLASS_HEAP) then ext_var_name = o2; end; else do; /* create if not found */ if n2 = "stat_" then ext_var_name = o2; else if o2 = "" then do; /* see if we have fortran common block */ i = index (n2, ".com"); if i = (length (n2) - 3) then do; ext_var_name = substr (n2, 1, i - 1); if ext_var_name = "b_" then ext_var_name = "blnk*com"; end; end; else if n2 = "cobol_fsb_" then ext_var_name = n2 || o2; if ext_var_name ^= " " then buf1 = " "; /* create-if-not-found now irrelevant */ end; if ext_var_name ^= " " then buf2 = New_line || "referencing external variable or common block " || ext_var_name; end; if ec = error_table_$bigger_ext_variable then do; /* print out more useful information */ call ioa_$rsnnl ("^a (^d words)", buf2, tlng, buf2, addrel (def_section_ptr, type_ptr -> type_pair.trap_relp) -> init_info.length); buf4 = New_line || "Type ""help external_storage.gi"" for more information."; call set_ext_variable_ (ext_var_name, null, ptr (addr (node_ptr), 0), found_sw, node_ptr, code); if code = 0 then if found_sw then do; if node_ptr -> variable_node.init_ptr ^= null then do; call hcs_$fs_get_path_name (ptr (node_ptr -> variable_node.init_ptr, 0), dirname, tlng, entname, code); if code = 0 then call ioa_$rsnnl ("^/Original allocation (^d words) was by ^a>^a.", buf3, tlng, node_ptr -> variable_node.init_ptr -> init_info.length, dirname, entname); else call ioa_$rsnnl ("^/Original allocation was ^d words.", buf3, tlng, node_ptr -> variable_node.init_ptr -> init_info.length); end; end; end; else if ec = error_table_$invalid_ptr_target then do; if ext_var_name ^= " " then buf2 = New_line || "referencing external variable " || ext_var_name; buf3, buf4 = ""; end; exit: call convert_status_code_ (ec, sinfo, linfo); /* get message */ nl = " "; last_exit: /* format the information */ call get_ppr_ (lngsw, lsp, sptr, pname1, pname2, pname3); call ioa_$rs ("Error: Linkage error by ^a^a^a^a^a^a^a^a", ostring, lng, pname1, pname2, buf2, buf1, nl, linfo, buf3, buf4); return; /* default_error_handler_ will decide what to do with the string */ %page; /* INCLUDE FILES */ %include object_link_dcls; %page; %include definition_dcls; %page; %include its; %page; %include mc; %page; %include stack_header; %page; %include system_link_names; end;  message_table_.alm 11/11/89 1139.1rew 11/11/89 0840.9 92205 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), " audit(86-07-17,Ginter), install(86-07-28,MR12.0-1104): " Fix fortran bug 355. " END HISTORY COMMENTS " " message_table_ " " This is a modified version of the old message_table_.mt. The program generates a sequence " of message table entries (MTEs) that are defined with the mte macro. " " The correct MTE is found by default_error_handler_ by searching the definitions " of message_table_. " " Coded Aug 19, 1977 by S.Webber " Modified June 1978 by M. Weaver to fix missing new line bugs and gate_err " Modified Nov. 22, 1978 by M. Weaver to fix storage, add command_abort_, and fix missing line bugs " Modified: 7 April 1981 by G. Palter to correct bug causing the command_query_error " condition to print garbage " " " Modified April 1981 by Benson I. Margulies to replace simfault with null_pointer_ " and remove obsolete accessviolation entry. " Modified June 1983 by Melanie Weaver to add fortran_pause " Modified November 29, 1984 by Melanie Weaver to add malformed_list_template_entry_ " Modified November 25, 1985 by Nashirali Samanani to change the stringrange error message. " Fixes fortran error list number 355 (TR phx13585). macro format zero 0,&l1 "length of varying string aci @&1@,104 "declare char (104) var &end macro cond maclist on,save ife &1,() "null string? zero nullp,0 ifend ine &1,() use data &U: zero 0,&l1 aci @&1@ use text zero &U,0 ifend maclist restore &end macro mte segdef &1 &1: zero &2,&3 "control bits zero 0,&4 "format index maclist off,save cond (&5) "first string cond (&6) "second string cond (&7) "third string cond (&8) "fourth string maclist restore ife &9,() "see if id given zero nullp,0 "no, point to null string ifend ine &9,() "id was given use data &U: zero 0,14+&l1 aci @ (&1 condition)@ use text zero &U,0 ifend &end use text use data join /text/text,data include message_table_entry use data nullp: zero 0,0 "zero length varying string use text segdef formats formats: format () format () format (^/Error: ^a^a by ^a^a^a^a^/^a^a^a^a) format (^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a ^a ^a^a^/^a ^a^/^a^a^a^a) format (^/Error while processing in ^a:^/^a ^a ^a^/^a ^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a ^a by ^a^a^/^a^a^a^a^a^a) format (^/Error while processing in ^a:^/^a ^a by ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a ^a^a^a^a^a^a^a^a) format (^/Error while processing in ^a:^/^a^a ^a^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a ^a^a^/^a ^a^/^a^a^a^a) format (^/Error while processing in ^a:^/^a^a ^a^/^a ^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a by ^a^a^a^a^a^/^a^a^a) format (^/Error while processing in ^a:^/^a^a by ^a^a^a^a^/^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a ^a^a^/^a ^a^a^a^a^a) format (^/Error while processing in ^a:^/^a^a ^a^/^a ^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a ^a^a^a^a^/^a^a^a^a) format (^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a by ^a^a^a^a^a^a^a^a) format (^/Error while processing in ^a:^/^a^a by ^a^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a error^a by ^a^a^/^a^a^a^a^a^a) format (^/Error while processing in ^a:^/^a error^a by ^a^/^a^a^a^a^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a by ^a^a^a^a^/^a^a^/^a^a) format (^/Error while processing in ^a:^/^a^a ^a^a^a^/^a^a^/^a^/Entry into lower ring was by^/^a^a^a^a) format (^/Error: ^a^a ^a^a^/^a ^a^/^a^a^/^a^a) format (^/Error while processing in ^a:^/^a^a ^a^/^a ^a^/^a^a^/^a^/Entry into lower ring was by^/^a^a^a^a) mte command_abort_,mte.no_tpr,mte.no_special,3,command_abort_,, (Program has stopped voluntarily.) mte command_query_error,mte.query_error,mte.no_special,23,command_query_error,, (A preset answer returned by the condition handler for command_question), (was neither "yes" nor "no" as required by the caller of command_query_.) mte active_function_error,mte.active_func,mte.no_special mte sub_error_,mte.no_tpr,mte.sub_err,21 mte error,mte.no_tpr,mte.no_special,19,(error condition) mte area,mte.no_tpr,mte.sig_error,23,(area condition),, (Either a variable could not be allocated in an area), (or an area could not be assigned to an existing area.) mte storage,mte.ignore,mte.storage+mte.sig_error,3,(storage condition) mte endfile,mte.no_tpr,mte.sig_error,19,(endfile condition) mte undefinedfile,mte.no_tpr,mte.sig_error,19,(undefinedfile condition) mte size,mte.no_tpr,mte.sig_error,13,(size condition),, (Precision of target insufficient for number of integral digits assigned to it.) mte conversion,mte.no_tpr,mte.sig_error,19,(conversion condition) mte endpage,mte.no_tpr,mte.endpage,19,(endpage condition) mte key,mte.no_tpr,mte.sig_error,19,(key condition) mte record,mte.no_tpr,mte.sig_error,19,(record condition) mte transmit,mte.no_tpr,mte.sig_error,13,(transmit condition),, (Data could not be reliably transmitted between file and some values in an I/O statement.) mte stringrange,mte.no_tpr,mte.sig_error,3,(stringrange condition),, (The given string does not completely contain the selected substring.) mte subscriptrange,mte.no_tpr,mte.sig_error,3,(subscriptrange condition),, (A subscript value has exceeded array bounds.) mte linkage_error,mte.with_tpr,mte.linkerr,11,(Linkage error by),referencing mte io_error,mte.io_err,mte.no_special,3,io_error mte illegal_procedure,mte.undefined mte privileged_info,mte.no_tpr,mte.cur_inst,17,(Attempt to execute privileged instruction by) mte unwinder_error,mte.unwind_err,mte.no_special,3,unwinder_error mte hard_default_info,mte.with_tpr,mte.no_special,5,(condition by),referencing mte null_pointer,mte.no_tpr,mte.no_special,17,(Attempt by),,(to reference through null pointer) mte fixedoverflow,mte.no_tpr,mte.sig_error,9,(Fixed point overflow by),,,,id mte overflow,mte.no_tpr,mte.sig_error,9,(Exponent overflow by),,,,id mte underflow,mte.no_tpr,mte.sig_error,9,(Exponent underflow by),,,,id mte zerodivide,mte.no_tpr,mte.sig_error,9,(Attempt to divide by zero at),,,,id mte illegal_opcode,mte.no_tpr,mte.cur_inst,17,(Illegal machine operation by),,,,id mte accessviolation,mte.with_tpr,mte.no_special,11,(Improper access by),referencing, (Improper access to referenced segment.),,id mte gate_err,mte.with_tpr,mte.gaterr,3,(gate error condition),,(Wrong number of arguments given.) mte seg_fault_error,mte.with_tpr,mte.segferr,11,(Segment-fault error by),referencing mte page_fault_error,mte.with_tpr,mte.pagerr,11,(Page read error encountered by),(in referencing) mte op_not_complete,mte.no_tpr,mte.no_special,17,(op_not_complete at), (Hardware error. Try invoking procedure again.) mte store,mte.with_tpr,mte.store,11,(store fault at),referencing mte command,mte.with_tpr,mte.no_special,25,(command condition by),referencing, (Either attempt to read clock on non-existent port), (or configuration error or hardware error.) mte lockup,mte.with_tpr,mte.no_special,25,(Possible loop by),referencing, (Interrupts not sampled for too long a time. Possibilities:), (tra * loop, infinite indirect chain, inhibited too long in BAR mode),id mte illegal_modifier,mte.with_tpr,mte.no_special,11,(illegal modifier condition by),referencing, (Possible illegal modifier in indirect chain or uninitialized pointer.) mte illegal_ring_order,mte.with_tpr,mte.no_special,11,(illegal_ring_order condition by),referencing, (Ring brackets in wrong order. Contact system maintenance staff.) mte bad_outward_call,mte.with_tpr,mte.no_special,11,(bad_outward_call condition by),referencing, (Incorrect access to, or ring brackets on, referenced segment.) mte inward_return,mte.with_tpr,mte.no_special 15,(Attempt to return to inward ring by),referencing,,,id mte cross_ring_transfer,mte.with_tpr,mte.no_special,25,(Illegal cross ring transfer by), (referencing),(Transfer instructions cannot be used to cross rings), (only call and rtcd instructions may be used.),id mte out_of_bounds,mte.with_tpr,mte.outbounds,11,(out_of_bounds at),referencing mte illegal_return,mte.no_tpr,mte.no_special,17,(Illegal return to), (Attempt to restore bad machine conditions after a fault.),,,id mte fault_tag_1,mte.with_tpr,mte.no_special,11,(fault_tag_1 by),referencing, (Ascii data where pointer expected.) mte truncation,mte.with_tpr,mte.no_special,11,(stringsize condition by),referencing, (Attempt to copy a longer string into a shorter one.) mte soft_default_info,mte.no_tpr,mte.no_special,7,condition mte not_a_gate,mte.with_tpr,mte.no_special,11,(Attempt by),(to access), (which is beyond the entry bound for the gate.),,id mte quit,mte.no_tpr,mte.no_special,9,(quit in) mte lot_fault,mte.with_tpr,mte.lotfault,11,(lot fault by),referencing mte return_conversion_error,mte.no_tpr,mte.no_special,13,(return conversion error),, (Incompatibility between a return or end statement and the way the procedure was entered.) mte fortran_pause,mte.no_tpr,mte.no_special,1,,,,,id mte malformed_list_template_entry_,mte.no_tpr,mte.no_special,5,(Attempt by), (to initialize a variable with a malformed list template.),,,id end  special_messages_.pl1 11/11/89 1139.1r w 11/11/89 0839.1 50319 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ special_messages_: proc (a_mcp, a_mtep, linfo, crlsw, no_restart); /* this procedure formats special messages which contain dynamic information */ /* initially coded by M. Weaver 5 June 1971 */ /* modified by M. Weaver 16 August 1971 */ /* modified by M. Weaver 18 October 1973 */ /* modified by M. Weaver 17 June 1974 for storage */ /* modified by M. Weaver 2 May 1977 for lot_fault */ /* modified by Benson I. Margulies 1/82 for improved oobstk codes */ /* Parameters */ dcl a_mcp ptr; dcl a_mtep ptr; dcl linfo char (500) var; dcl no_restart bit (1) aligned; dcl 1 pr_err aligned based (pre_infop), /* interpretation of errcode for page read error */ 2 device_addr bit (18) unal, 2 add_type bit (4) unal, 2 pad bit (5) unal, 2 pvtx fixed bin (8) unal; dcl (lng, i) fixed bin; dcl segno fixed bin (18); dcl ecode fixed bin (35); dcl segptr ptr; dcl error_table_$noentry ext fixed bin (35); dcl error_table_$stack_overflow ext fixed bin (35); dcl (objp, pre_infop) ptr; dcl fslinfo char (100) aligned; /* for convert_status_code_ */ dcl sinfo char (8) aligned; dcl (dirname, pathname) char (168); dcl ename char (32); %include disk_table; %include add_type; dcl string1 char (72) var; dcl (ioa_$rs, ioa_$rsnnl) entry options (variable); dcl convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl disassemble ext entry (ptr, char (72) var, fixed bin); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl (addr, addrel, baseptr, bin, divide, fixed, null, ptr, substr) builtin; dcl crlsw bit (1) unal; /* */ mcp = a_mcp; mtep = a_mtep; scup = addr (mc.scu); /* get ptr to saved control unit */ no_restart = "0"b; if mte.cur_inst then do; if ^crlsw then objp = ptr (baseptr (bin (scup -> scu.ppr.psr, 15)), scup -> scu.ilc); /* get inst from text */ else do; /* must get instruction from scu itself */ if substr (scup -> scu.ilc, 18, 1) = "1"b then i = 1; else i = 0; objp = addr (scup -> scux.instr (i)); end; call disassemble (objp, string1, 0); /* get inst in inst format */ call ioa_$rsnnl ("Current instruction is:^/^a", linfo, lng, string1); end; else if mte.segferr then do; ecode = mc.errcode; if ecode = error_table_$noentry then fslinfo = "Segment no longer exists."; else call convert_status_code_ (ecode, sinfo, fslinfo); linfo = fslinfo; end; else if mte.pagerr then do; /* page fault error */ pre_infop = addr (mcp -> mc.errcode); /* errcode is interpreted differently here */ if mcp -> mc.errcode = -1 then return; /* no device */ if (pr_err.add_type & add_type.non_null) = "0000"b then return; /* null */ if pr_err.add_type & add_type.pd then do; call ioa_$rs ("from paging device address ^o.", linfo, lng, pr_err.device_addr); return; end; call hcs_$make_seg ("", "disk_table.copy", "", 1010b, dtp, ecode); if dtp = null then return; call mdc_$read_disk_table (dtp, ecode); if ecode ^= 0 then return; if pr_err.pvtx > dt.n_entries | pr_err.pvtx <= 0 then return; dtep = addr (dt.array (pr_err.pvtx)); if dte.lvx > dt.n_lv_entries | dte.lvx <= 0 then return; lvep = addr (dt.lv_array (dte.lvx)); call ioa_$rs ("from ^a address ^o. Volume ^a of lv ^a.", linfo, lng, dte.drive_name, bin (pr_err.device_addr, 18), dte.pvname, lve.lvname); end; else if mte.outbounds then do; call convert_status_code_ ((mc.errcode), sinfo, fslinfo); linfo = fslinfo; end; else if mte.store then do; if scup -> scu.ir.bm then linfo = "Possible attempt to reference nonexistent memory."; else linfo = "Attempt to reference out of bounds in BAR mode."; end; else if mte.storage then do; if mcp = null then linfo = "System storage for based and controlled variables is full."; else do; /* detected by hardware on stack */ call convert_status_code_ ((mc.errcode), sinfo, fslinfo); linfo = fslinfo; if mc.errcode = error_table_$stack_overflow /* noplace to put the info */ then no_restart = "1"b; end; end; else if mte.lotfault then do; if crlsw then pathname = ""; else do; sb = ptr (mc.prs (6), 0); segno = bin (scup -> scu.ca, 18) - bin (rel (sb -> stack_header.lot_ptr), 18); segptr = baseptr (segno); call hcs_$fs_get_path_name (segptr, dirname, lng, ename, ecode); if ecode = 0 then call ioa_$rsnnl ("^a^[>^]^a", dirname, lng ^= 1, ename); else pathname = ""; end; linfo = "Attempt to execute non-object segment " || pathname; end; return; /* */ %include mc; %include stack_header; %include message_table_entry; end special_messages_; 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