copy_dump_seg_.pl1 11/15/82 1847.9rew 11/15/82 1516.3 33831 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ copy_dump_seg_: proc (segno, cur_proc_ind, p_array, l_array, outptr, retlen); /* Converted to 6180 and v2pl1 by R. Mullen Feb 1973 */ /* modified 11/14/80 by J. A. Bush for the DPS8/70M CPU */ dcl (segno, cur_proc_ind) fixed bin, /* Parameters */ retlen fixed bin (19), (p_array ptr, l_array fixed bin (19)) (0:31), outptr ptr; dcl (orig, next_orig) fixed bin (35); dcl (i, l, n, len, nsegs, idx, off, /* Misc variables */ next_off, seg_no, cpi, segn) fixed bin, (outp, p) ptr; dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl (addrel, divide, fixed, mod) builtin; dcl array (n) fixed bin (35) based; dcl wps fixed bin (19); % include bos_dump; /* Copy args first, then lookup segment # in image index */ dumpptr = p_array (0); outp = outptr; seg_no = segno; cpi = cur_proc_ind; call hcs_$get_max_length_seg (dumpptr, wps, orig); if orig ^= 0 then go to err; nsegs = dumpptr -> dump.num_segs; orig = size (dump); /* account for two page header */ i = 1; find_proc: if i = cpi then go to find_seg; orig = orig + fixed (dumpptr -> dump.segs (i).length, 18) * 64; i = i + 1; go to find_proc; find_seg: do i = cpi to nsegs; segn = fixed (dumpptr -> dump.segs (i).segno, 18); if segn = 0 /* Segment 0 is flag for new process */ then if i ^= cpi then go to err; /* Insure that we stay within the current process */ if segn = seg_no /* See if we've found desired seg */ then go to copy; orig = orig + fixed (dumpptr -> dump.segs (i).length, 18) * 64; /* increment orig to next seg */ end; /* and look at next seg */ err: retlen = 0; /* error, can't find segment */ return; copy: if i ^= nsegs /* If last seg of dump, use dump length */ then next_orig = fixed (dumpptr -> dump.segs (i).length, 18) * 64 + orig; else next_orig = fixed (dumpptr -> dump.words_dumped, 35); len = next_orig - orig; if len <= 0 then go to err; /* Something messed up, return 0 */ /* Length dumped is difference between current and next seg origins */ idx = divide (orig, wps, 17, 0); /* Get image-index for first word */ off = mod (orig, wps); /* And offset within the image segment */ p = p_array (idx); l = l_array (idx) * 1024; next_off = len + off; /* For checking bounds on seg */ call hcs_$truncate_seg (outp, 0, orig); /* Truncate output segment */ if next_off <= wps /* Does seg cross boundaries of image seg? */ then do; /* No, copy directly */ /* Since image is zero-suppressed from the end, can't run into trailing zeroes problem here */ n = len; /* Set arg for move operation */ outp -> array = addrel (p, off) -> array; /* Copy array */ end; else do; n = l - off; /* If zeroes near the boundary, may get bounds fault */ if n > 0 /* May be leading zeroes */ then outp -> array = addrel (p, off) -> array; /* Very similar */ outp = addrel (outp, (wps - off)); /* Advance "outp" regardless of "l" */ n = next_off - wps; /* Calculate second part */ outp -> array = p_array (idx + 1) -> array; end; retlen = len; /* Finished */ end copy_dump_seg_;  format_355_dump_line_.alm 11/15/82 1847.9rew 11/15/82 1533.9 37638 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " FORMAT_355_DUMP_LINE_ " " This is an alm program which is called by online_355_dump_ to " produce an ascii representation of 1 or more 355 words in octal. " It is called with three arguments: argument 1 is a pointer to the " input data. This pointer may have a bit offset in it but it must " be either 0 or 18 (i.e., the 355 words must be 18 bit aligned). " Argument 2 is the number of 355 18 bit words to be converted to " their ascii octal representation. Argument 3 is a pointer to the " place where the output is to be written. This pointer may have " a bit offset but it must be on a 9 bit (character) boundary. " " This program has another entry point, 'line'. The first 3 args " are as above but the last four consist of two pointer, fixed " bin pairs that are to be converted to octal. That is, the 2 fixed " bin args are to be converted to octal and the result placed in " the locations specified by the pointers. The two fixed bin values " are location counters for placement in the dump line. " " " Originally written by R.B.Snyder 09/14/73 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " name format_355_dump_line_ entry format_355_dump_line_ format_355_dump_line_: eppbp ap|2,* get ptr to ptr to input data ldaq bp|0 get ptr to data in AQ qrl 9 shift bit count to ql anq =o77,dl isolate eax1 0,ql copy to X1 eppbp bp|0,* put pointer in bp ldq ap|4,* get 355 word count in q mpy 6,dl compute number of octits eax3 0,ql put in X3 eppbb ap|6,* get pointer to pointer to output ldaq bb|0 get ptr to output in AQ qrl 9 shift bit count to ql anq =o77,dl isolate div 9,dl comput character number (0-3) qls 1 multiply char by 2 eax2 0,ql put char number*2 in X2 eppbb bb|0,* put pointer to output in bb ldq bp|0 get input qls 0,1 shift to get correct 18 bit word cmpx1 18,du see if 18 or 36 bit aligned tnz *+3 eax1 6 18 tra *+2 eax1 12 36 loop: lda 0,dl clear A lls 3 get an octit into A-reg ora =o60,dl convert to ascii xed store,2 store in output adx3 -1,du decrement character count tze return all done eax2 2,2 bump output character position cmpx2 8,du see if done with current word tnz *+3 eax2 0 yes eppbb bb|1 advance output pointer eax1 -1,1 decrement count of remaining octits cmpx1 6,du time to insert blank? tze insert_blank yes cmpx1 0,du tnz loop no insert_blank: lda =o40,dl get a blank xed store,2 put in output string eax2 2,2 advance output index cmpx2 8,du tnz *+3 eax2 0 eppbb bb|1 cmpx1 0,du done with current word? tnz loop still more in Q-reg eax1 12 get new count of octits eppbp bp|1 advance input pointer ldq bp|0 get new word tra loop return: lda ap|0 see if called with 3 args arl 18 cmpa 6,dl tnz line_entry no - we were called at line entry point real_return: short_return entry line line: eax4 0 tra format_355_dump_line_ do first 3 args line_entry: cmpx4 8,du have we gone thru both pairs tze real_return yes ldaq ap|8,4 get ptr staq ap|6 and substitute for third arg ldq 18,dl put a bit offset in arg ptr so qls 9 common code will work orsq ap|11,4 .. eppbp ap|10,4 get ptr to fixed bin number spribp ap|2 store as first arg eppbp =1 arg 2 is number of words to do spribp ap|4 eax4 4,4 bump call index tra format_355_dump_line_ even store: als 9*3 stba bb|0,40 als 9*2 stba bb|0,20 als 9*1 stba bb|0,10 nop 0,du stba bb|0,04 end  format_dump_line_.alm 11/15/82 1847.9rew 11/15/82 1534.0 39618 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name format_dump_line_ entry format_dump_line_ segdef line_size for od_print_ " dcl format_dump_line_ entry(ptr) " call format_dump_line_(bufp) " Gets input data from caller of its caller bool two_zeroes,060060 Will be OR'ed in bool two_pad,177177 Will be shifted set get,0 set put,5 format_dump_line_: eppbp ap|2,* eppbp bp|0,* Load pointer to buffer lda two_sp_pad Get two blanks sta bp|put+3 sta bp|put+7 sta bp|put+11 sta bp|put+15 sta bp|put+19 sta bp|put+23 sta bp|put+27 lda nl sta bp|put+31 ldq blanks Get four blanks stq bp|4 Separation between loc fields and 8-words eppap sp|26,* Get arg ptr of caller lda ap|2,* Convert "abs_loc" tmi set_blanks Not relevant, store blanks in field even; lrl 3 qrl 6 lrl 3 qrl 6 orq two_zeroes,du stq bp|1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|0 tra pick_loc Now format offset within seg set_blanks: " No absolute location, stuff in eight blanks stq bp|0 stq bp|1 pick_loc: " Convert offset value lda ap|4,* Second arg eaq two_pad Initialize even; lrl 3 qrl 6 lrl 3 qrl 6 orq two_zeroes,du stq bp|3 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|2 eppap ap|6,* Get pointer to data lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set get,get+1 set put,put+4 lda ap|get even; lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+2 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+1 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 lrl 3 qrl 6 orq zeroes stq bp|put+0 set put,put+4 One last update short_return zeroes: aci "0000" blanks: aci " " Four blanks two_sp_pad: vfd o36/177177040040 Two blanks between formatted words nl: vfd o36/177177177012 NL char plus padding line_size: vfd 36/put Last updated value is size of buffer end format_dump_line_  format_fnp_trace_msg_.pl1 11/15/82 1847.9rew 11/15/82 1516.3 71172 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* FORMAT_FNP_TRACE_MSG_ - A procedure to interpret an FNP trace table entry */ /* Written May 1977 by Larry Johnson */ /* Modified August 1979 by Larry Johnson for better decoding of dia codes */ /* This module performs an ioa-like edit of a control string found in od355_msgs. There is one control for each kind of trace message. The string may contain only ^d, ^o, ^w, ^b, ^e, and ^f codes with their normal ioa_ meaning. In addition, the special request ^n* may be used, with the following meanings: ^1* module|offset ^2* opblock name ^3* 3rd word of jump table ^4* dia mailbox opcode ^5* alter parameters sub-code */ format_fnp_trace_msg_: proc (arg_tmsgp, arg_modchp, arg_string); /* Parameters */ dcl arg_tmsgp ptr; /* Pointer to the trace table entry to interpret */ dcl arg_modchp ptr; /* Address of module chain */ dcl arg_string char (*) var; /* Where to put the result */ /* Automatic */ dcl (i, j) fixed bin; dcl p ptr; dcl argno fixed bin; /* For counting args */ dcl edit_temp char (50) var; dcl ctlp ptr; /* Pointer to unprocess part of control string */ dcl ctll fixed bin; /* Its length */ dcl ctl char (ctll) based (ctlp); dcl ctl_accp ptr; /* Pointer to origional ACC control string */ dcl 1 ctl_acc aligned based (ctl_accp), 2 length fixed bin (8) unal, 2 msg char (ctl_acc.length) unal; /* Format of a trace table entry */ dcl tmsgp ptr; dcl 1 tmsg unal based (tmsgp), 2 module bit (6) unal, /* Module that logged entry */ 2 type bit (6) unal, /* Index into possible msgs for that module */ 2 length bit (6) unal, /* Number of data words */ 2 time bit (18) unal, /* Relative time message was logged */ 2 data (1) bit (18) unal; /* Array of optional data words */ /* Format of module chain table */ dcl modchp ptr; dcl 1 modch aligned based (modchp), 2 nmodules fixed bin, 2 entries (modch.nmodules), 3 name char (4), 3 address fixed bin; /* Format of the third word of a jump table */ dcl jumptblp ptr; dcl 1 jumptbl unal based (jumptblp), 2 channel bit (4), 2 device bit (2), 2 subchan bit (5), 2 module bit (7); /* Things in od355_msgs */ dcl od355_msgs$ ext; dcl od355_msgs$trace_modtab (1) bit (18) aligned ext; /* Array of offsets for each module */ dcl message_offsetsp ptr; dcl message_offsets (1) bit (18) aligned based (message_offsetsp); /* Offsets to the individual acc strings */ /* External */ dcl ioa_$rsnpnnl entry options (variable); dcl db_fnp_opblock_util_$get_name entry (bit (18), char (*)); dcl db_fnp_sym_util_$lookup_member entry (fixed bin, char (*), char (*)); dcl (addr, bin, hbound, index, lbound, length, ptr, substr, verify) builtin; /* Find the origional control string in od355_msgs */ tmsgp = arg_tmsgp; /* Address of tracetable entry */ modchp = arg_modchp; i = bin (tmsg.module); /* Module number */ j = bin (tmsg.type); /* Message number for that module */ p = addr (od355_msgs$); /* For doing pointercalculations */ message_offsetsp = ptr (p, bin (od355_msgs$trace_modtab (i))); /* Address of table of messages for the module */ ctl_accp = ptr (p, bin (message_offsets (j))); /* Address of ACC string */ ctlp = addr (ctl_acc.msg); /* For looking at text part */ ctll = length (ctl_acc.msg); /* Now parse the input "ioa_" string, editing each operand */ call ioa_$rsnpnnl ("^.3b", arg_string, (0), tmsg.time); /* Start line with the time */ arg_string = arg_string || " "; argno = 0; do while (ctll > 0); /* Loop till string exhausted */ i = index (ctl, "^"); /* Look for next control */ if i = 1 then do; /* Found one */ i = verify (substr (ctl, 2), "0123456789."); /* Count digits */ if substr (ctl, i+1, 1) ^= "*" then do; /* Normal ioa_ control */ argno = argno + 1; /* Get next argument */ if substr (ctl, i+1, 1) = "b" then /* ^b requries a bit arg */ call ioa_$rsnpnnl (substr (ctl, 1, i+1), edit_temp, (0), tmsg.data (argno)); else call ioa_$rsnpnnl (substr (ctl, 1, i+1), edit_temp, (0), bin (tmsg.data (argno), 18)); /* Let ioa_ edit number */ arg_string = arg_string || edit_temp; end; else do; /* Special dump edit request */ j = bin (substr (ctl, 2, i-1)); /* Decode request nubber */ argno = argno + 1; call special_edit (j); end; ctlp = substraddr (ctl, i+2); /* Next character to deal with */ ctll = ctll - i - 1; end; else do; /* The next char is not a "^" */ if i = 0 then i = ctll; else i = i - 1; /* Number of characters berore next "^" */ arg_string = arg_string || substr (ctl, 1, i); /* Copy to string under construction */ ctlp = substraddr (ctl, i+1); /* Skip over them */ ctll = ctll - i; end; end; /* All items have been turned into character rsults */ return; /* Procedure to perform special editing requests */ special_edit: proc (n); dcl n fixed bin; /* The special type */ dcl i fixed bin; dcl idx fixed bin; dcl (diff, min_diff) fixed bin; dcl addr_val fixed bin; dcl opname char (6); dcl opval bit (18); go to special_ed (n); special_ed (1): /* ^1* means edit as module|offset */ min_diff = 32768; idx = 0; addr_val = bin (tmsg.data (argno)); do i = 1 to modch.nmodules; diff = addr_val - modch.address (i); if diff >= 0 then if diff < min_diff then do; idx = i; min_diff = diff; end; end; if idx = 0 then call ioa_$rsnpnnl ("^6w", edit_temp, (0), addr_val); /* No conversion */ else call ioa_$rsnpnnl ("^o (^a|^o)", edit_temp, (0), addr_val, modch.name (idx), min_diff); arg_string = arg_string || edit_temp; return; special_ed (2): /* ^2* means explain opblock number */ i = bin (tmsg.data (argno)); substr (opval, 1, 9) = "777"b3; /* rebuild opblock */ substr (opval, 10, 9) = bit (bin (i, 9), 9); call db_fnp_opblock_util_$get_name (opval, opname); if opname = "" then opname = "?"; call ioa_$rsnpnnl ("^3w (^a)", edit_temp, (0), i, opname); arg_string = arg_string || edit_temp; return; special_ed (3): /* ^3* means third word of jump table */ jumptblp = addr (tmsg.data (argno)); call ioa_$rsnpnnl ("^.3b (ch=^o dv=^o subch=^o mod=^o)", edit_temp, (0), tmsg.data (argno), bin (jumptbl.channel, 4), bin (jumptbl.device, 2), bin (jumptbl.subchan, 5), bin (jumptbl.module, 7)); arg_string = arg_string || edit_temp; return; special_ed (4): /* ^4* means dia opcode */ call db_fnp_sym_util_$lookup_member (bin (tmsg.data (argno)), "diaop", opname); call ioa_$rsnpnnl ("^o (^a)", edit_temp, (0), bin (tmsg.data (argno)), opname); arg_string = arg_string || edit_temp; return; special_ed (5): /* ^5* means alter paramaters code */ call db_fnp_sym_util_$lookup_member (bin (substr (tmsg.data (argno), 1, 9)), "alterp", opname); call ioa_$rsnpnnl ("^o (^a)", edit_temp, (0), bin (tmsg.data (argno)), opname); arg_string = arg_string || edit_temp; return; end special_edit; /* Simulate substraddr builtin temporarily */ substraddr: proc (c, n) returns (ptr); dcl c char (*); dcl n fixed bin; dcl ca (n) char (1) unal based (addr (c)); return (addr (ca (n))); end substraddr; end format_fnp_trace_msg_;  get_ast_name_.pl1 01/26/85 1314.2r w 01/22/85 1311.1 19188 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ get_ast_name_: proc (a_astep, a_sstp, a_sstnp, retstr); dcl (a_astep, a_sstp, a_sstnp) ptr; dcl retstr char (*); %include sst; %include sstnt; %include aste; astep = a_astep; sstp = a_sstp; sstnp = a_sstnp; if fixed (rel (astep), 18) < fixed (rel (sstp -> sst.astap), 18) then do; fail: retstr = "CANNOT GET PATHNAME"; return; end; if rel (astep) = rel (sstp -> sst.root_astep) then do; retstr = ">"; return; end; retstr = recurse (astep, length (retstr)); return; recurse: proc (astep, namel) returns (char (*)); dcl (ptsi, ra) fixed bin; dcl namel fixed bin; dcl astep ptr, name char (32) varying; ra = fixed (rel (astep), 18); /* for ease */ if ra < fixed (rel (sstp -> sst.astap), 18) then go to fail; do ptsi = 3 to 0 by -1 while (ra < sstnp -> sstnt.ast_offsets (ptsi)); end; if ptsi < 0 then go to fail; if ptsi ^= fixed (astep -> aste.ptsi, 2) then go to fail; name = sstnp -> sstnt.names ( divide (ra - sstnp -> sstnt.ast_offsets (ptsi), sstnp -> sstnt.ast_sizes (ptsi), 18, 0) + sstnp -> sstnt.ast_name_offsets (ptsi)); if length (name) = 0 then name = "CANNOT-GET"; if astep -> aste.par_astep = rel (sstp -> sst.root_astep) then do; if length (name) >= namel then return (""); else return (">" || name); end; if namel = 1 then return (">"); if length (name) >= namel then return ( recurse (ptr (astep, astep -> aste.par_astep), namel -1) || ">"); return (recurse (ptr (astep, astep -> aste.par_astep), namel - length (name) - 1) || ">" || name); end; end;  get_dump_ptrs_.pl1 11/15/82 1847.9rew 11/15/82 1516.4 33786 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ get_dump_ptrs_: proc (erfno, pa, la, nsegs, name); dcl erfno char (*), (pa ptr, la fixed bin) (0:31), nsegs fixed bin, name char (32) aligned, d_dir char (*); /* This program gets pointers to all of the segments of a multics on-line dump given the error report form number of the dump. It returns the pointers in the array 'pa' and the number of pointers returned in 'nsegs'. It also returns the name of the first dump segment in 'name'. Coded 4/71 SHW */ /* Modified 02/01/79 by F. W. Martinson to allow up to 32 dump segments */ /* Modified 06/29/79 by J. A. Bush to add the dump_dir entry point */ dcl code fixed bin (35); dcl (i, count) fixed bin, (dumpdir char (168) int static, (dump_name, star_name, char32 based) char (32), c0 char (0)) aligned, (eptr, nptr, areap) ptr, star_area area ((128)), hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35)); dcl (addr, fixed, null, substr) builtin; declare 1 br aligned, (2 (type bit (2), nnames bit (16), nrp bit (18)), 2 dtm bit (36), 2 dtu bit (36), 2 (mode bit (5), pad1 bit (13), records bit (18)), 2 dtd bit (36), 2 dtem bit (36), 2 acct bit (36), 2 (curlen bit (12), bitcnt bit (24)), 2 (did bit (4), imdid bit (4), copysw bit (1), pad3 bit (9), rbs (0:2) bit (6)), 2 uid bit (36)) unaligned; /* */ dumpdir = ">dumps"; /* set default dump directory */ join: areap = addr (star_area); /* get a pointer to the star area */ star_name = "*.*.0." || erfno; /* generate star name */ call hcs_$star_ (dumpdir, star_name, 2, areap, count, eptr, nptr, code); /* get first dump seg name */ if code = 0 then do; /* No problems, continue */ dump_name = nptr -> char32; /* copy name of first dump seg */ name = dump_name; /* return name to caller */ areap = addr (br); /* Get pointer to branch structure */ do i = 0 to 31; /* Initiate the dump segments */ call hcs_$initiate (dumpdir, dump_name, c0, 0, 1, eptr, code); /* initiate the dump seg */ if eptr = null then do; /* no more segs, return */ nsegs = i; /* return number of segs found */ return; end; /* We will allow up to 32 dump segments 0-31 */ pa (i) = eptr; /* Copy pointer */ call hcs_$status_long (dumpdir, dump_name, 1, areap, null, code); if code ^= 0 then la (i) = 0; else la (i) = fixed (br.curlen, 17); substr (dump_name, 13) = ltrim (char (i+1))||"."||ltrim (erfno); /* generate the next dump seg name */ end; end; nsegs = 0; /* Fell out of loop, or error in star_ call */ return; /* dump_dir - entry to get dump ptrs, given a dump directory name */ dump_dir: entry (d_dir, erfno, pa, la, nsegs, name); dumpdir = d_dir; /* copy dump directory */ go to join; /* and go to common code */ end get_dump_ptrs_;  od355_msgs.alm 11/15/82 1847.9rew 11/15/82 1452.6 88587 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " This module is used by online_355_dump_ to translate trace table " entries into intelligible messages " name od355_msgs segdef trace_modtab segdef die_list " " " " the module table is indexed by module number, and the " message tables pointed to by the module table entries " are indexed by trace type " trace_modtab: zero skdtrc zero diatrc zero inttrc zero utltrc zero lsltrc zero hsltrc " trace messages are in the form for pseudo-ioa control strings " They may contain ^o, ^w, ^d, ^b, ^e, and ^f operations with their " normal meaning. Also, they may contain special editing requests " in the form ^n*. The following special requests are defined: " ^1* - edit address in form module|offset " ^2* - edit name of opblock, given its number " ^3* - edit third word of jump table " ^4* - edit dia mailbox opcode " ^5* - edit 'alter parameters' code skdtrc: zero msg1.1 zero msg1.2 zero msg1.3 zero msg1.4 zero msg1.5 zero msg1.6 zero msg1.7 zero msg1.8 msg1.1: acc 'interrupt at ^5w, 3wjt ^3*' msg1.2: acc 'idle, indicators ^6w, ier ^6w' msg1.3: acc 'run interrupt routine ^6w' msg1.4: acc 'restart interrupted routine at ^6w' msg1.5: acc 'run queued routine ^6w' msg1.6: acc 'set timer ^6w for tib ^6w' msg1.7: acc 'interval timer runout, current time ^6w ^6w' msg1.8: acc 'queue routine, pri ^6w, rtn ^6w, x1 ^6w' diatrc: zero msg2.1 zero msg2.2 zero msg2.3 zero msg2.4 zero msg2.5 zero msg2.6 zero msg2.7 zero msg2.8 zero msg2.9 zero ms2.10 zero ms2.11 zero ms2.12 msg2.1: acc 'dia terminate, tcword = ^2w' msg2.2: acc 'dia interrupt for mailbox ^2w' msg2.3: acc 'dia reading mailbox ^2w' msg2.4: acc 'new entry in dia i/o queue at ^6w: opcode ^4*, line ^4w' msg2.5: acc 'wcd in mailbox ^2w: opcode ^4*, line ^4w' msg2.6: acc 'using dia i/o queue entry at ^6w: opcode ^4*, line ^4w' msg2.7: acc 'dia sending input count of ^6w for line ^4w' msg2.8: acc 'dia writing mailbox ^2w' msg2.9: acc 'dia freeing mailbox ^2w' ms2.10: acc 'wtx in mailbox ^2w for line ^4w, ^3w buffers' ms2.11: acc 'rtx in mailbox ^2w for line ^4w' ms2.12: acc 'alter parameters: ^5*' inttrc: zero msg3.1 zero msg3.2 zero msg3.3 zero msg3.4 zero msg3.5 msg3.1: acc 'itest: tib at ^6w, t.cur = ^1*' msg3.2: acc 'iwrite: tib at ^6w, t.cur = ^1*' msg3.3: acc 'istat: tib at ^6w, t.cur = ^1*, status ^6w' msg3.4: acc 'itime: tib at ^6w, t.cur = ^1*' msg3.5: acc 'op block at ^1*, type = ^2*' utltrc: zero msg4.1 zero msg4.2 zero msg4.3 zero msg4.4 msg4.1: acc 'buffer allocated at ^o (^o words) by ^1*, x1=^o' msg4.2: acc 'buffer freed at ^o (^o words) by ^1*, x1=^o' msg4.3: acc 'request for ^o buffers (^o words) by ^1*, x1=^o' msg4.4: acc 'buffer list at ^o freed by ^1*, x1=^o' lsltrc: zero msg5.1 zero msg5.2 zero msg5.3 zero msg5.4 zero msg5.5 zero msg5.6 zero msg5.7 msg5.1: acc 'lsla interrupt, 3wjt = ^3*' msg5.2: acc 'lsla output frame at ^6w, sfcm at ^6w' msg5.3: acc 'lsla output buffer at ^6w' msg5.4: acc 'lsla input frame at ^6w, sfcm at ^6w' msg5.5: acc 'lsla input buffer at ^6w' msg5.6: acc 'sending ^3w to lsla slot ^2w for line ^4w' msg5.7: acc 'escape in lsla slot ^2w for line ^4w' hsltrc: zero msg6.1 zero msg6.2 zero msg6.3 zero msg6.4 zero msg6.5 msg6.1: acc 'hsla dcw processor, tib ^6w, list ^1*, len ^2w' msg6.2: acc 'hsla pcw, tib ^6w, pcw ^6w ^6w' msg6.3: acc 'hsla interrupt, 3wjt = ^3*' msg6.4: acc 'hsla status, tib ^6w, status ^6w ^6w' msg6.5: acc 'hsla, tib ^6w, attempting icw indicator recovery' " die_list: aci 'scheduler ' zero 0,sked_messages aci 'dia_man ' zero 0,dia_messages aci 'interpreter ' zero 0,intp_messages aci 'utilities ' zero 0,util_messages aci 'lsla_man ' zero 0,lsla_messages aci 'hsla_man ' zero 0,hsla_messages aci 'console_man ' zero 0,cons_messages aci 'trace ' zero 0,trac_messages aci 'init ' zero 0,init_messages sked_messages: zero sked_1 zero sked_2 dia_messages: zero dia_1 zero dia_2 zero dia_3 zero dia_4 zero dia_5 zero dia_6 zero dia_7 zero dia_8 zero dia_9 zero dia_10 zero dia_11 zero dia_12 zero dia_13 zero dia_14 zero dia_15 zero dia_16 zero dia_17 zero dia_18 zero dia_19 zero dia_20 zero dia_21 zero dia_22 intp_messages: zero intp_1 zero intp_2 zero intp_3 zero intp_4 zero intp_5 zero intp_6 zero intp_7 zero intp_8 zero intp_9 zero intp_10 zero intp_11 zero intp_12 zero intp_13 zero intp_14 zero intp_15 zero intp_16 zero intp_17 zero dia_10 util_messages: zero util_1 zero util_2 zero util_3 zero util_4 zero util_5 zero util_6 zero intp_7 zero util_8 zero util_9 zero util_10 zero util_11 zero util_12 zero util_13 zero util_14 lsla_messages: zero lsla_1 zero util_8 zero util_9 zero lsla_4 zero lsla_5 zero intp_6 zero intp_7 zero lsla_8 zero lsla_9 zero dia_10 zero lsla_11 hsla_messages: zero hsla_1 zero hsla_2 zero hsla_3 zero hsla_4 zero hsla_5 zero hsla_6 zero hsla_7 zero hsla_8 zero dia_10 zero hsla_10 zero no_message zero hsla_12 zero hsla_13 cons_messages: zero no_message trac_messages: zero no_message init_messages: zero dia_10 zero init_2 zero init_3 zero init_4 zero init_5 zero init_6 zero bad_init zero init_8 zero init_9 zero init_10 zero init_11 zero init_12 zero init_13 zero init_14 zero init_15 sked_1: acc 'no buffers for delay queue' sked_2: acc 'attempt to run missing routine' dia_1: acc 'mailbox wraparound queue full' dia_2: acc 'unrecoverable i/o error' h dia_3: acc 'more than 5 consecutive i/o errors' h dia_4: acc 'invalid value for tcw' dia_5: acc 'mailbox queue count < 0' dia_6: acc 'invalid mailbox number in wraparound queue' dia_7: acc '3 consecutive mailbox checksum errors' h dia_8: acc 'op-code not valid for i/o command' dia_9: acc 'rcd processed with no queue entries' dia_10: acc 'buffer allocation failed' dia_11: acc 'last buffer in input chain lacks "last" flag' dia_12: acc 'tally for rtx too small' dia_13: acc 'tally for rtx too large' dia_14: acc 'attempt to lock already locked dia' dia_15: acc 'attempt to unlock already unlocked dia' dia_16: acc 'rtx in mailbox, next queue element not accept input' dia_17: acc 'unrecognized i/o command' dia_18: acc 'no dia configured' dia_19: acc 'accept input when no input chain' dia_20: acc 'attempt to chain to invalid output chain' dia_21: acc 'input buffer had zero tally' dia_22: acc 'no entry for line in tib list' intp_1: acc 'x1 = 0 at entry' intp_2: acc 't.cur = 0 at entry' intp_3: acc 'called when not at wait block' intp_4: acc 'type not of form 777xxx' intp_5: acc 'tried to execute status block' intp_6: acc 'unrecognized sub-op in dcw list' intp_7: acc 'outmsg not followed by output_end' intp_8: acc 'unrecognized op block' intp_9: acc 'started block check while check in progress' intp_10: acc 'compare block check without start block check' intp_11: acc 'unrecognized scan type' intp_12: acc 't.type <= 0' intp_13: acc 'error in use of calsub, retsub op blocks' intp_14: acc 'error in use of getext, retext op blocks' intp_15: acc 'error in scan control string' intp_16: acc 'invalid sub-op list to config op' intp_17: acc 'replay attempted with active output chain' util_1: acc 'buffer of size <= 0 requested' util_2: acc 'buffer of more than max size requested' util_3: acc 'tried to free buffer with address < .crbuf' util_4: acc 'tried to free space already free' util_5: acc 'address in block pointer too large' util_6: acc 'invalid interrupt vector' util_8: acc 'kybd/prtr addressing with control set' util_9: acc 'unrecognized type in output sub-op' util_10: acc 'could not allocate buffer for output' util_11: acc 't.olst -> buffer has forward pointer' util_12: acc 'free block size too large' util_13: acc 'attempt to append output to single-message chain' util_14: acc 'attempt to move data with an invalid address' hsla_1: acc 'attempt to modify loc < 1000(8)' hsla_2: acc 'config op is invalid for channel' hsla_3: acc 'read tally started with active input chain' hsla_4: acc 'receive transfer timing error' h hsla_5: acc 'input tally runout' hsla_6: acc 'unable to find cct for modes requested' hsla_7: acc 'xmit transfer timing error' h hsla_8: acc 'hdcw called with no dcw list' hsla_10: acc 'no sfcm addr for line' hsla_12: acc 'houtav called with bad chain' hsla_13: acc 'invalid hsla status' lsla_1: acc 'not in xmit mode after output sub-op' lsla_4: acc 'more than 10 successive re-sync attempts' lsla_5: acc 'send transfer timing error' h lsla_8: acc 'unrecognized receive status' lsla_9: acc 'input icw status does not agree with flag' lsla_11: acc 'output icw status does not agree with flag' no_message: acc 'unrecognized error code' init_2: acc 'timer channel not enabled' init_3: acc 'more than one dia configured' init_4: acc 'dia does not exist' init_5: acc 'dia did not respond' init_6: acc 'invalid baud rate specified' init_8: acc 'core image specified more memory than physically present' init_9: acc 'lsla ^o illegal sync speed' init_10: acc 'lsla ^o failed ten times to init' init_11: acc 'lsla ^o speed not equal desired speed' init_12: acc 'timer switch incorrectly set' init_13: acc 'lsla ^o, actual config does not match CDT' init_14: acc 'pager is disabled or inoperative' init_15: acc 'unable to allocate trace buffer' bad_init: acc 'unrecognized config status ^s^w' end  od_print_.pl1 11/15/82 1847.9rew 11/15/82 1516.5 36153 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* "ioa_" for on-line dumper, generates page headers etc. */ /* converted to 6180, v2pl1 by R Mullen Feb 1973 */ od_print_: proc (num_nl) recursive; /* Calls itself to print page headings */ dcl num_nl fixed bin; dcl (bufp ptr, (linect, cur_word_no, erf_no, proc_no, seg_no, page_no, zero init (0), two init (2), three init (3), wpl) fixed bin, (ioname char (32) init ("od_output_"), time_string char (24), /* date and time */ fmtheader char (51) init ("^|^-ERF ^d^3-^a^3-Page ^3d^2-Process ^d, Seg ^3o^2/"), buffer char (4104)) aligned) int static, /* 4096 + 8 characters of slop */ status bit (72) aligned, /* for ios_ calls */ p ptr, (i, /* Misc */ fmt_sw, /* 0 - fast 8 words, 1 - regular format */ n, /* length of formatted string */ nnl) fixed bin; /* # of NL chars in formatted string */ declare 1 fun based aligned, /* For adding NL plus PAD */ 2 fill char (n) unaligned, 2 ny bit (36) unaligned; dcl formline_ entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin), format_dump_line_ entry (ptr), /* Plus three args passed to "od_print_" */ ios_$write entry (char (*) aligned, ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned), date_time_ entry (fixed bin (52), char (*) aligned), od_print_ entry options (variable); dcl format_dump_line_$line_size ext fixed bin; dcl (addr, addrel, divide) builtin; /* Format the output line. */ fmt_sw = 1; /* not special, do formatting */ nnl = num_nl; test_page: /* First see if page overflow */ if nnl >= 0 then do; if (linect + nnl) > 54 /* Check for page overflow. */ then do; linect = -3; /* Reset line counter. */ page_no = page_no + 1; /* Increment the page number. */ call od_print_ (three, fmtheader, erf_no, time_string, page_no, proc_no, seg_no); /* Print out page heading. */ end; linect = linect + nnl; /* Now update the counter */ end; p = addrel (bufp, cur_word_no); /* Pointer to space to generate new text */ if fmt_sw ^= 0 then do; n = 256; /* Allow for multi-line formats */ call formline_ (two, three, p, n, zero); p -> fun.ny = "000001010001111111001111111001111111"b; /* Add NL char plus PADs */ cur_word_no = cur_word_no + divide (n + 4, 4, 17, 0); end; else do; call format_dump_line_ (p); cur_word_no = cur_word_no + wpl; end; if cur_word_no > 960 /* 1024 - 64 */ then do; n = cur_word_no * 4; /* Convert words to characters */ cur_word_no = 0; /* and reset counter */ call ios_$write (ioname, bufp, 0, n, i, status); end; return; op_fmt_line: entry (num_nl); /* Nominally */ nnl = 1; fmt_sw = 0; go to test_page; /* Miscellaneous entry points */ op_finish: entry; if cur_word_no = 0 then return; n = cur_word_no * 4; /* Same as before */ cur_word_no = 0; /* .. */ call ios_$write (ioname, bufp, 0, n, i, status); return; op_new_seg: entry (segno); dcl segno fixed bin; seg_no = segno; if seg_no = 0 then proc_no = proc_no + 1; op_new_page: entry; linect = 54; return; op_init: entry (erfno, time_val); dcl erfno fixed bin, time_val fixed bin (52); erf_no = erfno; call date_time_ (time_val, time_string); wpl = format_dump_line_$line_size; bufp = addr (buffer); cur_word_no = 0; page_no = 0; proc_no = 0; seg_no = 0; linect = 54; end od_print_;  od_stack_.pl1 11/05/86 1504.5r w 11/04/86 1034.3 98451 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ od_stack_: proc (stackptr, stacklen, sltp, namp, sstp, sstnp); /* Coded by RE Mullen June 73 */ /* Called with pointer to a stack, the stack's length, and pointers to an SLT and name_seg */ dcl (stackptr, sp_next, sp_curr, lineptr) ptr; dcl (stacklen, i, frame_no, depth, slen, fword, sword, segno, spoff, case, fsize) fixed bin; dcl stackwords (0: 1) fixed bin (35) aligned based (sb); dcl (addr, baseno, baseptr, addrel, max, min, mod, ptr, null, fixed, rel) builtin; dcl od_print_$op_fmt_line entry (fixed bin, fixed bin, fixed bin (35)); dcl od_print_ entry options (variable); dcl (curptr, lastptr) ptr; dcl plural char (1) aligned; dcl nskip fixed bin; dcl fmtskip char (21) aligned int static init ("^-^7o line^a repeated"); dcl 1 dbl based aligned, 2 (zero, two, four, six) fixed bin (71); dcl (entinfo, retinfo) char (128) aligned init (""); /* dcl od_frame_owner_ entry (ptr, ptr, ptr, ptr, ptr, char (*) aligned, char (*) aligned); */ dcl (sltp, ptr_to_entry, namp, ptr_to_return, sstp, sstnp) ptr; dcl (subsysfrms, save_slen) fixed bin init (0); dcl (save_sp_next, save_sp, last_sp) ptr; dcl subsysflag fixed bin init (0); % include its; % include stack_frame; % include stack_header; /* */ sp, sb = stackptr; /* initialize and copy args */ slen = stacklen; /* the length of the stack we will dump */ sp_next = stack_header.stack_begin_ptr; /* we will do a forward trace */ segno = fixed (baseno (sp_next)); /* this is the segno the dead stack had */ call check_sp_next; if case <= 4 then do; /* its a pointer and spoff is set to rel (sp_next) */ if segno = 49 then if spoff = 272 then sp_next = addrel (sp_next, 48); /* PRDS has bug in it . . . */ end; /* Prelim. trace to see if any next_sp = stack_end_ptr, if so the frame will be number zero implying its owner was running */ do frame_no = 0 by 1; call check_sp_next; /* internal proc to keep from being too gullible */ if case ^= 0 then go to bad; /* sp_next loses */ if addr (stack_header.stack_end_ptr) -> its.its_mod ^= "100011"b then go to bad;/* not its? */ if addr (stack_header.stack_end_ptr) -> its.mod ^= "000000"b then go to bad; /* not its? */ if spoff > fixed (rel (stack_header.stack_end_ptr), 18) then do; /* spoff has been set to offset of sp_next */ case = 10; /* FOR DEBUGGING */ go to bad; end; if sp_next = stack_header.stack_end_ptr then go to good; /* this frame will be number zero . . */ sp = ptr (sb, spoff); /* advance to next frame, but fudge segno */ sp_next = stack_frame.next_sp; /* pick up new sp_next */ end; bad: frame_no = 0; /* if stack was bad or not active, number frames from 0 up */ good: /* Now loop through th frames. At the beginning of each iteration sp will point to a frame to be printed (eg. sp = 334|2740), and sword will be the relative offset from the base of thestack of the first word of the frame. If that frames next_sp is good then sp will be advanced and the current frame will be printed. If next_sp is bad then the remainder of the stack will be dumped. Also any frames jumped over by syserr will be broken out with number "XX" */ curptr, sp, sb = stackptr; /* reinitialize */ slen = stacklen; /* in case we tampered with anything */ sp_next = stack_header.stack_begin_ptr; /* again trace forward */ call check_sp_next; if case <= 4 then do; /* sp_next is ptr and spoff is set to rel (sp_next) */ if segno = 49 then if spoff = 272 then sp_next = addrel (sp_next, 48); /* PRDS has bug in it . . . */ sp_curr = ptr (sp_next, 0); /* back pointers will be checked against this */ end; sword = 0; /* offset from base of the first word of a line to be printed */ ptr_to_entry, ptr_to_return = null; /* for stack header */ subsysfrms = 0; /* will = 1 if looking at frame jumped over by syserr */ do i = 0 by 1; /* only way out of loop is if sword >= slen */ below_syserr: /* come here when i must no increase */ call check_sp_next; /* which will advance spoff and set case */ if case ^= 0 then go to dump_rest; /* print this frame heading and rest of stack */ last_sp = sp; /* save this in case we find frames preserved by syserr */ sp = ptr (sb, spoff); /* advance sp to next frame */ if (i > 0 & i - frame_no >= 0) | subsysfrms = 1 then do; /* skip these tests low on the stack */ if addr (stack_frame.prev_sp) -> its.its_mod ^= "100011"b then go to dump_rest; /* not its? */ if addr (stack_frame.prev_sp) -> its.mod ^= "000000"b then go to dump_rest;/* furth. mod? */ if addr (sp_curr) -> its.its_mod ^= "100011"b then go to dump_rest;/* not its? */ if addr (sp_curr) -> its.mod ^= "000000"b then go to dump_rest;/* furth. mod? */ if baseno (sp_curr) ^= baseno (stack_frame.prev_sp) then go to dump_rest; /* another segno? */ if rel (sp_curr) ^= rel (stack_frame.prev_sp) then go to dump_rest; /* back pointer bad? */ end; if spoff = 12288 then if subsysfrms = 0 then do; /* probable syserr frame */ subsysfrms = 1; /* detour to see what is between here and syserr */ save_slen = slen; /* remember the length of the stack */ save_sp = sp; /* and the address of the syserr frame */ save_sp_next = sp_next; /* and the stacks internal representation of same */ slen = 12288; /* only want to print up to the syserr frame for now */ sp = last_sp; /* reset sp to previous frame */ sp_next = ptr_to_entry; /* and pick up sp_next from where syserr saves it */ go to below_syserr; /* retry the above with fudged sp_next */ end; fsize = fixed (rel (sp_next), 18) - fixed (rel (sp_curr), 18); /* size of frame to be printed */ go to print_frame; /* and print it knowing there will be another frame */ dump_rest: fsize = slen - sword; /* no next frame */ print_frame: retinfo, entinfo = ""; /* don't know anything yet */ /* call od_frame_owner_ (ptr_to_return, ptr_to_entry, sltp, namp, sstp, sstnp, retinfo, entinfo); */ if subsysflag = 0 then /* a mainline frame with a number */ call od_print_ (2, "^/^3-STACK FRAME ^d ^a", i - frame_no, retinfo); /* print the info */ else /* this frame has been jumped over by syserr, no number */ call od_print_ (2, "^/^3-STACK FRAME XX ^a", retinfo); if entinfo ^= "" then /* entinfo may be in retinfo, or may be absent */ call od_print_ (2, "^5-entry_ptr: ^a^/", entinfo); else call od_print_ (2, "^/"); if subsysfrms = 1 then subsysflag = 1; /* frame no = XX for now */ nskip = 0; /* have skiped no lines so far this frame */ do fword = 0 by 8 while (fword < fsize); /* loop to print contents of frame */ if fword ^= 0 then /* dont check for repeat on first line */ if lastptr -> dbl.zero = curptr -> dbl.zero then /* see if current line same al last printed line */ if lastptr -> dbl.two = curptr -> dbl.two then if lastptr -> dbl.four = curptr -> dbl.four then if lastptr -> dbl.six = curptr -> dbl.six then do; nskip = nskip + 1; /* note that another line has been skipped */ go to SKIP; /* and skip printing the line */ end; if nskip > 0 then do; /* before printing a line check backlog of skipped lines */ if nskip > 1 then plural = "s"; else plural = " "; /* more than one? */ call od_print_ (1, fmtskip, nskip, plural); /* tell how many */ nskip = 0; /* these are accounted for */ end; call od_print_$op_fmt_line (sword, fword, stackwords (sword)); /* now print the line */ lastptr = curptr; /* future lines will be compared to this one */ SKIP: /* come here if line was to be skipped */ sword = sword + 8; /* want to move to next line in any case */ curptr = addrel (curptr, 8); /* and advance pointer to it also */ end; /* leave loop when frame is printed */ if nskip > 0 then do; /* could have skipped a lot of lines lately */ if nskip > 1 then plural = "s"; else plural = " "; /* */ call od_print_ (1, fmtskip, nskip, plural); /* tell how many */ end; if sword >= slen then do; /* whole stack may be done . . . */ if subsysfrms = 1 then do; subsysfrms = 0; /* in which case we want to continue */ subsysflag = 0; /* print frame num not XX from now on */ slen = save_slen; /* reset to real lenght of stack */ sp = save_sp; /* reset sp to point to syserr frame */ sp_next = save_sp_next; /* reset */ end; else go to ALLDONE; /* actually at end of stack */ end; sp_curr = sp_next; /* advance internal representation */ ptr_to_entry = stack_frame.entry_ptr; /* sp -> next frame to be printed, which is known to be good */ if fixed (stack_frame.translator_id, 18) = 2 /* Version I pl1 */ then ptr_to_return = stack_frame.pointer_registers (0); else ptr_to_return = stack_frame.return_ptr; /* ret ptr in exptected place */ sp_next = stack_frame.next_sp; /* pick up foward pointer */ if subsysfrms = 1 then go to below_syserr; /* so frame nums won't increase */ end; ALLDONE: /* exit from above loop by coming here */ return; /* -------------------------------------------------------------------------- */ check_sp_next: proc; /* verifies that sp_next might point to next stack frame */ if addr (sp_next) -> its.mod = "000000"b then /* if sp_next is not too fancy */ if addr (sp_next) -> its.its_mod = "100011"b then do; /* and if it is an its pointer */ spoff = fixed (rel (sp_next), 18); /* then pick up word offset portion */ if fixed (baseno (sp_next), 18) = segno then /* if segno is good */ if spoff <= slen -stack_frame_min_length then /* if spoff is not too big */ if mod (spoff, 16) = 0 then /* and mod16 */ if spoff >= fixed (rel (sp), 18) + stack_frame_min_length then /* and further up the stack */ case = 0; /* then its possible sp_next points to a sack frame */ else case = 1; /* sp_next not forword enough */ else case = 2; /* sp_next not mod16 */ else case = 3; /* sp_next points off end of what stack we have */ else case = 4; /* sp_next points into some other segment */ end; else case = 5; /* sp_next is not a pointer */ else case = 6; /* sp_next has further modification */ return; end check_sp_next; end od_stack_;  online_355_dump_.pl1 07/21/86 1518.9rew 07/21/86 1507.9 170334 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ online_355_dump_: proc (a_dumpp, number); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * online_355_dump_ * * This is a subroutine to produce a dump suitable for printing from a fnp * fdump. This subroutine is called with a pointer to the dump to be printed * and with the stream name "od_output_" already attached to the output device. * * Originally written by Dick Snyder 05/31/73 * Modified for new 355 software by Robert Coren 04/01/75 * Modified for multiple 355s by Robert Coren 10/08/75 * Modified for new communications region and to add crash message by Robert Coren 06/24/76 * Modified 79 May 16 by Art Beattie to support 64K fnp dumps. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(85-05-31,Farley), approve(86-07-10,MCR7247), audit(86-07-18,Fawcett), install(86-07-21,MR12.0-1099): Allow for upto 256k FNP memory sizes (phx19295). END HISTORY COMMENTS */ /* EXTERNAL ENTRIES */ dcl ios_$write ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl com_err_ ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl ioa_$rs ext entry options (variable); dcl format_355_dump_line_$line ext entry (ptr, fixed bin, ptr, ptr, fixed bin, ptr, fixed bin); dcl format_355_dump_line_ ext entry (ptr, fixed bin, ptr); dcl date_time_ entry (fixed bin (71), char (*)); dcl format_fnp_trace_msg_ entry (ptr, ptr, char (*) var); dcl get_fnp_name_ entry (fixed bin) returns (char (32)); /* AUTOMATIC STORAGE */ dcl faultp pointer; /* points to fault data */ dcl a_dumpp pointer; dcl number fixed bin; /* fnp identifier */ dcl st bit (72) aligned; /* ios status word */ dcl st_code fixed bin based (statp); /* overlay for left half of st */ dcl statp pointer; /* points to st */ dcl dumpp pointer; /* argument copied to local variable for better code */ dcl (i, k, nelemt); /* scratch temps */ dcl retstring char (132); /* string returned by ioa_$rsnnl */ dcl retp pointer; /* points to retstring */ dcl retl fixed bin; /* number of valid chars in retstring */ dcl date_time_bound char (24); dcl date_time_booted char (24); dcl type char (5); /* fault type */ dcl octal char (200); /* string written by format_355_dump_line_ */ dcl octalp pointer; /* points to octal */ dcl next_module_start fixed bin; /* address of base of a module */ dcl dup_copy bit (144) based; /* for copying 8 fnp words */ dcl mem_size fixed bin (18) unsigned; /* size of fnp memory */ dcl mod_chain fixed bin; /* start of module chain */ dcl locs_to_dump fixed bin (18) unsigned; /* number of words left to dump */ dcl rel_addr fixed bin init (0); /* rell address in current module being dumped */ dcl curlp pointer; /* points to current line being dumped in fnp image */ dcl dupp pointer; /* points to last non-duplicate line */ dcl cur_loc fixed bin init (0); /* current loc being dumped in fnp image */ dcl cur_chain fixed bin (18) unsigned; /* offset in dump of current module chain block */ dcl modx fixed bin; /* current index into module chain */ dcl module_name char (12); dcl module_num fixed bin; dcl die_ptr ptr; dcl reasonp ptr; dcl ch_val fixed bin; dcl trace_edit char (128) var; dcl print_trace bit (1) init ("1"b); /* ON - try printing trace data */ /* BASED */ dcl bit36 bit (36) unal based; /* used to overlay module name in fnp module chain */ dcl first_200_words bit (7200) aligned based (dumpp); /* used to check if fnp core is all zero */ dcl message_offsets (1) bit (18) aligned based; /* list of message offsets (per module) */ dcl 1 die_reason based (reasonp) aligned, 2 length fixed bin (8) unaligned, 2 msg char (0 refer (die_reason.length)) unaligned; dcl 1 die_word based (die_ptr), /* format of illegal op word used to crash fnp */ 2 mod_num bit (4) unaligned, 2 op_code bit (5) unaligned, 2 reason fixed bin (8) unaligned; dcl dump_chars (16) bit (9) unaligned based (curlp); /* STRUCTURES */ dcl 1 core_fnpb aligned based (dumpp), /* overlay for fnp dump in 18 bit pieces */ 2 words (0: MEM_256K - 1) bit (18) unaligned; dcl 1 core_fnp aligned based (dumpp), /* overlay for fnp dump in packed fixed bin */ 2 words (0: MEM_256K - 1) fixed bin (17) unaligned; dcl 1 dump_line aligned, /* dump line */ 2 abs_addr char (6) unaligned, /* absolute fnp address */ 2 star char (1) unaligned, /* duplicate line indicator */ 2 space1 char (1) unaligned, /* blank */ 2 module char (4) unaligned, /* module name */ 2 space2 char (1) unaligned, /* blank */ 2 rel_addr char (6) unaligned, /* rel address in module */ 2 space3 char (3) unaligned, /* blanks */ 2 eight_words char (55) unaligned, /* dump line itself */ 2 space4 char (2) unaligned, /* blanks */ 2 ascii (16) char (1) unaligned, /* ascii of dump_line */ 2 nl char (1) unaligned; /* new line */ dcl 1 fault_data aligned based (faultp), /* to overlay fault data in fnp */ 2 regs (9) fixed bin (17) unaligned, 2 fault_number fixed bin (17) unaligned, 2 fault_name bit (18) unaligned; dcl 1 octal_overlay (50) unaligned based (addr (octal)), /* to get at 6 chars at a time in octal */ 2 word char (6) unaligned, /* octal representation of 1 fnp word */ 2 space char (1) unaligned; /* a space */ dcl 1 modch aligned, /* information provided by module chain */ 2 nmodules fixed bin, 2 entries (30), 3 name char (4), 3 address fixed bin (24); /* INTERNAL STATIC */ dcl MEM_24K fixed bin (19) uns int static options (constant) init (24576); dcl MEM_32K fixed bin (19) uns int static options (constant) init (32768); dcl MEM_64K fixed bin (19) uns int static options (constant) init (65536); dcl MEM_128K fixed bin (19) uns int static options (constant) init (131072); dcl MEM_256K fixed bin (19) uns int static options (constant) init (262144); dcl die_op bit (5) int static options (constant) init ("01001"b); dcl faults (0: 10) char (16) int static options (constant) init ( "POWER OFF ", "POWER ON ", "MEMORY PARITY", "ILLEGAL OPCODE", "OVERFLOW ", "STORE FAULT", "DIVIDE CHECK", "ILLEGAL INT", "EXTRA INT ", "IOM FAULT", "CONSOLE ABORT"); dcl xlate (0: 63) char (1) int static init ( /* bcd to ascii xlation table */ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "[", "#", "@", ":", ">", "?", " ", "A", "B", "C", "D", "E", "F", "G", "H", "I", "&", ".", "]", "(", "<", "^", "|", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "-", "$", "*", ")", ";", "'", "+", "/", "S", "T", "U", "V", "W", "X", "Y", "Z", "_", ",", "%", "=", """", "!"); dcl end_of_table bit (18) int static init ("101010101010101000"b); /* physical end of trace table pattern */ dcl logical_end bit (18) int static init ("101010101010101010"b); /* logical end of trace table pattern */ dcl nl char (1) int static options (constant) init (" "); /* EXTERNAL STATIC */ dcl od355_msgs$ fixed bin ext static; dcl 1 od355_msgs$die_list (8) ext static aligned, 2 name char (12), 2 offset fixed bin; /* BUILTINS */ dcl (addr, addrel, bin, bit, fixed, length, ptr, string, substr, unspec) builtin; /* INCLUDE FILES */ %include mcs_memory_map; memp, dumpp = a_dumpp; /* copy argument for better access code */ statp = addr (st); /* init random pointers */ octalp = addr (octal); retp = addr (retstring); if first_200_words = "0"b then return; /* assume in this case there's no core */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PRINT OUT DUMP HEADER * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call date_time_ (comm_reg.crldt, date_time_bound); call date_time_ (comm_reg.crbdt, date_time_booted); call ioa_$rsnnl ("^2/^3-DATANET FNP MEMORY DUMP^2/FNP ^a, MCS Version ^a^/Bound ^a^/Booted ^a^3/", retstring, retl, get_fnp_name_ (number), comm_reg.crver, date_time_bound, date_time_booted); /* format dump header */ call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output the string */ if st_code ^= 0 then do; /* error? */ err: call com_err_ (st_code, "online_355_dump_", "Attempted to write to output file."); /* bitch */ return; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PRINT OUT FAULT DATA * * Print cause of fault, and regs in the following order: * * IC, Indicators, A, Q, X1, X2, X3, Enable Register, Elapsed Timer * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ faultp = addr (core_fnp.words (comm_reg.crreg)); /* make pointer to fault data */ if fault_data.fault_number > 7 then type = "ABORT"; /* not a processor fault */ else type = "FAULT"; /* format fault/abort message */ if fault_data.fault_number = 3 /* illegal opcode */ then do; die_ptr = addr (core_fnp.words (fault_data.regs (1) - 1)); /* get word it died on */ if die_word.op_code = die_op /* software-induced crash */ then do; module_num = bin (die_word.mod_num, 4); module_name = od355_msgs$die_list (module_num).name; reasonp = ptr (addr (od355_msgs$), od355_msgs$die_list (module_num).offset); reasonp = ptr (reasonp, reasonp -> message_offsets (die_word.reason)); call ioa_$rsnnl ("CRASH REASON:^2/^a: ^a^3/", retstring, retl, module_name, reasonp -> die_reason.msg); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); if st_code ^= 0 then go to err; end; end; if fault_data.regs (1) = 0 then /* no fault if IC = 0 */ call ioa_$rsnnl ("^a: ^a^2/", retstring, retl, type, "NONE "); else call ioa_$rsnnl ("^a: ^a^2/", retstring, retl, type, faults (fault_data.fault_number)); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */ if st_code ^= 0 then go to err; /* error */ call format_355_dump_line_ (addr (fault_data.regs (1)), 9, octalp); /* get regs in octal */ /* format regs output line */ call ioa_$rsnnl ("IC ^a, IR ^a, A ^a, Q ^a, X1 ^a, X2 ^a, X3 ^a, ER ^a, ET ^a^/", retstring, retl, octal_overlay (1).word, octal_overlay (2).word, octal_overlay (3).word, octal_overlay (4).word, octal_overlay (5).word, octal_overlay (6).word, octal_overlay (7).word, octal_overlay (8).word, octal_overlay (9).word); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */ if st_code ^= 0 then go to err; /* error */ mem_size = comm_reg.crmem; /* copy out fnp mem size for better code */ if mem_size ^= MEM_24K - 1 then /* check for clobbered mem size */ if mem_size ^= MEM_32K - 1 then if mem_size ^= MEM_64K - 1 then if mem_size ^= MEM_128K - 1 then if mem_size ^= MEM_256K - 1 then do; /* memory really messed up */ mem_size = MEM_64K - 1; /* use 64K if clobbered */ print_trace = "0"b; /* better not try to do trace */ end; else; else; else; else; else; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PRINT OUT MODULE CHAIN * * Search through fnp module chain and print out module names * and starting addresses, also saving them for later use. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ modch.nmodules = 0; cur_chain = comm_reg.crmod; /* get beginning of module chain */ if cur_chain ^= 0 then if cur_chain < mem_size then do; /* if there's anything in it, print header */ call ioa_$rs ("^3/MODULE CHAIN", retstring, retl); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); end; do i = 1 by 1 while (cur_chain > 0 & cur_chain < mem_size); modch.address (i) = core_fnp.words (cur_chain+3); /* get address from chain entry */ /* convert bcd module name */ do k = 1 to 4; /* in module chain block */ /* get ascii translation */ substr (modch.name (i), k, 1) = xlate (fixed (substr (addr (core_fnpb.words (cur_chain+1)) -> bit36, (k-1)*6+1, 6), 6)); end; modch.nmodules = modch.nmodules + 1; call ioa_$rs ("^6x^4a ^5o", retstring, retl, modch.name (i), modch.address (i)); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); cur_chain = core_fnp.words (cur_chain); /* chase chain */ end; modch.address (i) = MEM_32K; /* no module is loaded above 32K */ modch.name (i) = ""; modch.address (i+1) = MEM_256K + 1; /* mark last entry so address won't pass it */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PRINT OUT CONTENTS OF TRACE TABLE * * Find the oldest entry in the trace table and then print all * the entries in order of age. The first word of an entry is a coded 18-bit * word which consists of three fields. The first 6 bits contain the number * of the module that made the entry; the next 6 bits contain * the trace type within the module; and the last 6 bits contain * the number of data words in the entry. This word is followed by * an 18-bit clock time and a variable number of data items. * The logical end of the trace table is marked by a word containing * the pattern 525252(8). * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if print_trace then do; mod_chain = comm_reg.crmod; /* do validity checking on trace pointers */ if comm_reg.crtrb <= mod_chain | comm_reg.crtrb > mem_size | comm_reg.crtrc <= mod_chain | comm_reg.crtrc > mem_size then go to skip_trace_print; if core_fnp.words (comm_reg.crtrc) = 0 then go to skip_trace_print; call ioa_$rsnnl ("^3/^3-TRACE TABLE^3/", retstring, retl); /* format trace table header */ call ios_$write ("od_output_", retp, 0, retl, nelemt, st); /* output it */ if st_code ^= 0 then go to err; /* error */ i = comm_reg.crtrc; /* put current trace index in i */ trace_start: if core_fnpb.words (i) = end_of_table then do; /* at end of trace table? */ i = comm_reg.crtrb; /* reset trace index to start of table */ go to trace_start; /* look some more */ end; if core_fnpb.words (i) = logical_end then go to trace_done; /* found end of table */ call format_fnp_trace_msg_ (addr (core_fnpb.words (i)), addr (modch), trace_edit); retstring = trace_edit || nl; call ios_$write ("od_output_", retp, 0, length (trace_edit) + 1, nelemt, st); if st_code ^= 0 then go to err; i = i + bin (substr (core_fnpb.words (i), 13, 6)) + 2; /* bump to next entry */ /* (include header and time words) */ go to trace_start; end; else do; skip_trace_print: call ioa_$rsnnl ("^3/Dump of trace data not attempted. The comm_reg appears to be inconsistent.", retstring, retl); call ios_$write ("od_output_", retp, 0, retl, nelemt, st); if st_code ^= 0 then go to err; end; trace_done: /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DUMP CONTENTS OF MEMORY * * Each print line will consist of four fields. The first is the * absolute address being printed followed possibly by a "*" if * some lines were skipped due to duplication. The second is the * name of the module in the area being dumped (or blanks if no * module. The third is the relative address within that module, * and the fourth is the octal representation of 8 18 bit words. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dump_line.space1, dump_line.space2, dump_line.space3, dump_line.space4, dump_line.module, dump_line.star = ""; /* init blanks */ dump_line.nl = nl; call ioa_$rsnnl ("^|^3-MEMORY DUMP^3/", retstring, retl); /* output header */ call ios_$write ("od_output_", retp, 0, retl, nelemt, st); if st_code ^= 0 then go to err; /* error */ locs_to_dump = mem_size; /* get size of fnp core */ modx = 1; /* initialize module chain index */ next_module_start = modch.address (1); /* and next module's starting address */ curlp = dumpp; /* init current line pointer for dup line checking */ go to skip_dup_test; mem_dump_loop: if curlp -> dup_copy = dupp -> dup_copy then do; /* check for duplicate lines */ dump_line.star = "*"; /* print out a star on next line to show dup */ go to dup_line; end; skip_dup_test: dupp = curlp; /* save prt to current line for dup checking */ call format_355_dump_line_$line (curlp, 8, addr (dump_line.eight_words), addr (dump_line.abs_addr), cur_loc, addr (dump_line.rel_addr), rel_addr); /* format a dump line */ do i = 1 to 16; /* format ascii data */ ch_val = fixed (dump_chars (i), 17); if ch_val < 32 | ch_val > 126 then ch_val = 32; unspec (dump_line.ascii (i)) = bit (fixed (ch_val, 9), 9); end; call ios_$write ("od_output_", addr (dump_line), 0, length (string (dump_line)), nelemt, st); /* output the line */ if st_code ^= 0 then go to err; /* error */ dump_line.star = " "; dup_line: rel_addr = rel_addr + 8; /* bump rel and abs addresses */ cur_loc = cur_loc +8; locs_to_dump = locs_to_dump - 8; /* see if done yet */ if locs_to_dump <= 0 then do; if dump_line.star = "*" then do; /* last line of dump always gets displayed */ rel_addr = rel_addr - 8; cur_loc = cur_loc - 8; go to skip_dup_test; end; call ioa_$rsnnl ("^/**DUMP FINISHED**^|", retstring, retl); /* let there be no misunderstanding */ call ios_$write ("od_output_", retp, 0, retl, nelemt, st); if st_code ^= 0 then go to err; return; /* all done */ end; curlp = addrel (curlp, 4); /* bump pointer to next line */ if cur_loc >= next_module_start then do; /* if we are dumping a new module */ if cur_loc >= MEM_32K then rel_addr = cur_loc; /* reset relative address */ else rel_addr = cur_loc - next_module_start; dump_line.module = modch.name (modx); /* set name */ modx = modx + 1; /* point to next chain entry */ next_module_start = modch.address (modx); skip_chain_code: end; go to mem_dump_loop; /* continue on */ end online_355_dump_;  online_dump.pl1 01/26/85 1314.2r w 01/22/85 1311.1 303102 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ONLINE-DUMP --- process dump image created by BOS */ /* od_355 entry added by R. Mullen May 1973 */ /* modified for multiple fnps by Robert Coren 10/08/75 */ /* modified 7/25/76 by Noel I. Morris for MR4.1 */ /* modified 79 Aug 14 by Art Beattie to handle longer erf numbers and identify entry called to com_err_. */ /* modified 2/24/81 by J. A. Bush for larger fdump header size */ online_dump: od: proc; dcl procname char (16); /* Identification for com_err_ calls */ dcl arg char (argl) based (argp), /* Variables used to access arguments */ argp ptr, argl fixed bin; dcl (erf_no char (18) aligned, /* First arg aligned, ERF # */ name char (32)) aligned; /* Returned by "get_dump_ptrs_" */ dcl error_table_$badopt fixed bin (35) external static; dcl num fixed bin init (1); dcl n_blocks fixed bin; dcl n_first fixed bin; dcl (ioname init ("od_output_"), /* Arguments for I/O attachment */ iotype init ("prtdim"), ioname2 init ("prta")) char (168) aligned int static; dcl get_dump_ptrs_ entry (char (*) aligned, (0:31) ptr, (0:31) fixed bin, fixed bin, char (32) aligned), od_print_ entry options (variable), od_stack_ entry (ptr, fixed bin, ptr, ptr, ptr, ptr), ioa_ entry options (variable), ring0_get_$segptr_given_slt entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35), ptr, ptr), hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35)), hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)), com_err_ entry options (variable), ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned), ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl (od_print_$op_new_page, od_print_$op_finish) entry, /* No args */ od_print_$op_fmt_line entry (fixed bin, fixed bin, fixed bin (35)), od_print_$op_new_seg entry (fixed bin), od_print_$op_init entry (fixed bin, fixed bin (71)), online_355_dump_ entry (ptr, fixed bin), copy_dump_seg_ entry (fixed bin, fixed bin, (0:31) ptr, (0:31) fixed bin, ptr, fixed bin), print_dump_seg_name_ entry (fixed bin, fixed bin (71), ptr, ptr), print_dump_seg_name_$hard entry (fixed bin, fixed bin (71), ptr, ptr), hcs_$terminate_noname entry (ptr, fixed bin (35)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (addr, addrel, baseno, bin, divide, index, mod, null, size, substr) builtin; /* PSI! */ dcl (ds_seg_no int static init (0), /* Seg # of descriptor segs */ slt_seg_no, nam_seg_no, sstnt_seg_no, pds_seg_no, prds_seg_no, /* Miscellaneous system segment #-s */ sst_seg_no) fixed bin; /* .. */ dcl (dslen, sstntlen, sltlen, namlen, sstlen, pdslen, prdslen, stklen) fixed bin; /* Lengths of copies of segs */ dcl (slt_seg init (null), nam_seg, sst_seg, sstnt_seg, ds_seg, pds_seg, /* Static pointers to created segments */ prds_seg /* , tc_data_seg, lot_seg */, stk_seg, shut_seg) ptr int static; dcl ( /* sstp, sltp, */ namp, dsp, pdsp, prdsp /* , tc_datap, lotp */) ptr; /* Automatic copies */ dcl (astep, ptwp) ptr, code fixed bin (35); dcl ((m1 init (-1), five init (5), four init (4), three init (3), two init (2), one init (1)) fixed bin, seg_mode fixed bin (5) init (1011b), max_fnps fixed bin init (4), fnp_size fixed bin init (16384), /* size of core image in 36-bit words */ wps fixed bin (18)) int static; dcl onechar char (1) aligned; dcl twochar char (2) aligned; dcl dsbr_stk_no fixed bin; /* the first stack segno, judged by dsbr.stack */ dcl xreg (0:7) fixed bin (17) unaligned based; dcl cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin); dcl ioargloc fixed bin init (2); dcl seg_no fixed bin; dcl restartsw bit (1) init ("0"b); dcl (rt_seg_no, rt_proc_no, cur_proc_no) fixed bin; dcl fnp_index fixed bin; dcl tag char (1); dcl all_fnps bit (1); /* indicator of whether dumping all fnps */ dcl segselsw bit (1) init ("0"b), wants_regs bit (1) init ("0"b), wants_seg (0:1151) bit (1) unal, ws16x72 (16) fixed bin (71) based, ask_ ext entry options (variable), zilch (16) fixed bin (71) init ((16) 0), ask_$ask_clr ext entry options (variable), argno fixed bin, fnp_only bit (1), seg_id char (32); dcl based_ptr based ptr; dcl (fmtdbrh char (31) init ("^-^-DBR ADDR BOUND U STACK^/"), fmtdbr char (34) init ("^-^- ^8.3b ^5.3b ^1.3b ^4.3b^/^/"), fmtpprh char (28) init ("^-^-PPR PRR PSR IC^/"), fmtppr char (35) init ("^-^- ^1.3b ^5.3b ^6.3b^/^/"), fmtrar char (17) init ("^-^-RAR ^1.3b^/"), fmtind char (17) init ("^-^-IND ^6.3b^/"), fmta char (14) init ("^-^-A ^12w"), fmtq char (14) init ("^-^-Q ^12w"), fmte char (15) init ("^-^-EXP ^3.3b"), fmtt char (20) init ("^-^-TIMER ^9.3b^/"), fmtbar char (14) init ("^-^-BAR ^w^/"), fmtx char (13) init ("^-^-X^o ^7o"), fmtinter char (16) init ("^/^-^-INTER ^12w"), fmtmode char (22) init ("^/^-^-MODE ^12w ^12w"), fmtflt char (14) init ("^-^-FAULT ^12w"), fmtprh char (39) init ("^/^/^-^-PR R SEG WORD BITS^/"), fmtpr char (39) init ("^- ^2a (^o) ^o ^5o ^6o ^2o"), fmtamsdwh char (81) init ("^/^/^-AM: SDW^/^-^- ADDR R1R2R3 F BOUND REWPUG CL POINTER F/E USAGE^/"), fmtamsdw char (51) init ("^-^-^8o ^o ^o ^o ^5o ^8a^5o ^5o ^a ^2o"), fmtamptwh char (63) init ("^/^/^-AM: PTW^/^-^- ADDR M POINTER PAGE F/E USAGE^/"), fmtamptw char (41) init ("^-^-^6o ^2a ^5o ^4o ^a ^2o"), fmtcbh char (33) init ("^/^/^-^-COREBLOCKS: FIRST NUM^/"), fmtcbno char (13) init ("^-^-^- NO MEM"), fmtmcmh char (33) init ("^/^/^-^-MEMORY CONTROLLER MASKS^/"), fmtmcm char (40) init ("^- ^2o ^14w^14w^14w^14w^14w^14w^14w^14w"), fmthrh char (29) init ("^/^/^-^-^-HISTORY REGISTERS^/")) aligned int static; dcl (fmteight char (37) init ("^-^4o^16w^14w^14w^14w^14w^14w^14w^14w"), /* For page table printing */ fmtdesc char (66) init ("^-^- ADDR R1R2R3 F BOUND REWPUG CL SEGMENT NAME^/"), fmtast char (64) init ("^/ ASTE ^14w^14w^14w^14w^14w^14w^14w^14w^/PAGE TABLE^/"), fmtlth char (14) init ("^2-LENGTH = ^o"), fmteject char (2) init ("^|"), fmthdr char (11) init ("^|^a ERF ^a"), fmteq char (21) init ("^-^7o line^a repeated")) aligned int static; dcl 1 dsbr based aligned, (2 add bit (24), 2 pad1 bit (12), 2 pad2 bit (1), 2 bound bit (14), 2 pad3 bit (4), 2 unpaged bit (1), 2 pad4 bit (4), 2 stack bit (12)) unaligned; dcl 1 scu based (scup) aligned, /* SCU data needed by online_dump */ 2 ppr, /* proceedure pointer register */ 3 prr bit (3) unal, /* procedure ting register */ 3 psr bit (15) unal, /* procedure segment register */ 2 pad1 bit (18) unal, /* */ 2 pad2 (3) bit (36) unal, /* */ 2 ilc bit (18) unal, /* instruction counter */ 2 ir bit (18) unal, /* indicator registers */ 2 pad3 (3) bit (36) unal; /* */ dcl (ptr_array ptr, /* Pointers to, lengths of component segments of image */ len_array fixed bin) (0:31); declare 1 cmp aligned, /* Buffer containing contents of last printed line */ 2 (zero, two, four, six) fixed bin (71); declare 1 temp aligned, /* Buffer used when current 8 words straddle image segment boundary */ 2 (zero, two, four, six) fixed bin (71); declare 1 dbl based aligned, /* Template used to access current 8 words */ 2 (zero, two, four, six) fixed bin (71); declare 1 sgl based aligned, /* Template for printing individual words */ 2 (zero, one, two, three, four, five, six, seven) fixed bin (35); dcl (cur, nxt, tmp, prt, eightp) ptr, /* Pointers used in dumping */ (ast_off, sst_abs_loc, sst_high_loc, abs_loc, jbdry, page_no) fixed bin, (b72 bit (72), /* I/O status */ bl char (l) based, /* For format overlay */ s char (1), /* for singular/plural printing */ c0 char (0)) aligned, /* = null string */ (i, j, l, j1, j2, eq_print) fixed bin, /* Misc values */ bin_array (0:1023) based fixed bin (35), dbl_array (0:1023) based fixed bin (71), cur_orig fixed bin (35), (cur_proc_index, cur_seg_no, given_length, half_gl) fixed bin, /* Per-segment values */ (nsegs, seg_index, ptr_index, wpsmsi) fixed bin (18); /* More misc */ declare 1 io_status based aligned, /* To check 72-bits from ios_ calls */ 2 code fixed bin, /* error code */ 2 substatus bit (36); /* Bits */ dcl axbitsp ptr; dcl axstring char (8) aligned; dcl axbits (6) bit (1) unaligned based (axbitsp); dcl (amrp, ampp, scup) ptr; % include assoc_mem; % include slt; % include sstnt; % include ptw; % include its; % include sdw; % include bos_dump; % include sst; /* Initialization */ procname = "online_dump"; prt = addr (wants_seg (0)); prt -> ws16x72 = zilch; fnp_only = "0"b; go to get_erfno; online_dump_355: od_355: entry; procname = "online_dump_355"; fnp_only = "1"b; fnp_index = 1; /* assume doing all starting with first */ tag = "a"; all_fnps = "1"b; get_erfno: call cu_$arg_ptr (1, argp, argl, code); /* Get mandatory first arg */ if code ^= 0 then do; call com_err_ (code, procname, "ERF #"); return; end; if ^fnp_only then erf_no = arg; /* Copy arg */ else erf_no = arg || ".355"; call get_dump_ptrs_ (erf_no, ptr_array, len_array, j, name); /* Get pointers to image segments */ if j = 0 then do; call com_err_ (0, procname, "no pointers returned for arg ""^a""", erf_no); return; end; ptr_array (j) = null; /* For terminate loop */ dumpptr = ptr_array (0); /* Copy pointer for header access */ call hcs_$get_max_length_seg (dumpptr, wps, code); if code ^= 0 then do; call com_err_ (code, procname, "unable to get max length of ^a", name); return; end; /* NEW STUFF */ get_args: argno = 1; next_arg: argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); /* any more args */ if code ^= 0 | argl = 0 then do; /* if not, then leave */ if fnp_only then go to no_more_segs; /* nothing more to do before attach call */ else go to no_more_args; end; if arg = "-dim" then do; /* next arg is name of dim */ argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 | argl = 0 then do; seg_id = "dim"; go to call_com; end; iotype = arg; end; else if arg = "-dev" then do; /* next arg is name of device or stream */ argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 | argl = 0 then do; seg_id = "device"; go to call_com; end; ioname2 = arg; end; else if arg = "-restart" & ^fnp_only then do; /* if we are restarting */ restartsw = "1"b; /* note it so no segs will be dumped */ argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 | argl = 0 then do; seg_id = "restart process_number"; go to call_com; end; rt_proc_no = cv_oct_check_ (arg, i); /* except those following the seg with this proc_no */ if i ^= 0 then do; seg_id = "restart process_no is not octal"; go to call_com_oct; end; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 | argl = 0 then do; seg_id = "restart segment number"; go to call_com; end; rt_seg_no = cv_oct_check_ (arg, i); /* AND this seg_no */ if i ^= 0 then do; seg_id = "restart segment_no is not octal"; go to call_com_oct; end; end; else if arg = "-segs" & ^fnp_only then do; segselsw = "1"b; /* later we will pick up selected segs */ end; else if arg = "-tag" & fnp_only then do; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 | argl = 0 then do; seg_id = "tag"; go to call_com; end; tag = arg; all_fnps = "0"b; /* not doing all now */ fnp_index = index ("abcdefgh", tag); /* convert to number */ if fnp_index = 0 then do; /* not legal tag */ seg_id = "invalid tag"; go to call_com_oct; end; dumpptr = addrel (dumpptr, fnp_size* (fnp_index-1)); /* point to relevant core image */ end; else do; seg_id = arg; code = error_table_$badopt; go to call_com; end; go to next_arg; call_com: call com_err_ (code, procname, "^a", seg_id); return; call_com_oct: call com_err_ (0, procname, "^a: ^a", seg_id, arg); return; no_more_args: /* Extract various system segment numbers, and copy per-system data bases */ if slt_seg = null then do; call hcs_$make_seg (c0, "od.slt--", c0, seg_mode, slt_seg, code); call hcs_$make_seg (c0, "od.nam--", c0, seg_mode, nam_seg, code); call hcs_$make_seg (c0, "od.sst--", c0, seg_mode, sst_seg, code); call hcs_$make_seg (c0, "od.sstnt", c0, seg_mode, sstnt_seg, code); call hcs_$make_seg (c0, "od.dseg-", c0, seg_mode, ds_seg, code); call hcs_$make_seg (c0, "od.pds--", c0, seg_mode, pds_seg, code); call hcs_$make_seg (c0, "od.prds-", c0, seg_mode, prds_seg, code); call hcs_$make_seg (c0, "od.shut-", c0, seg_mode, shut_seg, code); call hcs_$make_seg (c0, "od.stk--", c0, seg_mode, stk_seg, code); /* Following calls temporarily commented out: call hcs_$make_seg(c0, "od.pdf--", c0, seg_mode, pdf_seg, code); /* Need more temporary segments? Add above this line */ end; cur_proc_index = 1; /* For copy_dump_seg_ */ namp, dsp, sstnp, sstp = null; /* Just in case */ slt_seg_no = 7; call copy_dump_seg_ (7, cur_proc_index, ptr_array, len_array, slt_seg, sltlen); if sltlen = 0 then do; call ioa_ ("Can't find ""^a""", "slt"); NOT_SLT: sltp = null; sst_seg_no = 10; /* Subject to change */ go to copy_sst; end; else do; /* Pick out all interesting segment #-s */ sltp = slt_seg; nam_seg_no = bin (baseno (sltp -> based_ptr), 18); call copy_dump_seg_ (nam_seg_no, cur_proc_index, ptr_array, len_array, nam_seg, namlen); if namlen ^= 0 then namp = nam_seg; else do; /* well at best the SLT is useless... */ call ioa_ ("Cannot find name_table for slt"); go to NOT_SLT; end; call ring0_get_$segptr_given_slt ("", "slt", prt, code, sltp, namp); /* remember we guessed slt_seg_no = 7 */ if bin (baseno (prt), 18) ^= 7 then do; /* alleged SLT not able to figure its own number! */ call ioa_ ("Segments 7 and ^o not functioning as slt and name_table", nam_seg_no); namp = null; go to NOT_SLT; end; call ring0_get_$segptr_given_slt ("", "sst", prt, code, sltp, namp); if code = 0 then do; sst_seg_no = bin (baseno (prt), 18); end; else do; sst_seg_no = 9; end; call ring0_get_$segptr_given_slt ("", "sst_names_", prt, code, sltp, namp); sstnt_seg_no = bin (baseno (prt), 18); call ring0_get_$segptr_given_slt ("", "pds", prt, code, sltp, namp); pds_seg_no = bin (baseno (prt), 18); call ring0_get_$segptr_given_slt ("", "prds", prt, code, sltp, namp); prds_seg_no = bin (baseno (prt), 18); copy_sst: /* Copying of SST must be the last in this sequence */ call copy_dump_seg_ (sst_seg_no, cur_proc_index, ptr_array, len_array, sst_seg, sstlen); if sstlen = 0 then do; call ioa_ ("Can't find ""^a""", "sst"); sstp = null; end; else do; sstp = sst_seg; sst_abs_loc = sstp -> sst.ptwbase; sst_high_loc = sst_abs_loc + sstlen ; ast_off = - (sstp -> sst.astsize); end; /* Copy the SST name table */ call copy_dump_seg_ (sstnt_seg_no, cur_proc_index, ptr_array, len_array, sstnt_seg, sstntlen); if sstntlen = 0 then do; call ioa_ ("Cannot find SST name table."); sstnp = null; end; else do; sstnp = sstnt_seg; if ^sstnp -> sstnt.valid then do; call ioa_ ("SST name table not filled in."); sstnp = null; end; end; end; if segselsw then do; /* now we pick up selected segnames or numbers */ call ask_$ask_clr; /* clear ask's internal line buffer */ get_next_seg: call ask_ (c0, seg_id); /* pick up specification of a seg */ if seg_id = "quit" then go to no_more_segs; /* no more wanted */ if seg_id = "regs" then do; wants_regs = "1"b; go to get_next_seg; end; seg_no = cv_oct_check_ (seg_id, i); /* try it as octal segno */ if i = 0 then wants_seg (seg_no) = "1"b; /* it is octal and we mark it wanted */ else if sltp ^= null then do; /* not octal, see if its a name in SLT, if any */ call ring0_get_$segptr_given_slt ("", (seg_id), prt, code, sltp, namp); if code = 0 then do; /* it was found in SLT */ seg_no = bin (baseno (prt), 18); wants_seg (seg_no) = "1"b; /* and we mark it's segno as wanted */ end; else do; /* not in SLT,wasn't octal=> it loses */ call ioa_ ("Cannot find segment ^a in slt", seg_id); /* name or slt is nonsense */ end; end; go to get_next_seg; /* see if there are more */ end; no_more_segs: call ioa_ ("Segment ""^a"", device ""^a"", module ""^a""", /* Print current attachment info etc */ name, ioname2, iotype); call ios_$attach (ioname, iotype, ioname2, "w", b72); /* Attach printer or other device */ tmp = addr (b72); /* Pro _t_e_m_pore */ if tmp -> io_status.code ^= 0 then do; call com_err_ (tmp -> io_status.code, procname, "attach call, sub-status ^w, contact programming staff", tmp -> io_status.substatus); return; end; call od_print_$op_init (bin (dumpptr -> dump.erfno, 17), dumpptr -> dump.time); /* Initialize print program */ call od_print_ (m1, fmthdr, "Start", erf_no); /* Print header */ tmp = addr (temp); /* For short lines, boundary conditions, etc */ eightp = addr (fmteight); /* For page-table printout */ if restartsw then call ioa_ ("Continue dumping ^a", erf_no); else call ioa_ ("Begin dumping ^a", erf_no); /* Send message to console */ if fnp_only then do while ("1"b); call od_print_$op_finish; call online_355_dump_ (dumpptr, fnp_index); if all_fnps & fnp_index < max_fnps then do; /* more fnp dumps to process */ fnp_index = fnp_index + 1; dumpptr = addrel (dumpptr, fnp_size); /* point to next core image */ end; else go to tm_loop; end; /* Print register contents */ prt = addr (dumpptr -> dump.dbr); dsbr_stk_no = bin (prt -> dsbr.stack, 12) * 8; if (restartsw | (segselsw & ^wants_regs)) then go to skip_regs; call od_print_ (two, fmtdbrh); /* descriptor base register */ call od_print_ (three, fmtdbr, prt -> dsbr.add, prt -> dsbr.bound, prt -> dsbr.unpaged, prt -> dsbr.stack); call od_print_ (four, fmtpprh); /* proceedure pointer register */ scup = addr (dumpptr -> dump.scu (0)); call od_print_ (one, fmtppr, scup -> scu.ppr.prr, scup -> scu.ppr.psr, scup -> scu.ilc); call od_print_ (two, fmtrar, dumpptr -> dump.regs.ralr); call od_print_ (two, fmtind, scup -> scu.ir); call od_print_ (one, fmta, dumpptr -> dump.regs.a); call od_print_ (one, fmtq, dumpptr -> dump.regs.q); call od_print_ (one, fmte, dumpptr -> dump.regs.e); call od_print_ (two, fmtt, dumpptr -> dump.regs.t); call od_print_ (two, fmtbar, dumpptr -> dump.bar); prt = addr (dumpptr -> dump.regs.x (0)); do j = 0 by 1 while (j < 8); /* index registers */ call od_print_ (one, fmtx, j, prt -> xreg (j)); end; call od_print_ (two, fmtmode, dumpptr -> dump.modereg, dumpptr -> dump.cmodereg); call od_print_ (one, fmtflt, dumpptr -> dump.faultreg); call od_print_ (two, fmtinter, dumpptr -> dump.intrpts); /* interrupts */ call od_print_ (four, fmtprh); /* pointer registers */ do j = 0 by 1 while (j < 8); prt = addr (dumpptr -> dump.prs (j)); call od_print_ (one, fmtpr, substr ("APABBPBBLPLBSPSB", j*2+1, 2), j, bin (prt -> its.ringno, 3), bin (prt -> its.segno, 15), bin (prt -> its.offset, 18), bin (prt -> its.bit_offset, 6)); end; call od_print_$op_new_page; call od_print_ (five, fmtamsdwh); /* assoc. mem. segment descriptor words */ do j = 0 by 1 while (j < 16); amrp = addr (dumpptr -> dump.amsdwregs (j)); ampp = addr (dumpptr -> dump.amsdwptrs (j)); axstring = "REWPUG "; /* check some bits */ axbitsp = addr (amrp -> amsdwreg.read); do l = 1 to 6; if axbitsp -> axbits (l) = "0"b then substr (axstring, l, 1) = " "; end; call od_print_ (one, fmtamsdw, bin (amrp -> amsdwreg.addr, 24), bin (amrp -> amsdwreg.r1, 3), bin (amrp -> amsdwreg.r2, 3), bin (amrp -> amsdwreg.r3, 3), bin (amrp -> amsdwreg.bound, 14), axstring, bin (amrp -> amsdwreg.cl, 14), bin (ampp -> amsdwptr.pointer, 15), substr ("EF", bin (ampp -> amsdwptr.valid, 1)+1, 1), bin (ampp -> amsdwptr.usage, 4)); end; call od_print_ (five, fmtamptwh); /* assoc. mem. page table words */ do j = 0 by 1 while (j < 16); amrp = addr (dumpptr -> dump.amptwregs (j)); ampp = addr (dumpptr -> dump.amptwptrs (j)); if amrp -> amptwreg.modif then twochar = " "; else twochar = "NO"; if ampp -> amptwptr.valid then onechar = "F"; else onechar = "E"; call od_print_ (one, fmtamptw, bin (amrp -> amptwreg.addr, 18), twochar, bin (ampp -> amptwptr.pointer, 15), bin (ampp -> amptwptr.pageno, 12), onechar, bin (ampp -> amptwptr.usage, 4)); end; call od_print_$op_new_page; call od_print_ (four, fmtcbh); /* coreblocks */ do j = 0 by 1 while (j < 8); prt = addr (dumpptr -> dump.coreblocks (j).num_first); if prt -> sgl.zero = -1 then call od_print_ (one, fmtcbno); else do; n_first = bin (dumpptr -> dump.coreblocks (j).num_first, 18); n_blocks = bin (dumpptr -> dump.coreblocks (j).num_blocks, 18); call od_print_ (one, "^-^-^- ^6o ^4o", n_first, n_blocks); end; end; call od_print_ (four, fmtmcmh); /* memory controller masks */ do j = 0 by 4 while (j< 8); prt = addr (dumpptr -> dump.mcm (j)); call od_print_ (1, fmtmcm, 2*j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); end; call od_print_ (four, fmthrh); call od_print_ (two, "^/^-OU"); do j = 0 by 4 while (j < 16); prt = addr (dumpptr -> dump.ouhist (j)); /* operations unit history regs */ call od_print_ (one, fmtmcm, 2*j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); end; call od_print_ (two, "^/^-CU"); do j = 0 by 4 while (j < 16); prt = addr (dumpptr -> dump.cuhist (j)); /* control unit history registers */ call od_print_ (one, fmtmcm, 2*j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); end; call od_print_ (two, "^/^-AU"); do j = 0 by 4 while (j < 16); prt = addr (dumpptr -> dump.auhist (j)); /* appending unit history registers */ call od_print_ (one, fmtmcm, 2*j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); end; call od_print_ (two, "^/^-DU"); do j = 0 by 4 while (j < 16); prt = addr (dumpptr -> dump.duhist (j)); /* decimal unit history registers */ call od_print_ (one, fmtmcm, 2*j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); end; /* Now dump individual segments/processes */ skip_regs: nsegs = dumpptr -> dump.num_segs; /* Copy for quicker reference */ cur_proc_no = 0; do i = 1 to nsegs; cur_seg_no = bin (dumpptr -> dump.segs (i).segno, 18); if i > 1 then cur_orig = bin (dumpptr -> dump.segs (i-1).length, 18) * 64 + cur_orig ; else cur_orig = size (dump); given_length = bin (dumpptr -> dump.segs (i).length, 18) * 64; call od_print_$op_new_seg (cur_seg_no); if cur_seg_no = ds_seg_no then cur_proc_no = cur_proc_no + 1; if cur_seg_no = rt_seg_no then if cur_proc_no = rt_proc_no then restartsw = "0"b; if restartsw then if cur_seg_no ^= ds_seg_no then go to next_seg; if cur_seg_no = ds_seg_no & (^restartsw | cur_proc_no = rt_proc_no) /* Is it a new descriptor seg */ then do; cur_proc_index = i; /* Yes, remember position for info for new process */ prdsp, pdsp = null; if sltp ^= null then if namp ^= null /* If we know where KST, PDS,PRDS are, copy them */ then do; call copy_dump_seg_ (pds_seg_no, cur_proc_index, ptr_array, len_array, pds_seg, pdslen); if pdslen ^= 0 then pdsp = pds_seg; call copy_dump_seg_ (prds_seg_no, cur_proc_index, ptr_array, len_array, prds_seg, prdslen); if prdslen ^= 0 then prdsp = prds_seg; end; call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, ds_seg, dslen); /* Copy descriptor segment for this process */ if dslen = 0 then dsp, sdwp = null; else do; dsp = ds_seg; if (restartsw | (segselsw & ^wants_seg (ds_seg_no))) then go to next_seg; else do; eq_print = 0; call od_print_ (four, "^/^/^4-DESCRIPTOR SEGMENT^/"); call od_print_ (two, fmtdesc); half_gl = divide (given_length, 2, 17, 0); do j = 0 by 1 while (j ^= half_gl); /* Print symbolic breakout of descriptors */ if dsp -> dbl_array (j) = 0 /* Don't print null SDW */ then eq_print = eq_print + 1; /* merely note it for blank line later */ else do; if eq_print ^= 0 then call od_print_ (one, c0); /* Print blank line */ if sltp = null then go to CALL_PDSN_1; if sltp -> slt.last_sup_seg >= j then do; call print_dump_seg_name_$hard (j, dsp -> dbl_array (j), sltp, namp); end; else do; CALL_PDSN_1: call print_dump_seg_name_ (j, dsp -> dbl_array (j), sstp, sstnp); end; eq_print = 0; /* Reset counter */ end; end; end; end; call od_print_$op_new_page; /* After descriptor breakout, new page for segment */ end; if segselsw then if ^wants_seg (cur_seg_no) then go to next_seg; abs_loc = -wps; /* Generate large negative number */ jbdry = -1; /* Such that comparison below will never succeed */ if dsp ^= null then do; sdwp = addr (dsp -> dbl_array (cur_seg_no)); call od_print_ (two, fmtdesc); if sltp = null then go to CALL_PDSN_2; if sltp -> slt.last_sup_seg >= cur_seg_no then call print_dump_seg_name_$hard (cur_seg_no, dsp -> dbl_array (cur_seg_no), sltp, namp); else do; CALL_PDSN_2: call print_dump_seg_name_ (cur_seg_no, dsp -> dbl_array (cur_seg_no), sstp, sstnp); end; if sdwp -> sdw.add then if sdwp -> sdw.unpaged = "0"b then do; if sstp ^= null /* Get AST entry and page table */ then do; j = bin (sdwp -> sdw.add, 24); if j > sst_high_loc /* Check for address beyond end of SST */ then go to use_abs; jbdry = 0; /* Where absolute location is next computed */ page_no = 0; /* for indexing into page table */ ptp = addrel (sstp, j - sst_abs_loc); prt = ptp; astep = addrel (ptp, ast_off); j1 = bin (sdwp -> sdw.bound, 14) + 1; /* Extract bounds field */ j2 = divide (j1 + 63, 64, 17, 0); j1 = divide (j2, 8, 17, 0); j2 = j2 - j1 * 8; call od_print_ (four, fmtast, astep -> sgl.zero, astep -> sgl.one, astep -> sgl.two, astep -> sgl.three, astep -> sgl.four, astep -> sgl.five, astep -> sgl.six, astep -> sgl.seven); do j = 0 by 8 while (j < j1); /* Print full lines */ call od_print_ (one, fmteight, j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); prt = addrel (prt, 8); end; if j2 ^= 0 then do; l = j2 * 4 + 5; /* # of characters to use */ call od_print_ (one, eightp -> bl, j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six); end; end; end; else /* ! */ use_abs: abs_loc = bin (sdwp -> sdw.add, 24); call od_print_ (one, c0); /* Separate contents from header by blank line */ end; if given_length <= 0 then do; call od_print_ (one, fmtlth, given_length); go to next_seg; end; /* All preliminary work done, start to dump seg */ /* Note: given_length is in words */ prt = null; if cur_seg_no ^= 0 then do; if (cur_seg_no = pds_seg_no & pdsp ^= null) then prt = pdsp; else if (cur_seg_no = prds_seg_no & prdsp ^= null) then prt = prdsp; else if (cur_seg_no >= dsbr_stk_no & dsbr_stk_no ^= 0 & cur_seg_no - dsbr_stk_no < 8) then do; call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, stk_seg, stklen); if stklen ^= 0 then prt = stk_seg; end; end; if prt = null then go to NOT_STACK; call od_stack_ (prt, given_length, sltp, namp, sstp, sstnp); go to next_seg; /* this one is done */ NOT_STACK: j1 = given_length; /* num lines in seg as dumped by bos, which dumps 64 wd blocks */ if sdwp -> sdw.unpaged then do; j2 = (bin (sdwp -> sdw.bound, 14) + 1) * 16; /* unpaged segs' lengths not necess multiple of 64 really */ if j2 < j1 then j1 = j2; /* so we use the bounds field which gives num of 16 wd units */ end; ptr_index = divide (cur_orig, wps, 17, 0); seg_index = mod (cur_orig, wps); cur = addrel (ptr_array (ptr_index), seg_index); eq_print = 0; /* No suppressed lines */ /* Note re-entry to loop at "compare": if Version II PL/I makes noises, change to "do while", etc */ do j = 0 by 8 while (j < j1); /* print all full lines */ wpsmsi = wps - seg_index; /* Calculate # of words remaining in current image seg */ if wpsmsi >= 8 /* 8 or more, print directly */ then do; retry_8: prt = cur; compare: /* Come here at most once after main loop to compare and */ /* print partial line */ if j = jbdry then do; ptwp = addr (ptp -> bin_array (page_no)); if ptwp -> ptw.df then abs_loc = bin (ptwp -> ptw.add, 18) * 64; else abs_loc = -wps; /* Page not in core */ jbdry = jbdry + 1024; page_no = page_no + 1; end; if j ^= 0 /* Don't check first time through */ then if prt -> dbl.six = cmp.six /* See if this line equals previous line */ then if prt -> dbl.four = cmp.four then if prt -> dbl.two = cmp.two then if prt -> dbl.zero = cmp.zero then do; eq_print = eq_print + 1; /* Note occurence of repeated line */ go to endj; end; if eq_print ^= 0 /* Line was different, were there suppressed lines? */ then do; if eq_print = 1 /* How many? */ then s = " "; else s = "s"; call od_print_ (one, fmteq, eq_print, s); eq_print = 0; /* Reset counter */ end; /* call od_print_(one, fmt, abs_loc, j, prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three, prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); /* Print line */ call od_print_$op_fmt_line (abs_loc, j, prt -> sgl.zero); cmp.six = prt -> dbl.six; /* Copy for next comparison */ cmp.four = prt -> dbl.four; cmp.two = prt -> dbl.two; cmp.zero = prt -> dbl.zero; end; else do; /* fewer than 8, switch to next seg of image */ nxt = ptr_array (ptr_index + 1); if wpsmsi = 0 /* If zero, trivial */ then do; cur = nxt; seg_index = 0; go to retry_8; end; seg_index = -wpsmsi; /* Set for advancing at "endj" */ cur = addrel (nxt, seg_index); prt = tmp; /* Compare/print from special buffer */ go to compare; end; endj: cur = addrel (cur, 8); /* Advance pointer */ seg_index = seg_index + 8; /* and index in parallel */ abs_loc = abs_loc + 8; /* Augment absolute address */ end; if eq_print ^= 0 /* See if last line was identical to last printed line */ then do; if eq_print = 1 then s = " "; else s = "s"; call od_print_ (one, fmteq, eq_print, s); end; next_seg: end; /* Cleanup */ tm_loop: do j = 0 by 1 to 9 while (ptr_array (j) ^= null); /* Terminate all segs of image */ call hcs_$terminate_noname (ptr_array (j), code); end; call od_print_ (m1, fmthdr, "End", erf_no); od_cleanup: entry; /* To close buffer and detach printer */ call od_print_ (m1, fmteject); call od_print_$op_finish; call ios_$detach (ioname, c0, c0, b72); call ioa_ ("Finished dump"); end online_dump;  online_dump_fnp.pl1 11/15/82 1847.9rew 11/15/82 1517.2 69804 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ od_fnp: online_dump_fnp: proc; /* Command to access a dump created online by fdump_fnp_ * Dump (in >dumps) has entry name of the form fnp.TAG.MMDDYY.HHMM * * Usage: od_fnp -dt MMDDYY -device DEVICE -dim DIM [-tm HHMM] [-tag TAG] * * If time or tag is not supplied, a starname will be formed, but if more than one entry * matches it, an error code will be returned. */ /* ARGUMENT STUFF */ dcl nargs fixed bin; dcl iarg fixed bin; dcl argptr ptr; dcl arglen fixed bin; dcl arg char (arglen) based (argptr); /* ENTRIES */ dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl clock_ entry returns (fixed bin (71)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ioa_$rs entry options (variable); dcl get_system_free_area_ entry (ptr); dcl hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned); dcl ios_$detach entry (char (*), char (*), char (*), bit (72) aligned); dcl ios_$write entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl online_355_dump_ entry (ptr, fixed bin); dcl parse_fnp_name_ entry (char (*), fixed bin); /* AUTOMATIC */ dcl ap ptr; dcl code fixed bin (35); dcl starname char (32); dcl namelen fixed bin; dcl tag char (1) init ("*"); dcl date char (6) init ("*"); dcl time char (4) init ("*"); dcl device char (168) init ("*"); dcl dim char (32) init ("*"); dcl path char (168) init ("*"); dcl outline char (64); dcl iostat bit (72) aligned; dcl init bit (1) init ("0"b); dcl date_string char (24); dcl pathlen fixed bin; dcl dirname char (168); dcl segname char (32); dcl count fixed bin; dcl ep ptr; dcl np ptr; dcl dump_ptr ptr; dcl fnp_no fixed bin; /* INTERNAL STATIC */ dcl myname char (15) internal static options (constant) init ("online_dump_fnp"); dcl DUMP_DIR char (6) internal static options (constant) init (">dumps"); dcl output_stream char (32) internal static options (constant) init ("od_output_"); /* EXTERNAL STATIC */ dcl (error_table_$badopt, error_table_$noarg, error_table_$inconsistent) fixed bin (35) external static; /* BASED */ dcl the_area area (50) based (ap); dcl based_name char (32) based; dcl names (count) char (32) aligned based (np); dcl entries (count) fixed bin based (ep); dcl 1 io aligned based (addr (iostat)), 2 code fixed bin (35), 2 junk bit (36); /* CONDITIONS & BUILTINS */ dcl cleanup condition; dcl (addr, index, null, substr) builtin; /* */ call cu_$arg_count (nargs); if nargs < 2 then do; call com_err_ (0, myname, "Usage: online_dump_fnp -device DEVICE -dim DIM -date MMDDYY [-time HHMM] [-tag FNP_TAG] [-pathname PATH]"); return; end; do iarg = 1 to nargs by 2; call cu_$arg_ptr (iarg, argptr, arglen, code); if arg = "-tag" then call get_value (tag); else if arg = "-date" | arg = "-dt" then call get_value (date); else if arg = "-time" | arg = "-tm" then call get_value (time); else if arg = "-device" | arg = "-dv" | arg = "-dev" then call get_value (device); else if arg = "-dim" then call get_value (dim); else if arg = "-pn" | arg = "-pathname" then do; call get_value (path); pathlen = arglen; end; else code = error_table_$badopt; if code ^= 0 /* either set by preceding statement or by get_value */ then do; call com_err_ (code, myname, arg); return; end; end; /* make sure required arguments were specified */ if device = "*" then call noarg ("device"); if dim = "*" then call noarg ("dim"); if code ^= 0 then return; /* noarg sets code */ if path ^= "*" /* pathname of dump specified */ then do; call expand_path_ (addr (path), pathlen, addr (dirname), addr (segname), code); if code ^= 0 then do; call com_err_ (code, myname, path); return; end; if tag = "*" then tag = "a"; /* fake it */ end; /* else apply starname */ else do; dirname = DUMP_DIR; if date = "*" /* date defaults */ then do; call date_time_ (clock_ (), date_string); date = substr (date_string, 1, 2) || substr (date_string, 4, 2) || substr (date_string, 7, 2); end; call ioa_$rsnnl ("fnp.^a.^a.^a", starname, namelen, tag, date, time); call get_system_free_area_ (ap); call hcs_$star_ (DUMP_DIR, substr (starname, 1, namelen), 2, ap, count, ep, np, code); if code ^= 0 then do; call com_err_ (code, myname, starname); return; end; segname = np -> based_name; free entries in (the_area); free names in (the_area); if count > 1 then do; call com_err_ (0, myname, "^a identifies more than one dump.", starname); return; end; if tag = "*" then tag = substr (segname, 5, 1); if time = "*" then time = substr (segname, 14, 4); end; call ios_$attach (output_stream, dim, device, "w", iostat); if io.code ^= 0 then do; call com_err_ (io.code, myname, "Could not make attachment."); return; end; on cleanup call clean; call hcs_$initiate (dirname, segname, "", 0, 1, dump_ptr, code); if dump_ptr = null then do; call com_err_ (code, myname, "Could not initiate ^a", segname); call clean; return; end; else init = "1"b; /* now we do what we came here to do */ if path ^= "*" then call ioa_$rs ("FNP dump ^a>^a", outline, namelen, dirname, segname); else call ioa_$rs ("Dump of FNP ^a taken on ^a at ^a", outline, namelen, tag, date, time); call ios_$write (output_stream, addr (outline), 0, namelen, (0), iostat); call parse_fnp_name_ (tag, fnp_no); if fnp_no = -1 then fnp_no = 0; call online_355_dump_ (dump_ptr, fnp_no); call clean; call ioa_ ("Finished dump"); return; /* */ get_value: proc (result); /* Internal procedure to get value for keyword parameter */ dcl result char (*); dcl oldarg char (6); if result ^= "*" /* this one has already been specified */ then code = error_table_$inconsistent; else do; oldarg = arg; call cu_$arg_ptr (iarg+1, argptr, arglen, code); if code ^= 0 then arg = oldarg; else result = arg; end; return; end /* get_value */ ; /* */ noarg: proc (name); /* Internal procedure to print error message for unspecified keyword */ dcl name char (*); code = error_table_$noarg; call com_err_ (code, myname, "-^a must be supplied.", name); return; end /* noarg */ ; clean: proc; /* cleanup handler, also called at normal exit */ call ios_$detach (output_stream, "", "", iostat); if init then call hcs_$terminate_noname (dump_ptr, code); return; end /* clean */ ; end /* od_fnp */ ;  print_dump_seg_name_.pl1 01/26/85 1314.2r w 01/22/85 1311.1 40590 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_dump_seg_name_: proc (segno, psdw, sstp, sstnp); /* Converted to 6180 and v2pl1 by R Mullen Feb 1973 */ dcl segno fixed bin, /* Parameters */ psdw fixed bin (71), (xsltp, xnamp) ptr, /* Pointers to copies of the SLT and Name Table in dump */ astep ptr, /* Pointer to AST entry of interest */ np ptr, /* r0 name table ptr */ sstnp ptr; /* Pointer to copy of SST name table */ dcl axbitsp ptr; dcl ax char (8) aligned; dcl axbits (6) bit (1) unaligned based (axbitsp); dcl (cl, esw) fixed bin; dcl (line char (130), dirname char (168), name char (32), ename char (32), bline char (l) based (lp)) aligned, namebuf char (64), (lp, sltp, namp, segptr, xsegptr) ptr, expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), get_ast_name_ entry (ptr, ptr, ptr, char (*)), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)), (l, maxl, minl, i) fixed bin; dcl (fmtnl char (2) init ("^a"), fmtsstn char (5) init ("^a ^a"), fmtsdw char (46) init ("^-^-^8o ^o ^o ^o ^1a ^5o ^8a^5o ^4o")) int static aligned; dcl (ioa_$rsnnl, od_print_) entry options (variable); /* Descriptors required */ dcl ring0_get_$name_given_slt entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35), ptr, ptr); dcl (addr, baseptr, bin, null, substr) builtin; dcl code fixed bin (35); dcl dfchar char (1); dcl dfno fixed bin; /* */ %include sst; /* */ % include sdw; /* Copy args, initialize for formatting SDW breakout */ esw = 1; go to common; print_dump_seg_name_$get_ptr: entry (segno, sstp, sstnp, xsegptr); xsegptr = null; esw = 0; go to common; print_dump_seg_name_$hard: entry (segno, psdw, xsltp, xnamp); esw = 2; common: dirname = ""; ename = ""; if esw ^= 0 then do; maxl = 100; minl = 0; lp = addr (line); sdwp = addr (psdw); ax = "REWPUG "; /* fill in letters for these 6 bits */ axbitsp = addr (sdwp -> sdw.read); /* get pointer to the bits */ do i = 1 to 6; /* look at each one */ if axbitsp -> axbits (i) = "0"b then substr (ax, i, 1) = " "; /* if axbitsp -> zero, remove the letter */ end; if sdwp -> sdw.df then dfchar = " "; else do; dfno = bin (sdwp -> sdw.df_no, 2); dfchar = substr ("0123", dfno + 1, 1); end; cl = bin (sdwp -> sdw.entry_bound, 17); call ioa_$rsnnl (fmtsdw, line, l, bin (sdwp -> sdw.add, 24), bin (sdwp -> sdw.r1, 3), bin (sdwp -> sdw.r2, 3), bin (sdwp -> sdw.r3, 3), dfchar, bin (sdwp -> sdw.bound, 14), ax, bin (sdwp -> sdw.entry_bound, 14), segno); end; if esw ^= 2 then do; /* non hardcore segname/refname wanted */ if sstp = null | sstnp = null then go to print_line; astep = ptr (sstp, bin (sdwp -> sdw.add, 24) - sstp -> sst.ptwbase - sstp -> sst.astsize); /* Compute Astep */ call get_ast_name_ (astep, sstp, sstnp, namebuf); /* Figure out the name */ if esw = 1 then call ioa_$rsnnl(fmtsstn, line, l, bline, namebuf); else do; call expand_path_ (addr(namebuf), length (namebuf), addr (dirname), addr (ename), code); if code ^= 0 then go to pfail; if dirname = ">system_library_1" then dirname = ">ldd>hard>object"; call hcs_$initiate (dirname, ename, "", 0, 1, segptr, code); if segptr = null then xsegptr = segptr; else pfail: xsegptr = null; end; go to print_line; end; else do; sltp = xsltp; namp = xnamp; np = baseptr (segno); call ring0_get_$name_given_slt (dirname, name, np, code, sltp, namp); if code = 0 then call ioa_$rsnnl (fmtsstn, line, l, bline, name); end; print_line: /* Print accumulated line image */ if esw = 0 then return; if l > minl /* See if anything significant in buffer */ then call od_print_ (1, fmtnl, bline); end print_dump_seg_name_; 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